diff options
303 files changed, 17964 insertions, 9589 deletions
@@ -18,7 +18,7 @@ gbarr Graham Barr gbarr@ti.com gerti Gerd Knops gerti@BITart.com gibreel Stephen Zander gibreel@pobox.com gnat Nathan Torkington gnat@frii.com -gsar Gurusamy Sarathy gsar@umich.edu +gsar Gurusamy Sarathy gsar@activestate.com hansmu Hans Mulder hansmu@xs4all.nl ilya Ilya Zakharevich ilya@math.ohio-state.edu jbuehler Joe Buehler jbuehler@hekimian.com @@ -46,12 +46,12 @@ neale Neale Ferguson neale@VMA.TABNSW.COM.AU nik Nick Ing-Simmons nik@tiuk.ti.com okamoto Jeff Okamoto okamoto@corp.hp.com paul_green Paul Green Paul_Green@stratus.com -pmarquess Paul Marquess pmarquess@bfsec.bt.co.uk +pmarquess Paul Marquess Paul.Marquess@btinternet.com pomeranz Hal Pomeranz pomeranz@netcom.com pudge Chris Nandor pudge@pobox.com pueschel Norbert Pueschel pueschel@imsdd.meb.uni-bonn.de pvhp Peter Prymmer pvhp@forte.com -raphael Raphael Manfredi Raphael_Manfredi@grenoble.hp.com +raphael Raphael Manfredi Raphael_Manfredi@pobox.com rdieter Rex Dieter rdieter@math.unl.edu rsanders Robert Sanders Robert.Sanders@linux.org roberto Ollivier Robert roberto@keltia.freenix.fr @@ -29,7 +29,7 @@ current addresses (as of July 1998): Nick Ing-Simmons <nik@tiuk.ti.com> Andreas Koenig <a.koenig@mind.de> Doug MacEachern <dougm@opengroup.org> - Paul Marquess <pmarquess@bfsec.bt.co.uk> + Paul Marquess <Paul.Marquess@btinternet.com> Stephen McCamant <alias@mcs.com> Laszlo Molnar <laszlo.molnar@eth.ericsson.se> Hans Mulder <hansmu@xs4all.nl> @@ -54,7 +54,7 @@ And the Keepers of the Patch Pumpkin: Malcolm Beattie <mbeattie@sable.ox.ac.uk> Tim Bunce <Tim.Bunce@ig.co.uk> Andy Dougherty <doughera@lafcol.lafayette.edu> - Gurusamy Sarathy <gsar@umich.edu> + Gurusamy Sarathy <gsar@activestate.com> Chip Salzenberg <chip@perl.com> And, of course, the Author of Perl: @@ -75,10 +75,1181 @@ indicator: ---------------- -Version 5.005_63 Development release working toward 5.6 +Version v5.5.640 Development release working toward 5.6 ---------------- ____________________________________________________________________________ +[ 4772] By: gsar on 2000/01/09 19:05:33 + Log: s/usethreads/use5005threads/g + Branch: perl + ! myconfig.SH t/lib/english.t t/lib/thread.t t/op/nothread.t +____________________________________________________________________________ +[ 4771] By: gsar on 2000/01/09 18:51:50 + Log: Configure changes for new-style version numbers (from Andy Dougherty, + slightly altered) + Branch: perl + ! Configure INSTALL Porting/Glossary Porting/config.sh + ! Porting/config_H config_h.SH perl.h win32/Makefile + ! win32/config.bc win32/config.gc win32/config.vc + ! win32/makefile.mk +____________________________________________________________________________ +[ 4770] By: gsar on 2000/01/07 22:18:54 + Log: fix for 'make utest' failures (from Ilya Zakharevich) + Branch: perl + ! regexec.c +____________________________________________________________________________ +[ 4769] By: gsar on 2000/01/07 18:23:16 + Log: cygwin update (from Eric Fifer <EFifer@sanwaint.com>) + Branch: perl + + ext/IPC/SysV/hints/cygwin.pl ext/NDBM_File/hints/cygwin.pl + + ext/ODBM_File/hints/cygwin.pl + ! Configure INSTALL MANIFEST ext/POSIX/Makefile.PL + ! hints/cygwin.sh installman installperl lib/Cwd.pm + ! lib/ExtUtils/MakeMaker.pm lib/File/Spec/Unix.pm lib/perl5db.pl + ! perlsdio.h t/op/magic.t t/op/stat.t utils/perlcc.PL +____________________________________________________________________________ +[ 4768] By: gsar on 2000/01/07 18:12:15 + Log: typo on h2xs.PL (from Helmut Jarausch) + Branch: perl + ! utils/h2xs.PL +____________________________________________________________________________ +[ 4767] By: gsar on 2000/01/07 17:58:45 + Log: VMS update (from Peter Prymmer <pvhp@forte.com>) + Branch: perl + ! README.vms configure.com vms/subconfigure.com +____________________________________________________________________________ +[ 4766] By: gsar on 2000/01/07 17:54:05 + Log: os2/POSIX.mkfifo not needed (from Yitzchak Scott-Thoennes + <sthoenna@efn.org>) + Branch: perl + - os2/POSIX.mkfifo + ! MANIFEST README.os2 +____________________________________________________________________________ +[ 4765] By: gsar on 2000/01/06 20:11:46 + Log: add workaround for dlopen() bug on OpenBSD (relative paths that + match /^lib/ won't load properly) + Branch: perl + + ext/DynaLoader/hints/openbsd.pl + ! Changes MANIFEST ext/DynaLoader/dl_dlopen.xs +____________________________________________________________________________ +[ 4764] By: gsar on 2000/01/06 19:51:08 + Log: add undocumented globals for compatibility--find.pl, and find2perl + generated code need them (from Helmut Jarausch <jarausch@igpm.rwth-aachen.de>) + Branch: perl + ! lib/File/Find.pm +____________________________________________________________________________ +[ 4763] By: gsar on 2000/01/06 10:51:07 + Log: fix various C-backend shenanigans + Branch: perl + ! ext/B/B/C.pm +____________________________________________________________________________ +[ 4762] By: gsar on 2000/01/06 04:09:00 + Log: tweak test in change#4757 for Windows + Branch: perl + ! t/io/open.t +____________________________________________________________________________ +[ 4761] By: gsar on 2000/01/06 02:55:30 + Log: USE_ITHREADS tweak (reused pad values could be SvREADONLY if + they belonged to freed OP_CONSTs) + Branch: perl + ! op.c +____________________________________________________________________________ +[ 4760] By: gsar on 2000/01/06 00:22:40 + Log: constant ranges could escape bareword check in list context + Branch: perl + ! op.c t/pragma/strict-subs +____________________________________________________________________________ +[ 4759] By: gsar on 2000/01/05 20:52:50 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Wed, 05 Jan 2000 15:23:18 EST + Message-Id: <20000105152318.A7400@monk.mps.ohio-state.edu> + Subject: Re: minimal m//g matches appear busted + Branch: perl + ! regexec.c t/op/pat.t +____________________________________________________________________________ +[ 4758] By: gsar on 2000/01/05 12:49:40 + Log: various nits identified by warnings unmasked by recent changes + Branch: perl + ! ext/B/Makefile.PL lib/ExtUtils/Install.pm pod/perlfunc.pod +____________________________________________________________________________ +[ 4757] By: gsar on 2000/01/05 12:48:10 + Log: severe bugs in change#3786 fixed + Branch: perl + ! doio.c t/io/open.t +____________________________________________________________________________ +[ 4756] By: gsar on 2000/01/05 11:25:10 + Log: tweak change#4745 to make ebcdic output match for chars <= 037 + Branch: perl + ! ext/Data/Dumper/Dumper.pm +____________________________________________________________________________ +[ 4755] By: gsar on 2000/01/05 06:56:05 + Log: cygwin support tweaks (from Eric Fifer <EFifer@sanwaint.com>) + Branch: perl + ! Configure util.c utils/perlcc.PL +____________________________________________________________________________ +[ 4754] By: gsar on 2000/01/05 06:52:25 + Log: avoid expensive Version_check (from Andreas Koenig) + Branch: perl + ! Changes lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MM_VMS.pm + ! lib/ExtUtils/MM_Win32.pm lib/ExtUtils/MakeMaker.pm +____________________________________________________________________________ +[ 4753] By: gsar on 2000/01/05 06:48:22 + Log: From: andreas.koenig@anima.de (Andreas J. Koenig) + Date: 03 Jan 2000 21:56:02 +0100 + Message-ID: <sfcvh5azxgd.fsf@hohenstaufen.in-berlin.de> + Subject: Reloading File::Copy + Branch: perl + ! Changes lib/File/Copy.pm t/lib/filecopy.t +____________________________________________________________________________ +[ 4752] By: gsar on 2000/01/04 01:19:20 + Log: s/USE_TEXTMODE_SCRIPTS/PERL_TEXTMODE_SCRIPTS/g + Branch: perl + ! win32/Makefile win32/makefile.mk win32/win32.h +____________________________________________________________________________ +[ 4751] By: gsar on 2000/01/03 18:26:08 + Log: avoid using (custom) autoloader in MakeMaker (from Andreas Koenig) + Branch: perl + ! lib/ExtUtils/MakeMaker.pm +____________________________________________________________________________ +[ 4750] By: gsar on 2000/01/02 21:58:02 + Log: make DProf look at $ENV{PERL_DPROF_OUT_FILE_NAME} to make it possible + to write to a file other than tmon.out (suggested by Haakon Alstadheim + <Haakon.Alstadheim@sds.no>) + Branch: perl + ! ext/Devel/DProf/DProf.pm ext/Devel/DProf/DProf.xs +____________________________________________________________________________ +[ 4749] By: gsar on 2000/01/02 21:37:29 + Log: disable optimization in change#3612 for join() and quotemeta()--this + removes all the gross hacks for the special cases in that change; fix + pp_concat() for when TARG == arg (modified version of patch suggested + by Ilya Zakharevich) + Branch: perl + ! op.c opcode.h opcode.pl pp_hot.c sv.c t/op/lex_assign.t +____________________________________________________________________________ +[ 4748] By: gsar on 2000/01/02 20:26:06 + Log: MakeMaker should attempt to "require" rather than "use" prerequisites + to avoid imports (from Michael G Schwern <schwern@pobox.com>) + Branch: perl + ! lib/ExtUtils/MakeMaker.pm +____________________________________________________________________________ +[ 4747] By: gsar on 2000/01/02 20:17:36 + Log: fix 4-arg substr() when used as argument to subroutine + Branch: perl + ! pp.c t/op/substr.t +____________________________________________________________________________ +[ 4746] By: gsar on 2000/01/02 18:45:58 + Log: usethreads build fixups for NeXTstep (as suggested by Hans Mulder) + Branch: perl + ! embed.h embed.pl ext/DynaLoader/dl_beos.xs + ! ext/DynaLoader/dl_dlopen.xs ext/DynaLoader/dl_hpux.xs + ! ext/DynaLoader/dl_next.xs ext/DynaLoader/dl_rhapsody.xs + ! perlapi.c proto.h thread.h util.c +____________________________________________________________________________ +[ 4745] By: gsar on 2000/01/02 18:15:44 + Log: ebcdic fix for Data::Dumper from Peter Prymmer + Branch: perl + ! ext/Data/Dumper/Dumper.pm regcomp.c +____________________________________________________________________________ +[ 4744] By: gsar on 1999/12/31 22:42:23 + Log: missing files in previous submit + Branch: perl + ! embed.h embed.pl ext/Devel/DProf/DProf.xs globals.c + ! lib/ExtUtils/MM_Unix.pm objXSUB.h perlapi.c proto.h +____________________________________________________________________________ +[ 4743] By: gsar on 1999/12/31 06:47:18 + Log: various Windows build tweaks + Branch: perl + ! win32/win32.h +____________________________________________________________________________ +[ 4742] By: gsar on 1999/12/30 21:32:36 + Log: change#4705 breaks code that interpolates $], so leave string value + of $] as it was for compatibility (and perhaps introduce $^V or similar + for the utf8 representation, maybe?) + Branch: perl + ! configpm gv.c +____________________________________________________________________________ +[ 4741] By: gsar on 1999/12/30 19:36:21 + Log: avoid CRLF in byteloadable files created by perlcc + Branch: perl + ! utils/perlcc.PL +____________________________________________________________________________ +[ 4740] By: gsar on 1999/12/30 19:35:07 + Log: leave DATA open in binmode if __END__ line doesn't have CRLF + Branch: perl + ! pod/perldelta.pod toke.c +____________________________________________________________________________ +[ 4739] By: gsar on 1999/12/30 05:44:21 + Log: enable the PERL_BINMODE_SCRIPTS behavior by default on Windows + to allow ByteLoader to work; the DATA filehandles continue to + be left open in text mode for compatibility + Branch: perl + ! embed.h embed.pl objXSUB.h pod/perldelta.pod proto.h sv.c + ! toke.c win32/Makefile win32/makefile.mk win32/win32.c + ! win32/win32.h +____________________________________________________________________________ +[ 4738] By: gsar on 1999/12/30 04:36:12 + Log: CR-LF support broken for formats + Branch: perl + ! toke.c +____________________________________________________________________________ +[ 4737] By: gsar on 1999/12/29 22:30:52 + Log: make DProf functional under pseudo-fork() + Branch: perl + ! ext/Devel/DProf/DProf.xs +____________________________________________________________________________ +[ 4736] By: gsar on 1999/12/29 21:04:59 + Log: slurp mode fix in change#2910 wasn't quite right (spotted by Hans + Mulder) + Branch: perl + ! doio.c pp_hot.c t/io/argv.t +____________________________________________________________________________ +[ 4735] By: gsar on 1999/12/29 18:12:40 + Log: re.pm is needed earlier, xsubpp now uses it (spotted by Andreas + Koenig) + Branch: perl + ! Makefile.SH +____________________________________________________________________________ +[ 4734] By: gsar on 1999/12/28 21:10:37 + Log: Windows build tweaks + Branch: perl + ! INTERN.h sv.c +____________________________________________________________________________ +[ 4733] By: gsar on 1999/12/28 20:45:15 + Log: remove never-taken branch for making getc() operate on ARGV (spotted + by Ralph Corderoy <ralph@inputplus.demon.co.uk>) + Branch: perl + ! pp_sys.c +____________________________________________________________________________ +[ 4732] By: gsar on 1999/12/28 20:42:13 + Log: tests for change#4642 and pod fixups suggested by Ralph Corderoy + <ralph@inputplus.demon.co.uk> + Branch: perl + ! pod/perldelta.pod pod/perlfunc.pod pod/perlre.pod t/io/argv.t +____________________________________________________________________________ +[ 4731] By: gsar on 1999/12/28 20:23:17 + Log: optimize XSUBs to use targets if the -nooptimize xsubpp option is + not supplied (variant of patch suggested by Ilya Zakharevich) + Branch: perl + ! XSUB.h lib/ExtUtils/xsubpp +____________________________________________________________________________ +[ 4730] By: gsar on 1999/12/28 19:55:56 + Log: range operator does magical string increment iff both operands + are non-numbers, from Tom Phoenix <rootbeer@redcat.com>; fixed + the "foreach (RANGE)" case as well + Branch: perl + ! pp_ctl.c t/op/range.t +____________________________________________________________________________ +[ 4729] By: gsar on 1999/12/28 18:40:19 + Log: Win9x + GCC update from Benjamin Stuhl <sho_pi@hotmail.com> + Branch: perl + - win32/PerlCRT.def win32/gstartup.c win32/oldnames.def + ! EXTERN.h INTERN.h MANIFEST README.win32 iperlsys.h + ! lib/ExtUtils/MM_Win32.pm makedef.pl win32/Makefile + ! win32/config.gc win32/genmk95.pl win32/makefile.mk + ! win32/perlhost.h win32/perllib.c win32/runperl.c win32/win32.c + ! win32/win32.h +____________________________________________________________________________ +[ 4728] By: gsar on 1999/12/28 07:44:19 + Log: typecasts needed + Branch: perl + ! toke.c +____________________________________________________________________________ +[ 4727] By: gsar on 1999/12/28 06:23:08 + Log: change#4721 needed line number adjustments + Branch: perl + ! MANIFEST global.sym proto.h t/pragma/warn/doop + ! t/pragma/warn/pp t/pragma/warn/regcomp t/pragma/warn/sv + ! t/pragma/warn/toke t/pragma/warn/utf8 +____________________________________________________________________________ +[ 4726] By: gsar on 1999/12/28 04:18:15 + Log: integrate utfperl contents into mainline + Branch: perl + +> lib/byte.pm lib/byte_heavy.pl + !> configpm embed.h embed.pl embedvar.h gv.c intrpvar.h objXSUB.h + !> patchlevel.h perl.c perl.h perlapi.c pp_ctl.c pp_hot.c proto.h + !> regnodes.h sv.c sv.h t/comp/require.t toke.c utf8.h +____________________________________________________________________________ +[ 4725] By: gsar on 1999/12/28 04:08:09 + Log: integrate mainline contents + Branch: utfperl + - ext/DynaLoader/dl_cygwin.xs lib/unicode/Eq/Latin1 + - lib/unicode/Eq/Unicode + !> (integrate 60 files) +____________________________________________________________________________ +[ 4724] By: gsar on 1999/12/28 03:44:10 + Log: fix for /(^|a)b/ breakage from Ilya Zakharevich + Branch: perl + ! regcomp.c t/op/re_tests +____________________________________________________________________________ +[ 4723] By: gsar on 1999/12/28 03:28:39 + Log: more ebcdic testsuite fixups (from Peter Prymmer) + Branch: perl + ! Changes lib/bigfloat.pl t/lib/charnames.t t/lib/dumper.t + ! t/pragma/overload.t t/pragma/utf8.t +____________________________________________________________________________ +[ 4722] By: gsar on 1999/12/28 03:14:48 + Log: avoid "used once" warning + Branch: perl + ! lib/diagnostics.pm +____________________________________________________________________________ +[ 4721] By: gsar on 1999/12/28 03:10:32 + Log: ebcdic tweaks for tests from Peter Prymmer + Branch: perl + ! t/pragma/warn/doop t/pragma/warn/pp t/pragma/warn/regcomp + ! t/pragma/warn/sv t/pragma/warn/toke t/pragma/warn/utf8 +____________________________________________________________________________ +[ 4720] By: gsar on 1999/12/28 03:08:39 + Log: pod nits from Simon Cozens <simon@brecon.co.uk> and others + Branch: perl + ! README.os2 lib/ExtUtils/Embed.pm lib/ExtUtils/Install.pm + ! lib/ExtUtils/Liblist.pm lib/ExtUtils/MakeMaker.pm + ! lib/ExtUtils/Mkbootstrap.pm pod/perlop.pod +____________________________________________________________________________ +[ 4719] By: gsar on 1999/12/28 03:01:04 + Log: perlport v1.45 from Chris Nandor + Branch: perl + ! pod/perlport.pod +____________________________________________________________________________ +[ 4718] By: gsar on 1999/12/28 02:59:16 + Log: newer version of constant.pm from Tom Phoenix; added Tom's notes to + perldelta; added STOP, DESTROY and AUTOLOAD to specials list + Branch: perl + ! lib/constant.pm pod/perldelta.pod pod/perlvar.pod + ! t/pragma/constant.t +____________________________________________________________________________ +[ 4717] By: gsar on 1999/12/28 02:47:04 + Log: cygwin update from Eric Fifer <EFifer@sanwaint.com> + Branch: perl + - ext/DynaLoader/dl_cygwin.xs + ! MAINTAIN MANIFEST ext/POSIX/POSIX.xs ext/SDBM_File/sdbm/pair.c + ! hints/cygwin.sh installperl mg.c pod/perlfaq3.pod t/op/stat.t + ! util.c +____________________________________________________________________________ +[ 4716] By: gsar on 1999/12/28 02:40:51 + Log: tweak to show up db-linked-with-libpthread-but-not-perl problem + (from Andy Dougherty) + Branch: perl + ! Configure +____________________________________________________________________________ +[ 4715] By: gsar on 1999/12/28 02:38:44 + Log: better variant of change#4644 (from Andy Dougherty) + Branch: perl + ! Configure +____________________________________________________________________________ +[ 4714] By: gsar on 1999/12/28 02:36:40 + Log: be defensive about setting {host,group,pass}cat (from Andy Dougherty) + Branch: perl + ! Configure +____________________________________________________________________________ +[ 4713] By: gsar on 1999/12/28 02:35:15 + Log: $sitelib should be $prefix/lib/perl5/site_perl, as documented in + INSTALL (from Andy Dougherty) + Branch: perl + ! Configure +____________________________________________________________________________ +[ 4712] By: gsar on 1999/12/28 02:30:55 + Log: avoid creating new files during make install + Branch: perl + ! Makefile.SH +____________________________________________________________________________ +[ 4711] By: gsar on 1999/12/28 02:24:44 + Log: pod edits from Paul Marquess and Mark-Jason Dominus + Branch: perl + ! AUTHORS Changes ext/DynaLoader/dl_aix.xs + ! ext/DynaLoader/dl_dlopen.xs lib/Net/Ping.pm pod/perlcall.pod + ! pod/perldelta.pod +____________________________________________________________________________ +[ 4710] By: gsar on 1999/12/28 02:05:23 + Log: miniperl build fixes for os2 (from Yitzchak Scott-Thoennes + <sthoenna@efn.org>); add explicit target for opmini.o + Branch: perl + ! Makefile.SH cygwin/Makefile.SHs os2/Makefile.SHs +____________________________________________________________________________ +[ 4709] By: gsar on 1999/12/28 01:20:39 + Log: partly fix perldiag regressions identified by Tom Christiansen + Branch: perl + ! doio.c lib/diagnostics.pm pod/perldiag.pod pp_hot.c pp_sys.c + ! t/pragma/warn/4lint t/pragma/warn/doio t/pragma/warn/pp_hot + ! t/pragma/warn/pp_sys +____________________________________________________________________________ +[ 4708] By: gsar on 1999/12/27 23:33:24 + Log: update perldiag for change#4707 + Branch: perl + ! perl.c pod/perldiag.pod +____________________________________________________________________________ +[ 4707] By: gsar on 1999/12/27 23:23:39 + Log: allow spaces in -I switch argument + Branch: perl + ! perl.c +____________________________________________________________________________ +[ 4706] By: gsar on 1999/12/26 23:44:53 + Log: fix typos + Branch: utfperl + ! sv.h toke.c +____________________________________________________________________________ +[ 4705] By: gsar on 1999/12/24 04:02:35 + Log: support for v5.5.640 style version numbers + Branch: utfperl + ! configpm embedvar.h gv.c intrpvar.h objXSUB.h patchlevel.h + ! perl.c perl.h pp_ctl.c sv.c sv.h t/comp/require.t toke.c +____________________________________________________________________________ +[ 4704] By: gsar on 1999/12/23 08:54:27 + Log: bring in basic threads stuff under USE_ITHREADS + Branch: perl + ! makedef.pl op.c perl.c perl.h perlvars.h pp_sys.c thread.h + ! util.c +____________________________________________________________________________ +[ 4703] By: gsar on 1999/12/23 00:10:06 + Log: integrate mainline contents into utfperl + Branch: utfperl + !> (integrate 33 files) +____________________________________________________________________________ +[ 4702] By: gsar on 1999/12/20 17:18:23 + Log: virtual directory handling broken on paths with trailing slash + Branch: perl + ! win32/Makefile win32/makefile.mk win32/vdir.h +____________________________________________________________________________ +[ 4701] By: gsar on 1999/12/20 17:09:55 + Log: revert optimization in change#4700 (it appears OPpRUNTIME flag + isn't set for all m/$foo/o) + Branch: perl + ! pp_ctl.c +____________________________________________________________________________ +[ 4700] By: gsar on 1999/12/20 16:28:51 + Log: avoid pp_regcomp() changing optree at run time under USE_*THREADS (or + we have a race on our hands) + Branch: perl + ! pp_ctl.c +____________________________________________________________________________ +[ 4699] By: gsar on 1999/12/20 16:19:00 + Log: pod tweaks + Branch: perl + ! pod/perldelta.pod pod/perlfilter.pod pod/perlopentut.pod +____________________________________________________________________________ +[ 4698] By: gsar on 1999/12/20 07:55:07 + Log: uv_to_utf8() could lose 37th bit on HAS_QUAD platforms + Branch: perl + ! utf8.c +____________________________________________________________________________ +[ 4697] By: gsar on 1999/12/18 01:35:50 + Log: fix from Larry for parsing C<{ 0x1 => 'foo'}> as an + anon hash rather than a block; test case for the same + Branch: perl + ! t/comp/term.t toke.c +____________________________________________________________________________ +[ 4696] By: gsar on 1999/12/17 19:55:03 + Log: leak in change#4694 spotted by Larry + Branch: perl + ! hv.c +____________________________________________________________________________ +[ 4695] By: gsar on 1999/12/17 18:14:11 + Log: test case for change#4694 + Branch: perl + ! t/op/delete.t +____________________________________________________________________________ +[ 4694] By: gsar on 1999/12/17 18:09:08 + Log: delete() should return the value as is, not a copy thereof + Branch: perl + ! hv.c pod/perldelta.pod +____________________________________________________________________________ +[ 4693] By: gsar on 1999/12/17 17:45:58 + Log: fix for C<"\nx\taa\n" =~ /^\S\s+aa$/m> (from Ilya Zakharevich) + Branch: perl + ! regexec.c t/op/re_tests +____________________________________________________________________________ +[ 4692] By: gsar on 1999/12/17 17:41:10 + Log: credits tweak + Branch: perl + ! lib/File/Spec.pm +____________________________________________________________________________ +[ 4691] By: gsar on 1999/12/17 07:12:53 + Log: DynaLoader doesn't build properly when $(DLSRC) changes + (fix suggested by Hans Mulder) + Branch: perl + ! ext/DynaLoader/Makefile.PL +____________________________________________________________________________ +[ 4690] By: gsar on 1999/12/17 06:26:34 + Log: add missing new ops + Branch: perl + ! ext/B/ramblings/runtime.porting +____________________________________________________________________________ +[ 4689] By: gsar on 1999/12/17 06:16:49 + Log: test harness tweak from Hans Mulder + Branch: perl + ! t/TEST +____________________________________________________________________________ +[ 4688] By: gsar on 1999/12/17 06:14:23 + Log: miniperl build fixes for NeXTstep and cygwin (from Hans Mulder + and Lucian CIONCA <Lucian.Cionca@algoritma.ro>) + Branch: perl + ! Makefile.SH cygwin/Makefile.SHs +____________________________________________________________________________ +[ 4687] By: gsar on 1999/12/17 06:06:46 + Log: applied suggested patch with whitespace adjustments + From: Helmut Jarausch <jarausch@numa1.igpm.rwth-aachen.de> + Date: Thu, 16 Dec 1999 08:57:55 +0100 + Message-id: <38589B82.C4668E10@numa1.igpm.rwth-aachen.de> + Subject: Re: [ID 19991215.001] patch 5.005_63: Find::Fill cannot handle / + Branch: perl + ! lib/File/Find.pm +____________________________________________________________________________ +[ 4686] By: gsar on 1999/12/17 05:48:53 + Log: avoid warnings due to symbols unintroduced by XSLoader (spotted + by Hans Mulder) + Branch: perl + ! ext/DynaLoader/dl_dld.xs ext/DynaLoader/dl_hpux.xs + ! ext/DynaLoader/dl_mpeix.xs ext/DynaLoader/dl_next.xs + ! ext/DynaLoader/dl_rhapsody.xs +____________________________________________________________________________ +[ 4685] By: gsar on 1999/12/17 05:37:51 + Log: fix bug when one of the operands is +0E+0 (from Ronald J Kimball + <rjk@linguist.dartmouth.edu>) + Branch: perl + ! lib/Math/BigFloat.pm t/lib/bigfltpm.t +____________________________________________________________________________ +[ 4684] By: gsar on 1999/12/16 09:32:48 + Log: spell out how to get 4-digit year (from Micheal G Schwern + <schwern@pobox.com>) + Branch: perl + ! pod/perlfunc.pod +____________________________________________________________________________ +[ 4683] By: gsar on 1999/12/16 09:26:53 + Log: type mismatch for %c format argument (spotted by Robin Barker + <rmb1@cise.npl.co.uk>) + Branch: perl + ! regcomp.c +____________________________________________________________________________ +[ 4682] By: gsar on 1999/12/16 08:33:28 + Log: mingw32 doesn't have anonymous union (from Benjamin Stuhl + <sho_pi@hotmail.com>) + Branch: perl + ! win32/win32.c +____________________________________________________________________________ +[ 4681] By: gsar on 1999/12/16 08:31:15 + Log: missing backslash (spotted by Johan Vromans) + Branch: perl + ! perl.c +____________________________________________________________________________ +[ 4680] By: gsar on 1999/12/16 08:26:00 + Log: avoid coredump on diagnostics when STDERR is closed + Branch: perl + ! perl.h +____________________________________________________________________________ +[ 4679] By: gsar on 1999/12/12 18:09:41 + Log: integrate mainline changes + Branch: utfperl + +> (branch 39 files) + - lib/unicode/Jamo-2.txt lib/unicode/Unicode.html + - lib/unicode/UnicodeData-Latest.txt + !> (integrate 447 files) +____________________________________________________________________________ +[ 4678] By: gsar on 1999/12/10 01:39:13 + Log: interpreter structure should be nulled under -DMULTIPLICITY + Branch: perl + ! perl.c +____________________________________________________________________________ +[ 4677] By: gsar on 1999/12/09 11:10:27 + Log: update Changes + Branch: perl + ! Changes + +---------------- +Version 5.005_63 +---------------- + +____________________________________________________________________________ +[ 4676] By: gsar on 1999/12/09 10:51:43 + Log: fix File::Find testsuite bugs in symlink-less places + Branch: perl + ! t/lib/filefind.t +____________________________________________________________________________ +[ 4675] By: gsar on 1999/12/09 10:22:31 + Log: USE_ITHREADS tweaks and notes + Branch: perl + ! op.c pod/perldelta.pod sv.c +____________________________________________________________________________ +[ 4674] By: gsar on 1999/12/09 10:21:53 + Log: allow new style sort subs to work under usethreads + Branch: perl + ! pp_ctl.c +____________________________________________________________________________ +[ 4673] By: gsar on 1999/12/09 04:00:23 + Log: document compatibility issue with literal list slices and NOTOP + (C<not (1,2,3)[0]> is now a syntax error) + Branch: perl + ! pod/perldelta.pod +____________________________________________________________________________ +[ 4672] By: gsar on 1999/12/09 01:14:46 + Log: avoid mismatched expectation <-> int types for C++ builds + Branch: perl + ! embed.pl intrpvar.h proto.h toke.c +____________________________________________________________________________ +[ 4671] By: gsar on 1999/12/09 00:36:24 + Log: newer version of File::Find with support for following symlinks and + other features, from Helmut Jarausch <jarausch@igpm.rwth-aachen.de> + Branch: perl + ! lib/File/Find.pm pod/perldelta.pod t/lib/filefind.t +____________________________________________________________________________ +[ 4670] By: gsar on 1999/12/09 00:13:06 + Log: avoid initializing GvCV slot for autovivified filehandles + Branch: perl + ! pp.c +____________________________________________________________________________ +[ 4669] By: gsar on 1999/12/08 19:09:27 + Log: apply change#4618 again along with Ilya's patch to fix bugs + in it (see change#4622) + Branch: perl + ! embed.h embed.pl perl.h proto.h regcomp.c regcomp.h regexec.c + ! t/op/re_tests t/op/subst.t +____________________________________________________________________________ +[ 4668] By: gsar on 1999/12/08 18:56:53 + Log: patch to fix parser bug in C<${h{${a[0]}}} = 13> + From: Larry Wall <larry@wall.org> + Date: Tue, 7 Dec 1999 12:39:30 -0800 (PST) + Message-Id: <199912072039.MAA13257@kiev.wall.org> + Subject: Re: [ID 19991204.002] Inconsistency of ${hash{key}} + Branch: perl + ! embedvar.h intrpvar.h objXSUB.h sv.c toke.c +____________________________________________________________________________ +[ 4667] By: gsar on 1999/12/08 18:47:37 + Log: patch to fix aix hints from ortmann@vnet.ibm.com + Branch: perl + ! hints/aix.sh +____________________________________________________________________________ +[ 4666] By: gsar on 1999/12/08 18:29:02 + Log: documentation tweaks from M. J. T. Guy, Micheal Schwern, and + Tim Meadowcroft + Branch: perl + ! Changes lib/Benchmark.pm pod/perlipc.pod pod/perlre.pod +____________________________________________________________________________ +[ 4665] By: gsar on 1999/12/08 02:22:31 + Log: introduce save_I8() for saving byte values + Branch: perl + ! embed.h embed.pl global.sym objXSUB.h perlapi.c proto.h + ! regcomp.c regexec.c scope.c scope.h sv.c +____________________________________________________________________________ +[ 4664] By: gsar on 1999/12/08 02:02:33 + Log: use SAVEINT() rather than SAVEDESTRUCTOR() for saving PL_expect etc. + Branch: perl + ! toke.c +____________________________________________________________________________ +[ 4663] By: gsar on 1999/12/08 01:11:44 + Log: longstanding typo in lexer: PL_lex_expect was not properly + saved on reentry + Branch: perl + ! toke.c +____________________________________________________________________________ +[ 4662] By: gsar on 1999/12/07 23:16:21 + Log: typos in change#4546 + Branch: perl + ! ext/B/B.xs ext/B/B/Bytecode.pm ext/B/B/C.pm sv.c +____________________________________________________________________________ +[ 4661] By: gsar on 1999/12/07 09:33:50 + Log: typos in change#4660 + Branch: perl + ! embed.h embed.pl objXSUB.h perl.h perlapi.c pp_sys.c proto.h +____________________________________________________________________________ +[ 4660] By: gsar on 1999/12/06 23:42:55 + Log: tweaks for building with -DUSE_ITHREADS on !WIN32 platforms; + fix bug where lc($readonly) could result in bogus errors + Branch: perl + ! embed.h embed.pl iperlsys.h makedef.pl objXSUB.h perlapi.c + ! pp.c pp_sys.c proto.h sv.c +____________________________________________________________________________ +[ 4659] By: gsar on 1999/12/06 15:24:31 + Log: allow IRIX 6.5 to build perl (from Helmut Jarausch + <jarausch@igpm.rwth-aachen.de>) + Branch: perl + ! perl.h +____________________________________________________________________________ +[ 4658] By: gsar on 1999/12/06 15:18:30 + Log: fix for -Dp via $^D (suggested by Stephane Payrard + <stef@adnaccess.com>) + Branch: perl + ! mg.c +____________________________________________________________________________ +[ 4657] By: gsar on 1999/12/06 06:50:01 + Log: change#4641 needs perldiag.pod edit + Branch: perl + - lib/unicode/UnicodeData-Latest.txt + ! pod/perldiag.pod +____________________________________________________________________________ +[ 4656] By: gsar on 1999/12/06 01:36:56 + Log: Makefile tweak for change#4649 + Branch: perl + ! Makefile.SH +____________________________________________________________________________ +[ 4655] By: gsar on 1999/12/05 17:23:57 + Log: change#4653 was missing a patch reject + Branch: perl + ! win32/makefile.mk +____________________________________________________________________________ +[ 4654] By: gsar on 1999/12/05 11:41:04 + Log: windows build tweaks for Borland compiler + Branch: perl + ! win32/makefile.mk win32/perlhost.h win32/win32.c win32/win32.h +____________________________________________________________________________ +[ 4653] By: gsar on 1999/12/05 11:07:37 + Log: applied somewhat modified version of suggested patch + From: "Benjamin Stuhl" <sho_pi@hotmail.com> + Date: Thu, 18 Nov 1999 18:45:27 PST + Message-ID: <19991119024527.72749.qmail@hotmail.com> + Subject: [PATCH 5.005_62] Perl on Win95, Mark IIB + Branch: perl + + win32/PerlCRT.def win32/gstartup.c win32/oldnames.def + ! MANIFEST ext/SDBM_File/Makefile.PL lib/ExtUtils/MM_Unix.pm + ! lib/ExtUtils/MM_Win32.pm win32/config_sh.PL win32/genmk95.pl + ! win32/makefile.mk win32/win32.h +____________________________________________________________________________ +[ 4652] By: gsar on 1999/12/05 09:24:45 + Log: From: Mike Hopkirk (hops) <hops@scoot.pdev.sco.com> + Date: Thu, 4 Nov 1999 16:34:23 -0800 (PST) + Message-Id: <199911050034.QAA06499@scoot.pdev.sco.com> + Subject: [ID 19991104.005] modified hints file for UnixWare7 ( svr5) + Branch: perl + ! Changes hints/svr5.sh +____________________________________________________________________________ +[ 4651] By: gsar on 1999/12/05 09:01:19 + Log: on dosish platforms, avoid infinite recursion in File::Path::mkpath() + when given non-existent drive names + Branch: perl + ! lib/File/Path.pm +____________________________________________________________________________ +[ 4650] By: gsar on 1999/12/05 08:47:11 + Log: windows build tweaks for change#4649 + Branch: perl + ! win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 4649] By: gsar on 1999/12/05 07:49:28 + Log: make File::Glob::glob() the default for CORE::glob() + (old csh glob can still be had with -DPERL_EXTERNAL_GLOB) + Branch: perl + ! Makefile.SH op.c pod/perldelta.pod win32/Makefile + ! win32/makefile.mk +____________________________________________________________________________ +[ 4648] By: gsar on 1999/12/05 00:33:34 + Log: fix bug in processing L<> tags (from j.vavruska@post.cz) + Branch: perl + ! lib/Pod/Html.pm +____________________________________________________________________________ +[ 4647] By: gsar on 1999/12/05 00:14:01 + Log: remove outdated entry + Branch: perl + ! pod/perltrap.pod +____________________________________________________________________________ +[ 4646] By: gsar on 1999/12/04 22:48:51 + Log: s/block/loop block/ in diagnostics about next, last, redo + Branch: perl + ! pod/perldiag.pod pp_ctl.c t/op/runlevel.t t/pragma/warn/pp_ctl +____________________________________________________________________________ +[ 4645] By: gsar on 1999/12/04 22:25:32 + Log: readability tweak suggested by GRommel@sears.com + Branch: perl + ! pp.c +____________________________________________________________________________ +[ 4644] By: gsar on 1999/12/04 22:05:00 + Log: Configure tweak from Peter Prymmer + Branch: perl + ! Configure +____________________________________________________________________________ +[ 4643] By: gsar on 1999/12/04 21:55:27 + Log: make weak keyword check look for defined(&lock), not + merely defined(*lock) + Branch: perl + ! toke.c +____________________________________________________________________________ +[ 4642] By: gsar on 1999/12/04 21:11:51 + Log: make eof() open ARGV if it isn't open already; also fixes bug + where eof() would operate on any last-read filehandle, not + just ARGV + Branch: perl + ! pp_sys.c +____________________________________________________________________________ +[ 4641] By: gsar on 1999/12/04 04:42:25 + Log: make uninitialized value warnings report opcode + Branch: perl + ! doio.c embed.h embed.pl global.sym objXSUB.h opcode.h + ! opcode.pl perl.h perlapi.c pp.c pp_hot.c proto.h sv.c + ! t/op/misc.t t/pragma/warn/1global t/pragma/warn/2use + ! t/pragma/warn/3both t/pragma/warn/4lint t/pragma/warn/7fatal + ! t/pragma/warn/doio t/pragma/warn/pp t/pragma/warn/pp_hot + ! t/pragma/warn/sv +____________________________________________________________________________ +[ 4640] By: gsar on 1999/12/04 02:40:44 + Log: provide explicit functions timegm_nocheck() and timelocal_nocheck() + that don't do range checking + Branch: perl + ! lib/Time/Local.pm +____________________________________________________________________________ +[ 4639] By: gsar on 1999/12/04 01:00:49 + Log: better implementation of change#3326; open(local $foo,...) now + allowed in addition to any uninitialized variable, for consistency + with how autovivification works elsewhere; add code to use the + variable name as the name of the handle for simple variables, so + that diagnostics report the handle: "... at - line 1, <$foo> line 10." + Branch: perl + ! op.c pod/perldelta.pod pp.c t/io/open.t +____________________________________________________________________________ +[ 4638] By: gsar on 1999/12/03 21:20:00 + Log: pod nits + Branch: perl + ! pod/perlfunc.pod pod/perlrun.pod +____________________________________________________________________________ +[ 4637] By: gsar on 1999/12/03 08:59:04 + Log: change#4431 was flawed + Branch: perl + ! Makefile.SH +____________________________________________________________________________ +[ 4636] By: gsar on 1999/12/03 07:59:52 + Log: pod embellishments from Nathan Torkington + Branch: perl + ! pod/perlfaq2.pod pod/perlhack.pod +____________________________________________________________________________ +[ 4635] By: gsar on 1999/12/03 07:56:04 + Log: perlfaq4 typo (from Jeff Pinyan <jeffp@crusoe.net>) + Branch: perl + ! pod/perlfaq4.pod +____________________________________________________________________________ +[ 4634] By: gsar on 1999/12/03 07:47:47 + Log: test tweak for VMS (from Craig A. Berry) + Branch: perl + ! t/io/nargv.t +____________________________________________________________________________ +[ 4633] By: gsar on 1999/12/03 07:44:52 + Log: patchls tweak from Andreas Koenig + Branch: perl + ! Porting/patchls +____________________________________________________________________________ +[ 4632] By: gsar on 1999/12/03 07:42:23 + Log: don't mess with the umask() + Branch: perl + ! installhtml installman installperl lib/ExtUtils/Install.pm + ! lib/ExtUtils/Manifest.pm +____________________________________________________________________________ +[ 4631] By: gsar on 1999/12/03 06:52:50 + Log: support -a switch to append bytecode to an existing file and make + perlcc use it (from Tom Hughes <tom@compton.nu>) + Branch: perl + ! ext/B/B/Bytecode.pm utils/perlcc.PL +____________________________________________________________________________ +[ 4630] By: gsar on 1999/12/03 06:46:16 + Log: document incompatible perl4 vec() vs bitwise ops interaction trap + (from Tom Phoenix) + Branch: perl + ! pod/perltrap.pod +____________________________________________________________________________ +[ 4629] By: gsar on 1999/12/03 06:40:15 + Log: use PerlIO abstraction rather than straight stdio (from + Chip Salzenberg) + Branch: perl + ! ext/ByteLoader/ByteLoader.xs +____________________________________________________________________________ +[ 4628] By: gsar on 1999/12/03 06:15:54 + Log: avoid warning in IO::Select::exists() if socket doesn't exist + Branch: perl + ! ext/IO/lib/IO/Select.pm +____________________________________________________________________________ +[ 4627] By: gsar on 1999/12/03 06:05:19 + Log: two small patches from Peter Prymmer <pvhp@forte.com> + Branch: perl + ! makedepend.SH win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 4626] By: gsar on 1999/12/03 05:36:38 + Log: From: Peter Prymmer <pvhp@forte.com> + Date: Thu, 25 Nov 1999 21:06:19 -0800 (PST) + Message-Id: <199911260506.VAA17230@brio.forte.com> + Subject: [PATCH: 5.005_62] implement /[:ascii:]/ on ebcdic machines + Branch: perl + ! regcomp.c +____________________________________________________________________________ +[ 4625] By: gsar on 1999/12/03 05:20:21 + Log: Windows build tweaks due to change#4623 + Branch: perl + ! win32/Makefile win32/makefile.mk win32/perlhost.h +____________________________________________________________________________ +[ 4624] By: gsar on 1999/12/03 04:58:30 + Log: add missing file + Branch: perl + + ext/DynaLoader/XSLoader_pm.PL +____________________________________________________________________________ +[ 4623] By: gsar on 1999/12/03 04:47:03 + Log: applied suggested patch; removed $VERSION = $VERSION hack + (change#4043 fixed the need for that) + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Tue, 16 Nov 1999 01:50:31 EST + Message-Id: <199911160650.BAA18874@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_62] XSLoader.pm + Branch: perl + ! MANIFEST ext/B/B.pm ext/ByteLoader/ByteLoader.pm + ! ext/DB_File/DB_File.pm ext/Data/Dumper/Dumper.pm + ! ext/Devel/DProf/DProf.pm ext/Devel/Peek/Peek.pm + ! ext/DynaLoader/DynaLoader_pm.PL ext/DynaLoader/Makefile.PL + ! ext/DynaLoader/dlutils.c ext/Fcntl/Fcntl.pm + ! ext/File/Glob/Glob.pm ext/GDBM_File/GDBM_File.pm ext/IO/IO.pm + ! ext/NDBM_File/NDBM_File.pm ext/ODBM_File/ODBM_File.pm + ! ext/Opcode/Opcode.pm ext/POSIX/POSIX.pm + ! ext/SDBM_File/SDBM_File.pm ext/Socket/Socket.pm + ! ext/Thread/Thread.pm ext/attrs/attrs.pm ext/re/re.pm + ! lib/AutoLoader.pm lib/FindBin.pm lib/Getopt/Std.pm +____________________________________________________________________________ +[ 4622] By: gsar on 1999/12/03 04:02:39 + Log: revert change#4618 (breaks C<$_ = 'A:B'; s/^[a-z]:/x/>) + Branch: perl + ! Changes embed.h embed.pl perl.h proto.h regcomp.c regcomp.h +____________________________________________________________________________ +[ 4621] By: gsar on 1999/12/02 22:24:53 + Log: caveat about thread-safety of extensions + Branch: perl + ! pod/perlfork.pod +____________________________________________________________________________ +[ 4620] By: gsar on 1999/12/02 20:31:02 + Log: XS documentation patches suggested by Ilya, severally adjusted + Branch: perl + ! pod/perlxs.pod pod/perlxstut.pod +____________________________________________________________________________ +[ 4619] By: gsar on 1999/12/02 17:52:50 + Log: re-add missing Unicode database master + Branch: perl + + lib/unicode/Unicode.300 +____________________________________________________________________________ +[ 4618] By: gsar on 1999/12/02 06:56:18 + Log: applied suggested patch with prototype changes + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Tue, 23 Nov 1999 22:55:55 EST + Message-Id: <199911240355.WAA23033@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_62] First char cognizance + Branch: perl + ! embed.h embed.pl perl.h proto.h regcomp.c regcomp.h +____________________________________________________________________________ +[ 4617] By: gsar on 1999/12/02 06:04:57 + Log: fixes for bugs in change#4586 and OS/2 pod tweak, from Ilya + Branch: perl + ! os2/OS2/REXX/REXX.pm regexec.c t/op/re_tests +____________________________________________________________________________ +[ 4616] By: gsar on 1999/12/02 04:30:22 + Log: various documentation tweaks suggested by M. J. T. Guy + Branch: perl + ! INSTALL lib/strict.pm pod/perlfunc.pod pod/perlsyn.pod +____________________________________________________________________________ +[ 4615] By: gsar on 1999/12/02 04:17:43 + Log: various File::Glob fixes for DOSISH platforms + From: "Moore, Paul" <Paul.Moore@uk.origin-it.com> + Date: Tue, 02 Nov 1999 11:11:25 GMT + Message-Id: <714DFA46B9BBD0119CD000805FC1F53BDC38E3@UKRUX002.rundc.uk.origin-it.com> + Subject: File::Glob again. Final patch, honest! + Branch: perl + + t/lib/glob-case.t + ! MANIFEST ext/File/Glob/Changes ext/File/Glob/Glob.pm + ! ext/File/Glob/Glob.xs ext/File/Glob/bsd_glob.c + ! ext/File/Glob/bsd_glob.h op.c t/lib/glob-global.t +____________________________________________________________________________ +[ 4614] By: gsar on 1999/12/02 03:42:55 + Log: allow XSUBs and prototyped subroutines to be used with sort() (tweaked + variant of patch suggested by Peter Haworth <pmh@edison.ioppublishing.com>) + Branch: perl + ! pod/perldelta.pod pod/perlfunc.pod pp_ctl.c t/op/sort.t +____________________________________________________________________________ +[ 4613] By: gsar on 1999/12/02 01:59:19 + Log: ignore yet another known scalar leak + Branch: perl + ! t/pragma/warn/regcomp +____________________________________________________________________________ +[ 4612] By: gsar on 1999/12/02 01:15:02 + Log: avoid potential stack extension bug in pp_unpack() (spotted by Ilya) + Branch: perl + ! pp.c +____________________________________________________________________________ +[ 4611] By: gsar on 1999/12/02 00:31:43 + Log: a somewhat tweaked version of suggested patch + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Wed, 27 Oct 1999 18:57:41 -0400 (EDT) + Message-Id: <199910272257.SAA29928@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_62] Another round of pack/vec docs patches + Branch: perl + ! pod/perlfunc.pod +____________________________________________________________________________ +[ 4610] By: gsar on 1999/12/01 19:09:31 + Log: more accurate require() pseudocode (from James P. Williams + <James.P.Williams@USAHQ.UnitedSpaceAlliance.com>) + Branch: perl + ! pod/perlfunc.pod +____________________________________________________________________________ +[ 4609] By: gsar on 1999/12/01 18:43:49 + Log: avoid "Callback called exit" error on intentional exit() + Branch: perl + ! embedvar.h intrpvar.h objXSUB.h perl.c perl.h pp_ctl.c +____________________________________________________________________________ +[ 4608] By: gsar on 1999/12/01 18:42:38 + Log: find_byclass() prototype was incoherent + Branch: perl + ! regexec.c +____________________________________________________________________________ +[ 4607] By: gsar on 1999/12/01 05:45:10 + Log: better documentation for goto &NAME (from M. J. T. Guy) + Branch: perl + ! pod/perlfunc.pod +____________________________________________________________________________ +[ 4606] By: gsar on 1999/12/01 05:33:14 + Log: integrate cfgperl contents into mainline + Branch: perl + +> lib/unicode/Jamo.txt lib/unicode/NamesList.html + +> lib/unicode/UCD300.html lib/unicode/Unicode3.html + - lib/unicode/Jamo-2.txt lib/unicode/Unicode.html + ! Changes + !> (integrate 210 files) +____________________________________________________________________________ +[ 4605] By: gsar on 1999/12/01 05:15:27 + Log: avoid PTR->IV cast warnings + Branch: perl + ! mg.c op.c scope.h +____________________________________________________________________________ +[ 4604] By: gsar on 1999/12/01 03:59:56 + Log: email address changes + Branch: perl + ! AUTHORS Changes Porting/genlog Porting/p4d2p Porting/p4desc + ! README.win32 ext/Data/Dumper/Dumper.pm lib/DB.pm + ! lib/File/DosGlob.pm lib/Math/Complex.pm lib/Math/Trig.pm + ! pod/perl5005delta.pod pod/perlport.pod t/op/runlevel.t + ! utils/perlbug.PL utils/perldoc.PL win32/bin/perlglob.pl +____________________________________________________________________________ +[ 4603] By: gsar on 1999/12/01 03:45:13 + Log: minor USE_ITHREADS tweaks + Branch: perl + ! doio.c op.c op.h pp_hot.c pp_sys.c run.c win32/Makefile + ! win32/perllib.c win32/win32.h +____________________________________________________________________________ +[ 4602] By: gsar on 1999/12/01 01:00:09 + Log: more complete pseudo-fork() support for Windows + Branch: perl + + pod/perlfork.pod win32/perlhost.h win32/vdir.h win32/vmem.h + ! MANIFEST XSUB.h cop.h dump.c embed.h embed.pl embedvar.h + ! ext/B/B/CC.pm ext/Opcode/Opcode.xs global.sym globals.c + ! globvar.sym gv.c hv.c intrpvar.h iperlsys.h makedef.pl mg.c + ! mpeix/mpeixish.h objXSUB.h op.c op.h os2/os2ish.h perl.c + ! perl.h perlapi.c plan9/plan9ish.h pod/Makefile pod/buildtoc + ! pod/perl.pod pod/roffitall pp.c pp_ctl.c pp_hot.c pp_sys.c + ! proto.h regcomp.c run.c scope.c scope.h sv.c t/op/fork.t + ! toke.c unixish.h util.c vos/vosish.h win32/Makefile + ! win32/makefile.mk win32/perllib.c win32/win32.c win32/win32.h + ! win32/win32iop.h win32/win32thread.h +____________________________________________________________________________ +[ 4601] By: gsar on 1999/12/01 00:45:38 + Log: rudimentary support for remote debugging, from aeons ago (somewhat + modified) + From: Graham TerMarsch <grahamt@ActiveState.com> + Date: Sat, 12 Sep 1998 10:46:55 -0700 + Message-ID: <35FAB38F.EA9AAC50@activestate.com> + Subject: Re: Patches to perl5db.pl to allow for remote debugging + Branch: perl + ! lib/perl5db.pl +____________________________________________________________________________ +[ 4600] By: chip on 1999/11/19 21:16:00 + Log: Document known limitations of fdopen() on some systems, + as they apply to open() and sysopen(). + Branch: perl + ! pod/perlfunc.pod +____________________________________________________________________________ +[ 4599] By: chip on 1999/11/19 17:20:19 + Log: Undef printf before redirecting it to PerlIO_stdoutf. + (Avoids an irritating warning when compiling with PerlIO.) + Branch: perl + ! perl.h +____________________________________________________________________________ +[ 4598] By: jhi on 1999/11/22 21:30:17 + Log: Small VMS nits from Craig A. Berry, <craig.berry@metamor.com>. + Branch: cfgperl + ! README.vms t/io/open.t +____________________________________________________________________________ +[ 4597] By: jhi on 1999/11/21 16:21:21 + Log: Replace #4596 with the change done in 5.005_03. + Branch: cfgperl + ! ext/Errno/Errno_pm.PL +____________________________________________________________________________ +[ 4596] By: jhi on 1999/11/21 16:07:20 + Log: Skip processing a file if the file to be opened is '-' + (can happen in UNICOS) + Branch: cfgperl + ! ext/Errno/Errno_pm.PL +____________________________________________________________________________ +[ 4595] By: jhi on 1999/11/21 14:05:10 + Log: VMS patches from Peter Prymmer. + Branch: cfgperl + ! doio.c mg.c taint.c vms/subconfigure.com vms/vms.c +____________________________________________________________________________ +[ 4594] By: jhi on 1999/11/18 17:07:14 + Log: The find_byclass prototype is already in proto.h. + Branch: cfgperl + ! regexec.c +____________________________________________________________________________ +[ 4593] By: gsar on 1999/11/16 21:25:21 + Log: typo in flag checks + Branch: utfperl + ! sv.h +____________________________________________________________________________ +[ 4592] By: jhi on 1999/11/16 21:17:25 + Log: Regen Configure. + Branch: cfgperl + ! Configure config_h.SH pp.c pp.h vms/subconfigure.com + Branch: metaconfig + ! U/a_dvisory/quadtype.U +____________________________________________________________________________ +[ 4591] By: jhi on 1999/11/16 14:53:19 + Log: Integrate with Sarathy. + Branch: cfgperl + !> cop.h deb.c embed.h embed.pl global.sym lib/Pod/Checker.pm + !> lib/Pod/InputObjects.pm lib/Pod/Parser.pm lib/Pod/Select.pm + !> lib/Pod/Usage.pm makedef.pl objXSUB.h perl.c perlapi.c + !> pod/podchecker.PL pp_sys.c proto.h sv.c t/pod/poderrs.t + !> t/pod/poderrs.xr +____________________________________________________________________________ +[ 4590] By: gsar on 1999/11/16 05:57:56 + Log: Pod::Parser updates (v1.091) from Brad Appleton <bradapp@enteract.com> + Branch: perl + ! lib/Pod/Checker.pm lib/Pod/InputObjects.pm lib/Pod/Parser.pm + ! lib/Pod/Select.pm lib/Pod/Usage.pm pod/podchecker.PL + ! t/pod/poderrs.t t/pod/poderrs.xr +____________________________________________________________________________ +[ 4589] By: gsar on 1999/11/15 18:47:34 + Log: add a synchronous stub fork() for USE_ITHREADS to prove that a simple + C<if (fork()) { print "parent" } else { print "child" }> works on + Windows (incidentally running a cloned^2 interpreter :) + Branch: perl + ! embed.h embed.pl global.sym makedef.pl objXSUB.h perlapi.c + ! pp_sys.c proto.h sv.c +____________________________________________________________________________ +[ 4588] By: gsar on 1999/11/15 14:34:36 + Log: cloning the stack (part 1) + Branch: perl + ! cop.h deb.c perl.c sv.c +____________________________________________________________________________ +[ 4587] By: jhi on 1999/11/15 00:22:20 + Log: Integrate with Sarathy. + Branch: cfgperl + !> Changes embed.h embed.pl embedvar.h global.sym intrpvar.h + !> makedef.pl objXSUB.h op.c perl.h perlapi.c proto.h run.c sv.c + !> win32/perllib.c +____________________________________________________________________________ +[ 4586] By: jhi on 1999/11/14 21:17:26 + Log: Ilya's "hopscotch" patch, reworked by Ilya to fit. + Branch: cfgperl + ! embed.h embed.pl embedvar.h proto.h regexec.c t/op/re_tests +____________________________________________________________________________ +[ 4585] By: gsar on 1999/11/14 20:01:45 + Log: tweak for win32 build + Branch: perl + ! embed.h embed.pl op.c proto.h +____________________________________________________________________________ +[ 4584] By: gsar on 1999/11/14 19:46:25 + Log: cosmetic tweaks + Branch: perl + ! embed.h embed.pl embedvar.h global.sym intrpvar.h makedef.pl + ! objXSUB.h perl.h perlapi.c proto.h sv.c win32/perllib.c +____________________________________________________________________________ +[ 4583] By: gsar on 1999/11/14 17:38:32 + Log: fix problem pointer casts + Branch: perl + ! Changes run.c sv.c +____________________________________________________________________________ [ 4582] By: jhi on 1999/11/14 17:10:01 Log: Integrate with Sarathy. Branch: cfgperl @@ -20,7 +20,7 @@ # $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $ # -# Generated on Tue Nov 16 23:04:27 EET 1999 [metaconfig 3.0 PL70] +# Generated on Fri Jan 7 16:14:30 EST 2000 [metaconfig 3.0 PL70] # (with additional metaconfig patches by perlbug@perl.com) cat >/tmp/c1$$ <<EOF @@ -746,6 +746,8 @@ ranlib='' package='' spackage='' pager='' +apirevision='' +apisubversion='' apiversion='' patchlevel='' subversion='' @@ -862,6 +864,8 @@ usenm='' useperlio='' usesocks='' d_oldpthreads='' +use5005threads='' +useithreads='' usethreads='' incpath='' mips_type='' @@ -879,8 +883,6 @@ vendorprefix='' vendorprefixexp='' defvoidused='' voidflags='' -pm_apiversion='' -xs_apiversion='' CONFIG='' define='define' @@ -1888,6 +1890,7 @@ comm cp echo expr +find grep ls make @@ -1909,11 +1912,14 @@ date egrep gzip less +line ln more nm nroff +perl pg +sendmail test uname zip @@ -2205,12 +2211,14 @@ EOM osvers="$2.$3" fi fi - $test -f /sys/posix.dll && - $test -f /usr/bin/what && - set X `/usr/bin/what /sys/posix.dll` && - $test "$3" = UWIN && - osname=uwin && - osvers="$5" + + $test -f /sys/posix.dll && + $test -f /usr/bin/what && + set X `/usr/bin/what /sys/posix.dll` && + $test "$3" = UWIN && + osname=uwin && + osvers="$5" + if $test -f $uname; then set X $myuname shift @@ -2260,6 +2268,12 @@ EOM *) osvers=$tmp;; esac ;; + bsd386) osname=bsd386 + osvers=`$uname -r` + ;; + cygwin*) osname=cygwin + osvers="$3" + ;; *dc.osx) osname=dcosx osvers="$3" ;; @@ -2304,17 +2318,17 @@ EOM *) osname=newsos ;; esac ;; - bsd386) osname=bsd386 - osvers=`$uname -r` + next*) osname=next ;; + POSIX-BC | posix-bc ) osname=posix-bc + osvers="$3" ;; - POSIX-BC | posix-bc ) osname=posix-bc - osvers="$3" - ;; powerux | power_ux | powermax_os | powermaxos | \ powerunix | power_unix) osname=powerux osvers="$3" ;; - next*) osname=next ;; + qnx) osname=qnx + osvers="$4" + ;; solaris) osname=solaris case "$3" in 5*) osvers=`echo $3 | $sed 's/^5/2/g'` ;; @@ -2355,9 +2369,6 @@ EOM uts) osname=uts osvers="$3" ;; - qnx) osname=qnx - osvers="$4" - ;; $2) case "$osname" in *isc*) ;; *freebsd*) ;; @@ -2657,11 +2668,52 @@ esac rp='Build a threading Perl?' . ./myread case "$ans" in -y|Y) val="$define" ;; +y|Y) val="$define" ;; *) val="$undef" ;; esac set usethreads -eval $setvar +eval $setvar + +case "$usethreads" in +$define) + $cat <<EOM + +As of 5.5.640, Perl has two different internal threading implementations, +the 5.005 version (5005threads) and an interpreter-based version +(ithreads) that has one interpreter per thread. Both are very +experimental. This arrangement exists to help developers work out +which one is better. +EOM + : Default to ithreads unless overridden on command line or with + : old config.sh + dflt='y' + case "$use5005threads" in + $define|true|[yY]*) dflt='n';; + esac + case "$useithreads" in + $undef|false|[nN]*) dflt='n';; + esac + rp='Use interpreter-based ithreads?' + . ./myread + case "$ans" in + y|Y) val="$define" ;; + *) val="$undef" ;; + esac + set useithreads + eval $setvar + : Now set use5005threads to the opposite value. + case "$useithreads" in + $define) val="$undef" ;; + *) val="$define" ;; + esac + set use5005threads + eval $setvar + ;; +*) + useithreads="$undef" + use5005threads="$undef" + ;; +esac case "$d_oldpthreads" in '') : Configure tests would be welcome here. For now, assume undef. @@ -2686,27 +2738,34 @@ case "$usethreads" in Assuming POSIX threads, then.) EOM fi - ;; + ;; esac -cat <<EOM +case "$useithreads" in +$define|true|[yY]*) + echo "Interpreter threads requested, multiple interpreter support enabled..." >&4 + val="$define" ;; +*) + cat <<EOM -Perl can be built so that multiple Perl interpreters can coexist -within the same Perl executable. To do so, Configure must be run with --Dusemultiplicity. + Perl can be built so that multiple Perl interpreters can coexist + within the same Perl executable. To do so, Configure must be run with + -Dusemultiplicity. -Normally you do not need this and you should answer no. + Normally you do not need this and you should answer no. EOM -case "$usemultiplicity" in -$define|true|[yY]*) dflt='y';; -*) dflt='n';; -esac -rp='Build Perl for multiplicity?' -. ./myread -case "$ans" in -y|Y) val="$define" ;; -*) val="$undef" ;; + case "$usemultiplicity" in + $define|true|[yY]*) dflt='y';; + *) dflt='n';; + esac + rp='Build Perl for multiplicity?' + . ./myread + case "$ans" in + y|Y) val="$define" ;; + *) val="$undef" ;; + esac + ;; esac set usemultiplicity eval $setvar @@ -4595,20 +4654,23 @@ prefixit='case "$3" in esac;; esac' -: set the base revision -baserev=5.0 - -: get the patchlevel +: get the revision, patchlevel, subversion echo " " echo "Getting the current patchlevel..." >&4 if $test -r $rsrc/patchlevel.h;then + baserev=`awk '/define[ ]+PERL_REVISION/ {print $3}' $rsrc/patchlevel.h` patchlevel=`awk '/define[ ]+PERL_VERSION/ {print $3}' $rsrc/patchlevel.h` subversion=`awk '/define[ ]+PERL_SUBVERSION/ {print $3}' $rsrc/patchlevel.h` - apiversion=`awk '/define[ ]+PERL_APIVERSION/ {print $3}' $rsrc/patchlevel.h` + apirevision=`awk '/define[ ]+PERL_API_REVISION/ {print $3}' $rsrc/patchlevel.h` + apiversion=`awk '/define[ ]+PERL_API_VERSION/ {print $3}' $rsrc/patchlevel.h` + apisubversion=`awk '/define[ ]+PERL_API_SUBVERSION/ {print $3}' $rsrc/patchlevel.h` else + baserev=0 patchlevel=0 subversion=0 + apirevision=0 apiversion=0 + apisubversion=0 fi $echo $n "(You have $package" $c case "$package" in @@ -4619,14 +4681,14 @@ $echo $n " patchlevel $patchlevel" $c test 0 -eq "$subversion" || $echo $n " subversion $subversion" $c echo ".)" -if test 0 -eq "$subversion"; then +if $test -n $osname -a "$osname" = "dos"; then version=`LC_ALL=C; export LC_ALL; \ - echo $baserev $patchlevel | \ - $awk '{ printf "%.3f\n", $1 + $2/1000.0 }'` + echo $baserev $patchlevel $subversion | \ + $awk '{ printf "%d_%d_%d\n", $1, $2, $3 }'` else version=`LC_ALL=C; export LC_ALL; \ echo $baserev $patchlevel $subversion | \ - $awk '{ printf "%.5f\n", $1 + $2/1000.0 + $3/100000.0 }'` + $awk '{ printf "%d.%d.%d\n", $1, $2, $3 }'` fi : determine installation style @@ -5109,11 +5171,11 @@ case "$vendorprefix" in ;; *) d_vendorlib="$define" : determine where vendor-supplied modules go. - : Usual default is /usr/local/lib/perl5/vendor_perl + : Usual default is /usr/local/lib/perl5/vendor_perl/$version prog=`echo $package | $sed 's/-*[0-9.]*$//'` case "$installstyle" in - *lib/perl5*) dflt=$vendorprefix/lib/$package/vendor_$prog ;; - *) dflt=$vendorprefix/lib/vendor_$prog ;; + *lib/perl5*) dflt=$vendorprefix/lib/$package/vendor_$prog/$version ;; + *) dflt=$vendorprefix/lib/vendor_$prog/$version ;; esac fn=d~+ rp='Pathname for the vendor-supplied library files?' @@ -5905,7 +5967,7 @@ $undef) ;; *) case "$useshrplib" in '') case "$osname" in - svr4*|dgux|dynixptx|esix|powerux|beos) + svr4*|dgux|dynixptx|esix|powerux|beos|cygwin*) dflt=y also='Building a shared libperl is required for dynamic loading to work on your system.' ;; @@ -5975,6 +6037,9 @@ true) linux*) # ld won't link with a bare -lperl otherwise. dflt=libperl.$so ;; + cygwin*) # include version + dflt=`echo libperl$version | sed -e 's/\./_/g'`$lib_ext + ;; *) # Try to guess based on whether libc has major.minor. case "$libc" in *libc.$so.[0-9]*.[0-9]*) dflt=$majmin ;; @@ -6378,13 +6443,13 @@ if $test -d /usr/etc/yp || $test -d /etc/yp; then esac fi case "$hostcat" in -'') hostcat='cat /etc/hosts';; +'') test -f /etc/hosts && hostcat='cat /etc/hosts';; esac case "$groupcat" in -'') groupcat='cat /etc/group';; +'') test -f /etc/group && groupcat='cat /etc/group';; esac case "$passcat" in -'') passcat='cat /etc/passwd';; +'') test -f /etc/passwd && passcat='cat /etc/passwd';; esac : now get the host name @@ -6486,6 +6551,7 @@ case "$myhostname" in $sed -e 's/[ ]*#.*//; s/$/ /' > hosts && \ $test -s hosts } || { + test "X$hostcat" != "X" && $hostcat | $sed -n -e "s/[ ]*#.*//; s/\$/ / /[ ]$myhostname[ . ]/p" > hosts } @@ -6773,13 +6839,13 @@ siteprefix="$ans" siteprefixexp="$ansexp" : determine where site specific libraries go. -: Usual default is /usr/local/lib/perl5/site_perl +: Usual default is /usr/local/lib/perl5/site_perl/$version : The default "style" setting is made in installstyle.U : XXX No longer works with Prefixit stuff. prog=`echo $package | $sed 's/-*[0-9.]*$//'` case "$installstyle" in -*lib/perl5*) dflt=$siteprefix/lib/site_$prog ;; -*) dflt=$siteprefix/lib/site_$prog ;; +*lib/perl5*) dflt=$siteprefix/lib/$package/site_$prog/$version ;; +*) dflt=$siteprefix/lib/site_$prog/$version ;; esac $cat <<EOM @@ -6802,11 +6868,11 @@ else fi : determine where site specific architecture-dependent libraries go. -: sitelib default is /usr/local/lib/perl5/site_perl/ -: sitearch default is /usr/local/lib/perl5/site_perl/$apiversion/$archname +: sitelib default is /usr/local/lib/perl5/site_perl/$version +: sitearch default is /usr/local/lib/perl5/site_perl/$version/$archname : sitelib may have an optional trailing /share. tdflt=`echo $sitelib | $sed 's,/share$,,'` -tdflt="$tdflt/$apiversion/$archname" +tdflt="$tdflt/$archname" set sitearch sitearch none eval $prefixit case "$sitearch" in @@ -11262,7 +11328,7 @@ int main() } EOCP set try - if eval $compile && ./try; then + if eval $compile_ok && ./try; then echo 'Looks OK.' >&4 else echo "I can't use Berkeley DB with your <db.h>. I'll disable Berkeley DB." >&4 @@ -12619,15 +12685,6 @@ rp="What is the type of process ids on this system?" set pid_t pidtype int stdio.h sys/types.h eval $typedef_ask -: Find earliest binary compatible site_perl subdirectory perl can use. -case "$bincompat5005" in -"$define") xs_apiversion='5.005' ;; -*) xs_apiversion=$apiversion ;; # The current site_perl version. -esac -: Find earliest pure perl site_perl subdirectory perl can use. -: The versioned directories started at 5.005. -pm_apiversion='5.005' - : check for length of pointer echo " " case "$ptrsize" in @@ -12856,10 +12913,16 @@ esac : Remove SIGSTKSIZE used by Linux. : Remove SIGSTKSZ used by Posix. : Remove SIGTYP void lines used by OS2. -xxx=`echo '#include <signal.h>' | +: Some cpps, like os390, dont give the file name anywhere +if [ "X$fieldn" = X ]; then + : Just make some guesses. We check them later. + xxx='/usr/include/signal.h /usr/include/sys/signal.h' +else + xxx=`echo '#include <signal.h>' | $cppstdin $cppminus $cppflags 2>/dev/null | $grep '^[ ]*#.*include' | $awk "{print \\$$fieldn}" | $sed 's!"!!g' | $sort | $uniq` +fi : Check this list of files to be sure we have parsed the cpp output ok. : This will also avoid potentially non-existent files, such : as ../foo/bar.h @@ -12879,10 +12942,12 @@ $1 == "#" && $2 ~ /^define$/ && $3 ~ /^SIG[A-Z0-9]*$/ && $3 !~ /SIGARRAYSIZE/ && print substr($3, 4, 20) }' $xxxfiles` : Append some common names just in case the awk scan failed. -xxx="$xxx ABRT ALRM BUS CHLD CLD CONT DIL EMT FPE HUP ILL INT IO IOT KILL" -xxx="$xxx LOST PHONE PIPE POLL PROF PWR QUIT SEGV STKFLT STOP SYS TERM TRAP" -xxx="$xxx TSTP TTIN TTOU URG USR1 USR2 USR3 USR4 VTALRM" -xxx="$xxx WINCH WIND WINDOW XCPU XFSZ" +xxx="$xxx ABRT ALRM BUS CANCEL CHLD CLD CONT DIL EMT FPE" +xxx="$xxx FREEZE HUP ILL INT IO IOT KILL LOST LWP PHONE" +xxx="$xxx PIPE POLL PROF PWR QUIT RTMAX RTMIN SEGV STKFLT STOP" +xxx="$xxx SYS TERM THAW TRAP TSTP TTIN TTOU URG USR1 USR2" +xxx="$xxx USR3 USR4 VTALRM WAITING WINCH WIND WINDOW XCPU XFSZ" + : generate a few handy files for later $cat > signal.c <<'EOCP' #include <sys/types.h> @@ -14166,6 +14231,8 @@ afs='$afs' alignbytes='$alignbytes' ansi2knr='$ansi2knr' aphostname='$aphostname' +apirevision='$apirevision' +apisubversion='$apisubversion' apiversion='$apiversion' ar='$ar' archlib='$archlib' @@ -14718,7 +14785,6 @@ pg='$pg' phostname='$phostname' pidtype='$pidtype' plibpth='$plibpth' -pm_apiversion='$pm_apiversion' pmake='$pmake' pr='$pr' prefix='$prefix' @@ -14831,8 +14897,10 @@ uidtype='$uidtype' uname='$uname' uniq='$uniq' uquadtype='$uquadtype' +use5005threads='$use5005threads' use64bits='$use64bits' usedl='$usedl' +useithreads='$useithreads' uselargefiles='$uselargefiles' uselongdouble='$uselongdouble' uselonglong='$uselonglong' @@ -14866,7 +14934,6 @@ version='$version' vi='$vi' voidflags='$voidflags' xlibpth='$xlibpth' -xs_apiversion='$xs_apiversion' zcat='$zcat' zip='$zip' EOT @@ -27,7 +27,7 @@ # define EXTCONST globalref # define dEXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly #else -# if defined(WIN32) && !defined(PERL_STATIC_SYMS) && !defined(__GNUC__) && !defined(PERL_OBJECT) +# if defined(WIN32) && !defined(PERL_STATIC_SYMS) && !defined(PERL_OBJECT) # ifdef PERLDLL # define EXT extern __declspec(dllexport) # define dEXT @@ -4,6 +4,10 @@ Install - Build and Installation guide for perl5. =head1 SYNOPSIS +First, make sure you are installing an up-to-date version of Perl. If +you didn't get your Perl source from CPAN, check the latest version at +<URL:http://www.perl.com/CPAN/src/>. + The basic steps to build and install perl5 on a Unix system are: rm -f config.sh Policy.sh @@ -28,8 +32,6 @@ on the platform. If that's not okay with you, use make test make install -Full configuration instructions can be found in the INSTALL file. - For information on non-Unix systems, see the section on L<"Porting information"> below. @@ -333,7 +335,7 @@ The directories set up by Configure fall into three broad categories. By default, Configure will use the following directories for 5.6. $version is the full perl version number, including subversion, e.g. -5.6 or 5.6.1, and $archname is a string like sun4-sunos, +5.6.0 or 5.6.1, and $archname is a string like sun4-sunos, determined by Configure. The full definitions of all Configure variables are in the file Porting/Glossary. @@ -358,23 +360,22 @@ the common style is shown here. After perl is installed, you may later wish to add modules (e.g. from CPAN) or scripts. Configure will set up the following directories to -be used for installing those add-on modules and scripts. $apiversion -is the perl version number (without subversion), e.g. 5.6. +be used for installing those add-on modules and scripts. $version +is the perl version number, e.g. 5.6.0. Configure variable Default value $siteprefix $prefix $sitebin $siteprefix/bin $sitescriptdir $siteprefix/bin - $sitelib $siteprefix/lib/perl5/site_perl/ - $sitearch $siteprefix/lib/perl5/site_perl/$apiversion/$archname + $sitelib $siteprefix/lib/perl5/site_perl/$version + $sitearch $siteprefix/lib/perl5/site_perl/$version/$archname $siteman1dir $siteprefix/man/man1 $siteman3dir $siteprefix/man/man3 $sitehtml1dir (none) $sitehtml3dir (none) By default, ExtUtils::MakeMaker will install architecture-independent -modules into $sitelib/$apiversion and architecture-dependent modules -into $sitearch. +modules into $sitelib and architecture-dependent modules into $sitearch. =item Directories for vendor-supplied add-on files @@ -387,8 +388,8 @@ for you to use to distribute add-on modules. (The next ones are set only if vendorprefix is set.) $vendorbin $vendorprefix/bin $vendorscriptdir $vendorprefix/bin - $vendorlib $vendorprefix/lib/perl5/vendor_perl/ - $vendorarch $vendorprefix/lib/perl5/vendor_perl/$apiversion/$archname + $vendorlib $vendorprefix/lib/perl5/vendor_perl/$version + $vendorarch $vendorprefix/lib/perl5/vendor_perl/$version/$archname $vendorman1dir $vendorprefix/man/man1 $vendorman3dir $vendorprefix/man/man3 $vendorhtml1dir (none) @@ -412,24 +413,28 @@ This would have the effect of setting the following: $sitebin /usr/local/bin $sitescriptdir /usr/local/bin - $sitelib /usr/local/lib/perl5/site_perl/ - $sitearch /usr/local/lib/perl5/site_perl/$apiversion/$archname + $sitelib /usr/local/lib/perl5/site_perl/$version + $sitearch /usr/local/lib/perl5/site_perl/$version/$archname $siteman1dir /usr/local/man/man1 $siteman3dir /usr/local/man/man3 $vendorbin /usr/bin $vendorscriptdir /usr/bin - $vendorlib /usr/lib/perl5/vendor_perl/ - $vendorarch /usr/lib/perl5/vendor_perl/$apiversion/$archname + $vendorlib /usr/lib/perl5/vendor_perl/$version + $vendorarch /usr/lib/perl5/vendor_perl/$version/$archname $vendorman1dir /usr/man/man1 $vendorman3dir /usr/man/man3 Note how in this example, the vendor-supplied directories are in the /usr hierarchy, while the directories reserved for the end-user are in -the /usr/local hierarchy. Note too how the vendor-supplied -directories track $apiversion, rather than $version, to ease upgrading -between maintenance subversions. See L<"Coexistence with earlier -versions of perl5"> below for more details. +the /usr/local hierarchy. + +The entire installed library hierarchy is installed in locations with +version numbers, keeping the installations of different versions distinct. +However, later installations of Perl can still be configured to search the +installed libraries corresponding to compatible earlier versions. +See L<"Coexistence with earlier versions of perl5"> below for more details +on how Perl can be made to search older version directories. Of course you may use these directories however you see fit. For example, you may wish to use $siteprefix for site-specific files that @@ -457,7 +462,7 @@ without resetting MANPATH. You can continue to use the old default from the command line with - sh Configure -Dman3dir=/usr/local/lib/perl5/5.6/man/man3 + sh Configure -Dman3dir=/usr/local/lib/perl5/5.6.0/man/man3 Some users also prefer to use a .3pm suffix. You can do that with @@ -495,13 +500,13 @@ library directory structure is slightly simplified. Instead of suggesting $prefix/lib/perl5/, Configure will suggest $prefix/lib. Thus, for example, if you Configure with --Dprefix=/opt/perl, then the default library directories for 5.6 are +-Dprefix=/opt/perl, then the default library directories for 5.6.0 are Configure variable Default value - $privlib /opt/perl/lib/5.6 - $archlib /opt/perl/lib/5.6/$archname - $sitelib /opt/perl/lib/site_perl/5.6 - $sitearch /opt/perl/lib/site_perl/5.6/$archname + $privlib /opt/perl/lib/5.6.0 + $archlib /opt/perl/lib/5.6.0/$archname + $sitelib /opt/perl/lib/site_perl/5.6.0 + $sitearch /opt/perl/lib/site_perl/5.6.0/$archname =head2 Changing the installation directory @@ -602,6 +607,20 @@ line so that the hint files can make appropriate adjustments. The default is to compile without thread support. +As of v5.5.64, perl has two different internal threads implementations. +The 5.005 version (5005threads) and an interpreter-based implementation +(ithreads) with one interpreter per thread. By default, Configure selects +ithreads if -Dusethreads is specified. However, you can select the old +5005threads behavior instead by either + + sh Configure -Dusethreads -Duse5005threads + +or by + sh Configure -Dusethreads -Uuseithreads + +Eventually (by perl v5.6.0) this internal confusion ought to disappear, +and these options may disappear as well. + =head2 Selecting File IO mechanisms Previous versions of perl used the standard IO mechanisms as defined in @@ -719,7 +738,7 @@ You can elect to build a shared libperl by To build a shared libperl, the environment variable controlling shared library search (LD_LIBRARY_PATH in most systems, DYLD_LIBRARY_PATH for NeXTSTEP/OPENSTEP/Rhapsody, LIBRARY_PATH for BeOS, SHLIB_PATH for -HP-UX, LIBPATH for AIX, PATH for cygwin) must be set up to include +HP-UX, LIBPATH for AIX, PATH for Cygwin) must be set up to include the Perl build directory because that's where the shared libperl will be created. Configure arranges makefile to have the correct shared library search settings. @@ -1674,13 +1693,14 @@ searched by 5.005_03 are /usr/local/lib/perl5/site_perl/5.005/$archname /usr/local/lib/perl5/site_perl/5.005 -Now, suppose you install version 5.6. The directories searched by -version 5.6 will be +Beginning with 5.6.0 the version number in the site libraries are +fully versioned. Now, suppose you install version 5.6.0. The directories +searched by version 5.6.0 will be - /usr/local/lib/perl5/5.6/$archname - /usr/local/lib/perl5/5.6 - /usr/local/lib/perl5/site_perl/5.6/$archname - /usr/local/lib/perl5/site_perl/5.6 + /usr/local/lib/perl5/5.6.0/$archname + /usr/local/lib/perl5/5.6.0 + /usr/local/lib/perl5/site_perl/5.6.0/$archname + /usr/local/lib/perl5/site_perl/5.6.0 /usr/local/lib/perl5/site_perl/5.005/$archname /usr/local/lib/perl5/site_perl/5.005 @@ -1688,56 +1708,55 @@ version 5.6 will be Notice the last two entries -- Perl understands the default structure of the $sitelib directories and will look back in older, compatible directories. This way, modules installed under 5.005_03 will continue -to be usable by 5.005_03 but will also accessible to 5.6. Further, +to be usable by 5.005_03 but will also accessible to 5.6.0. Further, suppose that you upgrade a module to one which requires features -present only in 5.6. That new module will get installed into -/usr/local/lib/perl5/site_perl/5.6 and will be available to 5.6, +present only in 5.6.0. That new module will get installed into +/usr/local/lib/perl5/site_perl/5.6.0 and will be available to 5.6.0, but will not interfere with the 5.005_03 version. -Also, by default, 5.6 will look in +Also, by default, 5.6.0 will look in /usr/local/lib/perl5/site_perl/ for 5.004-era pure perl modules. -Lastly, suppose you now install version 5.6.1. The directories -searched by 5.6.1 will be +Lastly, suppose you now install version 5.6.1, which we'll assume is +binary compatible with 5.6.0 and 5.005. The directories searched +by 5.6.1 (if you don't change the Configure defaults) will be: /usr/local/lib/perl5/5.6.1/$archname /usr/local/lib/perl5/5.6.1 - /usr/local/lib/perl5/site_perl/5.6/$archname - /usr/local/lib/perl5/site_perl/5.6 + /usr/local/lib/perl5/site_perl/5.6.1/$archname + /usr/local/lib/perl5/site_perl/5.6.1 + + /usr/local/lib/perl5/site_perl/5.6.0/$archname + /usr/local/lib/perl5/site_perl/5.6.0 /usr/local/lib/perl5/site_perl/5.005/$archname /usr/local/lib/perl5/site_perl/5.005 /usr/local/lib/perl5/site_perl/ -When you install an add-on extension, it gets installed into $sitelib (or -$sitearch if it is architecture-specific). This directory deliberately -does NOT include the sub-version number (01) so that both 5.6 and -5.6.1 can use the extension. - -However, if you do run into problems, and you want to continue to use the -old version of perl along with your extension, move those extension files -to the appropriate version directory, such as $privlib (or $archlib). -(The extension's .packlist file lists the files installed with that -extension. For the Tk extension, for example, the list of files installed -is in $sitearch/auto/Tk/.packlist.) Then use your newer version of perl -to rebuild and re-install the extension into $sitelib. This way, Perl -5.6 will find your files in the 5.6 directory, and newer versions -of perl will find your newer extension in the $sitelib directory. -(This is also why perl searches the site-specific libraries last.) - -Alternatively, if you are willing to reinstall all your modules -every time you upgrade perl, then you can include the subversion -number in $sitearch and $sitelib when you run Configure. +Assuming the users in your site are still actively using perl 5.6.0 and +5.005 after you installed 5.6.1, you can continue to install add-on +extensions using any of perl 5.6.1, 5.6.0, or 5.005. The installations +of these different versions remain distinct, but remember that the newer +versions of perl are automatically set up to search the site libraries of +the older ones. This means that installing a new extension with 5.005 +will make it visible to all three versions. Later, if you install the +same extension using, say, perl 5.6.1, it will override the 5.005-installed +version, but only for perl 5.6.1. + +This way, you can choose to share compatible extensions, but also upgrade +to a newer version of an extension that may be incompatible with earlier +versions, without breaking the earlier versions' installations. =head2 Maintaining completely separate versions Many users prefer to keep all versions of perl in completely separate directories. This guarantees that an update to one version -won't interfere with another version. One convenient way to do this -is by using a separate prefix for each version, such as +won't interfere with another version. (The defaults guarantee this for +libraries after 5.6.0, but not for executables. TODO?) One convenient +way to do this is by using a separate prefix for each version, such as sh Configure -Dprefix=/opt/perl5.004 @@ -1754,13 +1773,13 @@ seriously consider using a separate directory, since development subversions may not have all the compatibility wrinkles ironed out yet. -=head2 Upgrading from 5.005 to 5.6 +=head2 Upgrading from 5.005 to 5.6.0 Extensions built and installed with versions of perl prior to 5.005_50 will need to be recompiled to be used with 5.005_50 and later. You will, however, be able to continue using 5.005 even after you install 5.6. The 5.005 binary will still be able to find the modules built under -5.005; the 5.6 binary will look in the new $sitearch and $sitelib +5.005; the 5.6.0 binary will look in the new $sitearch and $sitelib directories, and will not find them. See also your installed copy of the perllocal.pod file for a (possibly incomplete) list of locally installed modules. Note that you want perllocal.pod not perllocale.pod @@ -27,11 +27,17 @@ # define EXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly # define dEXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly #else -# ifdef __cplusplus -# define EXT -# define dEXT -# define EXTCONST extern const -# define dEXTCONST const +#if defined(WIN32) && defined(__MINGW32__) +# define EXT __declspec(dllexport) +# define dEXT +# define EXTCONST __declspec(dllexport) const +# define dEXTCONST const +#else +#ifdef __cplusplus +# define EXT +# define dEXT +# define EXTCONST extern const +# define dEXTCONST const #else # define EXT # define dEXT @@ -39,6 +45,7 @@ # define dEXTCONST const #endif #endif +#endif #undef INIT #define INIT(x) = x @@ -154,7 +154,6 @@ ext/DynaLoader/DynaLoader_pm.PL ext/DynaLoader/Makefile.PL ext/DynaLoader/README ext/DynaLoader/dl_aix.xs aix -ext/DynaLoader/dl_cygwin.xs cygwin ext/DynaLoader/dl_dld.xs rsanders ext/DynaLoader/dl_dlopen.xs timb ext/DynaLoader/dl_hpux.xs hpux @@ -153,15 +153,13 @@ emacs/ptags Creates smart TAGS file embed.h Maps symbols to safer names embed.pl Produces {embed,embedvar,objXSUB,proto}.h, global.sym embedvar.h C namespace management -epoc/autosplit.pl EPOC port -epoc/config.h EPOC port -epoc/Config.pm EPOC port -epoc/createpkg.pl EPOC port +epoc/config.sh EPOC port config.sh template +epoc/createpkg.pl EPOC port generate PKG file epoc/epoc.c EPOC port epoc/epoc_stubs.c EPOC port +epoc/epocish.c EPOC port epoc/epocish.h EPOC port -epoc/perl.mmp EPOC port -epoc/perl.pkg EPOC port +epoc/link.pl EPOC port link a exe ext/B/B.pm Compiler backend support functions and methods ext/B/B.xs Compiler backend external subroutines ext/B/B/Asmdata.pm Compiler backend data for assembler @@ -231,9 +229,9 @@ ext/Devel/Peek/Peek.xs Data debugging tool, externals ext/DynaLoader/DynaLoader_pm.PL Dynamic Loader perl module ext/DynaLoader/Makefile.PL Dynamic Loader makefile writer ext/DynaLoader/README Dynamic Loader notes and intro +ext/DynaLoader/XSLoader_pm.PL Simple XS Loader perl module ext/DynaLoader/dl_aix.xs AIX implementation ext/DynaLoader/dl_beos.xs BeOS implementation -ext/DynaLoader/dl_cygwin.xs Cygwin implementation ext/DynaLoader/dl_dld.xs GNU dld style implementation ext/DynaLoader/dl_dlopen.xs BSD/SunOS4&5 dlopen() style implementation ext/DynaLoader/dl_hpux.xs HP-UX implementation @@ -246,6 +244,7 @@ ext/DynaLoader/dl_vms.xs VMS implementation ext/DynaLoader/dlutils.c Dynamic loader utilities for dl_*.xs files ext/DynaLoader/hints/aix.pl Hint for DynaLoader for named architecture ext/DynaLoader/hints/linux.pl Hint for DynaLoader for named architecture +ext/DynaLoader/hints/openbsd.pl Hint for DynaLoader for named architecture ext/Errno/ChangeLog Errno perl module change log ext/Errno/Errno_pm.PL Errno perl module create script ext/Errno/Makefile.PL Errno extension makefile writer @@ -289,12 +288,14 @@ ext/IPC/SysV/README IPC::SysV extension Perl module ext/IPC/SysV/Semaphore.pm IPC::SysV extension Perl module ext/IPC/SysV/SysV.pm IPC::SysV extension Perl module ext/IPC/SysV/SysV.xs IPC::SysV extension Perl module +ext/IPC/SysV/hints/cygwin.pl Hint for IPC::SysV for named architecture ext/IPC/SysV/hints/next_3.pl Hint for IPC::SysV for named architecture ext/IPC/SysV/t/msg.t IPC::SysV extension Perl module ext/IPC/SysV/t/sem.t IPC::SysV extension Perl module ext/NDBM_File/Makefile.PL NDBM extension makefile writer ext/NDBM_File/NDBM_File.pm NDBM extension Perl module ext/NDBM_File/NDBM_File.xs NDBM extension external subroutines +ext/NDBM_File/hints/cygwin.pl Hint for NDBM_File for named architecture ext/NDBM_File/hints/dec_osf.pl Hint for NDBM_File for named architecture ext/NDBM_File/hints/dynixptx.pl Hint for NDBM_File for named architecture ext/NDBM_File/hints/solaris.pl Hint for NDBM_File for named architecture @@ -304,6 +305,7 @@ ext/NDBM_File/typemap NDBM extension interface types ext/ODBM_File/Makefile.PL ODBM extension makefile writer ext/ODBM_File/ODBM_File.pm ODBM extension Perl module ext/ODBM_File/ODBM_File.xs ODBM extension external subroutines +ext/ODBM_File/hints/cygwin.pl Hint for ODBM_File for named architecture ext/ODBM_File/hints/dec_osf.pl Hint for ODBM_File for named architecture ext/ODBM_File/hints/hpux.pl Hint for ODBM_File for named architecture ext/ODBM_File/hints/sco.pl Hint for ODBM_File for named architecture @@ -673,6 +675,8 @@ lib/bigfloat.pl An arbitrary precision floating point package lib/bigint.pl An arbitrary precision integer arithmetic package lib/bigrat.pl An arbitrary precision rational arithmetic package lib/blib.pm For "use blib" +lib/byte.pm Pragma to enable byte operations +lib/byte_heavy.pl Support routines for byte pragma lib/cacheout.pl Manages output filehandles when you need too many lib/caller.pm Inherit pragmatic attributes from caller's context lib/charnames.pm Character names @@ -996,7 +1000,6 @@ os2/OS2/REXX/t/rx_tievar.t DLL access module os2/OS2/REXX/t/rx_tieydb.t DLL access module os2/OS2/REXX/t/rx_varset.t DLL access module os2/OS2/REXX/t/rx_vrexx.t DLL access module -os2/POSIX.mkfifo OS2-specific patch os2/diff.configure Patches to Configure os2/dl_os2.c Addon for dl_open os2/dlfcn.h Addon for dl_open @@ -1067,6 +1070,7 @@ pod/perlfaq7.pod Frequently Asked Questions, Part 7 pod/perlfaq8.pod Frequently Asked Questions, Part 8 pod/perlfaq9.pod Frequently Asked Questions, Part 9 pod/perlfilter.pod Source filters info +pod/perlfork.pod Info about fork() pod/perlform.pod Format info pod/perlfunc.pod Function info pod/perlguts.pod Internals info @@ -1230,6 +1234,7 @@ t/lib/findbin.t See if FindBin works t/lib/gdbm.t See if GDBM_File works t/lib/getopt.t See if Getopt::Std and Getopt::Long work t/lib/glob-basic.t See if File::Glob works +t/lib/glob-case.t See if File::Glob works t/lib/glob-global.t See if File::Glob works t/lib/glob-taint.t See if File::Glob works t/lib/gol-basic.t See if Getopt::Long works @@ -1538,17 +1543,20 @@ win32/config_h.PL Perl code to convert Win32 config.sh to config.h win32/config_sh.PL Perl code to update Win32 config.sh from Makefile win32/des_fcrypt.patch Win32 port win32/dl_win32.xs Win32 port -win32/genmk95.pl Perl code to generate command.com-usable makew95.mk +win32/genmk95.pl Perl code to generate command.com-usable makefile.95 win32/include/arpa/inet.h Win32 port win32/include/dirent.h Win32 port win32/include/netdb.h Win32 port win32/include/sys/socket.h Win32 port -win32/makefile.mk Win32 makefile for DMAKE (BC++, VC++ builds) +win32/makefile.mk Win32 makefile for DMAKE (BC++, VC++ builds) win32/perlglob.c Win32 port +win32/perlhost.h Perl "host" implementation win32/perllib.c Win32 port win32/pod.mak Win32 port win32/runperl.c Win32 port win32/splittree.pl Win32 port +win32/vdir.h Perl "host" virtual directory manager +win32/vmem.h Perl "host" memory manager win32/win32.c Win32 port win32/win32.h Win32 port win32/win32iop.h Win32 port diff --git a/Makefile.SH b/Makefile.SH index ef1a0e2a98..347ee7e2cb 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -261,7 +261,7 @@ lintflags = -hbvxac .c$(OBJ_EXT): $(CCCMD) $(PLDLFLAGS) $*.c -all: $(FIRSTMAKEFILE) miniperl $(private) $(public) $(dynamic_ext) $(nonxs_ext) +all: $(FIRSTMAKEFILE) miniperl extra.pods $(private) $(public) $(dynamic_ext) $(nonxs_ext) @echo " "; @echo " Everything is up to date. 'make test' to run test suite." @@ -286,6 +286,9 @@ utilities: miniperl lib/Config.pm $(plextract) FORCE FORCE: @sh -c true +opmini$(OBJ_EXT): op.c + $(CCCMD) $(PLDLFLAGS) -DPERL_EXTERNAL_GLOB -o opmini$(OBJ_EXT) op.c + miniperlmain$(OBJ_EXT): miniperlmain.c $(CCCMD) $(PLDLFLAGS) $*.c @@ -336,8 +339,7 @@ $(LIBPERL_NONSHR): perl$(OBJ_EXT) $(obj) $(RMS) $(LIBPERL_NONSHR) $(AR) rcu $(LIBPERL_NONSHR) perl$(OBJ_EXT) $(obj) -$(MINIPERL_NONSHR): $(LIBPERL_NONSHR) miniperlmain$(OBJ_EXT) - $(CCCMD) $(PLDLFLAGS) -DMINIPERL_BUILD -o opmini$(OBJ_EXT) op.c +$(MINIPERL_NONSHR): $(LIBPERL_NONSHR) miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) $(CC) $(LDFLAGS) -o $(MINIPERL_NONSHR) miniperlmain$(OBJ_EXT) \ opmini$(OBJ_EXT) $(LIBPERL_NONSHR) $(LIBS) @@ -421,11 +423,28 @@ $(LIBPERL): $& perl$(OBJ_EXT) $(obj) $(LIBPERLEXPORT) # build problems but that's not obvious to the novice. # The Module used here must not depend on Config or any extensions. -miniperl: $& miniperlmain$(OBJ_EXT) $(LIBPERL) - $(CCCMD) $(PLDLFLAGS) -DMINIPERL_BUILD -o opmini$(OBJ_EXT) op.c +!NO!SUBS! + + case "${osname}${osvers}" in + next4*) + $spitshell >>Makefile <<'!NO!SUBS!' +miniperl: $& miniperlmain$(OBJ_EXT) $(LIBPERL) opmini$(OBJ_EXT) + $(CC) -o miniperl `echo $(obj) | sed 's/ op$(OBJ_EXT) / /'` \ + miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) perl$(OBJ_EXT) $(libs) + $(LDLIBPTH) ./miniperl -w -Ilib -MExporter -e '<?>' || $(MAKE) minitest +!NO!SUBS! + ;; + *) + $spitshell >>Makefile <<'!NO!SUBS!' +miniperl: $& miniperlmain$(OBJ_EXT) $(LIBPERL) opmini$(OBJ_EXT) $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) -o miniperl \ miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) $(LLIBPERL) $(libs) - $(LDLIBPTH) ./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest + $(LDLIBPTH) ./miniperl -w -Ilib -MExporter -e '<?>' || $(MAKE) minitest +!NO!SUBS! + ;; + esac + + $spitshell >>Makefile <<'!NO!SUBS!' perl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT) $(SHRPENV) $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) @@ -471,7 +490,7 @@ preplibrary: miniperl lib/Config.pm # Take care to avoid modifying lib/Config.pm without reason # (If trying to create a new port and having problems with the configpm script, # try 'make minitest' and/or commenting out the tests at the end of configpm.) -lib/Config.pm: config.sh miniperl configpm +lib/Config.pm: config.sh miniperl configpm lib/re.pm $(LDLIBPTH) ./miniperl configpm configpm.tmp sh mv-if-diff configpm.tmp $@ @@ -483,10 +502,11 @@ lib/re.pm: ext/re/re.pm rm -f $@ cat ext/re/re.pm > $@ -$(plextract): miniperl lib/Config.pm lib/re.pm +$(plextract): miniperl lib/Config.pm $(LDLIBPTH) ./miniperl -Ilib $@.PL -extra.pods: perl +extra.pods: miniperl + -@test -f extra.pods && rm -f `cat extra.pods` -@rm -f extra.pods -@for x in `grep -l '^=[a-z]' README.*` ; do \ nx=`echo $$x | sed -e "s/README\.//"`; \ @@ -494,7 +514,7 @@ extra.pods: perl echo "pod/perl"$$nx".pod" >> extra.pods ; \ done -install: all install.perl install.man extra.pods +install: all install.perl install.man install.perl: all installperl if [ -n "$(COMPILE)" ]; \ diff --git a/Porting/Glossary b/Porting/Glossary index 371a2a1335..bef7409c73 100644 --- a/Porting/Glossary +++ b/Porting/Glossary @@ -1646,8 +1646,9 @@ fflushall (fflushall.U): even be probed for and will be left undefined. find (Loc.U): - This variable is defined but not used by Configure. - The value is a plain '' and is not useful. + This variable is used internally by Configure to determine the + full pathname (if any) of the find program. After Configure runs, + the value is reset to a plain "find" and is not useful. firstmakefile (Unix.U): This variable defines the first file searched by make. On unix, @@ -1723,6 +1724,8 @@ groupcat (nis.U): This variable contains a command that produces the text of the /etc/group file. This is normally "cat /etc/group", but can be "ypcat group" when NIS is used. + On some systems, such as os390, there may be no equivalent + command, in which case this variable is unset. groupstype (groupstype.U): This variable defines Groups_t to be something like gid_t, int, @@ -1751,6 +1754,8 @@ hostcat (nis.U): This variable contains a command that produces the text of the /etc/hosts file. This is normally "cat /etc/hosts", but can be "ypcat hosts" when NIS is used. + On some systems, such as os390, there may be no equivalent + command, in which case this variable is unset. huge (models.U): This variable contains a flag which will tell the C compiler and loader @@ -2274,8 +2279,9 @@ libswanted (Myinit.U): ahead of ucb or bsd libraries for SVR4. line (Loc.U): - This variable is defined but not used by Configure. - The value is a plain '' and is not useful. + This variable is used internally by Configure to determine the + full pathname (if any) of the line program. After Configure runs, + the value is reset to a plain "line" and is not useful. lint (Loc.U): This variable is defined but not used by Configure. @@ -2583,6 +2589,8 @@ passcat (nis.U): This variable contains a command that produces the text of the /etc/passwd file. This is normally "cat /etc/passwd", but can be "ypcat passwd" when NIS is used. + On some systems, such as os390, there may be no equivalent + command, in which case this variable is unset. patchlevel (patchlevel.U): The patchlevel level of this package. @@ -2593,8 +2601,9 @@ path_sep (Unix.U): used to separate elements in the command shell search PATH. perl (Loc.U): - This variable is defined but not used by Configure. - The value is a plain '' and is not useful. + This variable is used internally by Configure to determine the + full pathname (if any) of the perl program. After Configure runs, + the value is reset to a plain "perl" and is not useful. perladmin (perladmin.U): Electronic mail address of the perl5 administrator. @@ -2808,8 +2817,9 @@ selecttype (selecttype.U): have select(), naturally. sendmail (Loc.U): - This variable is defined but not used by Configure. - The value is a plain '' and is not useful. + This variable is used internally by Configure to determine the + full pathname (if any) of the sendmail program. After Configure runs, + the value is reset to a plain "sendmail" and is not useful. sh (sh.U): This variable contains the full pathname of the shell used @@ -2943,9 +2953,6 @@ siteprefixexp (siteprefix.U): This variable holds the full absolute path of the directory below which the user will install add-on packages. Derived from siteprefix. -sizesize (sizesize.U): - This variable contains the size of a sizetype in bytes. - sizetype (sizetype.U): This variable defines sizetype to be something like size_t, unsigned long, or whatever type is used to declare length @@ -3179,15 +3186,25 @@ uquadtype (quadtype.U): unsigned int, unsigned long long, uint64_t, or whatever type is used for 64-bit integers. +use5005threads (usethreads.U): + This variable conditionally defines the USE_5005THREADS symbol, + and indicates that Perl should be built to use the 5.005-based + threading implementation. + use64bits (use64bits.U): This variable conditionally defines the USE_64_BITS symbol, - and indicates that explicit 64-bit interfaces should be used + and indicates that 64-bit integer types should be used when available. usedl (dlsrc.U): This variable indicates if the the system supports dynamic loading of some sort. See also dlsrc and dlobj. +useithreads (usethreads.U): + This variable conditionally defines the USE_ITHREADS symbol, + and indicates that Perl should be built to use the interpreter-based + threading implementation. + uselargefiles (uselfs.U): This variable conditionally defines the USE_LARGE_FILES symbol, and indicates that large file interfaces should be used when diff --git a/Porting/config.sh b/Porting/config.sh index b730743538..f037880769 100644 --- a/Porting/config.sh +++ b/Porting/config.sh @@ -8,9 +8,9 @@ # Package name : perl5 # Source directory : . -# Configuration time: Sat Nov 13 15:28:21 EET 1999 -# Configured by : jhi -# Target system : osf1 alpha.hut.fi v4.0 878 alpha +# Configuration time: Fri Jan 7 16:16:39 EST 2000 +# Configured by : doughera +# Target system : linux fractal 2.0.36 #1 mon feb 1 17:23:08 est 1999 i686 unknown Author='' Date='$Date' @@ -27,36 +27,38 @@ _a='.a' _exe='' _o='.o' afs='false' -alignbytes='8' +alignbytes='4' ansi2knr='' aphostname='' -apiversion='5.00563' +apirevision='5' +apisubversion='640' +apiversion='5' ar='ar' -archlib='/opt/perl/lib/5.00563/alpha-dec_osf-thread' -archlibexp='/opt/perl/lib/5.00563/alpha-dec_osf-thread' +archlib='/opt/perl/lib/5.5.640/i686-linux-thread' +archlibexp='/opt/perl/lib/5.5.640/i686-linux-thread' archname64='' -archname='alpha-dec_osf-thread' +archname='i686-linux-thread' archobjs='' awk='awk' -baserev='5.0' +baserev='5' bash='' bin='/opt/perl/bin' bincompat5005='undef' binexp='/opt/perl/bin' bison='' byacc='byacc' -byteorder='12345678' -c='\c' +byteorder='1234' +c='' castflags='0' cat='cat' cc='cc' -cccdlflags=' ' -ccdlflags=' -Wl,-rpath,/opt/perl/lib/5.00563/alpha-dec_osf-thread/CORE' -ccflags='-pthread -std -DLANGUAGE_C' -ccsymbols='LANGUAGE_C=1 SYSTYPE_BSD=1 _LONGLONG=1 __LANGUAGE_C__=1' -cf_by='jhi' +cccdlflags='-fpic' +ccdlflags='-rdynamic' +ccflags='-D_REENTRANT -Dbool=char -DHAS_BOOL -fno-strict-aliasing -I/usr/local/include -DUSE_LONG_LONG' +ccsymbols='__ELF__=1 __GNUC_MINOR__=95 __GNUC__=2 __linux=1 cpu=i386 machine=i386 system=posix' +cf_by='doughera' cf_email='yourname@yourhost.yourplace.com' -cf_time='Sat Nov 13 15:28:21 EET 1999' +cf_time='Fri Jan 7 16:16:39 EST 2000' charsize='1' chgrp='' chmod='' @@ -69,13 +71,13 @@ cp='cp' cpio='' cpp='cpp' cpp_stuff='42' -cppccsymbols='_SYSTYPE_BSD=1 __alpha=1 __osf__=1 __unix__=1 unix=1' -cppflags='-pthread -std -DLANGUAGE_C' -cpplast='' -cppminus='' -cpprun='/usr/bin/cpp' -cppstdin='cppstdin' -cppsymbols='' +cppccsymbols='__i386=1 __i386__=1 __linux__=1 __unix=1 __unix__=1 i386=1 linux=1 unix=1' +cppflags='-D_REENTRANT -Dbool=char -DHAS_BOOL -fno-strict-aliasing -I/usr/local/include' +cpplast='-' +cppminus='-' +cpprun='cc -E' +cppstdin='cc -E' +cppsymbols='__STDC__=1' crosscompile='undef' cryptlib='' csh='csh' @@ -97,14 +99,14 @@ d_accessx='undef' d_alarm='define' d_archlib='define' d_atolf='undef' -d_atoll='undef' -d_attribut='undef' +d_atoll='define' +d_attribut='define' d_bcmp='define' d_bcopy='define' d_bincompat5005='undef' d_bsd='undef' d_bsdgetpgrp='undef' -d_bsdsetpgrp='define' +d_bsdsetpgrp='undef' d_bzero='define' d_casti32='undef' d_castneg='define' @@ -119,7 +121,7 @@ d_csh='define' d_cuserid='define' d_dbl_dig='define' d_difftime='define' -d_dirnamlen='define' +d_dirnamlen='undef' d_dlerror='define' d_dlopen='define' d_dlsymun='undef' @@ -133,7 +135,7 @@ d_endnent='define' d_endpent='define' d_endpwent='define' d_endsent='define' -d_endspent='undef' +d_endspent='define' d_eofnblk='define' d_eunice='undef' d_fchmod='define' @@ -141,7 +143,7 @@ d_fchown='define' d_fcntl='define' d_fd_macros='define' d_fd_set='define' -d_fds_bits='define' +d_fds_bits='undef' d_fgetpos='define' d_flexfnam='define' d_flock='define' @@ -149,11 +151,11 @@ d_fork='define' d_fpathconf='define' d_fpos64_t='undef' d_fs_data_s='undef' -d_fseeko='undef' +d_fseeko='define' d_fsetpos='define' d_fstatfs='define' d_fstatvfs='define' -d_ftello='undef' +d_ftello='define' d_ftime='undef' d_getgrent='define' d_getgrps='define' @@ -164,7 +166,7 @@ d_gethname='define' d_gethostprotos='define' d_getlogin='define' d_getmnt='undef' -d_getmntent='undef' +d_getmntent='define' d_getnbyaddr='define' d_getnbyname='define' d_getnent='define' @@ -183,16 +185,16 @@ d_getsbyname='define' d_getsbyport='define' d_getsent='define' d_getservprotos='define' -d_getspent='undef' -d_getspnam='undef' +d_getspent='define' +d_getspnam='define' d_gettimeod='define' -d_gnulibc='undef' +d_gnulibc='define' d_grpasswd='define' -d_hasmntopt='undef' +d_hasmntopt='define' d_htonl='define' d_index='undef' d_inetaton='define' -d_int64t='undef' +d_int64t='define' d_isascii='define' d_killpg='define' d_lchown='define' @@ -219,7 +221,7 @@ d_msg_ctrunc='define' d_msg_dontroute='define' d_msg_oob='define' d_msg_peek='define' -d_msg_proxy='undef' +d_msg_proxy='define' d_msgctl='define' d_msgget='define' d_msgrcv='define' @@ -241,11 +243,11 @@ d_pthread_yield='undef' d_pwage='undef' d_pwchange='undef' d_pwclass='undef' -d_pwcomment='define' +d_pwcomment='undef' d_pwexpire='undef' d_pwgecos='define' d_pwpasswd='define' -d_pwquota='define' +d_pwquota='undef' d_quad='define' d_readdir='define' d_readlink='define' @@ -280,14 +282,14 @@ d_setpgrp='define' d_setprior='define' d_setpwent='define' d_setregid='define' -d_setresgid='undef' -d_setresuid='undef' +d_setresgid='define' +d_setresuid='define' d_setreuid='define' -d_setrgid='define' -d_setruid='define' +d_setrgid='undef' +d_setruid='undef' d_setsent='define' d_setsid='define' -d_setspent='undef' +d_setspent='define' d_setvbuf='define' d_sfio='undef' d_shm='define' @@ -302,12 +304,12 @@ d_socket='define' d_sockpair='define' d_sqrtl='define' d_statblks='define' -d_statfs_f_flags='define' +d_statfs_f_flags='undef' d_statfs_s='define' d_statvfs='define' -d_stdio_cnt_lval='define' +d_stdio_cnt_lval='undef' d_stdio_ptr_lval='define' -d_stdio_stream_array='define' +d_stdio_stream_array='undef' d_stdiobase='define' d_stdstdio='define' d_strchr='define' @@ -318,7 +320,7 @@ d_strerror='define' d_strtod='define' d_strtol='define' d_strtoul='define' -d_strtoull='undef' +d_strtoull='define' d_strxfrm='define' d_suidsafe='undef' d_symlink='define' @@ -361,7 +363,7 @@ dlext='so' dlsrc='dl_dlopen.xs' doublesize='8' drand01='drand48()' -dynamic_ext='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Fcntl File/Glob IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Thread attrs re' +dynamic_ext='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Fcntl File/Glob GDBM_File IO IPC/SysV ODBM_File Opcode POSIX SDBM_File Socket Thread attrs re' eagain='EAGAIN' ebcdic='undef' echo='echo' @@ -370,24 +372,24 @@ emacs='' eunicefix=':' exe_ext='' expr='expr' -extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Fcntl File/Glob IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Thread attrs re Errno' +extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Fcntl File/Glob GDBM_File IO IPC/SysV ODBM_File Opcode POSIX SDBM_File Socket Thread attrs re Errno' fflushNULL='define' fflushall='undef' -find='' +find='find' firstmakefile='makefile' flex='' -fpossize='8' +fpossize='4' fpostype='fpos_t' freetype='void' full_ar='/usr/bin/ar' -full_csh='/usr/bin/csh' -full_sed='/usr/bin/sed' -gccversion='' -gidformat='"u"' +full_csh='/bin/csh' +full_sed='/bin/sed' +gccversion='2.95.2 19991109 (Debian GNU/Linux)' +gidformat='"lu"' gidsign='1' gidsize='4' gidtype='gid_t' -glibpth='/usr/shlib /usr/ccs/lib /usr/lib/cmplrs/cc /usr/lib /usr/local/lib /var/shlib' +glibpth='/usr/shlib /shlib /lib/pa1.1 /usr/lib/large /lib /usr/lib /usr/lib/386 /lib/386 /lib/large /usr/lib/small /lib/small /usr/ccs/lib /usr/ucblib /usr/local/lib ' grep='grep' groupcat='cat /etc/group' groupstype='gid_t' @@ -400,9 +402,9 @@ huge='' i16size='2' i16type='short' i32size='4' -i32type='int' +i32type='long' i64size='8' -i64type='long' +i64type='long long' i8size='1' i8type='char' i_arpainet='define' @@ -414,17 +416,17 @@ i_dld='undef' i_dlfcn='define' i_fcntl='undef' i_float='define' -i_gdbm='undef' +i_gdbm='define' i_grp='define' -i_inttypes='undef' +i_inttypes='define' i_limits='define' i_locale='define' i_machcthr='undef' i_malloc='define' i_math='define' i_memory='undef' -i_mntent='undef' -i_ndbm='define' +i_mntent='define' +i_ndbm='undef' i_netdb='define' i_neterrno='undef' i_netinettcp='define' @@ -435,13 +437,13 @@ i_pwd='define' i_rpcsvcdbm='undef' i_sfio='undef' i_sgtty='undef' -i_shadow='undef' +i_shadow='define' i_socks='undef' i_stdarg='define' i_stddef='define' i_stdlib='define' i_string='define' -i_sysaccess='define' +i_sysaccess='undef' i_sysdir='define' i_sysfile='define' i_sysfilio='undef' @@ -451,11 +453,11 @@ i_sysmount='define' i_sysndir='undef' i_sysparam='define' i_sysresrc='define' -i_syssecrt='define' +i_syssecrt='undef' i_sysselct='define' i_syssockio='' i_sysstat='define' -i_sysstatfs='undef' +i_sysstatfs='define' i_sysstatvfs='define' i_systime='define' i_systimek='undef' @@ -463,7 +465,7 @@ i_systimes='define' i_systypes='define' i_sysuio='define' i_sysun='define' -i_sysvfs='undef' +i_sysvfs='define' i_syswait='define' i_termio='undef' i_termios='define' @@ -475,56 +477,56 @@ i_values='define' i_varargs='undef' i_varhdr='stdarg.h' i_vfork='undef' -ignore_versioned_solibs='' +ignore_versioned_solibs='y' incpath='' inews='' -installarchlib='/opt/perl/lib/5.00563/alpha-dec_osf-thread' +installarchlib='/opt/perl/lib/5.5.640/i686-linux-thread' installbin='/opt/perl/bin' installman1dir='/opt/perl/man/man1' installman3dir='/opt/perl/man/man3' installprefix='/opt/perl' installprefixexp='/opt/perl' -installprivlib='/opt/perl/lib/5.00563' -installscript='/opt/perl/bin' -installsitearch='/opt/perl/lib/site_perl/5.00563/alpha-dec_osf-thread' +installprivlib='/opt/perl/lib/5.5.640' +installscript='/opt/perl/script' +installsitearch='/opt/perl/lib/site_perl/5.5.640/i686-linux-thread' installsitebin='/opt/perl/bin' -installsitelib='/opt/perl/lib/site_perl' +installsitelib='/opt/perl/lib/site_perl/5.5.640' installstyle='lib' installusrbinperl='define' installvendorbin='' installvendorlib='' intsize='4' -ivdformat='"ld"' +ivdformat='"lld"' ivsize='8' -ivtype='long' +ivtype='long long' known_extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Fcntl File/Glob GDBM_File IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Thread attrs re' ksh='' large='' -ld='ld' -lddlflags='-shared -expect_unresolved "*" -msym -s' -ldflags='' +ld='cc' +lddlflags='-shared -L/usr/local/lib' +ldflags=' -L/usr/local/lib' ldlibpthname='LD_LIBRARY_PATH' less='less' lib_ext='.a' -libc='/usr/shlib/libc.so' -libperl='libperl.so' -libpth='/usr/shlib /usr/ccs/lib /usr/lib/cmplrs/cc /usr/lib /var/shlib' -libs='-lgdbm -ldbm -ldb -lm -lpthread -lexc' -libswanted='sfio socket inet nsl nm gdbm dbm db malloc dld ld sun m cposix posix ndir dir crypt sec ucb BSD x pthread exc' -line='' +libc='/lib/libc-2.1.2.so' +libperl='libperl.a' +libpth='/usr/local/lib /lib /usr/lib' +libs='-lnsl -lndbm -lgdbm -ldbm -ldb -ldl -lm -lpthread -lc -lposix -lcrypt' +libswanted='sfio socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m pthread c cposix posix ndir dir crypt sec ucb BSD PW x' +line='line' lint='' lkflags='' ln='ln' -lns='/usr/bin/ln -s' +lns='/bin/ln -s' locincpth='/usr/local/include /opt/local/include /usr/gnu/include /opt/gnu/include /usr/GNU/include /opt/GNU/include' loclibpth='/usr/local/lib /opt/local/lib /usr/gnu/lib /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib' -longdblsize='8' +longdblsize='12' longlongsize='8' -longsize='8' +longsize='4' lp='' lpr='' ls='ls' -lseeksize='8' +lseeksize='4' lseektype='off_t' mail='' mailx='' @@ -547,18 +549,18 @@ modetype='mode_t' more='more' multiarch='undef' mv='' -myarchname='alpha-dec_osf' +myarchname='i686-linux' mydomain='.yourplace.com' myhostname='yourhost' -myuname='osf1 alpha.hut.fi v4.0 878 alpha ' -n='' -netdb_hlen_type='int' +myuname='linux fractal 2.0.36 #1 mon feb 1 17:23:08 est 1999 i686 unknown ' +n='-n' +netdb_hlen_type='size_t' netdb_host_type='const char *' netdb_name_type='const char *' -netdb_net_type='int' +netdb_net_type='unsigned long' nm='nm' -nm_opt='-p' -nm_so_opt='' +nm_opt='' +nm_so_opt='--dynamic' nonxs_ext='Errno' nroff='nroff' nvsize='8' @@ -568,31 +570,30 @@ obj_ext='.o' old_pthread_create_joinable='' optimize='-O' orderlib='false' -osname='dec_osf' -osvers='4.0' +osname='linux' +osvers='2.0.36' package='perl5' -pager='/c/bin/less' +pager='/usr/bin/less' passcat='cat /etc/passwd' patchlevel='5' path_sep=':' -perl='' +perl='perl' perladmin='yourname@yourhost.yourplace.com' perlpath='/opt/perl/bin/perl' pg='pg' phostname='' pidtype='pid_t' plibpth='' -pm_apiversion='5.005' pmake='' pr='' prefix='/opt/perl' prefixexp='/opt/perl' -privlib='/opt/perl/lib/5.00563' -privlibexp='/opt/perl/lib/5.00563' +privlib='/opt/perl/lib/5.5.640' +privlibexp='/opt/perl/lib/5.5.640' prototype='define' -ptrsize='8' -quadkind='2' -quadtype='long' +ptrsize='4' +quadkind='3' +quadtype='long long' randbits='48' randfunc='drand48' randseedtype='long' @@ -600,27 +601,27 @@ ranlib=':' rd_nodata='-1' rm='rm' rmail='' -runnm='true' -sPRIEldbl='"E"' -sPRIFldbl='"F"' -sPRIGldbl='"G"' -sPRIX64='"lX"' -sPRId64='"ld"' -sPRIeldbl='"e"' -sPRIfldbl='"f"' -sPRIgldbl='"g"' -sPRIi64='"li"' -sPRIo64='"lo"' -sPRIu64='"lu"' -sPRIx64='"lx"' +runnm='false' +sPRIEldbl='"llE"' +sPRIFldbl='"llF"' +sPRIGldbl='"llG"' +sPRIX64='"llX"' +sPRId64='"lld"' +sPRIeldbl='"lle"' +sPRIfldbl='"llf"' +sPRIgldbl='"llg"' +sPRIi64='"lli"' +sPRIo64='"llo"' +sPRIu64='"llu"' +sPRIx64='"llx"' sched_yield='sched_yield()' -scriptdir='/opt/perl/bin' -scriptdirexp='/opt/perl/bin' +scriptdir='/opt/perl/script' +scriptdirexp='/opt/perl/script' sed='sed' seedfunc='srand48' selectminbits='32' selecttype='fd_set *' -sendmail='' +sendmail='sendmail' sh='/bin/sh' shar='' sharpbang='#!' @@ -628,21 +629,20 @@ shmattype='void *' shortsize='2' shrpenv='' shsharp='true' -sig_count='49' -sig_name='ZERO HUP INT QUIT ILL TRAP ABRT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM IOINT STOP TSTP CONT CHLD TTIN TTOU AIO XCPU XFSZ VTALRM PROF WINCH INFO USR1 USR2 RESV RTMIN NUM34 NUM35 NUM36 NUM37 NUM38 NUM39 NUM40 NUM41 NUM42 NUM43 NUM44 NUM45 NUM46 NUM47 MAX IOT LOST URG CLD IO POLL PTY PWR RTMAX ' -sig_name_init='"ZERO", "HUP", "INT", "QUIT", "ILL", "TRAP", "ABRT", "EMT", "FPE", "KILL", "BUS", "SEGV", "SYS", "PIPE", "ALRM", "TERM", "IOINT", "STOP", "TSTP", "CONT", "CHLD", "TTIN", "TTOU", "AIO", "XCPU", "XFSZ", "VTALRM", "PROF", "WINCH", "INFO", "USR1", "USR2", "RESV", "RTMIN", "NUM34", "NUM35", "NUM36", "NUM37", "NUM38", "NUM39", "NUM40", "NUM41", "NUM42", "NUM43", "NUM44", "NUM45", "NUM46", "NUM47", "MAX", "IOT", "LOST", "URG", "CLD", "IO", "POLL", "PTY", "PWR", "RTMAX", 0' -sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 6 6 16 20 23 23 23 29 48 ' -sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 6, 6, 16, 20, 23, 23, 23, 29, 48, 0' +sig_count='64' +sig_name='ZERO HUP INT QUIT ILL TRAP ABRT BUS FPE KILL USR1 SEGV USR2 PIPE ALRM TERM STKFLT CHLD CONT STOP TSTP TTIN TTOU URG XCPU XFSZ VTALRM PROF WINCH IO PWR UNUSED NUM32 NUM33 NUM34 NUM35 NUM36 NUM37 NUM38 NUM39 NUM40 NUM41 NUM42 NUM43 NUM44 NUM45 NUM46 NUM47 NUM48 NUM49 NUM50 NUM51 NUM52 NUM53 NUM54 NUM55 NUM56 NUM57 NUM58 NUM59 NUM60 NUM61 NUM62 NUM63 RTMIN IOT CLD POLL ' +sig_name_init='"ZERO", "HUP", "INT", "QUIT", "ILL", "TRAP", "ABRT", "BUS", "FPE", "KILL", "USR1", "SEGV", "USR2", "PIPE", "ALRM", "TERM", "STKFLT", "CHLD", "CONT", "STOP", "TSTP", "TTIN", "TTOU", "URG", "XCPU", "XFSZ", "VTALRM", "PROF", "WINCH", "IO", "PWR", "UNUSED", "NUM32", "NUM33", "NUM34", "NUM35", "NUM36", "NUM37", "NUM38", "NUM39", "NUM40", "NUM41", "NUM42", "NUM43", "NUM44", "NUM45", "NUM46", "NUM47", "NUM48", "NUM49", "NUM50", "NUM51", "NUM52", "NUM53", "NUM54", "NUM55", "NUM56", "NUM57", "NUM58", "NUM59", "NUM60", "NUM61", "NUM62", "NUM63", "RTMIN", "IOT", "CLD", "POLL", 0' +sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 -1 6 17 29 ' +sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, -1, 6, 17, 29, 0' signal_t='void' -sitearch='/opt/perl/lib/site_perl/5.00563/alpha-dec_osf-thread' -sitearchexp='/opt/perl/lib/site_perl/5.00563/alpha-dec_osf-thread' +sitearch='/opt/perl/lib/site_perl/5.5.640/i686-linux-thread' +sitearchexp='/opt/perl/lib/site_perl/5.5.640/i686-linux-thread' sitebin='/opt/perl/bin' sitebinexp='/opt/perl/bin' -sitelib='/opt/perl/lib/site_perl' -sitelibexp='/opt/perl/lib/site_perl' +sitelib='/opt/perl/lib/site_perl/5.5.640' +sitelibexp='/opt/perl/lib/site_perl/5.5.640' siteprefix='/opt/perl' siteprefixexp='/opt/perl' -sizesize='8' sizetype='size_t' sleep='' smail='' @@ -659,16 +659,16 @@ ssizetype='ssize_t' startperl='#!/opt/perl/bin/perl' startsh='#!/bin/sh' static_ext=' ' -stdchar='unsigned char' -stdio_base='((fp)->_base)' -stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)' -stdio_cnt='((fp)->_cnt)' +stdchar='char' +stdio_base='((fp)->_IO_read_base)' +stdio_bufsiz='((fp)->_IO_read_end - (fp)->_IO_read_base)' +stdio_cnt='((fp)->_IO_read_end - (fp)->_IO_read_ptr)' stdio_filbuf='' -stdio_ptr='((fp)->_ptr)' -stdio_stream_array='_iob' +stdio_ptr='((fp)->_IO_read_ptr)' +stdio_stream_array='' strings='/usr/include/string.h' submit='' -subversion='63' +subversion='640' sysman='/usr/man/man1' tail='' tar='' @@ -684,54 +684,55 @@ troff='' u16size='2' u16type='unsigned short' u32size='4' -u32type='unsigned int' +u32type='unsigned long' u64size='8' -u64type='unsigned long' +u64type='unsigned long long' u8size='1' u8type='unsigned char' -uidformat='"u"' +uidformat='"lu"' uidsign='1' uidsize='4' uidtype='uid_t' uname='uname' uniq='uniq' -uquadtype='unsigned long' +uquadtype='unsigned long long' +use5005threads='undef' use64bits='define' usedl='define' -uselargefiles='undef' +useithreads='define' +uselargefiles='define' uselongdouble='undef' -uselonglong='undef' +uselonglong='define' usemorebits='undef' usemultiplicity='undef' usemymalloc='n' -usenm='true' +usenm='false' useopcode='true' useperlio='undef' useposix='true' usesfio='false' -useshrplib='true' +useshrplib='false' usesocks='undef' usethreads='define' usevendorprefix='undef' usevfork='false' usrinc='/usr/include' uuname='' -uvoformat='"lo"' +uvoformat='"llo"' uvsize='8' -uvtype='unsigned long' -uvuformat='"lu"' -uvxformat='"lx"' +uvtype='unsigned long long' +uvuformat='"llu"' +uvxformat='"llx"' vendorbin='' vendorbinexp='' vendorlib='' vendorlibexp='' vendorprefix='' vendorprefixexp='' -version='5.00563' +version='5.5.640' vi='' voidflags='15' xlibpth='/usr/lib/386 /lib/386' -xs_apiversion='5.00563' zcat='' zip='zip' # Configure command line arguments. @@ -751,8 +752,8 @@ config_arg10='-Dmyhostname=yourhost' config_arg11='-dE' PERL_REVISION=5 PERL_VERSION=5 -PERL_SUBVERSION=63 -PERL_APIVERSION=5.00563 +PERL_SUBVERSION=640 +PERL_API_REVISION=5 +PERL_API_VERSION=5 +PERL_API_SUBVERSION=640 CONFIGDOTSH=true -# Variables propagated from previous config.sh file. -pp_sys_cflags='ccflags="$ccflags -DNO_EFF_ONLY_OK"' diff --git a/Porting/config_H b/Porting/config_H index 313007519b..1a33778137 100644 --- a/Porting/config_H +++ b/Porting/config_H @@ -17,9 +17,9 @@ /* * Package name : perl5 * Source directory : . - * Configuration time: Sat Nov 13 15:28:21 EET 1999 - * Configured by : jhi - * Target system : osf1 alpha.hut.fi v4.0 878 alpha + * Configuration time: Fri Jan 7 16:16:39 EST 2000 + * Configured by : doughera + * Target system : linux fractal 2.0.36 #1 mon feb 1 17:23:08 est 1999 i686 unknown */ #ifndef _config_h_ @@ -28,7 +28,7 @@ /* LOC_SED: * This symbol holds the complete pathname to the sed program. */ -#define LOC_SED "/usr/bin/sed" /**/ +#define LOC_SED "/bin/sed" /**/ /* HAS_ALARM: * This symbol, if defined, indicates that the alarm routine is @@ -40,7 +40,7 @@ * This symbol indicates the C compiler can check for function attributes, * such as printf formats. This is normally only supported by GNU cc. */ -/*#define HASATTRIBUTE / **/ +#define HASATTRIBUTE /**/ #ifndef HASATTRIBUTE #define __attribute__(_arg_) #endif @@ -493,7 +493,7 @@ * for a POSIX interface. */ #define HAS_SETPGRP /**/ -#define USE_BSD_SETPGRP /**/ +/*#define USE_BSD_SETPGRP / **/ /* HAS_SETPGRP2: * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) @@ -518,7 +518,7 @@ * process. */ #define HAS_SETREGID /**/ -/*#define HAS_SETRESGID / **/ +#define HAS_SETRESGID /**/ /* HAS_SETREUID: * This symbol, if defined, indicates that the setreuid routine is @@ -531,19 +531,19 @@ * process. */ #define HAS_SETREUID /**/ -/*#define HAS_SETRESUID / **/ +#define HAS_SETRESUID /**/ /* HAS_SETRGID: * This symbol, if defined, indicates that the setrgid routine is available * to change the real gid of the current program. */ -#define HAS_SETRGID /**/ +/*#define HAS_SETRGID / **/ /* HAS_SETRUID: * This symbol, if defined, indicates that the setruid routine is available * to change the real uid of the current program. */ -#define HAS_SETRUID /**/ +/*#define HAS_SETRUID / **/ /* HAS_SETSID: * This symbol, if defined, indicates that the setsid routine is @@ -734,7 +734,7 @@ * portably declare your directory entries. */ #define I_DIRENT /**/ -#define DIRNAMLEN /**/ +/*#define DIRNAMLEN / **/ #define Direntry_t struct dirent /* I_DLFCN: @@ -784,7 +784,7 @@ * This symbol, if defined, indicates that <ndbm.h> exists and should * be included. */ -#define I_NDBM /**/ +/*#define I_NDBM / **/ /* I_NET_ERRNO: * This symbol, if defined, indicates that <net/errno.h> exists and @@ -982,26 +982,49 @@ * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". */ -#define STDCHAR unsigned char /**/ +#define STDCHAR char /**/ -/* HAS_QUAD: - * This symbol, if defined, tells that there's a 64-bit integer type, - * Quad_t. +/* CROSSCOMPILE: + * This symbol, if defined, signifies that we our + * build process is a cross-compilation. + */ +/*#define CROSSCOMPILE / **/ + +/* INTSIZE: + * This symbol contains the value of sizeof(int) so that the C + * preprocessor can make decisions based on it. + */ +/* LONGSIZE: + * This symbol contains the value of sizeof(long) so that the C + * preprocessor can make decisions based on it. + */ +/* SHORTSIZE: + * This symbol contains the value of sizeof(short) so that the C + * preprocessor can make decisions based on it. */ -/* Quad_t: - * This symbol holds the type used for 64-bit integers. - * It can be int, long, long long, int64_t etc... +#define INTSIZE 4 /**/ +#define LONGSIZE 4 /**/ +#define SHORTSIZE 2 /**/ + +/* MULTIARCH: + * This symbol, if defined, signifies that the build + * process will produce some binary files that are going to be + * used in a cross-platform environment. This is the case for + * example with the NeXT "fat" binaries that contain executables + * for several CPUs. */ -/* Uquad_t: - * This symbol holds the type used for unsigned 64-bit integers. - * It can be unsigned int, unsigned long, unsigned long long, - * uint64_t etc... +/*#define MULTIARCH / **/ + +/* HAS_QUAD: + * This symbol, if defined, tells that there's a 64-bit integer type, + * Quad_t, and its unsigned counterpar, Uquad_t. QUADKIND will be one + * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, or QUAD_IS_INT64_T. */ #define HAS_QUAD /**/ -#define Quad_t long /**/ -#define Uquad_t unsigned long /**/ #ifdef HAS_QUAD -# define QUADKIND 2 /**/ +# define Quad_t long long /**/ +# define Uquad_t unsigned long long /**/ +# define QUADKIND 3 /**/ # define QUAD_IS_INT 1 # define QUAD_IS_LONG 2 # define QUAD_IS_LONG_LONG 3 @@ -1024,44 +1047,13 @@ * This symbol, if defined, indicates to the C program that it should * include <sys/access.h>. */ -#define I_SYS_ACCESS /**/ +/*#define I_SYS_ACCESS / **/ /* I_SYS_SECURITY: * This symbol, if defined, indicates to the C program that it should * include <sys/security.h>. */ -#define I_SYS_SECURITY /**/ - -/* CROSSCOMPILE: - * This symbol, if defined, signifies that we our - * build process is a cross-compilation. - */ -/*#define CROSSCOMPILE / **/ - -/* INTSIZE: - * This symbol contains the value of sizeof(int) so that the C - * preprocessor can make decisions based on it. - */ -/* LONGSIZE: - * This symbol contains the value of sizeof(long) so that the C - * preprocessor can make decisions based on it. - */ -/* SHORTSIZE: - * This symbol contains the value of sizeof(short) so that the C - * preprocessor can make decisions based on it. - */ -#define INTSIZE 4 /**/ -#define LONGSIZE 8 /**/ -#define SHORTSIZE 2 /**/ - -/* MULTIARCH: - * This symbol, if defined, signifies that the build - * process will produce some binary files that are going to be - * used in a cross-platform environment. This is the case for - * example with the NeXT "fat" binaries that contain executables - * for several CPUs. - */ -/*#define MULTIARCH / **/ +/*#define I_SYS_SECURITY / **/ /* MEM_ALIGNBYTES: * This symbol contains the number of bytes required to align a @@ -1071,7 +1063,7 @@ #if defined(CROSSCOMPILE) || defined(MULTIARCH) # define MEM_ALIGNBYTES 8 #else -#define MEM_ALIGNBYTES 8 +#define MEM_ALIGNBYTES 4 #endif /* BYTEORDER: @@ -1114,7 +1106,7 @@ # define BYTEORDER 0x4321 # endif #else -#define BYTEORDER 0x12345678 /* large digits for MSB */ +#define BYTEORDER 0x1234 /* large digits for MSB */ #endif /* NeXT */ /* CASTI32: @@ -1171,7 +1163,7 @@ * This symbol, if defined, indicates to the C program that * the GNU C library is being used. */ -/*#define HAS_GNULIBC / **/ +#define HAS_GNULIBC /**/ /* HAS_ISASCII: * This manifest constant lets the C program know that isascii * is available. @@ -1278,10 +1270,10 @@ */ #define USE_STDIO_PTR /**/ #ifdef USE_STDIO_PTR -#define FILE_ptr(fp) ((fp)->_ptr) +#define FILE_ptr(fp) ((fp)->_IO_read_ptr) #define STDIO_PTR_LVALUE /**/ -#define FILE_cnt(fp) ((fp)->_cnt) -#define STDIO_CNT_LVALUE /**/ +#define FILE_cnt(fp) ((fp)->_IO_read_end - (fp)->_IO_read_ptr) +/*#define STDIO_CNT_LVALUE / **/ #endif /* USE_STDIO_BASE: @@ -1306,8 +1298,8 @@ */ #define USE_STDIO_BASE /**/ #ifdef USE_STDIO_BASE -#define FILE_base(fp) ((fp)->_base) -#define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base) +#define FILE_base(fp) ((fp)->_IO_read_base) +#define FILE_bufsiz(fp) ((fp)->_IO_read_end - (fp)->_IO_read_base) #endif /* HAS_VPRINTF: @@ -1379,7 +1371,7 @@ * the compiler supports (void *); otherwise it will be * sizeof(char *). */ -#define PTRSIZE 8 /**/ +#define PTRSIZE 4 /**/ /* Drand01: * This macro is to be used to generate uniformly distributed @@ -1435,8 +1427,8 @@ * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define ARCHLIB "/opt/perl/lib/5.00563/alpha-dec_osf-thread" /**/ -#define ARCHLIB_EXP "/opt/perl/lib/5.00563/alpha-dec_osf-thread" /**/ +#define ARCHLIB "/opt/perl/lib/5.5.640/i686-linux-thread" /**/ +#define ARCHLIB_EXP "/opt/perl/lib/5.5.640/i686-linux-thread" /**/ /* BIN: * This symbol holds the path of the bin directory where the package will @@ -1465,8 +1457,8 @@ * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define PRIVLIB "/opt/perl/lib/5.00563" /**/ -#define PRIVLIB_EXP "/opt/perl/lib/5.00563" /**/ +#define PRIVLIB "/opt/perl/lib/5.5.640" /**/ +#define PRIVLIB_EXP "/opt/perl/lib/5.5.640" /**/ /* SITEARCH: * This symbol contains the name of the private library for this package. @@ -1483,8 +1475,8 @@ * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITEARCH "/opt/perl/lib/site_perl/5.00563/alpha-dec_osf-thread" /**/ -#define SITEARCH_EXP "/opt/perl/lib/site_perl/5.00563/alpha-dec_osf-thread" /**/ +#define SITEARCH "/opt/perl/lib/site_perl/5.5.640/i686-linux-thread" /**/ +#define SITEARCH_EXP "/opt/perl/lib/site_perl/5.5.640/i686-linux-thread" /**/ /* SITELIB: * This symbol contains the name of the private library for this package. @@ -1515,7 +1507,7 @@ * by Configure. You shouldn't rely on it too much; the specific * feature tests from Configure are generally more reliable. */ -#define OSNAME "dec_osf" /**/ +#define OSNAME "linux" /**/ /* CAT2: * This macro catenates 2 tokens together. @@ -1562,10 +1554,10 @@ * This symbol is intended to be used along with CPPRUN in the same manner * symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "". */ -#define CPPSTDIN "cppstdin" -#define CPPMINUS "" -#define CPPRUN "/usr/bin/cpp" -#define CPPLAST "" +#define CPPSTDIN "cc -E" +#define CPPMINUS "-" +#define CPPRUN "cc -E" +#define CPPLAST "-" /* HAS_ACCESS: * This manifest constant lets the C program know that the access() @@ -1582,7 +1574,7 @@ */ #define HAS_CSH /**/ #ifdef HAS_CSH -#define CSH "/usr/bin/csh" /**/ +#define CSH "/bin/csh" /**/ #endif /* HAS_ENDGRENT: @@ -1769,7 +1761,7 @@ */ #define HAS_LONG_DOUBLE /**/ #ifdef HAS_LONG_DOUBLE -#define LONG_DOUBLESIZE 8 /**/ +#define LONG_DOUBLESIZE 12 /**/ #endif /* HAS_LONG_LONG: @@ -1903,7 +1895,7 @@ #define HAS_MSG_DONTROUTE /**/ #define HAS_MSG_OOB /**/ #define HAS_MSG_PEEK /**/ -/*#define HAS_MSG_PROXY / **/ +#define HAS_MSG_PROXY /**/ #define HAS_SCM_RIGHTS /**/ /* USE_STAT_BLOCKS: @@ -2035,12 +2027,12 @@ * contains pw_passwd. */ #define I_PWD /**/ -#define PWQUOTA /**/ +/*#define PWQUOTA / **/ /*#define PWAGE / **/ /*#define PWCHANGE / **/ /*#define PWCLASS / **/ /*#define PWEXPIRE / **/ -#define PWCOMMENT /**/ +/*#define PWCOMMENT / **/ #define PWGECOS /**/ #define PWPASSWD /**/ @@ -2093,8 +2085,8 @@ * The last element is 0, corresponding to the 0 at the end of * the sig_name list. */ -#define SIG_NAME "ZERO", "HUP", "INT", "QUIT", "ILL", "TRAP", "ABRT", "EMT", "FPE", "KILL", "BUS", "SEGV", "SYS", "PIPE", "ALRM", "TERM", "IOINT", "STOP", "TSTP", "CONT", "CHLD", "TTIN", "TTOU", "AIO", "XCPU", "XFSZ", "VTALRM", "PROF", "WINCH", "INFO", "USR1", "USR2", "RESV", "RTMIN", "NUM34", "NUM35", "NUM36", "NUM37", "NUM38", "NUM39", "NUM40", "NUM41", "NUM42", "NUM43", "NUM44", "NUM45", "NUM46", "NUM47", "MAX", "IOT", "LOST", "URG", "CLD", "IO", "POLL", "PTY", "PWR", "RTMAX", 0 /**/ -#define SIG_NUM 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 6, 6, 16, 20, 23, 23, 23, 29, 48, 0 /**/ +#define SIG_NAME "ZERO", "HUP", "INT", "QUIT", "ILL", "TRAP", "ABRT", "BUS", "FPE", "KILL", "USR1", "SEGV", "USR2", "PIPE", "ALRM", "TERM", "STKFLT", "CHLD", "CONT", "STOP", "TSTP", "TTIN", "TTOU", "URG", "XCPU", "XFSZ", "VTALRM", "PROF", "WINCH", "IO", "PWR", "UNUSED", "NUM32", "NUM33", "NUM34", "NUM35", "NUM36", "NUM37", "NUM38", "NUM39", "NUM40", "NUM41", "NUM42", "NUM43", "NUM44", "NUM45", "NUM46", "NUM47", "NUM48", "NUM49", "NUM50", "NUM51", "NUM52", "NUM53", "NUM54", "NUM55", "NUM56", "NUM57", "NUM58", "NUM59", "NUM60", "NUM61", "NUM62", "NUM63", "RTMIN", "IOT", "CLD", "POLL", 0 /**/ +#define SIG_NUM 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, -1, 6, 17, 29, 0 /**/ /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this @@ -2131,7 +2123,7 @@ * This symbol, if defined, indicates that the atoll routine is * available to convert strings into long longs. */ -/*#define HAS_ATOLL / **/ +#define HAS_ATOLL /**/ /* PERL_BINCOMPAT_5005: * This symbol, if defined, indicates that Perl 5.006 should be @@ -2153,7 +2145,7 @@ * This symbol, if defined, indicates that the endspent system call is * available to finalize the scan of SysV shadow password entries. */ -/*#define HAS_ENDSPENT / **/ +#define HAS_ENDSPENT /**/ /* HAS_STRUCT_FS_DATA: * This symbol, if defined, indicates that the struct fs_data @@ -2165,7 +2157,7 @@ * This symbol, if defined, indicates that the fseeko routine is * available to fseek beyond 32 bits (useful for ILP32 hosts). */ -/*#define HAS_FSEEKO / **/ +#define HAS_FSEEKO /**/ /* HAS_FSTATFS: * This symbol, if defined, indicates that the fstatfs routine is @@ -2176,7 +2168,7 @@ * This symbol, if defined, indicates that the ftello routine is * available to ftell beyond 32 bits (useful for ILP32 hosts). */ -/*#define HAS_FTELLO / **/ +#define HAS_FTELLO /**/ /* HAS_GETMNT: * This symbol, if defined, indicates that the getmnt routine is @@ -2188,32 +2180,32 @@ * This symbol, if defined, indicates that the getmntent routine is * available to iterate through mounted file systems to get their info. */ -/*#define HAS_GETMNTENT / **/ +#define HAS_GETMNTENT /**/ /* HAS_GETSPENT: * This symbol, if defined, indicates that the getspent system call is * available to retrieve SysV shadow password entries sequentially. */ -/*#define HAS_GETSPENT / **/ +#define HAS_GETSPENT /**/ /* HAS_GETSPNAM: * This symbol, if defined, indicates that the getspnam system call is * available to retrieve SysV shadow password entries by name. */ -/*#define HAS_GETSPNAM / **/ +#define HAS_GETSPNAM /**/ /* HAS_HASMNTOPT: * This symbol, if defined, indicates that the hasmntopt routine is * available to query the mount options of file systems. */ -/*#define HAS_HASMNTOPT / **/ +#define HAS_HASMNTOPT /**/ /* HAS_INT64_T: * This symbol will defined if the C compiler supports int64_t. * Usually the <inttypes.h> needs to be included, but sometimes * <sys/types.h> is enough. */ -/*#define HAS_INT64_T / **/ +#define HAS_INT64_T /**/ /* HAS_LDBL_DIG: * This symbol, if defined, indicates that this system's <float.h> @@ -2227,7 +2219,7 @@ * This symbol, if defined, indicates that the setspent system call is * available to initialize the scan of SysV shadow password entries. */ -/*#define HAS_SETSPENT / **/ +#define HAS_SETSPENT /**/ /* USE_SFIO: * This symbol, if defined, indicates that sfio should @@ -2250,7 +2242,7 @@ * have statfs() and struct statfs, they have ustat() and getmnt() * with struct ustat and struct fs_data. */ -#define HAS_STRUCT_STATFS_F_FLAGS /**/ +/*#define HAS_STRUCT_STATFS_F_FLAGS / **/ /* HAS_STRUCT_STATFS: * This symbol, if defined, indicates that the struct statfs @@ -2315,13 +2307,13 @@ * This symbol, if defined, indicates to the C program that it should * include <inttypes.h>. */ -/*#define I_INTTYPES / **/ +#define I_INTTYPES /**/ /* I_MNTENT: * This symbol, if defined, indicates that <mntent.h> exists and * should be included. */ -/*#define I_MNTENT / **/ +#define I_MNTENT /**/ /* I_NETINET_TCP: * This symbol, if defined, indicates to the C program that it should @@ -2339,7 +2331,7 @@ * This symbol, if defined, indicates that <shadow.h> exists and * should be included. */ -/*#define I_SHADOW / **/ +#define I_SHADOW /**/ /* I_SOCKS: * This symbol, if defined, indicates that <socks.h> exists and @@ -2356,7 +2348,7 @@ /* I_SYS_STATFS: * This symbol, if defined, indicates that <sys/statfs.h> exists. */ -/*#define I_SYS_STATFS / **/ +#define I_SYS_STATFS /**/ /* I_SYS_STATVFS: * This symbol, if defined, indicates that <sys/statvfs.h> exists and @@ -2368,7 +2360,7 @@ * This symbol, if defined, indicates that <sys/vfs.h> exists and * should be included. */ -/*#define I_SYS_VFS / **/ +#define I_SYS_VFS /**/ /* I_USTAT: * This symbol, if defined, indicates that <ustat.h> exists and @@ -2393,8 +2385,8 @@ * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'g') for output. */ -#define PERL_PRIfldbl "f" /**/ -#define PERL_PRIgldbl "g" /**/ +#define PERL_PRIfldbl "llf" /**/ +#define PERL_PRIgldbl "llg" /**/ /* IVTYPE: * This symbol defines the C type used for Perl's IV. @@ -2459,20 +2451,17 @@ /* U64SIZE: * This symbol contains the sizeof(U64). */ -/* NVSIZE: - * This symbol contains the sizeof(NV). - */ -#define IVTYPE long /**/ -#define UVTYPE unsigned long /**/ +#define IVTYPE long long /**/ +#define UVTYPE unsigned long long /**/ #define I8TYPE char /**/ #define U8TYPE unsigned char /**/ #define I16TYPE short /**/ #define U16TYPE unsigned short /**/ -#define I32TYPE int /**/ -#define U32TYPE unsigned int /**/ +#define I32TYPE long /**/ +#define U32TYPE unsigned long /**/ #ifdef HAS_QUAD -#define I64TYPE long /**/ -#define U64TYPE unsigned long /**/ +#define I64TYPE long long /**/ +#define U64TYPE unsigned long long /**/ #endif #define NVTYPE double /**/ #define IVSIZE 8 /**/ @@ -2487,7 +2476,6 @@ #define I64SIZE 8 /**/ #define U64SIZE 8 /**/ #endif -#define NVSIZE 8 /**/ /* IVdf: * This symbol defines the format string used for printing a Perl IV @@ -2505,10 +2493,10 @@ * This symbol defines the format string used for printing a Perl UV * as an unsigned hexadecimal integer. */ -#define IVdf "ld" /**/ -#define UVuf "lu" /**/ -#define UVof "lo" /**/ -#define UVxf "lx" /**/ +#define IVdf "lld" /**/ +#define UVuf "llu" /**/ +#define UVof "llo" /**/ +#define UVxf "llx" /**/ /* SELECT_MIN_BITS: * This symbol holds the minimum number of bits operated by select. @@ -2534,18 +2522,18 @@ * This symbol tells the name of the array holding the stdio streams. * Usual values include _iob, __iob, and __sF. */ -#define HAS_STDIO_STREAM_ARRAY /**/ -#define STDIO_STREAM_ARRAY _iob +/*#define HAS_STDIO_STREAM_ARRAY / **/ +#define STDIO_STREAM_ARRAY /* HAS_STRTOULL: * This symbol, if defined, indicates that the strtoull routine is * available to convert strings into unsigned long longs. */ -/*#define HAS_STRTOULL / **/ +#define HAS_STRTOULL /**/ /* USE_64_BITS: - * This symbol, if defined, indicates that 64-bit interfaces should - * be used when available. If not defined, the native default interfaces + * This symbol, if defined, indicates that 64-bit integers should + * be used when available. If not defined, the native integers * will be used (be they 32 or 64 bits). */ #ifndef USE_64_BITS @@ -2558,7 +2546,7 @@ * also be turned on if necessary. */ #ifndef USE_LARGE_FILES -/*#define USE_LARGE_FILES / **/ +#define USE_LARGE_FILES /**/ #endif /* USE_LONG_DOUBLE: @@ -2574,7 +2562,7 @@ * be used when available. */ #ifndef USE_LONG_LONG -/*#define USE_LONG_LONG / **/ +#define USE_LONG_LONG /**/ #endif #ifndef USE_MORE_BITS @@ -2606,41 +2594,6 @@ /*#define USE_SOCKS / **/ #endif -/* PERL_XS_APIVERSION: - * This variable contains the version of the oldest perl binary - * compatible with the present perl. perl.c:incpush() and - * lib/lib.pm will automatically search in /opt/perl/lib/site_perl/5.00563/alpha-dec_osf-thread for older - * directories across major versions back to xs_apiversion. - * This is only useful if you have a perl library directory tree - * structured like the default one. - * See INSTALL for how this works. - * The versioned site_perl directory was introduced in 5.005, - * so that is the lowest possible value. - * Since this can depend on compile time options (such as - * bincompat) it is set by Configure. Other non-default sources - * of potential incompatibility, such as multiplicity, threads, - * debugging, 64bits, sfio, etc., are not checked for currently, - * though in principle we could go snooping around in old - * Config.pm files. - */ -/* PERL_PM_APIVERSION: - * This variable contains the version of the oldest perl - * compatible with the present perl. (That is, pure perl modules - * written for pm_apiversion will still work for the current - * version). perl.c:incpush() and lib/lib.pm will automatically - * search in /opt/perl/lib/site_perl for older directories across major versions - * back to pm_apiversion. This is only useful if you have a perl - * library directory tree structured like the default one. The - * versioned site_perl library was introduced in 5.005, so that's - * the default setting for this variable. It's hard to imagine - * it changing before Perl6. It is included here for symmetry - * with xs_apiveprsion -- the searching algorithms will - * (presumably) be similar. - * See the INSTALL file for how this works. - */ -#define PERL_XS_APIVERSION 5.00563 /* Change to string for tuples?*/ -#define PERL_PM_APIVERSION 5.005 /* Change to string for tuples?*/ - /* HAS_DRAND48_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the drand48() function. Otherwise, it is up @@ -2698,9 +2651,9 @@ * getnetbyaddr(). */ #define Netdb_host_t const char * /**/ -#define Netdb_hlen_t int /**/ +#define Netdb_hlen_t size_t /**/ #define Netdb_name_t const char * /**/ -#define Netdb_net_t int /**/ +#define Netdb_net_t unsigned long /**/ /* Select_fd_set_t: * This symbol holds the type used for the 2nd, 3rd, and 4th @@ -2716,7 +2669,7 @@ * where library files may be held under a private library, for * instance. */ -#define ARCHNAME "alpha-dec_osf-thread" /**/ +#define ARCHNAME "i686-linux-thread" /**/ /* OLD_PTHREAD_CREATE_JOINABLE: * This symbol, if defined, indicates how to create pthread @@ -2759,16 +2712,22 @@ */ #define I_PTHREAD /**/ -/* USE_THREADS: - * This symbol, if defined, indicates that Perl should - * be built to use threads. +/* USE_ITHREADS: + * This symbol, if defined, indicates that Perl should be built to + * use the interpreter-based threading implementation. + */ +/* USE_5005THREADS: + * This symbol, if defined, indicates that Perl should be built to + * use the 5.005-based threading implementation. */ /* OLD_PTHREADS_API: * This symbol, if defined, indicates that Perl should * be built to use the old draft POSIX threads API. */ -#ifndef USE_TTHREADS -#define USE_THREADS /**/ +/*#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 / **/ @@ -2796,7 +2755,7 @@ /* Gid_t_f: * This symbol defines the format string used for printing a Gid_t. */ -#define Gid_t_f "u" /**/ +#define Gid_t_f "lu" /**/ /* Gid_t_size: * This symbol holds the size of a Gid_t in bytes. @@ -2824,8 +2783,8 @@ * This symbol holds the number of bytes used by the Off_t. */ #define Off_t off_t /* <offset> type */ -#define LSEEKSIZE 8 /* <offset> size */ -#define Off_t_size 8 /* <offset> size */ +#define LSEEKSIZE 4 /* <offset> size */ +#define Off_t_size 4 /* <offset> size */ /* Mode_t: * This symbol holds the type used to declare file modes @@ -2842,11 +2801,6 @@ */ #define Pid_t pid_t /* PID type */ -/* Size_t_size: - * This symbol holds the size of a Size_t in bytes. - */ -#define Size_t_size 8 /* */ - /* Size_t: * This symbol holds the type used to declare length parameters * for string functions. It is usually size_t, but may be @@ -2858,7 +2812,7 @@ /* Uid_t_f: * This symbol defines the format string used for printing a Uid_t. */ -#define Uid_t_f "u" /**/ +#define Uid_t_f "lu" /**/ /* Uid_t_size: * This symbol holds the size of a Uid_t in bytes. diff --git a/Porting/genlog b/Porting/genlog index b8bd1d6b2f..efb7ef8e10 100755 --- a/Porting/genlog +++ b/Porting/genlog @@ -12,7 +12,7 @@ # # Outputs the changelist to stdout. # -# Gurusamy Sarathy <gsar@umich.edu> +# Gurusamy Sarathy <gsar@activestate.com> # use Text::Wrap; diff --git a/Porting/p4d2p b/Porting/p4d2p index 67780a9393..f645ef807e 100755 --- a/Porting/p4d2p +++ b/Porting/p4d2p @@ -4,7 +4,7 @@ # reads a perforce style diff on stdin and outputs appropriate headers # so the diff can be applied with the patch program # -# Gurusamy Sarathy <gsar@umich.edu> +# Gurusamy Sarathy <gsar@activestate.com> # BEGIN { diff --git a/Porting/p4desc b/Porting/p4desc index 7bac3eb1f2..b6b412d517 100755 --- a/Porting/p4desc +++ b/Porting/p4desc @@ -3,7 +3,7 @@ # # Munge "p4 describe ..." output to include new files. # -# Gurusamy Sarathy <gsar@umich.edu> +# Gurusamy Sarathy <gsar@activestate.com> # use vars qw($thisfile $change $file $fnum $h $v $p4port @addfiles); diff --git a/Porting/patchls b/Porting/patchls index 2e4a0ac5a7..4329f4cebc 100644 --- a/Porting/patchls +++ b/Porting/patchls @@ -17,7 +17,7 @@ use Text::Tabs qw(expand unexpand); use strict; use vars qw($VERSION); -$VERSION = 2.10; +$VERSION = 2.11; sub usage { die qq{ @@ -35,6 +35,7 @@ die qq{ (F has \$ appended unless it contains a /). -e Expect patched files to Exist (relative to current directory) Will print warnings for files which don't. Also affects -4 option. + - Read patch from STDIN other options for special uses: -I just gather and display summary Information about the patches. -4 write to stdout the PerForce commands to prepare for patching. @@ -159,7 +160,9 @@ foreach my $argv (@ARGV) { warn "Ignored directory $in\n"; next; } - unless (open F, "<$in") { + if ($in eq "-") { + *F = \*STDIN; + } elsif (not open F, "<$in") { warn "Unable to open $in: $!\n"; next; } diff --git a/README.epoc b/README.epoc index 88d2e5ed83..2ff36fd8f9 100644 --- a/README.epoc +++ b/README.epoc @@ -1,42 +1,49 @@ -================================================= +===================================================================== Perl 5 README file for the EPOC operating system. -================================================== +===================================================================== Olaf Flebbe <o.flebbe@gmx.de> -http://www.linuxstart.com/~oflebbe/perl/perl.html -1999-11-01 +http://www.linuxstart.com/~oflebbe/perl/perl5.html +2000-01-08 +===================================================================== Introduction ------------- +===================================================================== -This is a port of Perl version 5.005_62 to EPOC. +EPOC is a OS for palmtops and mobile phones. For more informations look at: +http://www.symbian.com/ -There are many features left out, because of restrictions of the POSIX -support in the SDK. +This is a port of Perl version 5.005_63 to EPOC. It runs on the Perl +Series 5, Series 5mx. I have no reports about the Psion Revo, the +Ericcson (??) and the Psion NetBook. I only have acess to an Series 5. +Features are left out, because of restrictions of the POSIX support. +===================================================================== Installation/Usage ------------------- +===================================================================== -You will need ~4MB free space in order to run perl. +You will need ~4MB free space in order to install and run perl. -Install perl.sis on the EPOC machine (most likely a PSION Series -5). If you do not know how to do that, you are on your own. You may -have to use a CF Card in order to work with perl. The perl debugger -uses more then 1.5 MB additional RAM. The heap is limited to 2 MB. +Install perl.sis on the EPOC machine (most likely a PSION Series 5, +5mx). If you do not know how to do that, you are on your own. -Perl itself and its standard library are using 1.7MB disk space. I -left out UTF support and modules which will not work with this -version. (For details look into epoc/createpkg.pl). +Perl itself and its standard library are using 2.5 MB disk space. I +left out unicode support modules and modules which will not work with +this version. (For details look into epoc/createpkg.pl). If you like +to use them, you are free to copy them from a current perl release. -Copy eshell.exe to the same location as perl. Start eshell.exe with a -double click. +Copy eshell.exe from the same page you got perl to your EPOC device. +Start eshell.exe with a double tap. Now you can enter: perl -de 0 in order to run the perl debugger. If -you are leaving perl, you have to switch back manually to eshell.exe -(With Ctrl-System or the button in the upper right corner of the -System screen.) When perl is running, you will see a task with the -name STDOUT in the task list. +you are leaving perl, you get into the system screen. You have to +switch back manually to eshell.exe When perl is running, you will see +a task with the name STDOUT in the task list. + +====================================================================== +IO Redirection +====================================================================== You can redirect the output with the UNIX bourne shell syntax (this is built into perl rather then eshell) For instance the following command @@ -45,88 +52,113 @@ stdout_file, the errors to stderr_file and input from stdin_file. perl test.pl >stdout_file <stdin_file 2>stderr_file -Alternativly you can use 2>&1 in order to add the standard error output to -stdout. +Alternativly you can use 2>&1 in order to add the standard error +output to stdout. + +====================================================================== +PATH Names +====================================================================== Pathnames to executables in eshell.exe have to be written with -backslashes, file arguments to perl with slashes. The default drive of -perl is the same as the drive perl.exe is located on, the default path -is the path perl.exe is / (???). +backslashes '\', file arguments to perl with slashes '/'. The default +drive of perl is the same as the drive perl.exe is located on, the +default path seems to be '/'. i.e. command lines look a little bit funny: D:\perl.exe C:/test.pl >C:/output.txt -In order to use Getopt::Long you have to autosplit this module by hand: run +You can automatically search for file on all EPOC drives with a ? as +the driver letter. For instance ?:\a.txt seraches for C:\a.txt, +D:\b.txt (and Z:\a.txt). -\perl.exe \autosplit.pl in order to create the necessary files. +====================================================================== +Editors +====================================================================== You may have a problem to create perl scripts. A cumbersome workaround is to use the OPL Editor and exporting to text. -Problems --------- +The OPL+ Editor is quite good. (Shareware: http://www.twiddlebit.com) +There is a port of vim around: + http://www.starship.freeserve.co.uk/index.html + +====================================================================== +Restrictions +====================================================================== -The following known problems exist: +The following things are left out of this perl port: -1) no support for system, backquoting, pipes etc. One cannot exec a - different process. ++ backquoting, pipes etc. -2) no signals, kill, alarm. Do not try to use them. This may be - impossible to implement on EPOC. ++ system() does not inherit ressources like: file descriptors, + environment etc. -3) select is missing. ++ signal, kill, alarm. Do not try to use them. This may be + impossible to implement on EPOC. -4) binmode does not exist. (No CR LF to LF translation for text files) ++ select is missing. -5) Only a stub Config.pm ++ binmode does not exist. (No CR LF to LF translation for text files) -6) EPOC does not handle the notion of current drive and current - directory very well (i.e. not at all, but it tries hard to emulate - one) ++ EPOC does not handle the notion of current drive and current + directory very well (i.e. not at all, but it tries hard to emulate + one) See PATH. -7) sockets may hardly of any use. ++ sockets seems to work now! -8) You need the shell eshell.exe in order to run perl.exe and supply - it with arguments. ++ You need the shell eshell.exe in order to run perl.exe and supply + it with arguments. ++ Heap is limited to 4MB. +=================================================================== Compiling Perl 5 on the EPOC cross compiling envionment. --------------------------------------------------------- +=================================================================== -0. You will need the C++ SDK from - http://developer.epocworld.com/. Install it on a separate - drive. +Sorry, this is far too short. -1. Get the Perl sources from your nearest CPAN site. - Unpack the sources of perl5.005_60 in the epoc development drive. - -2. Copy all files in the directory perl5.005_60/epoc to perl5.005_60. + You will need the C++ SDK from http://developer.epocworld.com/. -3. Check the perl.mmp file: It should have the correct locations for - project und subproject (see step 1) + You will need to set up the cross SDK from + http://www.linuxstart.com/~oflebbe -4. Change to the EPOC development drive and run - makmake perl marm - nmake -f perl.marm - makesis perl.pkg perl5.005.sis + You may have to adjust config.sh (cc, cppflags) for your epoc + install location. -5. Beam the perl5.005.sis to the Psion5, install and enjoy! + You may have to adjust config.sh for your cross SDK location -You can use epoc\createpkg.pl to generate a new perl.pkg file. + Get the Perl sources from your nearest CPAN site. + Unpack the sources. -Wish List ---------- + Build a native miniperl... + cp epoc/* . + for i in *.SH ; do + sh $i + done + make perl + cp miniperl.native miniperl + make perl + perl linkit perlmain.o lib/auto/DynaLoader/DynaLoader.a \ + lib/auto/Data/Dumper.a \ + lib/auto/File/Glob/Glob.a lib/auto/IO/IO.a \ + lib/auto/Socket/Socket.a perl.a `cat ext.libs` + perl createpkg.pl + wine "G:/bin/makesis perl.pkg perl.sis" -- Implement an OPX to get rid of eshell.exe. -- Implement system(), in order to run the tests. +==================================================================== +TODO +==================================================================== -- Implement getprotcolbyname() and relatives. +- Get the HTTPD::* working (Hey, It worked the first time for me!) +- Threads ? +- Acess to the GUI? +==================================================================== Support Status --------------- +==================================================================== I'm offering this port "as is". You can ask me questions, but I can't guarantee I'll be able to answer them; I don't know much about Perl diff --git a/README.os2 b/README.os2 index 409c774591..cd07ca19b6 100644 --- a/README.os2 +++ b/README.os2 @@ -809,10 +809,8 @@ Change to the directory of extraction. =head2 Application of the patches -You need to apply the patches in F<./os2/diff.*> and -F<./os2/POSIX.mkfifo> like this: +You need to apply the patches in F<./os2/diff.*> like this: - gnupatch -p0 < os2\POSIX.mkfifo gnupatch -p0 < os2\diff.configure You may also need to apply the patches supplied with the binary @@ -939,6 +937,8 @@ The reasons for most important skipped tests are: =item F<op/fs.t> +=over 4 + =item 18 Checks C<atime> and C<mtime> of C<stat()> - unfortunately, HPFS diff --git a/README.vms b/README.vms index 13a1f9bb51..d9ea97ea52 100644 --- a/README.vms +++ b/README.vms @@ -6,7 +6,7 @@ Originally by Charles Bailey <bailey@newman.upenn.edu> The build and install procedures have changed significantly from the 5.004 releases! Make sure you read the "Building Perl" and "Installing Perl" -sections before you build or install. +sections of this document before you build or install. Also note that, as of 5.005, an ANSI C compliant compiler is required to build Perl. Vax C is *not* ANSI compliant, as it died a natural death some @@ -84,7 +84,7 @@ Building perl has two steps, configuration and compilation. To configure perl (a necessary first step), issue the command -@CONFIGURE + @CONFIGURE from the top of an unpacked perl directory. You'll be asked a series of questions, and the answers to them (along with the capabilities of your C @@ -96,7 +96,22 @@ you're using a version older than 5.2, check the Dec C Issues section. The configuration script will print out, at the very end, the MMS or MMK command you need to compile perl. Issue it (exactly as printed) to start -the build. +the build. If you have any symbols or logical names in your environment +that may interfere with the build or regression testing of perl then +configure.com will try to warn you about them. If a logical name is causing +you trouble but is in an LNM table that you do not have write access to +then try defining your own to a harmless equivalence string in a table +such that it is resolved before the other (e.g. if TMP is defined in the +SYSTEM table then try DEFINE TMP "NL:" or somesuch) otherwise simply deasign +the dangerous logical names. The potentially troublesome logicals and +symbols are: + + TMP "LOGICAL" + LIB "LOGICAL" + T "LOGICAL" + FOO "LOGICAL" + EXT "LOGICAL" + TEST "SYMBOL" Once you issue your MMS command, sit back and wait. Perl should build and link without a problem. If it doesn't, check the Gotchas to watch out for @@ -105,7 +120,7 @@ Instructions are in the Mailing Lists section. As a handy shortcut, the command: -@CONFIGURE "-des" + @CONFIGURE "-des" (note the quotation marks and case) will choose reasonable defaults. (It takes Dec C over Gnu C, Dec C sockets over SOCKETSHR sockets, and either @@ -245,18 +260,18 @@ into DCLTABLES, replace it with just perl. Execute the following command file to define PERL as a DCL command. You'll need CMKRNL priv to install the new dcltables.exe. -$ create perl.cld -! -! modify to reflect location of your perl.exe -! -define verb perl - image perl_root:[000000]perl.exe - cliflags (foreign) -$! -$ set command perl /table=sys$common:[syslib]dcltables.exe - - /output=sys$common:[syslib]dcltables.exe -$ install replace sys$common:[syslib]dcltables.exe -$ exit + $ create perl.cld + ! + ! modify to reflect location of your perl.exe + ! + define verb perl + image perl_root:[000000]perl.exe + cliflags (foreign) + $! + $ set command perl /table=sys$common:[syslib]dcltables.exe - + /output=sys$common:[syslib]dcltables.exe + $ install replace sys$common:[syslib]dcltables.exe + $ exit * Changing compile-time things @@ -410,7 +425,7 @@ missed someone. That said, special thanks are due to the following: for the getredirection() code Rich Salz <rsalz@bbn.com> for readdir() and related routines - Peter Prymmer <pvhp@forte.com> or <pvhp@lns62.lns.cornell.edu> + Peter Prymmer <pvhp@forte.com> for extensive testing, as well as development work on configuration and documentation for VMS Perl, Dan Sugalski <dan@sidhe.org> diff --git a/README.win32 b/README.win32 index dfd6eb09f2..1623acf20f 100644 --- a/README.win32 +++ b/README.win32 @@ -47,11 +47,11 @@ following compilers: Borland C++ version 5.02 or later Microsoft Visual C++ version 4.2 or later - Mingw32 with EGCS versions 1.0.2, 1.1 - Mingw32 with GCC version 2.8.1 + Mingw32 with GCC version 2.95.2 or better -The last two of these are high quality freeware compilers. Support -for them is still experimental. +The last of these is a high quality freeware compiler. Support +for it is still experimental. (Older versions of GCC are known +not to work.) This port currently supports MakeMaker (the set of modules that is used to build extensions to perl). Therefore, you should be @@ -92,6 +92,11 @@ A port of dmake for win32 platforms is available from: ftp://ftp.linux.activestate.com/pub/staff/gsar/dmake-4.1-win32.zip +(This is a fixed version of original dmake sources obtained from +http://www.wticorp.com/dmake/. As of version 4.1PL1, the original +sources did not build as shipped, and had various other problems. +A patch is included in the above fixed version.) + Fetch and install dmake somewhere on your path (follow the instructions in the README.NOW file). @@ -108,24 +113,17 @@ and edit win32/config.vc to change "make=nmake" into "make=dmake". The latter step is only essential if you want to use dmake as your default make for building extensions using MakeMaker. -=item Mingw32 with EGCS or GCC +=item Mingw32 with GCC -ECGS binaries can be downloaded from: +GCC-2.95.2 binaries can be downloaded from: ftp://ftp.xraylith.wisc.edu/pub/khan/gnu-win32/mingw32/ -GCC-2.8.1 binaries are available from: - - http://agnes.dida.physik.uni-essen.de/~janjaap/mingw32/ +The GCC-2.95.2 bundle comes with Mingw32 libraries and headers. -You only need either one of those, not both. Both bundles come with -Mingw32 libraries and headers. While both of them work to build perl, -the EGCS binaries are currently favored by the maintainers, since they -come with more up-to-date Mingw32 libraries. - -Make sure you install the binaries as indicated in the web sites -above. You will need to set up a few environment variables (usually -run from a batch file). +Make sure you install the binaries as indicated in the README for +the GCC bundle. You may need to set up a few environment variables +(usually run from a batch file). You also need dmake. See L</"Borland C++"> above on how to get it. @@ -160,7 +158,7 @@ is typically requested through: perl Makefile.PL CAPI=TRUE PERL_OBJECT requires VC++ 5.0 (Service Pack 3 recommended) or later. It -is not yet supported under GCC or EGCS. WARNING: Binaries built with +is not yet supported under GCC. WARNING: Binaries built with PERL_OBJECT enabled are B<not> compatible with binaries built without. Perl installs PERL_OBJECT binaries under a distinct architecture name, so they B<can> coexist, though. @@ -252,10 +250,6 @@ default path. You will need to copy the DLLs reported by the messages from where Borland chose to install it, into the Windows system directory (usually somewhere like C:\WINNT\SYSTEM32), and rerun the test. -The Visual C runtime apparently has a bug that causes posix.t to fail -test#2. This usually happens only if you extracted the files in text -mode. Enable the USE_PERLCRT option in the Makefile to fix this bug. - Please report any other failures as described under L<BUGS AND CAVEATS>. =head2 Installation @@ -729,7 +723,7 @@ by C<perl -V>. Gary Ng E<lt>71564.1743@CompuServe.COME<gt> -Gurusamy Sarathy E<lt>gsar@umich.eduE<gt> +Gurusamy Sarathy E<lt>gsar@activestate.comE<gt> Nick Ing-Simmons E<lt>nick@ni-s.u-net.comE<gt> @@ -745,10 +739,8 @@ L<perl> This port was originally contributed by Gary Ng around 5.003_24, and borrowed from the Hip Communications port that was available -at the time. - -Nick Ing-Simmons and Gurusamy Sarathy have made numerous and -sundry hacks since then. +at the time. Various people have made numerous and sundry hacks +since then. Borland support was added in 5.004_01 (Gurusamy Sarathy). @@ -756,7 +748,10 @@ GCC/mingw32 support was added in 5.005 (Nick Ing-Simmons). Support for PERL_OBJECT was added in 5.005 (ActiveState Tool Corp). -Last updated: 18 January 1999 +Support for fork() emulation was added in 5.6 (ActiveState Tool Corp). -=cut +Win9x support was added in 5.6 (Benjamin Stuhl). +Last updated: 28 December 1999 + +=cut @@ -17,6 +17,9 @@ #define dXSTARG SV * targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \ ? PAD_SV(PL_op->op_targ) : sv_newmortal()) +/* Should be used before final PUSHi etc. if not in PPCODE section. */ +#define XSprePUSH (sp = PL_stack_base + ax - 1) + #define XSANY CvXSUBANY(cv) #define dXSI32 I32 ix = XSANY.any_i32 @@ -238,6 +241,7 @@ # define setjmp PerlProc_setjmp # define longjmp PerlProc_longjmp # define signal PerlProc_signal +# define getpid PerlProc_getpid # define htonl PerlSock_htonl # define htons PerlSock_htons # define ntohl PerlSock_ntohl @@ -591,6 +591,86 @@ Perl_av_fill(pTHX_ register AV *av, I32 fill) (void)av_store(av,fill,&PL_sv_undef); } +SV * +Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags) +{ + SV *sv; + + if (!av) + return Nullsv; + if (SvREADONLY(av)) + Perl_croak(aTHX_ PL_no_modify); + if (key < 0) { + key += AvFILL(av) + 1; + if (key < 0) + return Nullsv; + } + if (SvRMAGICAL(av)) { + SV **svp; + if ((mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) + && (svp = av_fetch(av, key, TRUE))) + { + sv = *svp; + mg_clear(sv); + if (mg_find(sv, 'p')) { + sv_unmagic(sv, 'p'); /* No longer an element */ + return sv; + } + return Nullsv; /* element cannot be deleted */ + } + } + if (key > AvFILLp(av)) + return Nullsv; + else { + sv = AvARRAY(av)[key]; + if (key == AvFILLp(av)) { + do { + AvFILLp(av)--; + } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef); + } + else + AvARRAY(av)[key] = &PL_sv_undef; + if (SvSMAGICAL(av)) + mg_set((SV*)av); + } + if (flags & G_DISCARD) { + SvREFCNT_dec(sv); + sv = Nullsv; + } + return sv; +} + +/* + * This relies on the fact that uninitialized array elements + * are set to &PL_sv_undef. + */ + +bool +Perl_av_exists(pTHX_ AV *av, I32 key) +{ + if (!av) + return FALSE; + if (key < 0) { + key += AvFILL(av) + 1; + if (key < 0) + return FALSE; + } + if (SvRMAGICAL(av)) { + if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) { + SV *sv = sv_newmortal(); + mg_copy((SV*)av, sv, 0, key); + magic_existspack(sv, mg_find(sv, 'p')); + return SvTRUE(sv); + } + } + if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef + && AvARRAY(av)[key]) + { + return TRUE; + } + else + return FALSE; +} /* AVHV: Support for treating arrays as if they were hashes. The * first element of the array should be a hash reference that maps @@ -638,34 +718,33 @@ Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash) return av_fetch(av, avhv_index_sv(HeVAL(he)), lval); } +SV * +Perl_avhv_delete_ent(pTHX_ AV *av, SV *keysv, I32 flags, U32 hash) +{ + HV *keys = avhv_keys(av); + HE *he; + + he = hv_fetch_ent(keys, keysv, FALSE, hash); + if (!he || !SvOK(HeVAL(he))) + return Nullsv; + + return av_delete(av, avhv_index_sv(HeVAL(he)), flags); +} + /* Check for the existence of an element named by a given key. * - * This relies on the fact that uninitialized array elements - * are set to &PL_sv_undef. */ bool Perl_avhv_exists_ent(pTHX_ AV *av, SV *keysv, U32 hash) { HV *keys = avhv_keys(av); HE *he; - IV ix; he = hv_fetch_ent(keys, keysv, FALSE, hash); if (!he || !SvOK(HeVAL(he))) return FALSE; - ix = SvIV(HeVAL(he)); - - /* If the array hasn't been extended to reach the key yet then - * it hasn't been accessed and thus does not exist. We use - * AvFILL() rather than AvFILLp() to handle tied av. */ - if (ix > 0 && ix <= AvFILL(av) - && (SvRMAGICAL(av) - || (AvARRAY(av)[ix] && AvARRAY(av)[ix] != &PL_sv_undef))) - { - return TRUE; - } - return FALSE; + return av_exists(av, avhv_index_sv(HeVAL(he))); } HE * diff --git a/config_h.SH b/config_h.SH index 7e0f25af9d..2ecf108e52 100644 --- a/config_h.SH +++ b/config_h.SH @@ -998,6 +998,37 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #define STDCHAR $stdchar /**/ +/* CROSSCOMPILE: + * This symbol, if defined, signifies that we our + * build process is a cross-compilation. + */ +#$crosscompile CROSSCOMPILE /**/ + +/* INTSIZE: + * This symbol contains the value of sizeof(int) so that the C + * preprocessor can make decisions based on it. + */ +/* LONGSIZE: + * This symbol contains the value of sizeof(long) so that the C + * preprocessor can make decisions based on it. + */ +/* SHORTSIZE: + * This symbol contains the value of sizeof(short) so that the C + * preprocessor can make decisions based on it. + */ +#define INTSIZE $intsize /**/ +#define LONGSIZE $longsize /**/ +#define SHORTSIZE $shortsize /**/ + +/* MULTIARCH: + * This symbol, if defined, signifies that the build + * process will produce some binary files that are going to be + * used in a cross-platform environment. This is the case for + * example with the NeXT "fat" binaries that contain executables + * for several CPUs. + */ +#$multiarch MULTIARCH /**/ + /* HAS_QUAD: * This symbol, if defined, tells that there's a 64-bit integer type, * Quad_t, and its unsigned counterpar, Uquad_t. QUADKIND will be one @@ -1038,37 +1069,6 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$i_syssecrt I_SYS_SECURITY /**/ -/* CROSSCOMPILE: - * This symbol, if defined, signifies that we our - * build process is a cross-compilation. - */ -#$crosscompile CROSSCOMPILE /**/ - -/* INTSIZE: - * This symbol contains the value of sizeof(int) so that the C - * preprocessor can make decisions based on it. - */ -/* LONGSIZE: - * This symbol contains the value of sizeof(long) so that the C - * preprocessor can make decisions based on it. - */ -/* SHORTSIZE: - * This symbol contains the value of sizeof(short) so that the C - * preprocessor can make decisions based on it. - */ -#define INTSIZE $intsize /**/ -#define LONGSIZE $longsize /**/ -#define SHORTSIZE $shortsize /**/ - -/* MULTIARCH: - * This symbol, if defined, signifies that the build - * process will produce some binary files that are going to be - * used in a cross-platform environment. This is the case for - * example with the NeXT "fat" binaries that contain executables - * for several CPUs. - */ -#$multiarch MULTIARCH /**/ - /* MEM_ALIGNBYTES: * This symbol contains the number of bytes required to align a * double. Usual values are 2, 4 and 8. The default is eight, @@ -2608,41 +2608,6 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- #$usesocks USE_SOCKS /**/ #endif -/* PERL_XS_APIVERSION: - * This variable contains the version of the oldest perl binary - * compatible with the present perl. perl.c:incpush() and - * lib/lib.pm will automatically search in $sitearch for older - * directories across major versions back to xs_apiversion. - * This is only useful if you have a perl library directory tree - * structured like the default one. - * See INSTALL for how this works. - * The versioned site_perl directory was introduced in 5.005, - * so that is the lowest possible value. - * Since this can depend on compile time options (such as - * bincompat) it is set by Configure. Other non-default sources - * of potential incompatibility, such as multiplicity, threads, - * debugging, 64bits, sfio, etc., are not checked for currently, - * though in principle we could go snooping around in old - * Config.pm files. - */ -/* PERL_PM_APIVERSION: - * This variable contains the version of the oldest perl - * compatible with the present perl. (That is, pure perl modules - * written for pm_apiversion will still work for the current - * version). perl.c:incpush() and lib/lib.pm will automatically - * search in $sitelib for older directories across major versions - * back to pm_apiversion. This is only useful if you have a perl - * library directory tree structured like the default one. The - * versioned site_perl library was introduced in 5.005, so that's - * the default setting for this variable. It's hard to imagine - * it changing before Perl6. It is included here for symmetry - * with xs_apiveprsion -- the searching algorithms will - * (presumably) be similar. - * See the INSTALL file for how this works. - */ -#define PERL_XS_APIVERSION $xs_apiversion /* Change to string for tuples?*/ -#define PERL_PM_APIVERSION $pm_apiversion /* Change to string for tuples?*/ - /* HAS_DRAND48_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the drand48() function. Otherwise, it is up @@ -2761,16 +2726,22 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$i_pthread I_PTHREAD /**/ -/* USE_THREADS: - * This symbol, if defined, indicates that Perl should - * be built to use threads. +/* USE_ITHREADS: + * This symbol, if defined, indicates that Perl should be built to + * use the interpreter-based threading implementation. + */ +/* USE_5005THREADS: + * This symbol, if defined, indicates that Perl should be built to + * use the 5.005-based threading implementation. */ /* OLD_PTHREADS_API: * This symbol, if defined, indicates that Perl should * be built to use the old draft POSIX threads API. */ -#ifndef USE_TTHREADS -#$usethreads USE_THREADS /**/ +#$use5005threads USE_5005THREADS /**/ +#$useithreads USE_ITHREADS /**/ +#if defined(USE_5005THREADS) && !defined(USE_ITHREADS) +#define USE_THREADS /* until src is revised*/ #endif #$d_oldpthreads OLD_PTHREADS_API /**/ diff --git a/configure.com b/configure.com index cbc3bb7e32..a77bec87cb 100644 --- a/configure.com +++ b/configure.com @@ -14,7 +14,7 @@ $! $ @Configure "-des" $! $! That's it. If you get into a bind trying to build perl on VMS then $! definitely read through the README.VMS file. -$! Beyond that send email to VMSPerl@cor.newman.upenn.edu +$! Beyond that send email to vmsperl@perl.org $! $! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $! @@ -24,8 +24,8 @@ $! Thank you!!!! $! $! Adapted and converted from Larry Wall & Andy Dougherty's $! "Configure generated by metaconfig 3.0 PL60." by Peter Prymmer -$! (a Bourne sh[ell] script for configuring the installation of perl on VMS) -$! in the perl5.002|3 epoch (spring/summer 1996) +$! (a Bourne sh[ell] script for configuring the installation of perl +$! on non-VMS systems) in the perl5.002|3 epoch (spring/summer 1996) $! with much valuable help from Charles Bailey & $! the whole VMSPerl crew. $! Extended and messed about with by Dan Sugalski @@ -41,7 +41,7 @@ $ ans = "" $ macros = "" $ use_vmsdebug_perl = "N" $ use_debugging_perl = "Y" -$ use_64bit = "N" +$ use_64bit = "n" $ C_Compiler_Replace = "CC=" $ Thread_Live_Dangerously = "MT=" $ use_two_pot_malloc = "N" @@ -481,6 +481,19 @@ $ IF (((f$length(file_2_find)+1) .eq. f$length(basename)) .and. - $ file_2_find = dirname + basename $! $ found = F$SEARCH(file_2_find) +$ IF (found .EQS. "" .AND. dots .GT. 2) +$ THEN +$! 17-DEC-1999 Improved to turn "[.foo.bar]baz.c_buz" into +$! "[.foo.bar]baz_c.buz" to cover unzipped archives and put +$! "[.foo.bar]baz.c_buz,baz_c.buz" into missing list if neither is found. +$ basename[f$locate(".",basename),1] := _ +$ dot_ele = F$ELEMENT(dots - 1,"_",basename) +$ basename = - + f$extract(0,f$length(basename)-(f$length(dot_ele)+1),basename) - + + "." + dot_ele +$ found = F$SEARCH(dirname + basename) +$ file_2_find = file_2_find + "," + basename +$ ENDIF $ IF (found .EQS. "") $ THEN $ WRITE MISSING file_2_find @@ -702,7 +715,7 @@ $ TYPE SYS$INPUT: %Config-E-VMS, ERROR: Err, you do not appear to be running VMS! - This package is intended to Configure the building of Perl for VMS. + This procedure is intended to Configure the building of Perl for VMS. $ READ SYS$COMMAND/PROMPT="Continue anyway? [n] " ans $ IF ans @@ -826,7 +839,7 @@ $! $TZSet: $ echo "" $ echo "Please tell me in hh:mm form what time offset from GMT/UTC in England" -$ echo "you are. As an example Eastern (US) Standard Time is -5:00 offset, but" +$ echo "you are. As an example Eastern (US) Standard Time is -5:00 offset, but" $ echo "Eastern Daylight Time (summer) is -4:00 offset." $ dflt = "0:00" $ rp = "Enter the Time Zone offset: [''dflt'] " @@ -870,8 +883,10 @@ $! $ IF (F$GETSYI("HW_MODEL") .LT. 1024) $ THEN $ archname = "VMS_VAX" +$ otherarch = "an Alpha" $ ELSE $ archname = "VMS_AXP" +$ otherarch = "a VAX" $ ENDIF $ rp = "What is your architecture name? [''archname'] " $ GOSUB myread @@ -883,24 +898,22 @@ $ THEN $ echo4 "I'll go with ''archname' anyway..." $ ENDIF $ ENDIF -$ IF (archname.EQS."VMS_AXP") +$ dflt = "n" +$ rp = "Will you be sharing your PERL_ROOT with ''otherarch'? [''dflt'] " +$ GOSUB myread +$ if ans.NES."" $ THEN -$ dflt = "n" -$ rp = "Are you sharing your PERL_ROOT with a VAX? [''dflt'] " -$ GOSUB myread -$ if ans.NES."" -$ THEN -$ ans = F$EDIT(ans,"COLLAPSE, UPCASE") -$ ENDIF -$ IF (ans.NES."Y") +$ ans = F$EXTRACT(0,1,F$EDIT(ans,"COLLAPSE, UPCASE")) +$ ENDIF +$ IF (ans.NES."Y") +$ THEN +$ sharedperl = "N" +$ ELSE +$ sharedperl = "Y" +$ IF (archname.EQS."VMS_AXP") $ THEN -$ sharedperl = "N" -$ ELSE -$ sharedperl = "Y" $ macros = macros + """AXE=1""," $ ENDIF -$ ELSE -$ sharedperl = "N" $ ENDIF $! $!: is AFS running? !sfn @@ -971,7 +984,7 @@ $! $ ENDIF !%Config-I-VMS, skip "where install" questions $! $!: set the base revision -$ baserev="5.0" +$ baserev="5" $!: get the patchlevel $ echo "" $ echo4 "Getting the current patchlevel..." !>&4 @@ -1019,7 +1032,7 @@ $ ENDIF $ ELSE subversion = "" $ ENDIF $! -$ version = F$EXTRACT(0,1,baserev) + "_" + patchlevel + subversion +$ version = baserev + "_" + patchlevel + "_" + subversion $! $ IF (.NOT.vms_skip_install) $ THEN @@ -1597,7 +1610,7 @@ no easy means to double check it. The default value provided below is most probably close to the reality but may not be valid from outside your organization... $ ENDIF -$ dflt = "''cf_by@''myhostname'"+"''mydomain'" +$ dflt = "''cf_by'@''myhostname'"+"''mydomain'" $ rp = "What is your e-mail address? [''dflt'] " $ GOSUB myread $ IF ans .nes. "" @@ -1685,16 +1698,16 @@ $ endif $! $! $! Ask if they want to build with VMS_DEBUG perl +$ echo "" $ echo "Perl can be built to run under the VMS debugger." $ echo "You should only select this option if you are debugging" $ echo "perl itself. This can be a useful feature if you are " $ echo "embedding perl in a program." -$ echo "" -$ dflt = "N" +$ dflt = "n" $ rp = "Build a VMS-DEBUG version of Perl? [''dflt'] " $ GOSUB myread -$ if ans.eqs."" then ans = dflt -$ if (f$extract(0, 1, "''ans'").eqs."Y").or.(f$extract(0, 1, "''ans'").eqs."y") +$ IF ans.eqs."" then ans = dflt +$ IF F$EXTRACT(0, 1, F$EDIT(ans,"COLLAPSE,UPCASE")) .eqs. "Y" $ THEN $ use_vmsdebug_perl = "Y" $ macros = macros + """__DEBUG__=1""," @@ -1703,18 +1716,18 @@ $ use_vmsdebug_perl = "N" $ ENDIF $! $! Ask if they want to build with MULTIPLICITY +$ echo "" $ echo "The perl interpreter engine can be built in a way that makes it -$ echo "possible for a program that embeds perl into it (and yep, you can +$ echo "possible for a program that embeds perl into it (and yes, you can $ echo "do that--it's pretty keen) to have multiple perl interpreters active $ echo "at once. There is some performance overhead, however, so you $ echo "probably don't want to choose this unless you're going to be doing $ echo "funky perl embedding." -$ echo "" $ dflt = "n" $ rp = "Build with MULTIPLICITY? [''dflt'] " $ GOSUB myread -$ if ans.eqs."" then ans = dflt -$ if (f$extract(0, 1, "''ans'").eqs."Y").or.(f$extract(0, 1, "''ans'").eqs."y") +$ if ans.eqs."" then ans = dflt +$ IF F$EXTRACT(0, 1, F$EDIT(ans,"COLLAPSE,UPCASE")) .eqs. "Y" $ THEN $ use_multiplicity="Y" $ ELSE @@ -1724,16 +1737,16 @@ $! $! Ask if they want to build with 64-bit support $ if (Archname.eqs."VMS_AXP").and.("''f$extract(1,3, f$getsyi(""version""))'".ges."7.1") $ THEN +$ echo "" $ echo "This version of perl has experimental support for building with $ echo "64 bit integers and 128 bit floating point variables. This gives $ echo "a much larger range for perl's mathematical operations. (Note that $ echo "does *not* enable 64-bit fileops at the moment, as Dec C doesn't $ echo "do that yet)" -$ echo "" $ dflt = use_64bit $ rp = "Build with 64 bits? [''dflt'] " $ GOSUB myread -$ if ans.eqs."" then ans = dflt +$ if ans.eqs."" then ans = dflt $ if (f$extract(0, 1, "''ans'").eqs."Y").or.(f$extract(0, 1, "''ans'").eqs."y") $ THEN $ use_64bit="Y" @@ -1745,10 +1758,10 @@ $! $! Ask about threads, if appropriate $ if (Using_Dec_C.eqs."Yes") $ THEN +$ echo "" $ echo "This version of Perl can be built with threads. While really nifty, $ echo "they are a beta feature, and there is a speed penalty for perl $ echo "programs if you build with threads *even if you don't use them* -$ echo "" $ dflt = "n" $ rp = "Build with threads? [''dflt'] " $ GOSUB myread @@ -1768,7 +1781,6 @@ $ echo "all the threads in a program, even on a single-processor $ echo "machine. Unfortunately this feature isn't safe on an $ echo "unpatched 7.1 system. (Several OS patches were required when $ echo "this procedure was written) -$ echo "" $ dflt = "n" $ rp = "Enable multiple kernel threads and upcalls? [''dflt'] " $ gosub myread @@ -1796,7 +1808,6 @@ $ echo "This restriction does not apply to the %ENV hash or to implicit" $ echo "logical name translation during parsing of file specifications;" $ echo "these always use the normal sequence of access modes for logical" $ echo "name translation." -$ echo "" $ dflt = "n" $ rp = "Use secure logical name translation? [''dflt'] " $ GOSUB myread @@ -1812,12 +1823,11 @@ $ echo "default file types, however, you can configure Perl to try default" $ echo "file types of nothing, .pl, and .com, in that order (e.g. typing" $ echo """$ perl foo"" would cause Perl to look for foo., then foo.pl, and" $ echo "finally foo.com)." -$ echo "" $ dflt = "n" $ rp = "Always use default file types? [''dflt'] " $ GOSUB myread $ if ans.eqs."" then ans="''dflt'" -$ d_alwdeftype = f$extract(0, 1, f$edit(ans,"TRIM,COMPRESS,UPCASE")) +$ d_alwdeftype = f$extract(0, 1, f$edit(ans,"COLLAPSE,UPCASE")) $! $! Ask if they want to use perl's memory allocator $ echo "" @@ -1825,12 +1835,11 @@ $ echo "Perl has a built-in memory allocator that's tuned for perl's $ echo "normal memory usage. It's oftentimes better than the standard $ echo "system memory allocator. It also has the advantage of providing $ echo "memory allocation statistics, if you choose to enable them. -$ echo "" $ dflt = "n" $ rp = "Build with perl's memory allocator? [''dflt'] " $ GOSUB myread $ if ans.eqs."" then ans="''dflt'" -$ mymalloc = f$extract(0, 1, f$edit(ans,"TRIM,COMPRESS,UPCASE")) +$ mymalloc = f$extract(0, 1, f$edit(ans,"COLLAPSE,UPCASE")) $ if mymalloc.eqs."Y" $ THEN $ if use_debugging_perl.eqs."Y" @@ -1839,12 +1848,11 @@ $ echo "" $ echo "Perl can keep statistics on memory usage if you choose to use $ echo "them. This is useful for debugging, but does have some $ echo "performance overhead. -$ echo "" $ dflt = "n" $ rp = "Do you want the debugging memory allocator? [''dflt'] " $ gosub myread $ if ans.eqs."" then ans="''dflt'" -$ use_debugmalloc = f$extract(0, 1, f$edit(ans, "TRIM,COMPRESS,UPCASE")) +$ use_debugmalloc = f$extract(0, 1, f$edit(ans, "COLLAPSE,UPCASE")) $ ENDIF $ ! Check which memory allocator we want $ echo "" @@ -1855,7 +1863,6 @@ $ echo "larger allocations), and PACK_MALLOC (which is optimized to save $ echo "memory for smaller allocations). They're all good, but if your $ echo "usage tends towards larger chunks use TWO_POT, otherwise use $ echo "PACK_MALLOC." -$ echo "" $ dflt = "DEFAULT" $ rp = "Memory allocator (DEFAULT, TWO_POT, PACK_MALLOC) [''dflt'] " $ GOSUB myread @@ -1872,8 +1879,8 @@ $ echo "you might, for example, want to build GDBM_File instead of $ echo "SDBM_File if you have the GDBM library built on your machine $ echo " $ echo "Which modules do you want to build into perl?" -$! dflt = "Fcntl Errno IO Opcode Byteloader Devel::Peek Devel::DProf Data::Dumper attrs re VMS::Stdio VMS::DCLsym B SDBM_File" -$ dflt = "Fcntl Errno IO Opcode Devel::Peek Devel::DProf Data::Dumper attrs re VMS::Stdio VMS::DCLsym B SDBM_File" +$! dflt = "Fcntl Errno File::Glob IO Opcode Byteloader Devel::Peek Devel::DProf Data::Dumper attrs re VMS::Stdio VMS::DCLsym B SDBM_File" +$ dflt = "Fcntl Errno File::Glob IO Opcode Devel::Peek Devel::DProf Data::Dumper attrs re VMS::Stdio VMS::DCLsym B SDBM_File" $ if Using_Dec_C.eqs."Yes" $ THEN $ dflt = dflt + " POSIX" @@ -2028,10 +2035,17 @@ $ SET DEFAULT [-.vms] $ @subconfigure $ SET DEFAULT 'dflt $! -$! Warn of dangerous logical names +$! Warn of dangerous symbols or logical names $! -$Bad_logical: SUBROUTINE -$ IF f$trnlnm(p1) .nes. "" +$Bad_environment: SUBROUTINE +$ Bad_env = "" +$ IF p2 .eqs. "SYMBOL" +$ THEN +$ IF f$type('p1) .nes. "" THEN Bad_env := SYMBOL +$ ELSE +$ IF f$trnlnm(p1) .nes. "" THEN Bad_env := LOGICAL +$ ENDIF +$ IF Bad_env .eqs. "SYMBOL" .or. Bad_env .eqs. "LOGICAL" $ THEN $ IF f$search("config.msg") .nes. "" $ THEN @@ -2039,19 +2053,38 @@ $ OPEN/APPEND CONFIG config.msg $ ELSE $ OPEN/WRITE CONFIG config.msg $ ENDIF -$ WRITE CONFIG "Logical name ''p1' found in environment as " + f$trnlnm(p1) -$ WRITE CONFIG " deassign before building ''package'" +$ IF Bad_env .eqs. "SYMBOL" +$ THEN +$ WRITE CONFIG "" +$ WRITE CONFIG "Symbol name ''p1' found in environment as " + &p1 +$ WRITE CONFIG " delete before building ''package' via:" +$ WRITE CONFIG " $ DELETE/SYMBOL/GLOBAL ''p1'" +$ IF f$locate("""",&p1) .ge. f$length(&p1) +$ THEN +$ WRITE CONFIG " after building, testing, and installing ''package' +$ WRITE CONFIG " restore the symbol with:" +$ WRITE CONFIG " $ ''p1' == """ + &p1 + """" +$ ENDIF +$ ENDIF +$ IF Bad_env .eqs. "LOGICAL" +$ THEN +$ WRITE CONFIG "" +$ WRITE CONFIG "Logical name ''p1' found in environment as " + f$trnlnm(p1) +$ WRITE CONFIG " deassign before building ''package'" +$ ENDIF $ CLOSE CONFIG +$ Bad_env = "" $ ENDIF $ EXIT -$ ENDSUBROUTINE ! Bad_logical +$ ENDSUBROUTINE ! Bad_environment $ echo "" -$ echo4 "%Config-I-VMS, Checking for dangerous pre extant logical names." -$ CALL Bad_logical "TMP" -$ CALL Bad_logical "LIB" -$ CALL Bad_logical "T" -$ CALL Bad_logical "FOO" -$ CALL Bad_logical "EXT" +$ echo4 "%Config-I-VMS, Checking for dangerous pre extant global symbols and logical names." +$ CALL Bad_environment "TMP" +$ CALL Bad_environment "LIB" +$ CALL Bad_environment "T" +$ CALL Bad_environment "FOO" +$ CALL Bad_environment "EXT" +$ CALL Bad_environment "TEST" "SYMBOL" $ IF f$search("config.msg") .eqs. "" THEN echo "OK." $! $! %Config-I-VMS, write perl_setup.com here @@ -96,19 +96,27 @@ struct block_sub { (void)SvREFCNT_inc(cx->blk_sub.dfoutgv) #ifdef USE_THREADS -#define POPSAVEARRAY() NOOP +# define POP_SAVEARRAY() NOOP #else -#define POPSAVEARRAY() \ +# define POP_SAVEARRAY() \ STMT_START { \ SvREFCNT_dec(GvAV(PL_defgv)); \ GvAV(PL_defgv) = cx->blk_sub.savearray; \ } STMT_END #endif /* USE_THREADS */ +#ifdef USE_ITHREADS + /* junk in @_ spells trouble when cloning CVs, so don't leave any */ +# define CLEAR_ARGARRAY() av_clear(cx->blk_sub.argarray) +#else +# define CLEAR_ARGARRAY() NOOP +#endif /* USE_ITHREADS */ + + #define POPSUB(cx,sv) \ STMT_START { \ if (cx->blk_sub.hasargs) { \ - POPSAVEARRAY(); \ + POP_SAVEARRAY(); \ /* abandon @_ if it got reified */ \ if (AvREAL(cx->blk_sub.argarray)) { \ SSize_t fill = AvFILLp(cx->blk_sub.argarray); \ @@ -118,6 +126,9 @@ struct block_sub { AvFLAGS(cx->blk_sub.argarray) = AVf_REIFY; \ PL_curpad[0] = (SV*)cx->blk_sub.argarray; \ } \ + else { \ + CLEAR_ARGARRAY(); \ + } \ } \ sv = (SV*)cx->blk_sub.cv; \ if (sv && (CvDEPTH((CV*)sv) = cx->blk_sub.olddepth)) \ @@ -146,14 +157,15 @@ struct block_eval { #define PUSHEVAL(cx,n,fgv) \ cx->blk_eval.old_in_eval = PL_in_eval; \ cx->blk_eval.old_op_type = PL_op->op_type; \ - cx->blk_eval.old_name = n; \ + cx->blk_eval.old_name = (n ? savepv(n) : Nullch); \ cx->blk_eval.old_eval_root = PL_eval_root; \ cx->blk_eval.cur_text = PL_linestr; #define POPEVAL(cx) \ PL_in_eval = cx->blk_eval.old_in_eval; \ optype = cx->blk_eval.old_op_type; \ - PL_eval_root = cx->blk_eval.old_eval_root; + PL_eval_root = cx->blk_eval.old_eval_root; \ + Safefree(cx->blk_eval.old_name); /* loop context */ struct block_loop { @@ -162,7 +174,11 @@ struct block_loop { OP * redo_op; OP * next_op; OP * last_op; +#ifdef USE_ITHREADS + void * iterdata; +#else SV ** itervar; +#endif SV * itersave; SV * iterlval; AV * iterary; @@ -170,23 +186,40 @@ struct block_loop { IV itermax; }; -#define PUSHLOOP(cx, ivar, s) \ +#ifdef USE_ITHREADS +# define CxITERVAR(c) \ + ((c)->blk_loop.iterdata \ + ? (CxPADLOOP(cx) \ + ? &PL_curpad[(PADOFFSET)(c)->blk_loop.iterdata] \ + : &GvSV((GV*)(c)->blk_loop.iterdata)) \ + : (SV**)NULL) +# define CX_ITERDATA_SET(cx,idata) \ + if (cx->blk_loop.iterdata = (idata)) \ + cx->blk_loop.itersave = SvREFCNT_inc(*CxITERVAR(cx)); +#else +# define CxITERVAR(c) ((c)->blk_loop.itervar) +# define CX_ITERDATA_SET(cx,ivar) \ + if (cx->blk_loop.itervar = (SV**)(ivar)) \ + cx->blk_loop.itersave = SvREFCNT_inc(*CxITERVAR(cx)); +#endif + +#define PUSHLOOP(cx, dat, s) \ cx->blk_loop.label = PL_curcop->cop_label; \ cx->blk_loop.resetsp = s - PL_stack_base; \ cx->blk_loop.redo_op = cLOOP->op_redoop; \ cx->blk_loop.next_op = cLOOP->op_nextop; \ cx->blk_loop.last_op = cLOOP->op_lastop; \ - if (cx->blk_loop.itervar = (ivar)) \ - cx->blk_loop.itersave = SvREFCNT_inc(*cx->blk_loop.itervar);\ cx->blk_loop.iterlval = Nullsv; \ cx->blk_loop.iterary = Nullav; \ - cx->blk_loop.iterix = -1; + cx->blk_loop.iterix = -1; \ + CX_ITERDATA_SET(cx,dat); #define POPLOOP(cx) \ SvREFCNT_dec(cx->blk_loop.iterlval); \ - if (cx->blk_loop.itervar) { \ - sv_2mortal(*(cx->blk_loop.itervar)); \ - *(cx->blk_loop.itervar) = cx->blk_loop.itersave; \ + if (CxITERVAR(cx)) { \ + SV **s_v_p = CxITERVAR(cx); \ + sv_2mortal(*s_v_p); \ + *s_v_p = cx->blk_loop.itersave; \ } \ if (cx->blk_loop.iterary && cx->blk_loop.iterary != PL_curstack)\ SvREFCNT_dec(cx->blk_loop.iterary); @@ -319,12 +352,23 @@ struct context { #define CXt_LOOP 3 #define CXt_SUBST 4 #define CXt_BLOCK 5 +#define CXt_FORMAT 6 /* private flags for CXt_EVAL */ #define CXp_REAL 0x00000100 /* truly eval'', not a lookalike */ +#ifdef USE_ITHREADS +/* private flags for CXt_LOOP */ +# define CXp_PADVAR 0x00000100 /* itervar lives on pad, iterdata + has pad offset; if not set, + iterdata holds GV* */ +# define CxPADLOOP(c) (((c)->cx_type & (CXt_LOOP|CXp_PADVAR)) \ + == (CXt_LOOP|CXp_PADVAR)) +#endif + #define CxTYPE(c) ((c)->cx_type & CXTYPEMASK) -#define CxREALEVAL(c) (((c)->cx_type & (CXt_EVAL|CXp_REAL)) == (CXt_EVAL|CXp_REAL)) +#define CxREALEVAL(c) (((c)->cx_type & (CXt_EVAL|CXp_REAL)) \ + == (CXt_EVAL|CXp_REAL)) #define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc())) diff --git a/cygwin/Makefile.SHs b/cygwin/Makefile.SHs index 4a3790768d..d466bdea52 100644 --- a/cygwin/Makefile.SHs +++ b/cygwin/Makefile.SHs @@ -124,9 +124,9 @@ $(LIBPERL)$(LIB_EXT): $& perl$(OBJ_EXT) $(cwobj) ld2 # build problems but that's not obvious to the novice. # The Module used here must not depend on Config or any extensions. -miniperl: $& miniperlmain$(OBJ_EXT) $(LIBPERL)s$(LIB_EXT) - $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) $(LLIBPERL)s $(libs) - $(LDLIBPTH) ./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest +miniperl: $& miniperlmain$(OBJ_EXT) $(LIBPERL)s$(LIB_EXT) opmini$(OBJ_EXT) + $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) $(LLIBPERL)s $(libs) + $(LDLIBPTH) ./miniperl -w -Ilib -MExporter -e '<?>' || $(MAKE) minitest !NO!SUBS! ;; @@ -146,9 +146,9 @@ $(LIBPERL)$(LIB_EXT): $& perl$(OBJ_EXT) $(cwobj) # build problems but that's not obvious to the novice. # The Module used here must not depend on Config or any extensions. -miniperl: $& miniperlmain$(OBJ_EXT) $(LIBPERL)$(LIB_EXT) - $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) $(LLIBPERL) $(libs) - $(LDLIBPTH) ./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest +miniperl: $& miniperlmain$(OBJ_EXT) $(LIBPERL)$(LIB_EXT) opmini$(OBJ_EXT) + $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) $(LLIBPERL) $(libs) + $(LDLIBPTH) ./miniperl -w -Ilib -MExporter -e '<?>' || $(MAKE) minitest !NO!SUBS! ;; @@ -159,6 +159,9 @@ esac # $spitshell >>Makefile <<'!NO!SUBS!' +opmini$(OBJ_EXT) : op.c + $(CCCMD) $(PLDLFLAGS) -DPERL_EXTERNAL_GLOB -o opmini$(OBJ_EXT) op.c + perl: $& perlmain$(OBJ_EXT) $(LIBPERL)$(LIB_EXT) $(DYNALOADER) $(static_ext) ext.libs $(SHRPENV) $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) @@ -183,28 +183,29 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } } else { - char *myname; - char *type = name; - char *otype = name; + char *type; + char *oname = name; STRLEN tlen; - STRLEN otlen = len; + STRLEN olen = len; char mode[3]; /* stdio file mode ("r\0" or "r+\0") */ int dodup; + type = savepvn(name, len); + tlen = len; + SAVEFREEPV(type); if (num_svs) { - type = name; - name = SvPV(svs, tlen) ; - len = (I32)tlen; + STRLEN l; + name = SvPV(svs, l) ; + len = (I32)l; + name = savepvn(name, len); + SAVEFREEPV(name); } - - tlen = otlen; - myname = savepvn(name, len); - SAVEFREEPV(myname); - name = myname; - if (!num_svs) + else { while (tlen && isSPACE(type[tlen-1])) type[--tlen] = '\0'; - + name = type; + len = tlen; + } mode[0] = mode[1] = mode[2] = '\0'; IoTYPE(io) = *type; if (*type == '+' && tlen > 1 && type[tlen-1] != '|') { /* scary */ @@ -216,12 +217,14 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (*type == '|') { if (num_svs && (tlen != 2 || type[1] != '-')) { unknown_desr: - Perl_croak(aTHX_ "Unknown open() mode '%.*s'", otlen, otype); + Perl_croak(aTHX_ "Unknown open() mode '%.*s'", olen, oname); } /*SUPPRESS 530*/ - for (type++; isSPACE(*type); type++) ; - if (!num_svs) + for (type++, tlen--; isSPACE(*type); type++, tlen--) ; + if (!num_svs) { name = type; + len = tlen; + } if (*name == '\0') { /* command is missing 19990114 */ dTHR; if (ckWARN(WARN_PIPE)) @@ -232,11 +235,11 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (strNE(name,"-") || num_svs) TAINT_ENV(); TAINT_PROPER("piped open"); - if (name[strlen(name)-1] == '|') { + if (name[len-1] == '|') { dTHR; - name[strlen(name)-1] = '\0' ; + name[--len] = '\0' ; if (ckWARN(WARN_PIPE)) - Perl_warner(aTHX_ WARN_PIPE, "Can't do bidirectional pipe"); + Perl_warner(aTHX_ WARN_PIPE, "Can't open bidirectional pipe"); } fp = PerlProc_popen(name,"w"); writing = 1; @@ -308,7 +311,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (!(fp = PerlIO_fdopen(fd,mode))) { if (dodup) PerlLIO_close(fd); - } + } } } else { @@ -452,6 +455,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } #endif IoIFP(io) = fp; + IoFLAGS(io) &= ~IOf_NOLINE; if (writing) { dTHR; if (IoTYPE(io) == 's' @@ -660,9 +664,9 @@ Perl_nextargv(pTHX_ register GV *gv) if (!S_ISREG(PL_statbuf.st_mode)) Perl_warner(aTHX_ WARN_INPLACE, "Can't do inplace edit: %s is not a regular file", - PL_oldname ); + PL_oldname); else - Perl_warner(aTHX_ WARN_INPLACE, "Can't open %s: %s\n", + Perl_warner(aTHX_ WARN_INPLACE, "Can't open %s: %s", PL_oldname, Strerror(errno)); } } @@ -1026,7 +1030,7 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) { dTHR; if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } return TRUE; case SVt_IV: @@ -1064,7 +1068,7 @@ Perl_my_stat(pTHX) if (PL_op->op_flags & OPf_REF) { EXTEND(SP,1); - tmpgv = cGVOP; + tmpgv = cGVOP_gv; do_fstat: io = GvIO(tmpgv); if (io && IoIFP(io)) { @@ -1117,7 +1121,7 @@ Perl_my_lstat(pTHX) STRLEN n_a; if (PL_op->op_flags & OPf_REF) { EXTEND(SP,1); - if (cGVOP == PL_defgv) { + if (cGVOP_gv == PL_defgv) { if (PL_laststype != OP_LSTAT) Perl_croak(aTHX_ "The stat preceding -l _ wasn't an lstat"); return PL_laststatval; @@ -19,6 +19,7 @@ # ifdef USE_THREADS # define OLD_PTHREADS_API # endif +# define PERL_FS_VER_FMT "%d_%d_%d" #else /* DJGPP */ # ifdef WIN32 # define PERL_SYS_INIT(c,v) Perl_win32_init(c,v) @@ -531,6 +531,8 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) #endif break; case OP_CONST: + Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv)); + break; case OP_METHOD_NAMED: Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo->op_sv)); break; @@ -45,19 +45,37 @@ #if !defined(PERL_OBJECT) #if !defined(PERL_IMPLICIT_CONTEXT) +#if defined(PERL_IMPLICIT_SYS) +#else +#endif +#if defined(USE_ITHREADS) +# if defined(PERL_IMPLICIT_SYS) +# endif +#endif +#if defined(MYMALLOC) +#define malloced_size Perl_malloced_size +#endif #if defined(PERL_OBJECT) +#ifndef __BORLANDC__ +#endif +#endif +#if defined(PERL_OBJECT) +#else #endif #define amagic_call Perl_amagic_call #define Gv_AMupdate Perl_Gv_AMupdate #define append_elem Perl_append_elem #define append_list Perl_append_list #define apply Perl_apply +#define avhv_delete_ent Perl_avhv_delete_ent #define avhv_exists_ent Perl_avhv_exists_ent #define avhv_fetch_ent Perl_avhv_fetch_ent #define avhv_iternext Perl_avhv_iternext #define avhv_iterval Perl_avhv_iterval #define avhv_keys Perl_avhv_keys #define av_clear Perl_av_clear +#define av_delete Perl_av_delete +#define av_exists Perl_av_exists #define av_extend Perl_av_extend #define av_fake Perl_av_fake #define av_fetch Perl_av_fetch @@ -355,9 +373,6 @@ #define magic_sizepack Perl_magic_sizepack #define magic_wipepack Perl_magic_wipepack #define magicname Perl_magicname -#if defined(MYMALLOC) -#define malloced_size Perl_malloced_size -#endif #define markstack_grow Perl_markstack_grow #if defined(USE_LOCALE_COLLATE) #define mem_collxfrm Perl_mem_collxfrm @@ -473,11 +488,10 @@ #define pad_swipe Perl_pad_swipe #define peep Perl_peep #if defined(PERL_OBJECT) -#else +#endif #if defined(USE_THREADS) #define new_struct_thread Perl_new_struct_thread #endif -#endif #define call_atexit Perl_call_atexit #define call_argv Perl_call_argv #define call_method Perl_call_method @@ -552,6 +566,7 @@ #define save_hptr Perl_save_hptr #define save_I16 Perl_save_I16 #define save_I32 Perl_save_I32 +#define save_I8 Perl_save_I8 #define save_int Perl_save_int #define save_item Perl_save_item #define save_iv Perl_save_iv @@ -561,6 +576,7 @@ #define save_op Perl_save_op #define save_scalar Perl_save_scalar #define save_pptr Perl_save_pptr +#define save_vptr Perl_save_vptr #define save_re_context Perl_save_re_context #define save_sptr Perl_save_sptr #define save_svref Perl_save_svref @@ -593,11 +609,15 @@ #define sv_2mortal Perl_sv_2mortal #define sv_2nv Perl_sv_2nv #define sv_2pv Perl_sv_2pv +#define sv_2pvutf8 Perl_sv_2pvutf8 +#define sv_2pvbyte Perl_sv_2pvbyte #define sv_2uv Perl_sv_2uv #define sv_iv Perl_sv_iv #define sv_uv Perl_sv_uv #define sv_nv Perl_sv_nv #define sv_pvn Perl_sv_pvn +#define sv_pvutf8n Perl_sv_pvutf8n +#define sv_pvbyten Perl_sv_pvbyten #define sv_true Perl_sv_true #define sv_add_arena Perl_sv_add_arena #define sv_backoff Perl_sv_backoff @@ -639,6 +659,8 @@ #define sv_pos_u2b Perl_sv_pos_u2b #define sv_pos_b2u Perl_sv_pos_b2u #define sv_pvn_force Perl_sv_pvn_force +#define sv_pvutf8n_force Perl_sv_pvutf8n_force +#define sv_pvbyten_force Perl_sv_pvbyten_force #define sv_reftype Perl_sv_reftype #define sv_replace Perl_sv_replace #define sv_report_used Perl_sv_report_used @@ -690,6 +712,7 @@ #define vivify_defelem Perl_vivify_defelem #define vivify_ref Perl_vivify_ref #define wait4pid Perl_wait4pid +#define report_uninit Perl_report_uninit #define warn Perl_warn #define vwarn Perl_vwarn #define warner Perl_warner @@ -753,7 +776,11 @@ #define vdefault_protect Perl_vdefault_protect #define reginitcolors Perl_reginitcolors #define sv_2pv_nolen Perl_sv_2pv_nolen +#define sv_2pvutf8_nolen Perl_sv_2pvutf8_nolen +#define sv_2pvbyte_nolen Perl_sv_2pvbyte_nolen #define sv_pv Perl_sv_pv +#define sv_pvutf8 Perl_sv_pvutf8 +#define sv_pvbyte Perl_sv_pvbyte #define sv_force_normal Perl_sv_force_normal #define tmps_grow Perl_tmps_grow #define sv_rvweaken Perl_sv_rvweaken @@ -767,6 +794,7 @@ #define cx_dup Perl_cx_dup #define si_dup Perl_si_dup #define ss_dup Perl_ss_dup +#define any_dup Perl_any_dup #define he_dup Perl_he_dup #define re_dup Perl_re_dup #define fp_dup Perl_fp_dup @@ -783,6 +811,7 @@ #define ptr_table_split Perl_ptr_table_split #endif #if defined(PERL_OBJECT) +#else #endif #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) #define avhv_index_sv S_avhv_index_sv @@ -924,7 +953,14 @@ #define regwhite S_regwhite #define nextchar S_nextchar #define dumpuntil S_dumpuntil +#define put_byte S_put_byte #define scan_commit S_scan_commit +#define cl_anything S_cl_anything +#define cl_is_anything S_cl_is_anything +#define cl_init S_cl_init +#define cl_init_zero S_cl_init_zero +#define cl_and S_cl_and +#define cl_or S_cl_or #define study_chunk S_study_chunk #define add_data S_add_data #define re_croak2 S_re_croak2 @@ -1046,8 +1082,8 @@ # if defined(CRIPPLED_CC) #define uni S_uni # endif -# if defined(WIN32) -#define win32_textfilter S_win32_textfilter +# if defined(PERL_CR_FILTER) +#define cr_textfilter S_cr_textfilter # endif #endif #if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT) @@ -1059,6 +1095,8 @@ #define xstat S_xstat # endif #endif +#if defined(PERL_OBJECT) +#endif #define ck_anoncode Perl_ck_anoncode #define ck_bitop Perl_ck_bitop #define ck_concat Perl_ck_concat @@ -1445,19 +1483,37 @@ #else /* PERL_IMPLICIT_CONTEXT */ +#if defined(PERL_IMPLICIT_SYS) +#else +#endif +#if defined(USE_ITHREADS) +# if defined(PERL_IMPLICIT_SYS) +# endif +#endif +#if defined(MYMALLOC) +#define malloced_size Perl_malloced_size +#endif #if defined(PERL_OBJECT) +#ifndef __BORLANDC__ +#endif +#endif +#if defined(PERL_OBJECT) +#else #endif #define amagic_call(a,b,c,d) Perl_amagic_call(aTHX_ a,b,c,d) #define Gv_AMupdate(a) Perl_Gv_AMupdate(aTHX_ a) #define append_elem(a,b,c) Perl_append_elem(aTHX_ a,b,c) #define append_list(a,b,c) Perl_append_list(aTHX_ a,b,c) #define apply(a,b,c) Perl_apply(aTHX_ a,b,c) +#define avhv_delete_ent(a,b,c,d) Perl_avhv_delete_ent(aTHX_ a,b,c,d) #define avhv_exists_ent(a,b,c) Perl_avhv_exists_ent(aTHX_ a,b,c) #define avhv_fetch_ent(a,b,c,d) Perl_avhv_fetch_ent(aTHX_ a,b,c,d) #define avhv_iternext(a) Perl_avhv_iternext(aTHX_ a) #define avhv_iterval(a,b) Perl_avhv_iterval(aTHX_ a,b) #define avhv_keys(a) Perl_avhv_keys(aTHX_ a) #define av_clear(a) Perl_av_clear(aTHX_ a) +#define av_delete(a,b,c) Perl_av_delete(aTHX_ a,b,c) +#define av_exists(a,b) Perl_av_exists(aTHX_ a,b) #define av_extend(a,b) Perl_av_extend(aTHX_ a,b) #define av_fake(a,b) Perl_av_fake(aTHX_ a,b) #define av_fetch(a,b,c) Perl_av_fetch(aTHX_ a,b,c) @@ -1738,9 +1794,6 @@ #define magic_sizepack(a,b) Perl_magic_sizepack(aTHX_ a,b) #define magic_wipepack(a,b) Perl_magic_wipepack(aTHX_ a,b) #define magicname(a,b,c) Perl_magicname(aTHX_ a,b,c) -#if defined(MYMALLOC) -#define malloced_size Perl_malloced_size -#endif #define markstack_grow() Perl_markstack_grow(aTHX) #if defined(USE_LOCALE_COLLATE) #define mem_collxfrm(a,b,c) Perl_mem_collxfrm(aTHX_ a,b,c) @@ -1761,20 +1814,20 @@ #define my(a) Perl_my(aTHX_ a) #define my_atof(a) Perl_my_atof(aTHX_ a) #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY) -#define my_bcopy(a,b,c) Perl_my_bcopy(aTHX_ a,b,c) +#define my_bcopy Perl_my_bcopy #endif #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) -#define my_bzero(a,b) Perl_my_bzero(aTHX_ a,b) +#define my_bzero Perl_my_bzero #endif #define my_exit(a) Perl_my_exit(aTHX_ a) #define my_failure_exit() Perl_my_failure_exit(aTHX) #define my_fflush_all() Perl_my_fflush_all(aTHX) #define my_lstat() Perl_my_lstat(aTHX) #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) -#define my_memcmp(a,b,c) Perl_my_memcmp(aTHX_ a,b,c) +#define my_memcmp Perl_my_memcmp #endif #if !defined(HAS_MEMSET) -#define my_memset(a,b,c) Perl_my_memset(aTHX_ a,b,c) +#define my_memset Perl_my_memset #endif #if !defined(PERL_OBJECT) #define my_pclose(a) Perl_my_pclose(aTHX_ a) @@ -1854,11 +1907,10 @@ #define pad_swipe(a) Perl_pad_swipe(aTHX_ a) #define peep(a) Perl_peep(aTHX_ a) #if defined(PERL_OBJECT) -#else +#endif #if defined(USE_THREADS) #define new_struct_thread(a) Perl_new_struct_thread(aTHX_ a) #endif -#endif #define call_atexit(a,b) Perl_call_atexit(aTHX_ a,b) #define call_argv(a,b,c) Perl_call_argv(aTHX_ a,b,c) #define call_method(a,b) Perl_call_method(aTHX_ a,b) @@ -1933,6 +1985,7 @@ #define save_hptr(a) Perl_save_hptr(aTHX_ a) #define save_I16(a) Perl_save_I16(aTHX_ a) #define save_I32(a) Perl_save_I32(aTHX_ a) +#define save_I8(a) Perl_save_I8(aTHX_ a) #define save_int(a) Perl_save_int(aTHX_ a) #define save_item(a) Perl_save_item(aTHX_ a) #define save_iv(a) Perl_save_iv(aTHX_ a) @@ -1942,6 +1995,7 @@ #define save_op() Perl_save_op(aTHX) #define save_scalar(a) Perl_save_scalar(aTHX_ a) #define save_pptr(a) Perl_save_pptr(aTHX_ a) +#define save_vptr(a) Perl_save_vptr(aTHX_ a) #define save_re_context() Perl_save_re_context(aTHX) #define save_sptr(a) Perl_save_sptr(aTHX_ a) #define save_svref(a) Perl_save_svref(aTHX_ a) @@ -1974,11 +2028,15 @@ #define sv_2mortal(a) Perl_sv_2mortal(aTHX_ a) #define sv_2nv(a) Perl_sv_2nv(aTHX_ a) #define sv_2pv(a,b) Perl_sv_2pv(aTHX_ a,b) +#define sv_2pvutf8(a,b) Perl_sv_2pvutf8(aTHX_ a,b) +#define sv_2pvbyte(a,b) Perl_sv_2pvbyte(aTHX_ a,b) #define sv_2uv(a) Perl_sv_2uv(aTHX_ a) #define sv_iv(a) Perl_sv_iv(aTHX_ a) #define sv_uv(a) Perl_sv_uv(aTHX_ a) #define sv_nv(a) Perl_sv_nv(aTHX_ a) #define sv_pvn(a,b) Perl_sv_pvn(aTHX_ a,b) +#define sv_pvutf8n(a,b) Perl_sv_pvutf8n(aTHX_ a,b) +#define sv_pvbyten(a,b) Perl_sv_pvbyten(aTHX_ a,b) #define sv_true(a) Perl_sv_true(aTHX_ a) #define sv_add_arena(a,b,c) Perl_sv_add_arena(aTHX_ a,b,c) #define sv_backoff(a) Perl_sv_backoff(aTHX_ a) @@ -2019,6 +2077,8 @@ #define sv_pos_u2b(a,b,c) Perl_sv_pos_u2b(aTHX_ a,b,c) #define sv_pos_b2u(a,b) Perl_sv_pos_b2u(aTHX_ a,b) #define sv_pvn_force(a,b) Perl_sv_pvn_force(aTHX_ a,b) +#define sv_pvutf8n_force(a,b) Perl_sv_pvutf8n_force(aTHX_ a,b) +#define sv_pvbyten_force(a,b) Perl_sv_pvbyten_force(aTHX_ a,b) #define sv_reftype(a,b) Perl_sv_reftype(aTHX_ a,b) #define sv_replace(a,b) Perl_sv_replace(aTHX_ a,b) #define sv_report_used() Perl_sv_report_used(aTHX) @@ -2069,6 +2129,7 @@ #define vivify_defelem(a) Perl_vivify_defelem(aTHX_ a) #define vivify_ref(a,b) Perl_vivify_ref(aTHX_ a,b) #define wait4pid(a,b,c) Perl_wait4pid(aTHX_ a,b,c) +#define report_uninit() Perl_report_uninit(aTHX) #define vwarn(a,b) Perl_vwarn(aTHX_ a,b) #define vwarner(a,b,c) Perl_vwarner(aTHX_ a,b,c) #define watch(a) Perl_watch(aTHX_ a) @@ -2126,7 +2187,11 @@ #define vdefault_protect(a,b,c,d) Perl_vdefault_protect(aTHX_ a,b,c,d) #define reginitcolors() Perl_reginitcolors(aTHX) #define sv_2pv_nolen(a) Perl_sv_2pv_nolen(aTHX_ a) +#define sv_2pvutf8_nolen(a) Perl_sv_2pvutf8_nolen(aTHX_ a) +#define sv_2pvbyte_nolen(a) Perl_sv_2pvbyte_nolen(aTHX_ a) #define sv_pv(a) Perl_sv_pv(aTHX_ a) +#define sv_pvutf8(a) Perl_sv_pvutf8(aTHX_ a) +#define sv_pvbyte(a) Perl_sv_pvbyte(aTHX_ a) #define sv_force_normal(a) Perl_sv_force_normal(aTHX_ a) #define tmps_grow(a) Perl_tmps_grow(aTHX_ a) #define sv_rvweaken(a) Perl_sv_rvweaken(aTHX_ a) @@ -2139,7 +2204,8 @@ #if defined(USE_ITHREADS) #define cx_dup(a,b,c) Perl_cx_dup(aTHX_ a,b,c) #define si_dup(a) Perl_si_dup(aTHX_ a) -#define ss_dup(a,b,c) Perl_ss_dup(aTHX_ a,b,c) +#define ss_dup(a) Perl_ss_dup(aTHX_ a) +#define any_dup(a,b) Perl_any_dup(aTHX_ a,b) #define he_dup(a,b) Perl_he_dup(aTHX_ a,b) #define re_dup(a) Perl_re_dup(aTHX_ a) #define fp_dup(a,b) Perl_fp_dup(aTHX_ a,b) @@ -2156,6 +2222,7 @@ #define ptr_table_split(a) Perl_ptr_table_split(aTHX_ a) #endif #if defined(PERL_OBJECT) +#else #endif #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) #define avhv_index_sv(a) S_avhv_index_sv(aTHX_ a) @@ -2297,7 +2364,14 @@ #define regwhite(a,b) S_regwhite(aTHX_ a,b) #define nextchar() S_nextchar(aTHX) #define dumpuntil(a,b,c,d,e) S_dumpuntil(aTHX_ a,b,c,d,e) +#define put_byte(a,b) S_put_byte(aTHX_ a,b) #define scan_commit(a) S_scan_commit(aTHX_ a) +#define cl_anything(a) S_cl_anything(aTHX_ a) +#define cl_is_anything(a) S_cl_is_anything(aTHX_ a) +#define cl_init(a) S_cl_init(aTHX_ a) +#define cl_init_zero(a) S_cl_init_zero(aTHX_ a) +#define cl_and(a,b) S_cl_and(aTHX_ a,b) +#define cl_or(a,b) S_cl_or(aTHX_ a,b) #define study_chunk(a,b,c,d,e) S_study_chunk(aTHX_ a,b,c,d,e) #define add_data(a,b) S_add_data(aTHX_ a,b) #define regpposixcc(a) S_regpposixcc(aTHX_ a) @@ -2418,8 +2492,8 @@ # if defined(CRIPPLED_CC) #define uni(a,b) S_uni(aTHX_ a,b) # endif -# if defined(WIN32) -#define win32_textfilter(a,b,c) S_win32_textfilter(aTHX_ a,b,c) +# if defined(PERL_CR_FILTER) +#define cr_textfilter(a,b,c) S_cr_textfilter(aTHX_ a,b,c) # endif #endif #if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT) @@ -2431,6 +2505,8 @@ #define xstat(a) S_xstat(aTHX_ a) # endif #endif +#if defined(PERL_OBJECT) +#endif #define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a) #define ck_bitop(a) Perl_ck_bitop(aTHX_ a) #define ck_concat(a) Perl_ck_concat(aTHX_ a) @@ -2818,7 +2894,26 @@ #endif /* PERL_IMPLICIT_CONTEXT */ #else /* PERL_OBJECT */ +#if defined(PERL_IMPLICIT_SYS) +#else +#endif +#if defined(USE_ITHREADS) +# if defined(PERL_IMPLICIT_SYS) +# endif +#endif +#if defined(MYMALLOC) +#define malloc Perl_malloc +#define calloc Perl_calloc +#define realloc Perl_realloc +#define mfree Perl_mfree +#define malloced_size Perl_malloced_size +#endif #if defined(PERL_OBJECT) +#ifndef __BORLANDC__ +#endif +#endif +#if defined(PERL_OBJECT) +#else #endif #define Perl_amagic_call CPerlObj::Perl_amagic_call #define amagic_call Perl_amagic_call @@ -2830,6 +2925,8 @@ #define append_list Perl_append_list #define Perl_apply CPerlObj::Perl_apply #define apply Perl_apply +#define Perl_avhv_delete_ent CPerlObj::Perl_avhv_delete_ent +#define avhv_delete_ent Perl_avhv_delete_ent #define Perl_avhv_exists_ent CPerlObj::Perl_avhv_exists_ent #define avhv_exists_ent Perl_avhv_exists_ent #define Perl_avhv_fetch_ent CPerlObj::Perl_avhv_fetch_ent @@ -2842,6 +2939,10 @@ #define avhv_keys Perl_avhv_keys #define Perl_av_clear CPerlObj::Perl_av_clear #define av_clear Perl_av_clear +#define Perl_av_delete CPerlObj::Perl_av_delete +#define av_delete Perl_av_delete +#define Perl_av_exists CPerlObj::Perl_av_exists +#define av_exists Perl_av_exists #define Perl_av_extend CPerlObj::Perl_av_extend #define av_extend Perl_av_extend #define Perl_av_fake CPerlObj::Perl_av_fake @@ -3416,10 +3517,6 @@ #define magic_wipepack Perl_magic_wipepack #define Perl_magicname CPerlObj::Perl_magicname #define magicname Perl_magicname -#if defined(MYMALLOC) -#define Perl_malloced_size CPerlObj::Perl_malloced_size -#define malloced_size Perl_malloced_size -#endif #define Perl_markstack_grow CPerlObj::Perl_markstack_grow #define markstack_grow Perl_markstack_grow #if defined(USE_LOCALE_COLLATE) @@ -3635,23 +3732,16 @@ #define Perl_peep CPerlObj::Perl_peep #define peep Perl_peep #if defined(PERL_OBJECT) -#define perl_construct CPerlObj::perl_construct -#define perl_destruct CPerlObj::perl_destruct -#define perl_free CPerlObj::perl_free -#define perl_run CPerlObj::perl_run -#define perl_parse CPerlObj::perl_parse -#else -#define perl_alloc CPerlObj::perl_alloc -#define perl_construct CPerlObj::perl_construct -#define perl_destruct CPerlObj::perl_destruct -#define perl_free CPerlObj::perl_free -#define perl_run CPerlObj::perl_run -#define perl_parse CPerlObj::perl_parse +#define Perl_construct CPerlObj::Perl_construct +#define Perl_destruct CPerlObj::Perl_destruct +#define Perl_free CPerlObj::Perl_free +#define Perl_run CPerlObj::Perl_run +#define Perl_parse CPerlObj::Perl_parse +#endif #if defined(USE_THREADS) #define Perl_new_struct_thread CPerlObj::Perl_new_struct_thread #define new_struct_thread Perl_new_struct_thread #endif -#endif #define Perl_call_atexit CPerlObj::Perl_call_atexit #define call_atexit Perl_call_atexit #define Perl_call_argv CPerlObj::Perl_call_argv @@ -3798,6 +3888,8 @@ #define save_I16 Perl_save_I16 #define Perl_save_I32 CPerlObj::Perl_save_I32 #define save_I32 Perl_save_I32 +#define Perl_save_I8 CPerlObj::Perl_save_I8 +#define save_I8 Perl_save_I8 #define Perl_save_int CPerlObj::Perl_save_int #define save_int Perl_save_int #define Perl_save_item CPerlObj::Perl_save_item @@ -3816,6 +3908,8 @@ #define save_scalar Perl_save_scalar #define Perl_save_pptr CPerlObj::Perl_save_pptr #define save_pptr Perl_save_pptr +#define Perl_save_vptr CPerlObj::Perl_save_vptr +#define save_vptr Perl_save_vptr #define Perl_save_re_context CPerlObj::Perl_save_re_context #define save_re_context Perl_save_re_context #define Perl_save_sptr CPerlObj::Perl_save_sptr @@ -3878,6 +3972,10 @@ #define sv_2nv Perl_sv_2nv #define Perl_sv_2pv CPerlObj::Perl_sv_2pv #define sv_2pv Perl_sv_2pv +#define Perl_sv_2pvutf8 CPerlObj::Perl_sv_2pvutf8 +#define sv_2pvutf8 Perl_sv_2pvutf8 +#define Perl_sv_2pvbyte CPerlObj::Perl_sv_2pvbyte +#define sv_2pvbyte Perl_sv_2pvbyte #define Perl_sv_2uv CPerlObj::Perl_sv_2uv #define sv_2uv Perl_sv_2uv #define Perl_sv_iv CPerlObj::Perl_sv_iv @@ -3888,6 +3986,10 @@ #define sv_nv Perl_sv_nv #define Perl_sv_pvn CPerlObj::Perl_sv_pvn #define sv_pvn Perl_sv_pvn +#define Perl_sv_pvutf8n CPerlObj::Perl_sv_pvutf8n +#define sv_pvutf8n Perl_sv_pvutf8n +#define Perl_sv_pvbyten CPerlObj::Perl_sv_pvbyten +#define sv_pvbyten Perl_sv_pvbyten #define Perl_sv_true CPerlObj::Perl_sv_true #define sv_true Perl_sv_true #define Perl_sv_add_arena CPerlObj::Perl_sv_add_arena @@ -3968,6 +4070,10 @@ #define sv_pos_b2u Perl_sv_pos_b2u #define Perl_sv_pvn_force CPerlObj::Perl_sv_pvn_force #define sv_pvn_force Perl_sv_pvn_force +#define Perl_sv_pvutf8n_force CPerlObj::Perl_sv_pvutf8n_force +#define sv_pvutf8n_force Perl_sv_pvutf8n_force +#define Perl_sv_pvbyten_force CPerlObj::Perl_sv_pvbyten_force +#define sv_pvbyten_force Perl_sv_pvbyten_force #define Perl_sv_reftype CPerlObj::Perl_sv_reftype #define sv_reftype Perl_sv_reftype #define Perl_sv_replace CPerlObj::Perl_sv_replace @@ -4066,6 +4172,8 @@ #define vivify_ref Perl_vivify_ref #define Perl_wait4pid CPerlObj::Perl_wait4pid #define wait4pid Perl_wait4pid +#define Perl_report_uninit CPerlObj::Perl_report_uninit +#define report_uninit Perl_report_uninit #define Perl_warn CPerlObj::Perl_warn #define warn Perl_warn #define Perl_vwarn CPerlObj::Perl_vwarn @@ -4094,14 +4202,6 @@ #if defined(MYMALLOC) #define Perl_dump_mstats CPerlObj::Perl_dump_mstats #define dump_mstats Perl_dump_mstats -#define Perl_malloc CPerlObj::Perl_malloc -#define malloc Perl_malloc -#define Perl_calloc CPerlObj::Perl_calloc -#define calloc Perl_calloc -#define Perl_realloc CPerlObj::Perl_realloc -#define realloc Perl_realloc -#define Perl_mfree CPerlObj::Perl_mfree -#define mfree Perl_mfree #endif #define Perl_safesysmalloc CPerlObj::Perl_safesysmalloc #define safesysmalloc Perl_safesysmalloc @@ -4191,8 +4291,16 @@ #define reginitcolors Perl_reginitcolors #define Perl_sv_2pv_nolen CPerlObj::Perl_sv_2pv_nolen #define sv_2pv_nolen Perl_sv_2pv_nolen +#define Perl_sv_2pvutf8_nolen CPerlObj::Perl_sv_2pvutf8_nolen +#define sv_2pvutf8_nolen Perl_sv_2pvutf8_nolen +#define Perl_sv_2pvbyte_nolen CPerlObj::Perl_sv_2pvbyte_nolen +#define sv_2pvbyte_nolen Perl_sv_2pvbyte_nolen #define Perl_sv_pv CPerlObj::Perl_sv_pv #define sv_pv Perl_sv_pv +#define Perl_sv_pvutf8 CPerlObj::Perl_sv_pvutf8 +#define sv_pvutf8 Perl_sv_pvutf8 +#define Perl_sv_pvbyte CPerlObj::Perl_sv_pvbyte +#define sv_pvbyte Perl_sv_pvbyte #define Perl_sv_force_normal CPerlObj::Perl_sv_force_normal #define sv_force_normal Perl_sv_force_normal #define Perl_tmps_grow CPerlObj::Perl_tmps_grow @@ -4218,6 +4326,8 @@ #define si_dup Perl_si_dup #define Perl_ss_dup CPerlObj::Perl_ss_dup #define ss_dup Perl_ss_dup +#define Perl_any_dup CPerlObj::Perl_any_dup +#define any_dup Perl_any_dup #define Perl_he_dup CPerlObj::Perl_he_dup #define he_dup Perl_he_dup #define Perl_re_dup CPerlObj::Perl_re_dup @@ -4244,10 +4354,9 @@ #define ptr_table_store Perl_ptr_table_store #define Perl_ptr_table_split CPerlObj::Perl_ptr_table_split #define ptr_table_split Perl_ptr_table_split -#define perl_clone CPerlObj::perl_clone -#define perl_clone_using CPerlObj::perl_clone_using #endif #if defined(PERL_OBJECT) +#else #endif #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) #define S_avhv_index_sv CPerlObj::S_avhv_index_sv @@ -4498,8 +4607,22 @@ #define nextchar S_nextchar #define S_dumpuntil CPerlObj::S_dumpuntil #define dumpuntil S_dumpuntil +#define S_put_byte CPerlObj::S_put_byte +#define put_byte S_put_byte #define S_scan_commit CPerlObj::S_scan_commit #define scan_commit S_scan_commit +#define S_cl_anything CPerlObj::S_cl_anything +#define cl_anything S_cl_anything +#define S_cl_is_anything CPerlObj::S_cl_is_anything +#define cl_is_anything S_cl_is_anything +#define S_cl_init CPerlObj::S_cl_init +#define cl_init S_cl_init +#define S_cl_init_zero CPerlObj::S_cl_init_zero +#define cl_init_zero S_cl_init_zero +#define S_cl_and CPerlObj::S_cl_and +#define cl_and S_cl_and +#define S_cl_or CPerlObj::S_cl_or +#define cl_or S_cl_or #define S_study_chunk CPerlObj::S_study_chunk #define study_chunk S_study_chunk #define S_add_data CPerlObj::S_add_data @@ -4725,9 +4848,9 @@ #define S_uni CPerlObj::S_uni #define uni S_uni # endif -# if defined(WIN32) -#define S_win32_textfilter CPerlObj::S_win32_textfilter -#define win32_textfilter S_win32_textfilter +# if defined(PERL_CR_FILTER) +#define S_cr_textfilter CPerlObj::S_cr_textfilter +#define cr_textfilter S_cr_textfilter # endif #endif #if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT) @@ -4742,6 +4865,8 @@ #define xstat S_xstat # endif #endif +#if defined(PERL_OBJECT) +#endif #define Perl_ck_anoncode CPerlObj::Perl_ck_anoncode #define ck_anoncode Perl_ck_anoncode #define Perl_ck_bitop CPerlObj::Perl_ck_bitop @@ -31,6 +31,7 @@ sub walk_table (&@) { seek DATA, $END, 0; # so we may restart while (<DATA>) { chomp; + next if /^:/; while (s|\\$||) { $_ .= <DATA>; chomp; @@ -106,8 +107,7 @@ sub write_protos { my $ret = ""; if (@_ == 1) { my $arg = shift; - $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifdef|else|endif)\b/ - or $arg =~ /^\s*(public|protected|private):/; + $ret .= "$arg\n"; } else { my ($flags,$retval,$func,@args) = @_; @@ -144,7 +144,7 @@ sub write_global_sym { my $ret = ""; if (@_ > 1) { my ($flags,$retval,$func,@args) = @_; - unless ($flags =~ /s/) { + unless ($flags =~ /[sx]/) { $func = "Perl_$func" if $flags =~ /p/; $ret = "$func\n"; } @@ -324,7 +324,7 @@ walk_table { my $ret = ""; if (@_ == 1) { my $arg = shift; - $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifdef|else|endif)\b/; + $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/; } else { my ($flags,$retval,$func,@args) = @_; @@ -357,7 +357,7 @@ walk_table { my $ret = ""; if (@_ == 1) { my $arg = shift; - $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifdef|else|endif)\b/; + $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/; } else { my ($flags,$retval,$func,@args) = @_; @@ -417,20 +417,20 @@ walk_table { my $ret = ""; if (@_ == 1) { my $arg = shift; - $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifdef|else|endif)\b/; + $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/; } else { my ($flags,$retval,$func,@args) = @_; if ($flags =~ /s/) { - $ret .= hide("S_$func","CPerlObj::S_$func"); + $ret .= hide("S_$func","CPerlObj::S_$func") if $flags !~ /j/; $ret .= hide($func,"S_$func"); } elsif ($flags =~ /p/) { - $ret .= hide("Perl_$func","CPerlObj::Perl_$func"); + $ret .= hide("Perl_$func","CPerlObj::Perl_$func") if $flags !~ /j/; $ret .= hide($func,"Perl_$func"); } else { - $ret .= hide($func,"CPerlObj::$func"); + $ret .= hide($func,"CPerlObj::$func") if $flags !~ /j/; } } $ret; @@ -597,7 +597,26 @@ print EM <<'END'; # endif /* USE_THREADS */ #else /* !MULTIPLICITY */ -/* cases 1, 4 and 6 above */ + +# if defined(PERL_OBJECT) +/* case 6 above */ + +END + +for $sym (sort keys %thread) { + print EM multon($sym,'T','aTHXo->interp.'); +} + + +for $sym (sort keys %intrp) { + print EM multon($sym,'I','aTHXo->interp.'); +} + +print EM <<'END'; + +# else /* !PERL_OBJECT */ + +/* cases 1 and 4 above */ END @@ -607,7 +626,7 @@ for $sym (sort keys %intrp) { print EM <<'END'; -# if defined(USE_THREADS) +# if defined(USE_THREADS) /* case 4 above */ END @@ -618,8 +637,8 @@ for $sym (sort keys %thread) { print EM <<'END'; -# else /* !USE_THREADS */ -/* cases 1 and 6 above */ +# else /* !USE_THREADS */ +/* case 1 above */ END @@ -629,7 +648,8 @@ for $sym (sort keys %thread) { print EM <<'END'; -# endif /* USE_THREADS */ +# endif /* USE_THREADS */ +# endif /* PERL_OBJECT */ #endif /* MULTIPLICITY */ #if defined(PERL_GLOBAL_STRUCT) @@ -712,11 +732,11 @@ walk_table { my $ret = ""; if (@_ == 1) { my $arg = shift; - $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifdef|else|endif)\b/; + $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/; } else { my ($flags,$retval,$func,@args) = @_; - unless ($flags =~ /s/) { + unless ($flags =~ /[js]/) { if ($flags =~ /p/) { $ret .= undefine("Perl_$func") . hide("Perl_$func","pPerl->Perl_$func"); $ret .= undefine($func) . hide($func,"Perl_$func"); @@ -813,9 +833,9 @@ START_EXTERN_C #undef PERLVARI #undef PERLVARIC #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHXo) \ - { return &(aTHXo->PL_##v); } + { return &(aTHXo->interp.v); } #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHXo) \ - { return &(aTHXo->PL_##v); } + { return &(aTHXo->interp.v); } #define PERLVARI(v,t,i) PERLVAR(v,t) #define PERLVARIC(v,t,i) PERLVAR(v, const t) @@ -923,12 +943,12 @@ walk_table { my $ret = ""; if (@_ == 1) { my $arg = shift; - $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifdef|else|endif)\b/; + $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/; } else { my ($flags,$retval,$func,@args) = @_; return $ret if exists $skipapi_funcs{$func}; - unless ($flags =~ /s/) { + unless ($flags =~ /[js]/) { $ret .= "\n"; my $addctx = 1 if $flags =~ /n/; if ($flags =~ /p/) { @@ -965,7 +985,7 @@ Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...) dTHXo; va_list(arglist); va_start(arglist, format); - return (*pPerl->PL_StdIO->pVprintf)(pPerl->PL_StdIO, stream, format, arglist); + return (*PL_StdIO->pVprintf)(PL_StdIO, stream, format, arglist); } END_EXTERN_C @@ -975,44 +995,104 @@ EOT __END__ -# Lines are of the form: -# flags|return_type|function_name|arg1|arg2|...|argN -# -# A line may be continued on another by ending it with a backslash. -# Leading and trailing whitespace will be ignored in each component. -# -# flags are single letters with following meanings: -# s static function, should have an S_ prefix in source -# file -# n has no implicit interpreter/thread context argument -# p function has a Perl_ prefix -# r function never returns -# o has no compatibility macro (#define foo Perl_foo) -# -# Individual flags may be separated by whitespace. -# -# New global functions should be added at the end for binary compatibility -# in some configurations. -# -# TODO: 1) Add a flag to mark the functions that are part of the public API. -# 2) Add a field for documentation, so that L<perlguts/"API LISTING"> -# may be autogenerated. -# +: Lines are of the form: +: flags|return_type|function_name|arg1|arg2|...|argN +: +: A line may be continued on another by ending it with a backslash. +: Leading and trailing whitespace will be ignored in each component. +: +: flags are single letters with following meanings: +: s static function, should have an S_ prefix in source +: file +: n has no implicit interpreter/thread context argument +: p function has a Perl_ prefix +: r function never returns +: o has no compatibility macro (#define foo Perl_foo) +: j not a member of CPerlObj +: x not exported +: +: Individual flags may be separated by whitespace. +: +: New global functions should be added at the end for binary compatibility +: in some configurations. +: +: TODO: 1) Add a flag to mark the functions that are part of the public API. +: 2) Add a field for documentation, so that L<perlguts/"API LISTING"> +: may be autogenerated. + +START_EXTERN_C +#if defined(PERL_IMPLICIT_SYS) +jno |PerlInterpreter* |perl_alloc_using \ + |struct IPerlMem* m|struct IPerlMem* ms \ + |struct IPerlMem* mp|struct IPerlEnv* e \ + |struct IPerlStdIO* io|struct IPerlLIO* lio \ + |struct IPerlDir* d|struct IPerlSock* s \ + |struct IPerlProc* p +#else +jno |PerlInterpreter* |perl_alloc +#endif +jno |void |perl_construct |PerlInterpreter* interp +jno |void |perl_destruct |PerlInterpreter* interp +jno |void |perl_free |PerlInterpreter* interp +jno |int |perl_run |PerlInterpreter* interp +jno |int |perl_parse |PerlInterpreter* interp|XSINIT_t xsinit \ + |int argc|char** argv|char** env +#if defined(USE_ITHREADS) +jno |PerlInterpreter*|perl_clone|PerlInterpreter* interp, UV flags +# if defined(PERL_IMPLICIT_SYS) +jno |PerlInterpreter*|perl_clone_using|PerlInterpreter *interp|UV flags \ + |struct IPerlMem* m|struct IPerlMem* ms \ + |struct IPerlMem* mp|struct IPerlEnv* e \ + |struct IPerlStdIO* io|struct IPerlLIO* lio \ + |struct IPerlDir* d|struct IPerlSock* s \ + |struct IPerlProc* p +# endif +#endif + +#if defined(MYMALLOC) +jnop |Malloc_t|malloc |MEM_SIZE nbytes +jnop |Malloc_t|calloc |MEM_SIZE elements|MEM_SIZE size +jnop |Malloc_t|realloc |Malloc_t where|MEM_SIZE nbytes +jnop |Free_t |mfree |Malloc_t where +jnp |MEM_SIZE|malloced_size |void *p +#endif + +END_EXTERN_C + +/* functions with flag 'n' should come before here */ +#if defined(PERL_OBJECT) +class CPerlObj { +public: + struct interpreter interp; + CPerlObj(IPerlMem*, IPerlMem*, IPerlMem*, IPerlEnv*, IPerlStdIO*, + IPerlLIO*, IPerlDir*, IPerlSock*, IPerlProc*); + void* operator new(size_t nSize, IPerlMem *pvtbl); +#ifndef __BORLANDC__ + static void operator delete(void* pPerl, IPerlMem *pvtbl); +#endif + int do_aspawn (void *vreally, void **vmark, void **vsp); +#endif #if defined(PERL_OBJECT) public: +#else +START_EXTERN_C #endif +# include "pp_proto.h" p |SV* |amagic_call |SV* left|SV* right|int method|int dir p |bool |Gv_AMupdate |HV* stash p |OP* |append_elem |I32 optype|OP* head|OP* tail p |OP* |append_list |I32 optype|LISTOP* first|LISTOP* last p |I32 |apply |I32 type|SV** mark|SV** sp +p |SV* |avhv_delete_ent|AV *ar|SV* keysv|I32 flags|U32 hash p |bool |avhv_exists_ent|AV *ar|SV* keysv|U32 hash p |SV** |avhv_fetch_ent |AV *ar|SV* keysv|I32 lval|U32 hash p |HE* |avhv_iternext |AV *ar p |SV* |avhv_iterval |AV *ar|HE* entry p |HV* |avhv_keys |AV *ar p |void |av_clear |AV* ar +p |SV* |av_delete |AV* ar|I32 key|I32 flags +p |bool |av_exists |AV* ar|I32 key p |void |av_extend |AV* ar|I32 key p |AV* |av_fake |I32 size|SV** svp p |SV** |av_fetch |AV* ar|I32 key|I32 lval @@ -1047,7 +1127,7 @@ p |OP* |convert |I32 optype|I32 flags|OP* o pr |void |croak |const char* pat|... pr |void |vcroak |const char* pat|va_list* args #if defined(PERL_IMPLICIT_CONTEXT) -npr |void |croak_nocontext|const char* pat|... +nrp |void |croak_nocontext|const char* pat|... np |OP* |die_nocontext |const char* pat|... np |void |deb_nocontext |const char* pat|... np |char* |form_nocontext |const char* pat|... @@ -1321,9 +1401,6 @@ p |int |magic_set_all_env|SV* sv|MAGIC* mg p |U32 |magic_sizepack |SV* sv|MAGIC* mg p |int |magic_wipepack |SV* sv|MAGIC* mg p |void |magicname |char* sym|char* name|I32 namlen -#if defined(MYMALLOC) -np |MEM_SIZE|malloced_size |void *p -#endif p |void |markstack_grow #if defined(USE_LOCALE_COLLATE) p |char* |mem_collxfrm |const char* s|STRLEN len|STRLEN* xlen @@ -1345,20 +1422,20 @@ p |char* |moreswitches |char* s p |OP* |my |OP* o p |NV |my_atof |const char *s #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY) -p |char* |my_bcopy |const char* from|char* to|I32 len +np |char* |my_bcopy |const char* from|char* to|I32 len #endif #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) -p |char* |my_bzero |char* loc|I32 len +np |char* |my_bzero |char* loc|I32 len #endif pr |void |my_exit |U32 status pr |void |my_failure_exit p |I32 |my_fflush_all p |I32 |my_lstat #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) -p |I32 |my_memcmp |const char* s1|const char* s2|I32 len +np |I32 |my_memcmp |const char* s1|const char* s2|I32 len #endif #if !defined(HAS_MEMSET) -p |void* |my_memset |char* loc|I32 ch|I32 len +np |void* |my_memset |char* loc|I32 ch|I32 len #endif #if !defined(PERL_OBJECT) p |I32 |my_pclose |PerlIO* ptr @@ -1443,24 +1520,16 @@ p |void |pad_reset p |void |pad_swipe |PADOFFSET po p |void |peep |OP* o #if defined(PERL_OBJECT) -no |void |perl_construct -no |void |perl_destruct -no |void |perl_free -no |int |perl_run -no |int |perl_parse |XSINIT_t xsinit \ - |int argc|char** argv|char** env -#else -no |PerlInterpreter* |perl_alloc -no |void |perl_construct |PerlInterpreter* interp -no |void |perl_destruct |PerlInterpreter* interp -no |void |perl_free |PerlInterpreter* interp -no |int |perl_run |PerlInterpreter* interp -no |int |perl_parse |PerlInterpreter* interp|XSINIT_t xsinit \ +ox |void |Perl_construct +ox |void |Perl_destruct +ox |void |Perl_free +ox |int |Perl_run +ox |int |Perl_parse |XSINIT_t xsinit \ |int argc|char** argv|char** env +#endif #if defined(USE_THREADS) p |struct perl_thread* |new_struct_thread|struct perl_thread *t #endif -#endif p |void |call_atexit |ATEXIT_t fn|void *ptr p |I32 |call_argv |const char* sub_name|I32 flags|char** argv p |I32 |call_method |const char* methname|I32 flags @@ -1542,6 +1611,7 @@ p |void |save_hints p |void |save_hptr |HV** hptr p |void |save_I16 |I16* intp p |void |save_I32 |I32* intp +p |void |save_I8 |I8* bytep p |void |save_int |int* intp p |void |save_item |SV* item p |void |save_iv |IV* iv @@ -1551,6 +1621,7 @@ p |void |save_nogv |GV* gv p |void |save_op p |SV* |save_scalar |GV* gv p |void |save_pptr |char** pptr +p |void |save_vptr |void* pptr p |void |save_re_context p |void |save_sptr |SV** sptr p |SV* |save_svref |SV** sptr @@ -1584,11 +1655,15 @@ p |IV |sv_2iv |SV* sv p |SV* |sv_2mortal |SV* sv p |NV |sv_2nv |SV* sv p |char* |sv_2pv |SV* sv|STRLEN* lp +p |char* |sv_2pvutf8 |SV* sv|STRLEN* lp +p |char* |sv_2pvbyte |SV* sv|STRLEN* lp p |UV |sv_2uv |SV* sv p |IV |sv_iv |SV* sv p |UV |sv_uv |SV* sv p |NV |sv_nv |SV* sv p |char* |sv_pvn |SV *sv|STRLEN *len +p |char* |sv_pvutf8n |SV *sv|STRLEN *len +p |char* |sv_pvbyten |SV *sv|STRLEN *len p |I32 |sv_true |SV *sv p |void |sv_add_arena |char* ptr|U32 size|U32 flags p |int |sv_backoff |SV* sv @@ -1632,6 +1707,8 @@ p |char* |sv_peek |SV* sv p |void |sv_pos_u2b |SV* sv|I32* offsetp|I32* lenp p |void |sv_pos_b2u |SV* sv|I32* offsetp p |char* |sv_pvn_force |SV* sv|STRLEN* lp +p |char* |sv_pvutf8n_force|SV* sv|STRLEN* lp +p |char* |sv_pvbyten_force|SV* sv|STRLEN* lp p |char* |sv_reftype |SV* sv|int ob p |void |sv_replace |SV* sv|SV* nsv p |void |sv_report_used @@ -1689,6 +1766,7 @@ p |U8* |uv_to_utf8 |U8 *d|UV uv 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_uninit p |void |warn |const char* pat|... p |void |vwarn |const char* pat|va_list* args p |void |warner |U32 err|const char* pat|... @@ -1705,20 +1783,16 @@ p |int |yyparse p |int |yywarn |char* s #if defined(MYMALLOC) p |void |dump_mstats |char* s -pno |Malloc_t|malloc |MEM_SIZE nbytes -pno |Malloc_t|calloc |MEM_SIZE elements|MEM_SIZE size -pno |Malloc_t|realloc |Malloc_t where|MEM_SIZE nbytes -pno |Free_t |mfree |Malloc_t where #endif -pn |Malloc_t|safesysmalloc |MEM_SIZE nbytes -pn |Malloc_t|safesyscalloc |MEM_SIZE elements|MEM_SIZE size -pn |Malloc_t|safesysrealloc|Malloc_t where|MEM_SIZE nbytes -pn |Free_t |safesysfree |Malloc_t where +np |Malloc_t|safesysmalloc |MEM_SIZE nbytes +np |Malloc_t|safesyscalloc |MEM_SIZE elements|MEM_SIZE size +np |Malloc_t|safesysrealloc|Malloc_t where|MEM_SIZE nbytes +np |Free_t |safesysfree |Malloc_t where #if defined(LEAKTEST) -pn |Malloc_t|safexmalloc |I32 x|MEM_SIZE size -pn |Malloc_t|safexcalloc |I32 x|MEM_SIZE elements|MEM_SIZE size -pn |Malloc_t|safexrealloc |Malloc_t where|MEM_SIZE size -pn |void |safexfree |Malloc_t where +np |Malloc_t|safexmalloc |I32 x|MEM_SIZE size +np |Malloc_t|safexcalloc |I32 x|MEM_SIZE elements|MEM_SIZE size +np |Malloc_t|safexrealloc |Malloc_t where|MEM_SIZE size +np |void |safexfree |Malloc_t where #endif #if defined(PERL_GLOBAL_STRUCT) p |struct perl_vars *|GetVars @@ -1762,7 +1836,11 @@ p |void* |vdefault_protect|volatile JMPENV *je|int *excpt \ |protect_body_t body|va_list *args p |void |reginitcolors p |char* |sv_2pv_nolen |SV* sv +p |char* |sv_2pvutf8_nolen|SV* sv +p |char* |sv_2pvbyte_nolen|SV* sv p |char* |sv_pv |SV *sv +p |char* |sv_pvutf8 |SV *sv +p |char* |sv_pvbyte |SV *sv p |void |sv_force_normal|SV *sv p |void |tmps_grow |I32 n p |SV* |sv_rvweaken |SV *sv @@ -1775,7 +1853,8 @@ p |void |boot_core_xsutils #if defined(USE_ITHREADS) p |PERL_CONTEXT*|cx_dup |PERL_CONTEXT* cx|I32 ix|I32 max p |PERL_SI*|si_dup |PERL_SI* si -p |ANY* |ss_dup |ANY* ss|I32 ix|I32 max +p |ANY* |ss_dup |PerlInterpreter* proto_perl +p |void* |any_dup |void* v|PerlInterpreter* proto_perl p |HE* |he_dup |HE* e|bool shared p |REGEXP*|re_dup |REGEXP* r p |PerlIO*|fp_dup |PerlIO* fp|char type @@ -1791,17 +1870,14 @@ p |PTR_TBL_t*|ptr_table_new p |void* |ptr_table_fetch|PTR_TBL_t *tbl|void *sv p |void |ptr_table_store|PTR_TBL_t *tbl|void *oldsv|void *newsv p |void |ptr_table_split|PTR_TBL_t *tbl -no |PerlInterpreter*|perl_clone|PerlInterpreter* interp, UV flags -no |PerlInterpreter*|perl_clone_using|PerlInterpreter *interp|UV flags \ - |struct IPerlMem* m|struct IPerlEnv* e \ - |struct IPerlStdIO* io|struct IPerlLIO* lio \ - |struct IPerlDir* d|struct IPerlSock* s \ - |struct IPerlProc* p #endif #if defined(PERL_OBJECT) protected: +#else +END_EXTERN_C #endif + #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) s |I32 |avhv_index_sv |SV* sv #endif @@ -1956,7 +2032,16 @@ s |char*|regwhite |char *|char * s |char*|nextchar s |regnode*|dumpuntil |regnode *start|regnode *node \ |regnode *last|SV* sv|I32 l +s |void |put_byte |SV* sv|int c s |void |scan_commit |struct scan_data_t *data +s |void |cl_anything |struct regnode_charclass_class *cl +s |int |cl_is_anything |struct regnode_charclass_class *cl +s |void |cl_init |struct regnode_charclass_class *cl +s |void |cl_init_zero |struct regnode_charclass_class *cl +s |void |cl_and |struct regnode_charclass_class *cl \ + |struct regnode_charclass_class *and_with +s |void |cl_or |struct regnode_charclass_class *cl \ + |struct regnode_charclass_class *or_with s |I32 |study_chunk |regnode **scanp|I32 *deltap \ |regnode *last|struct scan_data_t *data \ |U32 flags @@ -2071,7 +2156,7 @@ s |void |force_ident |char *s|int kind s |void |incline |char *s s |int |intuit_method |char *s|GV *gv s |int |intuit_more |char *s -s |I32 |lop |I32 f|expectation x|char *s +s |I32 |lop |I32 f|int x|char *s s |void |missingterm |char *s s |void |no_op |char *what|char *s s |void |set_csh @@ -2089,8 +2174,8 @@ s |I32 |utf16rev_textfilter|int idx|SV *sv|int maxlen # if defined(CRIPPLED_CC) s |int |uni |I32 f|char *s # endif -# if defined(WIN32) -s |I32 |win32_textfilter |int idx|SV *sv|int maxlen +# if defined(PERL_CR_FILTER) +s |I32 |cr_textfilter |int idx|SV *sv|int maxlen # endif #endif @@ -2104,3 +2189,7 @@ s |SV* |mess_alloc s |void |xstat |int # endif #endif + +#if defined(PERL_OBJECT) +}; +#endif diff --git a/embedvar.h b/embedvar.h index 610f266db2..837c0308cf 100644 --- a/embedvar.h +++ b/embedvar.h @@ -184,12 +184,13 @@ #define PL_Env (PERL_GET_INTERP->IEnv) #define PL_LIO (PERL_GET_INTERP->ILIO) #define PL_Mem (PERL_GET_INTERP->IMem) +#define PL_MemParse (PERL_GET_INTERP->IMemParse) +#define PL_MemShared (PERL_GET_INTERP->IMemShared) #define PL_Proc (PERL_GET_INTERP->IProc) #define PL_Sock (PERL_GET_INTERP->ISock) #define PL_StdIO (PERL_GET_INTERP->IStdIO) #define PL_amagic_generation (PERL_GET_INTERP->Iamagic_generation) #define PL_an (PERL_GET_INTERP->Ian) -#define PL_archpat_auto (PERL_GET_INTERP->Iarchpat_auto) #define PL_argvgv (PERL_GET_INTERP->Iargvgv) #define PL_argvout_stack (PERL_GET_INTERP->Iargvout_stack) #define PL_argvoutgv (PERL_GET_INTERP->Iargvoutgv) @@ -239,6 +240,7 @@ #define PL_eval_root (PERL_GET_INTERP->Ieval_root) #define PL_eval_start (PERL_GET_INTERP->Ieval_start) #define PL_evalseq (PERL_GET_INTERP->Ievalseq) +#define PL_exit_flags (PERL_GET_INTERP->Iexit_flags) #define PL_exitlist (PERL_GET_INTERP->Iexitlist) #define PL_exitlistlen (PERL_GET_INTERP->Iexitlistlen) #define PL_expect (PERL_GET_INTERP->Iexpect) @@ -279,7 +281,6 @@ #define PL_lex_defer (PERL_GET_INTERP->Ilex_defer) #define PL_lex_dojoin (PERL_GET_INTERP->Ilex_dojoin) #define PL_lex_expect (PERL_GET_INTERP->Ilex_expect) -#define PL_lex_fakebrack (PERL_GET_INTERP->Ilex_fakebrack) #define PL_lex_formbrack (PERL_GET_INTERP->Ilex_formbrack) #define PL_lex_inpat (PERL_GET_INTERP->Ilex_inpat) #define PL_lex_inwhat (PERL_GET_INTERP->Ilex_inwhat) @@ -350,6 +351,8 @@ #define PL_preambled (PERL_GET_INTERP->Ipreambled) #define PL_preprocess (PERL_GET_INTERP->Ipreprocess) #define PL_profiledata (PERL_GET_INTERP->Iprofiledata) +#define PL_psig_name (PERL_GET_INTERP->Ipsig_name) +#define PL_psig_ptr (PERL_GET_INTERP->Ipsig_ptr) #define PL_ptr_table (PERL_GET_INTERP->Iptr_table) #define PL_replgv (PERL_GET_INTERP->Ireplgv) #define PL_rsfp (PERL_GET_INTERP->Irsfp) @@ -445,12 +448,13 @@ #define PL_Env (vTHX->IEnv) #define PL_LIO (vTHX->ILIO) #define PL_Mem (vTHX->IMem) +#define PL_MemParse (vTHX->IMemParse) +#define PL_MemShared (vTHX->IMemShared) #define PL_Proc (vTHX->IProc) #define PL_Sock (vTHX->ISock) #define PL_StdIO (vTHX->IStdIO) #define PL_amagic_generation (vTHX->Iamagic_generation) #define PL_an (vTHX->Ian) -#define PL_archpat_auto (vTHX->Iarchpat_auto) #define PL_argvgv (vTHX->Iargvgv) #define PL_argvout_stack (vTHX->Iargvout_stack) #define PL_argvoutgv (vTHX->Iargvoutgv) @@ -500,6 +504,7 @@ #define PL_eval_root (vTHX->Ieval_root) #define PL_eval_start (vTHX->Ieval_start) #define PL_evalseq (vTHX->Ievalseq) +#define PL_exit_flags (vTHX->Iexit_flags) #define PL_exitlist (vTHX->Iexitlist) #define PL_exitlistlen (vTHX->Iexitlistlen) #define PL_expect (vTHX->Iexpect) @@ -540,7 +545,6 @@ #define PL_lex_defer (vTHX->Ilex_defer) #define PL_lex_dojoin (vTHX->Ilex_dojoin) #define PL_lex_expect (vTHX->Ilex_expect) -#define PL_lex_fakebrack (vTHX->Ilex_fakebrack) #define PL_lex_formbrack (vTHX->Ilex_formbrack) #define PL_lex_inpat (vTHX->Ilex_inpat) #define PL_lex_inwhat (vTHX->Ilex_inwhat) @@ -611,6 +615,8 @@ #define PL_preambled (vTHX->Ipreambled) #define PL_preprocess (vTHX->Ipreprocess) #define PL_profiledata (vTHX->Iprofiledata) +#define PL_psig_name (vTHX->Ipsig_name) +#define PL_psig_ptr (vTHX->Ipsig_ptr) #define PL_ptr_table (vTHX->Iptr_table) #define PL_replgv (vTHX->Ireplgv) #define PL_rsfp (vTHX->Irsfp) @@ -693,7 +699,407 @@ # endif /* USE_THREADS */ #else /* !MULTIPLICITY */ -/* cases 1, 4 and 6 above */ + +# if defined(PERL_OBJECT) +/* case 6 above */ + +#define PL_Sv (aTHXo->interp.TSv) +#define PL_Xpv (aTHXo->interp.TXpv) +#define PL_av_fetch_sv (aTHXo->interp.Tav_fetch_sv) +#define PL_bodytarget (aTHXo->interp.Tbodytarget) +#define PL_bostr (aTHXo->interp.Tbostr) +#define PL_chopset (aTHXo->interp.Tchopset) +#define PL_colors (aTHXo->interp.Tcolors) +#define PL_colorset (aTHXo->interp.Tcolorset) +#define PL_curcop (aTHXo->interp.Tcurcop) +#define PL_curpad (aTHXo->interp.Tcurpad) +#define PL_curpm (aTHXo->interp.Tcurpm) +#define PL_curstack (aTHXo->interp.Tcurstack) +#define PL_curstackinfo (aTHXo->interp.Tcurstackinfo) +#define PL_curstash (aTHXo->interp.Tcurstash) +#define PL_defoutgv (aTHXo->interp.Tdefoutgv) +#define PL_defstash (aTHXo->interp.Tdefstash) +#define PL_delaymagic (aTHXo->interp.Tdelaymagic) +#define PL_dirty (aTHXo->interp.Tdirty) +#define PL_dumpindent (aTHXo->interp.Tdumpindent) +#define PL_efloatbuf (aTHXo->interp.Tefloatbuf) +#define PL_efloatsize (aTHXo->interp.Tefloatsize) +#define PL_errors (aTHXo->interp.Terrors) +#define PL_extralen (aTHXo->interp.Textralen) +#define PL_firstgv (aTHXo->interp.Tfirstgv) +#define PL_formtarget (aTHXo->interp.Tformtarget) +#define PL_hv_fetch_ent_mh (aTHXo->interp.Thv_fetch_ent_mh) +#define PL_hv_fetch_sv (aTHXo->interp.Thv_fetch_sv) +#define PL_in_eval (aTHXo->interp.Tin_eval) +#define PL_last_in_gv (aTHXo->interp.Tlast_in_gv) +#define PL_lastgotoprobe (aTHXo->interp.Tlastgotoprobe) +#define PL_lastscream (aTHXo->interp.Tlastscream) +#define PL_localizing (aTHXo->interp.Tlocalizing) +#define PL_mainstack (aTHXo->interp.Tmainstack) +#define PL_markstack (aTHXo->interp.Tmarkstack) +#define PL_markstack_max (aTHXo->interp.Tmarkstack_max) +#define PL_markstack_ptr (aTHXo->interp.Tmarkstack_ptr) +#define PL_maxscream (aTHXo->interp.Tmaxscream) +#define PL_modcount (aTHXo->interp.Tmodcount) +#define PL_na (aTHXo->interp.Tna) +#define PL_nrs (aTHXo->interp.Tnrs) +#define PL_ofs (aTHXo->interp.Tofs) +#define PL_ofslen (aTHXo->interp.Tofslen) +#define PL_op (aTHXo->interp.Top) +#define PL_opsave (aTHXo->interp.Topsave) +#define PL_protect (aTHXo->interp.Tprotect) +#define PL_reg_call_cc (aTHXo->interp.Treg_call_cc) +#define PL_reg_curpm (aTHXo->interp.Treg_curpm) +#define PL_reg_eval_set (aTHXo->interp.Treg_eval_set) +#define PL_reg_flags (aTHXo->interp.Treg_flags) +#define PL_reg_ganch (aTHXo->interp.Treg_ganch) +#define PL_reg_leftiter (aTHXo->interp.Treg_leftiter) +#define PL_reg_magic (aTHXo->interp.Treg_magic) +#define PL_reg_maxiter (aTHXo->interp.Treg_maxiter) +#define PL_reg_oldcurpm (aTHXo->interp.Treg_oldcurpm) +#define PL_reg_oldpos (aTHXo->interp.Treg_oldpos) +#define PL_reg_oldsaved (aTHXo->interp.Treg_oldsaved) +#define PL_reg_oldsavedlen (aTHXo->interp.Treg_oldsavedlen) +#define PL_reg_poscache (aTHXo->interp.Treg_poscache) +#define PL_reg_poscache_size (aTHXo->interp.Treg_poscache_size) +#define PL_reg_re (aTHXo->interp.Treg_re) +#define PL_reg_start_tmp (aTHXo->interp.Treg_start_tmp) +#define PL_reg_start_tmpl (aTHXo->interp.Treg_start_tmpl) +#define PL_reg_starttry (aTHXo->interp.Treg_starttry) +#define PL_reg_sv (aTHXo->interp.Treg_sv) +#define PL_reg_whilem_seen (aTHXo->interp.Treg_whilem_seen) +#define PL_regbol (aTHXo->interp.Tregbol) +#define PL_regcc (aTHXo->interp.Tregcc) +#define PL_regcode (aTHXo->interp.Tregcode) +#define PL_regcomp_parse (aTHXo->interp.Tregcomp_parse) +#define PL_regcomp_rx (aTHXo->interp.Tregcomp_rx) +#define PL_regcompp (aTHXo->interp.Tregcompp) +#define PL_regdata (aTHXo->interp.Tregdata) +#define PL_regdummy (aTHXo->interp.Tregdummy) +#define PL_regendp (aTHXo->interp.Tregendp) +#define PL_regeol (aTHXo->interp.Tregeol) +#define PL_regexecp (aTHXo->interp.Tregexecp) +#define PL_regflags (aTHXo->interp.Tregflags) +#define PL_regfree (aTHXo->interp.Tregfree) +#define PL_regindent (aTHXo->interp.Tregindent) +#define PL_reginput (aTHXo->interp.Treginput) +#define PL_regint_start (aTHXo->interp.Tregint_start) +#define PL_regint_string (aTHXo->interp.Tregint_string) +#define PL_reginterp_cnt (aTHXo->interp.Treginterp_cnt) +#define PL_reglastparen (aTHXo->interp.Treglastparen) +#define PL_regnarrate (aTHXo->interp.Tregnarrate) +#define PL_regnaughty (aTHXo->interp.Tregnaughty) +#define PL_regnpar (aTHXo->interp.Tregnpar) +#define PL_regprecomp (aTHXo->interp.Tregprecomp) +#define PL_regprev (aTHXo->interp.Tregprev) +#define PL_regprogram (aTHXo->interp.Tregprogram) +#define PL_regsawback (aTHXo->interp.Tregsawback) +#define PL_regseen (aTHXo->interp.Tregseen) +#define PL_regsize (aTHXo->interp.Tregsize) +#define PL_regstartp (aTHXo->interp.Tregstartp) +#define PL_regtill (aTHXo->interp.Tregtill) +#define PL_regxend (aTHXo->interp.Tregxend) +#define PL_restartop (aTHXo->interp.Trestartop) +#define PL_retstack (aTHXo->interp.Tretstack) +#define PL_retstack_ix (aTHXo->interp.Tretstack_ix) +#define PL_retstack_max (aTHXo->interp.Tretstack_max) +#define PL_rs (aTHXo->interp.Trs) +#define PL_savestack (aTHXo->interp.Tsavestack) +#define PL_savestack_ix (aTHXo->interp.Tsavestack_ix) +#define PL_savestack_max (aTHXo->interp.Tsavestack_max) +#define PL_scopestack (aTHXo->interp.Tscopestack) +#define PL_scopestack_ix (aTHXo->interp.Tscopestack_ix) +#define PL_scopestack_max (aTHXo->interp.Tscopestack_max) +#define PL_screamfirst (aTHXo->interp.Tscreamfirst) +#define PL_screamnext (aTHXo->interp.Tscreamnext) +#define PL_secondgv (aTHXo->interp.Tsecondgv) +#define PL_seen_evals (aTHXo->interp.Tseen_evals) +#define PL_seen_zerolen (aTHXo->interp.Tseen_zerolen) +#define PL_sortcop (aTHXo->interp.Tsortcop) +#define PL_sortcxix (aTHXo->interp.Tsortcxix) +#define PL_sortstash (aTHXo->interp.Tsortstash) +#define PL_stack_base (aTHXo->interp.Tstack_base) +#define PL_stack_max (aTHXo->interp.Tstack_max) +#define PL_stack_sp (aTHXo->interp.Tstack_sp) +#define PL_start_env (aTHXo->interp.Tstart_env) +#define PL_statbuf (aTHXo->interp.Tstatbuf) +#define PL_statcache (aTHXo->interp.Tstatcache) +#define PL_statgv (aTHXo->interp.Tstatgv) +#define PL_statname (aTHXo->interp.Tstatname) +#define PL_tainted (aTHXo->interp.Ttainted) +#define PL_timesbuf (aTHXo->interp.Ttimesbuf) +#define PL_tmps_floor (aTHXo->interp.Ttmps_floor) +#define PL_tmps_ix (aTHXo->interp.Ttmps_ix) +#define PL_tmps_max (aTHXo->interp.Ttmps_max) +#define PL_tmps_stack (aTHXo->interp.Ttmps_stack) +#define PL_top_env (aTHXo->interp.Ttop_env) +#define PL_toptarget (aTHXo->interp.Ttoptarget) +#define PL_watchaddr (aTHXo->interp.Twatchaddr) +#define PL_watchok (aTHXo->interp.Twatchok) +#define PL_Argv (aTHXo->interp.IArgv) +#define PL_Cmd (aTHXo->interp.ICmd) +#define PL_DBcv (aTHXo->interp.IDBcv) +#define PL_DBgv (aTHXo->interp.IDBgv) +#define PL_DBline (aTHXo->interp.IDBline) +#define PL_DBsignal (aTHXo->interp.IDBsignal) +#define PL_DBsingle (aTHXo->interp.IDBsingle) +#define PL_DBsub (aTHXo->interp.IDBsub) +#define PL_DBtrace (aTHXo->interp.IDBtrace) +#define PL_Dir (aTHXo->interp.IDir) +#define PL_Env (aTHXo->interp.IEnv) +#define PL_LIO (aTHXo->interp.ILIO) +#define PL_Mem (aTHXo->interp.IMem) +#define PL_MemParse (aTHXo->interp.IMemParse) +#define PL_MemShared (aTHXo->interp.IMemShared) +#define PL_Proc (aTHXo->interp.IProc) +#define PL_Sock (aTHXo->interp.ISock) +#define PL_StdIO (aTHXo->interp.IStdIO) +#define PL_amagic_generation (aTHXo->interp.Iamagic_generation) +#define PL_an (aTHXo->interp.Ian) +#define PL_argvgv (aTHXo->interp.Iargvgv) +#define PL_argvout_stack (aTHXo->interp.Iargvout_stack) +#define PL_argvoutgv (aTHXo->interp.Iargvoutgv) +#define PL_basetime (aTHXo->interp.Ibasetime) +#define PL_beginav (aTHXo->interp.Ibeginav) +#define PL_bitcount (aTHXo->interp.Ibitcount) +#define PL_bufend (aTHXo->interp.Ibufend) +#define PL_bufptr (aTHXo->interp.Ibufptr) +#define PL_collation_ix (aTHXo->interp.Icollation_ix) +#define PL_collation_name (aTHXo->interp.Icollation_name) +#define PL_collation_standard (aTHXo->interp.Icollation_standard) +#define PL_collxfrm_base (aTHXo->interp.Icollxfrm_base) +#define PL_collxfrm_mult (aTHXo->interp.Icollxfrm_mult) +#define PL_compcv (aTHXo->interp.Icompcv) +#define PL_compiling (aTHXo->interp.Icompiling) +#define PL_comppad (aTHXo->interp.Icomppad) +#define PL_comppad_name (aTHXo->interp.Icomppad_name) +#define PL_comppad_name_fill (aTHXo->interp.Icomppad_name_fill) +#define PL_comppad_name_floor (aTHXo->interp.Icomppad_name_floor) +#define PL_cop_seqmax (aTHXo->interp.Icop_seqmax) +#define PL_copline (aTHXo->interp.Icopline) +#define PL_cred_mutex (aTHXo->interp.Icred_mutex) +#define PL_cryptseen (aTHXo->interp.Icryptseen) +#define PL_cshlen (aTHXo->interp.Icshlen) +#define PL_cshname (aTHXo->interp.Icshname) +#define PL_curcopdb (aTHXo->interp.Icurcopdb) +#define PL_curstname (aTHXo->interp.Icurstname) +#define PL_curthr (aTHXo->interp.Icurthr) +#define PL_dbargs (aTHXo->interp.Idbargs) +#define PL_debstash (aTHXo->interp.Idebstash) +#define PL_debug (aTHXo->interp.Idebug) +#define PL_defgv (aTHXo->interp.Idefgv) +#define PL_diehook (aTHXo->interp.Idiehook) +#define PL_doextract (aTHXo->interp.Idoextract) +#define PL_doswitches (aTHXo->interp.Idoswitches) +#define PL_dowarn (aTHXo->interp.Idowarn) +#define PL_e_script (aTHXo->interp.Ie_script) +#define PL_egid (aTHXo->interp.Iegid) +#define PL_endav (aTHXo->interp.Iendav) +#define PL_envgv (aTHXo->interp.Ienvgv) +#define PL_errgv (aTHXo->interp.Ierrgv) +#define PL_error_count (aTHXo->interp.Ierror_count) +#define PL_euid (aTHXo->interp.Ieuid) +#define PL_eval_cond (aTHXo->interp.Ieval_cond) +#define PL_eval_mutex (aTHXo->interp.Ieval_mutex) +#define PL_eval_owner (aTHXo->interp.Ieval_owner) +#define PL_eval_root (aTHXo->interp.Ieval_root) +#define PL_eval_start (aTHXo->interp.Ieval_start) +#define PL_evalseq (aTHXo->interp.Ievalseq) +#define PL_exit_flags (aTHXo->interp.Iexit_flags) +#define PL_exitlist (aTHXo->interp.Iexitlist) +#define PL_exitlistlen (aTHXo->interp.Iexitlistlen) +#define PL_expect (aTHXo->interp.Iexpect) +#define PL_fdpid (aTHXo->interp.Ifdpid) +#define PL_filemode (aTHXo->interp.Ifilemode) +#define PL_forkprocess (aTHXo->interp.Iforkprocess) +#define PL_formfeed (aTHXo->interp.Iformfeed) +#define PL_generation (aTHXo->interp.Igeneration) +#define PL_gensym (aTHXo->interp.Igensym) +#define PL_gid (aTHXo->interp.Igid) +#define PL_glob_index (aTHXo->interp.Iglob_index) +#define PL_globalstash (aTHXo->interp.Iglobalstash) +#define PL_he_root (aTHXo->interp.Ihe_root) +#define PL_hintgv (aTHXo->interp.Ihintgv) +#define PL_hints (aTHXo->interp.Ihints) +#define PL_in_clean_all (aTHXo->interp.Iin_clean_all) +#define PL_in_clean_objs (aTHXo->interp.Iin_clean_objs) +#define PL_in_my (aTHXo->interp.Iin_my) +#define PL_in_my_stash (aTHXo->interp.Iin_my_stash) +#define PL_incgv (aTHXo->interp.Iincgv) +#define PL_initav (aTHXo->interp.Iinitav) +#define PL_inplace (aTHXo->interp.Iinplace) +#define PL_last_lop (aTHXo->interp.Ilast_lop) +#define PL_last_lop_op (aTHXo->interp.Ilast_lop_op) +#define PL_last_swash_hv (aTHXo->interp.Ilast_swash_hv) +#define PL_last_swash_key (aTHXo->interp.Ilast_swash_key) +#define PL_last_swash_klen (aTHXo->interp.Ilast_swash_klen) +#define PL_last_swash_slen (aTHXo->interp.Ilast_swash_slen) +#define PL_last_swash_tmps (aTHXo->interp.Ilast_swash_tmps) +#define PL_last_uni (aTHXo->interp.Ilast_uni) +#define PL_lastfd (aTHXo->interp.Ilastfd) +#define PL_laststatval (aTHXo->interp.Ilaststatval) +#define PL_laststype (aTHXo->interp.Ilaststype) +#define PL_lex_brackets (aTHXo->interp.Ilex_brackets) +#define PL_lex_brackstack (aTHXo->interp.Ilex_brackstack) +#define PL_lex_casemods (aTHXo->interp.Ilex_casemods) +#define PL_lex_casestack (aTHXo->interp.Ilex_casestack) +#define PL_lex_defer (aTHXo->interp.Ilex_defer) +#define PL_lex_dojoin (aTHXo->interp.Ilex_dojoin) +#define PL_lex_expect (aTHXo->interp.Ilex_expect) +#define PL_lex_formbrack (aTHXo->interp.Ilex_formbrack) +#define PL_lex_inpat (aTHXo->interp.Ilex_inpat) +#define PL_lex_inwhat (aTHXo->interp.Ilex_inwhat) +#define PL_lex_op (aTHXo->interp.Ilex_op) +#define PL_lex_repl (aTHXo->interp.Ilex_repl) +#define PL_lex_starts (aTHXo->interp.Ilex_starts) +#define PL_lex_state (aTHXo->interp.Ilex_state) +#define PL_lex_stuff (aTHXo->interp.Ilex_stuff) +#define PL_lineary (aTHXo->interp.Ilineary) +#define PL_linestart (aTHXo->interp.Ilinestart) +#define PL_linestr (aTHXo->interp.Ilinestr) +#define PL_localpatches (aTHXo->interp.Ilocalpatches) +#define PL_main_cv (aTHXo->interp.Imain_cv) +#define PL_main_root (aTHXo->interp.Imain_root) +#define PL_main_start (aTHXo->interp.Imain_start) +#define PL_max_intro_pending (aTHXo->interp.Imax_intro_pending) +#define PL_maxo (aTHXo->interp.Imaxo) +#define PL_maxsysfd (aTHXo->interp.Imaxsysfd) +#define PL_mess_sv (aTHXo->interp.Imess_sv) +#define PL_min_intro_pending (aTHXo->interp.Imin_intro_pending) +#define PL_minus_F (aTHXo->interp.Iminus_F) +#define PL_minus_a (aTHXo->interp.Iminus_a) +#define PL_minus_c (aTHXo->interp.Iminus_c) +#define PL_minus_l (aTHXo->interp.Iminus_l) +#define PL_minus_n (aTHXo->interp.Iminus_n) +#define PL_minus_p (aTHXo->interp.Iminus_p) +#define PL_modglobal (aTHXo->interp.Imodglobal) +#define PL_multi_close (aTHXo->interp.Imulti_close) +#define PL_multi_end (aTHXo->interp.Imulti_end) +#define PL_multi_open (aTHXo->interp.Imulti_open) +#define PL_multi_start (aTHXo->interp.Imulti_start) +#define PL_multiline (aTHXo->interp.Imultiline) +#define PL_nexttoke (aTHXo->interp.Inexttoke) +#define PL_nexttype (aTHXo->interp.Inexttype) +#define PL_nextval (aTHXo->interp.Inextval) +#define PL_nice_chunk (aTHXo->interp.Inice_chunk) +#define PL_nice_chunk_size (aTHXo->interp.Inice_chunk_size) +#define PL_nomemok (aTHXo->interp.Inomemok) +#define PL_nthreads (aTHXo->interp.Inthreads) +#define PL_nthreads_cond (aTHXo->interp.Inthreads_cond) +#define PL_numeric_local (aTHXo->interp.Inumeric_local) +#define PL_numeric_name (aTHXo->interp.Inumeric_name) +#define PL_numeric_radix (aTHXo->interp.Inumeric_radix) +#define PL_numeric_standard (aTHXo->interp.Inumeric_standard) +#define PL_ofmt (aTHXo->interp.Iofmt) +#define PL_oldbufptr (aTHXo->interp.Ioldbufptr) +#define PL_oldname (aTHXo->interp.Ioldname) +#define PL_oldoldbufptr (aTHXo->interp.Ioldoldbufptr) +#define PL_op_mask (aTHXo->interp.Iop_mask) +#define PL_op_seqmax (aTHXo->interp.Iop_seqmax) +#define PL_origalen (aTHXo->interp.Iorigalen) +#define PL_origargc (aTHXo->interp.Iorigargc) +#define PL_origargv (aTHXo->interp.Iorigargv) +#define PL_origenviron (aTHXo->interp.Iorigenviron) +#define PL_origfilename (aTHXo->interp.Iorigfilename) +#define PL_ors (aTHXo->interp.Iors) +#define PL_orslen (aTHXo->interp.Iorslen) +#define PL_osname (aTHXo->interp.Iosname) +#define PL_pad_reset_pending (aTHXo->interp.Ipad_reset_pending) +#define PL_padix (aTHXo->interp.Ipadix) +#define PL_padix_floor (aTHXo->interp.Ipadix_floor) +#define PL_patchlevel (aTHXo->interp.Ipatchlevel) +#define PL_pending_ident (aTHXo->interp.Ipending_ident) +#define PL_perl_destruct_level (aTHXo->interp.Iperl_destruct_level) +#define PL_perldb (aTHXo->interp.Iperldb) +#define PL_pidstatus (aTHXo->interp.Ipidstatus) +#define PL_preambleav (aTHXo->interp.Ipreambleav) +#define PL_preambled (aTHXo->interp.Ipreambled) +#define PL_preprocess (aTHXo->interp.Ipreprocess) +#define PL_profiledata (aTHXo->interp.Iprofiledata) +#define PL_psig_name (aTHXo->interp.Ipsig_name) +#define PL_psig_ptr (aTHXo->interp.Ipsig_ptr) +#define PL_ptr_table (aTHXo->interp.Iptr_table) +#define PL_replgv (aTHXo->interp.Ireplgv) +#define PL_rsfp (aTHXo->interp.Irsfp) +#define PL_rsfp_filters (aTHXo->interp.Irsfp_filters) +#define PL_runops (aTHXo->interp.Irunops) +#define PL_sawampersand (aTHXo->interp.Isawampersand) +#define PL_sh_path (aTHXo->interp.Ish_path) +#define PL_sighandlerp (aTHXo->interp.Isighandlerp) +#define PL_splitstr (aTHXo->interp.Isplitstr) +#define PL_srand_called (aTHXo->interp.Isrand_called) +#define PL_statusvalue (aTHXo->interp.Istatusvalue) +#define PL_statusvalue_vms (aTHXo->interp.Istatusvalue_vms) +#define PL_stderrgv (aTHXo->interp.Istderrgv) +#define PL_stdingv (aTHXo->interp.Istdingv) +#define PL_stopav (aTHXo->interp.Istopav) +#define PL_strtab (aTHXo->interp.Istrtab) +#define PL_strtab_mutex (aTHXo->interp.Istrtab_mutex) +#define PL_sub_generation (aTHXo->interp.Isub_generation) +#define PL_sublex_info (aTHXo->interp.Isublex_info) +#define PL_subline (aTHXo->interp.Isubline) +#define PL_subname (aTHXo->interp.Isubname) +#define PL_sv_arenaroot (aTHXo->interp.Isv_arenaroot) +#define PL_sv_count (aTHXo->interp.Isv_count) +#define PL_sv_mutex (aTHXo->interp.Isv_mutex) +#define PL_sv_no (aTHXo->interp.Isv_no) +#define PL_sv_objcount (aTHXo->interp.Isv_objcount) +#define PL_sv_root (aTHXo->interp.Isv_root) +#define PL_sv_undef (aTHXo->interp.Isv_undef) +#define PL_sv_yes (aTHXo->interp.Isv_yes) +#define PL_svref_mutex (aTHXo->interp.Isvref_mutex) +#define PL_sys_intern (aTHXo->interp.Isys_intern) +#define PL_tainting (aTHXo->interp.Itainting) +#define PL_thr_key (aTHXo->interp.Ithr_key) +#define PL_threadnum (aTHXo->interp.Ithreadnum) +#define PL_threads_mutex (aTHXo->interp.Ithreads_mutex) +#define PL_threadsv_names (aTHXo->interp.Ithreadsv_names) +#define PL_thrsv (aTHXo->interp.Ithrsv) +#define PL_tokenbuf (aTHXo->interp.Itokenbuf) +#define PL_uid (aTHXo->interp.Iuid) +#define PL_unsafe (aTHXo->interp.Iunsafe) +#define PL_utf8_alnum (aTHXo->interp.Iutf8_alnum) +#define PL_utf8_alnumc (aTHXo->interp.Iutf8_alnumc) +#define PL_utf8_alpha (aTHXo->interp.Iutf8_alpha) +#define PL_utf8_ascii (aTHXo->interp.Iutf8_ascii) +#define PL_utf8_cntrl (aTHXo->interp.Iutf8_cntrl) +#define PL_utf8_digit (aTHXo->interp.Iutf8_digit) +#define PL_utf8_graph (aTHXo->interp.Iutf8_graph) +#define PL_utf8_lower (aTHXo->interp.Iutf8_lower) +#define PL_utf8_mark (aTHXo->interp.Iutf8_mark) +#define PL_utf8_print (aTHXo->interp.Iutf8_print) +#define PL_utf8_punct (aTHXo->interp.Iutf8_punct) +#define PL_utf8_space (aTHXo->interp.Iutf8_space) +#define PL_utf8_tolower (aTHXo->interp.Iutf8_tolower) +#define PL_utf8_totitle (aTHXo->interp.Iutf8_totitle) +#define PL_utf8_toupper (aTHXo->interp.Iutf8_toupper) +#define PL_utf8_upper (aTHXo->interp.Iutf8_upper) +#define PL_utf8_xdigit (aTHXo->interp.Iutf8_xdigit) +#define PL_uudmap (aTHXo->interp.Iuudmap) +#define PL_warnhook (aTHXo->interp.Iwarnhook) +#define PL_xiv_arenaroot (aTHXo->interp.Ixiv_arenaroot) +#define PL_xiv_root (aTHXo->interp.Ixiv_root) +#define PL_xnv_root (aTHXo->interp.Ixnv_root) +#define PL_xpv_root (aTHXo->interp.Ixpv_root) +#define PL_xpvav_root (aTHXo->interp.Ixpvav_root) +#define PL_xpvbm_root (aTHXo->interp.Ixpvbm_root) +#define PL_xpvcv_root (aTHXo->interp.Ixpvcv_root) +#define PL_xpvhv_root (aTHXo->interp.Ixpvhv_root) +#define PL_xpviv_root (aTHXo->interp.Ixpviv_root) +#define PL_xpvlv_root (aTHXo->interp.Ixpvlv_root) +#define PL_xpvmg_root (aTHXo->interp.Ixpvmg_root) +#define PL_xpvnv_root (aTHXo->interp.Ixpvnv_root) +#define PL_xrv_root (aTHXo->interp.Ixrv_root) +#define PL_yychar (aTHXo->interp.Iyychar) +#define PL_yydebug (aTHXo->interp.Iyydebug) +#define PL_yyerrflag (aTHXo->interp.Iyyerrflag) +#define PL_yylval (aTHXo->interp.Iyylval) +#define PL_yynerrs (aTHXo->interp.Iyynerrs) +#define PL_yyval (aTHXo->interp.Iyyval) + +# else /* !PERL_OBJECT */ + +/* cases 1 and 4 above */ #define PL_IArgv PL_Argv #define PL_ICmd PL_Cmd @@ -708,12 +1114,13 @@ #define PL_IEnv PL_Env #define PL_ILIO PL_LIO #define PL_IMem PL_Mem +#define PL_IMemParse PL_MemParse +#define PL_IMemShared PL_MemShared #define PL_IProc PL_Proc #define PL_ISock PL_Sock #define PL_IStdIO PL_StdIO #define PL_Iamagic_generation PL_amagic_generation #define PL_Ian PL_an -#define PL_Iarchpat_auto PL_archpat_auto #define PL_Iargvgv PL_argvgv #define PL_Iargvout_stack PL_argvout_stack #define PL_Iargvoutgv PL_argvoutgv @@ -763,6 +1170,7 @@ #define PL_Ieval_root PL_eval_root #define PL_Ieval_start PL_eval_start #define PL_Ievalseq PL_evalseq +#define PL_Iexit_flags PL_exit_flags #define PL_Iexitlist PL_exitlist #define PL_Iexitlistlen PL_exitlistlen #define PL_Iexpect PL_expect @@ -803,7 +1211,6 @@ #define PL_Ilex_defer PL_lex_defer #define PL_Ilex_dojoin PL_lex_dojoin #define PL_Ilex_expect PL_lex_expect -#define PL_Ilex_fakebrack PL_lex_fakebrack #define PL_Ilex_formbrack PL_lex_formbrack #define PL_Ilex_inpat PL_lex_inpat #define PL_Ilex_inwhat PL_lex_inwhat @@ -874,6 +1281,8 @@ #define PL_Ipreambled PL_preambled #define PL_Ipreprocess PL_preprocess #define PL_Iprofiledata PL_profiledata +#define PL_Ipsig_name PL_psig_name +#define PL_Ipsig_ptr PL_psig_ptr #define PL_Iptr_table PL_ptr_table #define PL_Ireplgv PL_replgv #define PL_Irsfp PL_rsfp @@ -953,7 +1362,7 @@ #define PL_Iyynerrs PL_yynerrs #define PL_Iyyval PL_yyval -# if defined(USE_THREADS) +# if defined(USE_THREADS) /* case 4 above */ #define PL_Sv (aTHX->TSv) @@ -1090,8 +1499,8 @@ #define PL_watchaddr (aTHX->Twatchaddr) #define PL_watchok (aTHX->Twatchok) -# else /* !USE_THREADS */ -/* cases 1 and 6 above */ +# else /* !USE_THREADS */ +/* case 1 above */ #define PL_TSv PL_Sv #define PL_TXpv PL_Xpv @@ -1227,7 +1636,8 @@ #define PL_Twatchaddr PL_watchaddr #define PL_Twatchok PL_watchok -# endif /* USE_THREADS */ +# endif /* USE_THREADS */ +# endif /* PERL_OBJECT */ #endif /* MULTIPLICITY */ #if defined(PERL_GLOBAL_STRUCT) diff --git a/epoc/Config.pm b/epoc/Config.pm deleted file mode 100644 index 24dba58ca0..0000000000 --- a/epoc/Config.pm +++ /dev/null @@ -1,6 +0,0 @@ -package Config; - -use Exporter (); -@ISA = (Exporter); -@EXPORT = qw(%Config); -1; diff --git a/epoc/autosplit.pl b/epoc/autosplit.pl deleted file mode 100644 index 0d1e54dd2d..0000000000 --- a/epoc/autosplit.pl +++ /dev/null @@ -1,3 +0,0 @@ -use AutoSplit; -mkdir "/perl/lib/5.00562/auto", 0777; -autosplit("/perl/lib/5.00562/Getopt/Long.pm","/perl/lib/5.00562/auto", 1, 0, 0); diff --git a/epoc/config.h b/epoc/config.h deleted file mode 100644 index 9f7f37023e..0000000000 --- a/epoc/config.h +++ /dev/null @@ -1,2471 +0,0 @@ -/* This file (config_H) is a sample config.h file. If you are unable - to successfully run Configure, copy this file to config.h and - edit it to suit your system. -*/ -/* - * This file was produced by running the config_h.SH script, which - * gets its values from config.sh, which is generally produced by - * running Configure. - * - * Feel free to modify any of this as the need arises. Note, however, - * that running config_h.SH again will wipe out any changes you've made. - * For a more permanent change edit config.sh and rerun config_h.SH. - * - * $Id: Config_h.U,v 3.0.1.5 1997/02/28 14:57:43 ram Exp $ - */ - -/* - * Package name : perl5 - * Source directory : . - * Configuration time: Sat May 22 00:43:12 EET DST 1999 - * Configured by : jhi - * Target system : osf1 alpha.hut.fi v4.0 878 alpha - */ - -#ifndef _config_h_ -#define _config_h_ - -#define EPOC 1 -#define PERL_CORE 1 - -/* LOC_SED: - * This symbol holds the complete pathname to the sed program. - */ -/* #define LOC_SED "/usr/bin/sed" /**/ - -/* BIN: - * This symbol holds the path of the bin directory where the package will - * be installed. Program must be prepared to deal with ~name substitution. - */ -/* BIN_EXP: - * This symbol is the filename expanded version of the BIN symbol, for - * programs that do not want to deal with that at run-time. - */ -#define BIN "/perl" /**/ -#define BIN_EXP "/perl" /**/ - -/* HAS_ALARM: - * This symbol, if defined, indicates that the alarm routine is - * available. - */ -/* #define HAS_ALARM /**/ - -/* HASATTRIBUTE: - * This symbol indicates the C compiler can check for function attributes, - * such as printf formats. This is normally only supported by GNU cc. - */ -#ifdef __MARM__ -#define HASATTRIBUTE / **/ -#endif -#ifndef HASATTRIBUTE -#define __attribute__(_arg_) -#endif - -/* HAS_BCMP: - * This symbol is defined if the bcmp() routine is available to - * compare blocks of memory. - */ -#define HAS_BCMP /**/ - -/* HAS_BCOPY: - * This symbol is defined if the bcopy() routine is available to - * copy blocks of memory. - */ -#define HAS_BCOPY /**/ - -/* HAS_BZERO: - * This symbol is defined if the bzero() routine is available to - * set a memory block to 0. - */ -#define HAS_BZERO /**/ - -/* HAS_CHOWN: - * This symbol, if defined, indicates that the chown routine is - * available. - */ -/*#define HAS_CHOWN /**/ - -/* HAS_CHROOT: - * This symbol, if defined, indicates that the chroot routine is - * available. - */ -/*#define HAS_CHROOT /**/ - -/* HAS_CHSIZE: - * This symbol, if defined, indicates that the chsize routine is available - * to truncate files. You might need a -lx to get this routine. - */ -/*#define HAS_CHSIZE / **/ - -/* HASCONST: - * This symbol, if defined, indicates that this C compiler knows about - * the const type. There is no need to actually test for that symbol - * within your programs. The mere use of the "const" keyword will - * trigger the necessary tests. - */ -#define HASCONST /**/ -#ifndef HASCONST -#define const -#endif - -/* HAS_CRYPT: - * This symbol, if defined, indicates that the crypt routine is available - * to encrypt passwords and the like. - */ -/*#define HAS_CRYPT /**/ - -/* HAS_CUSERID: - * This symbol, if defined, indicates that the cuserid routine is - * available to get character login names. - */ -/*#define HAS_CUSERID /**/ - -/* HAS_DBL_DIG: - * This symbol, if defined, indicates that this system's <float.h> - * or <limits.h> defines the symbol DBL_DIG, which is the number - * of significant digits in a double precision number. If this - * symbol is not defined, a guess of 15 is usually pretty good. - */ -/*#define HAS_DBL_DIG /* */ - -/* HAS_DIFFTIME: - * This symbol, if defined, indicates that the difftime routine is - * available. - */ -#define HAS_DIFFTIME /**/ - -/* HAS_DLERROR: - * This symbol, if defined, indicates that the dlerror routine is - * available to return a string describing the last error that - * occurred from a call to dlopen(), dlclose() or dlsym(). - */ -/*#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. - */ -/*#define HAS_DUP2 /**/ - -/* HAS_FCHMOD: - * This symbol, if defined, indicates that the fchmod routine is available - * to change mode of opened files. If unavailable, use chmod(). - */ -/*#define HAS_FCHMOD /**/ - -/* HAS_FCHOWN: - * This symbol, if defined, indicates that the fchown routine is available - * to change ownership of opened files. If unavailable, use chown(). - */ -/*#define HAS_FCHOWN /**/ - -/* HAS_FCNTL: - * This symbol, if defined, indicates to the C program that - * the fcntl() function exists. - */ -/*#define HAS_FCNTL /**/ - -/* HAS_FGETPOS: - * This symbol, if defined, indicates that the fgetpos routine is - * available to get the file position indicator, similar to ftell(). - */ -#define HAS_FGETPOS /**/ - -/* FLEXFILENAMES: - * This symbol, if defined, indicates that the system supports filenames - * longer than 14 characters. - */ -#define FLEXFILENAMES /**/ - -/* HAS_FLOCK: - * This symbol, if defined, indicates that the flock routine is - * available to do file locking. - */ -/*#define HAS_FLOCK /**/ - -/* HAS_FORK: - * This symbol, if defined, indicates that the fork routine is - * available. - */ -/*#define HAS_FORK /**/ - -/* HAS_FSETPOS: - * This symbol, if defined, indicates that the fsetpos routine is - * available to set the file position indicator, similar to fseek(). - */ -#define HAS_FSETPOS /**/ - -/* HAS_GETTIMEOFDAY: - * This symbol, if defined, indicates that the gettimeofday() system - * call is available for a sub-second accuracy clock. Usually, the file - * <sys/resource.h> needs to be included (see I_SYS_RESOURCE). - * The type "Timeval" should be used to refer to "struct timeval". - */ -#define HAS_GETTIMEOFDAY /**/ -#ifdef HAS_GETTIMEOFDAY -#define Timeval struct timeval /* Structure used by gettimeofday() */ -#endif - -/* HAS_GETGROUPS: - * This symbol, if defined, indicates that the getgroups() routine is - * available to get the list of process groups. If unavailable, multiple - * groups are probably not supported. - */ -/*#define HAS_GETGROUPS /**/ - -/* HAS_GETLOGIN: - * This symbol, if defined, indicates that the getlogin routine is - * available to get the login name. - */ -/*#define HAS_GETLOGIN /**/ - -/* HAS_GETPGID: - * This symbol, if defined, indicates to the C program that - * the getpgid(pid) function is available to get the - * process group id. - */ -/*#define HAS_GETPGID /**/ - -/* HAS_GETPGRP: - * This symbol, if defined, indicates that the getpgrp routine is - * available to get the current process group. - */ -/* USE_BSD_GETPGRP: - * This symbol, if defined, indicates that getpgrp needs one - * arguments whereas USG one needs none. - */ -/*#define HAS_GETPGRP /**/ -/*#define USE_BSD_GETPGRP / **/ - -/* HAS_GETPGRP2: - * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) - * routine is available to get the current process group. - */ -/*#define HAS_GETPGRP2 / **/ - -/* HAS_GETPPID: - * This symbol, if defined, indicates that the getppid routine is - * available to get the parent process ID. - */ -/*#define HAS_GETPPID /**/ - -/* HAS_GETPRIORITY: - * This symbol, if defined, indicates that the getpriority routine is - * available to get a process's priority. - */ -/*#define HAS_GETPRIORITY /**/ - -/* HAS_INET_ATON: - * This symbol, if defined, indicates to the C program that the - * inet_aton() function is available to parse IP address "dotted-quad" - * strings. - */ -/*#define HAS_INET_ATON /**/ - -/* HAS_KILLPG: - * This symbol, if defined, indicates that the killpg routine is available - * to kill process groups. If unavailable, you probably should use kill - * with a negative process number. - */ -/*#define HAS_KILLPG /**/ - -/* HAS_LINK: - * This symbol, if defined, indicates that the link routine is - * available to create hard links. - */ -/*#define HAS_LINK /**/ - -/* HAS_LOCALECONV: - * This symbol, if defined, indicates that the localeconv routine is - * available for numeric and monetary formatting conventions. - */ -/*#define HAS_LOCALECONV /**/ - -/* HAS_LOCKF: - * This symbol, if defined, indicates that the lockf routine is - * available to do file locking. - */ -/*#define HAS_LOCKF /**/ - -/* HAS_LSTAT: - * This symbol, if defined, indicates that the lstat routine is - * available to do file stats on symbolic links. - */ -/*#define HAS_LSTAT /**/ - -/* HAS_MBLEN: - * This symbol, if defined, indicates that the mblen routine is available - * to find the number of bytes in a multibye character. - */ -/*#define HAS_MBLEN /**/ - -/* HAS_MBSTOWCS: - * This symbol, if defined, indicates that the mbstowcs routine is - * available to covert a multibyte string into a wide character string. - */ -/*#define HAS_MBSTOWCS /**/ - -/* HAS_MBTOWC: - * This symbol, if defined, indicates that the mbtowc routine is available - * to covert a multibyte to a wide character. - */ -/*#define HAS_MBTOWC /**/ - -/* HAS_MEMCMP: - * This symbol, if defined, indicates that the memcmp routine is available - * to compare blocks of memory. - */ -#define HAS_MEMCMP /**/ - -/* HAS_MEMCPY: - * This symbol, if defined, indicates that the memcpy routine is available - * to copy blocks of memory. - */ -#define HAS_MEMCPY /**/ - -/* HAS_MEMMOVE: - * This symbol, if defined, indicates that the memmove routine is available - * to copy potentially overlapping blocks of memory. This should be used - * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your - * own version. - */ -#define HAS_MEMMOVE /**/ - -/* HAS_MEMSET: - * This symbol, if defined, indicates that the memset routine is available - * to set blocks of memory. - */ -#define HAS_MEMSET /**/ - -/* HAS_MKDIR: - * This symbol, if defined, indicates that the mkdir routine is available - * to create directories. Otherwise you should fork off a new process to - * exec /bin/mkdir. - */ -#define HAS_MKDIR /**/ - -/* HAS_MKFIFO: - * This symbol, if defined, indicates that the mkfifo routine is - * available to create FIFOs. Otherwise, mknod should be able to - * do it for you. However, if mkfifo is there, mknod might require - * super-user privileges which mkfifo will not. - */ -/*#define HAS_MKFIFO /**/ - -/* HAS_MKTIME: - * This symbol, if defined, indicates that the mktime routine is - * available. - */ -#define HAS_MKTIME /**/ - -/* HAS_NICE: - * This symbol, if defined, indicates that the nice routine is - * available. - */ -/*#define HAS_NICE /**/ - -/* HAS_PATHCONF: - * This symbol, if defined, indicates that pathconf() is available - * to determine file-system related limits and options associated - * with a given filename. - */ -/* HAS_FPATHCONF: - * This symbol, if defined, indicates that pathconf() is available - * to determine file-system related limits and options associated - * with a given open file descriptor. - */ -/*#define HAS_PATHCONF /**/ -/*#define HAS_FPATHCONF /**/ - -/* HAS_PAUSE: - * This symbol, if defined, indicates that the pause routine is - * available to suspend a process until a signal is received. - */ -/*#define HAS_PAUSE /**/ - -/* HAS_PIPE: - * This symbol, if defined, indicates that the pipe routine is - * available to create an inter-process channel. - */ -/*#define HAS_PIPE /**/ - -/* HAS_POLL: - * This symbol, if defined, indicates that the poll routine is - * available to poll active file descriptors. You may safely - * include <poll.h> when this symbol is defined. - */ -/*#define HAS_POLL /**/ - -/* HAS_READDIR: - * This symbol, if defined, indicates that the readdir routine is - * available to read directory entries. You may have to include - * <dirent.h>. See I_DIRENT. - */ -#define HAS_READDIR /**/ - -/* HAS_SEEKDIR: - * This symbol, if defined, indicates that the seekdir routine is - * available. You may have to include <dirent.h>. See I_DIRENT. - */ -#define HAS_SEEKDIR /**/ - -/* HAS_TELLDIR: - * This symbol, if defined, indicates that the telldir routine is - * available. You may have to include <dirent.h>. See I_DIRENT. - */ -#define HAS_TELLDIR /**/ - -/* HAS_REWINDDIR: - * This symbol, if defined, indicates that the rewinddir routine is - * available. You may have to include <dirent.h>. See I_DIRENT. - */ -#define HAS_REWINDDIR /**/ - -/* HAS_READLINK: - * This symbol, if defined, indicates that the readlink routine is - * available to read the value of a symbolic link. - */ -/*#define HAS_READLINK /**/ - -/* HAS_RENAME: - * This symbol, if defined, indicates that the rename routine is available - * to rename files. Otherwise you should do the unlink(), link(), unlink() - * trick. - */ -#define HAS_RENAME /**/ - -/* HAS_RMDIR: - * This symbol, if defined, indicates that the rmdir routine is - * available to remove directories. Otherwise you should fork off a - * new process to exec /bin/rmdir. - */ -#define HAS_RMDIR /**/ - -/* HAS_SELECT: - * This symbol, if defined, indicates that the select routine is - * available to select active file descriptors. If the timeout field - * is used, <sys/time.h> may need to be included. - */ -/*#define HAS_SELECT /**/ - -/* HAS_SETEGID: - * This symbol, if defined, indicates that the setegid routine is available - * to change the effective gid of the current program. - */ -/*#define HAS_SETEGID /**/ - -/* HAS_SETEUID: - * This symbol, if defined, indicates that the seteuid routine is available - * to change the effective uid of the current program. - */ -/*#define HAS_SETEUID /**/ - -/* HAS_SETLINEBUF: - * This symbol, if defined, indicates that the setlinebuf routine is - * available to change stderr or stdout from block-buffered or unbuffered - * to a line-buffered mode. - */ -/*#define HAS_SETLINEBUF /**/ - -/* HAS_SETLOCALE: - * This symbol, if defined, indicates that the setlocale routine is - * available to handle locale-specific ctype implementations. - */ -/*#define HAS_SETLOCALE /**/ - -/* HAS_SETPGID: - * This symbol, if defined, indicates that the setpgid(pid, gpid) - * routine is available to set process group ID. - */ -/*#define HAS_SETPGID /**/ - -/* HAS_SETPGRP: - * This symbol, if defined, indicates that the setpgrp routine is - * available to set the current process group. - */ -/* USE_BSD_SETPGRP: - * This symbol, if defined, indicates that setpgrp needs two - * arguments whereas USG one needs none. See also HAS_SETPGID - * for a POSIX interface. - */ -/*#define HAS_SETPGRP /**/ -/*#define USE_BSD_SETPGRP /**/ - -/* HAS_SETPGRP2: - * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) - * routine is available to set the current process group. - */ -/*#define HAS_SETPGRP2 / **/ - -/* HAS_SETPRIORITY: - * This symbol, if defined, indicates that the setpriority routine is - * available to set a process's priority. - */ -/*#define HAS_SETPRIORITY /**/ - -/* HAS_SETREGID: - * This symbol, if defined, indicates that the setregid routine is - * available to change the real and effective gid of the current - * process. - */ -/* HAS_SETRESGID: - * This symbol, if defined, indicates that the setresgid routine is - * available to change the real, effective and saved gid of the current - * process. - */ -/*#define HAS_SETREGID /**/ -/*#define HAS_SETRESGID / **/ - -/* HAS_SETREUID: - * This symbol, if defined, indicates that the setreuid routine is - * available to change the real and effective uid of the current - * process. - */ -/* HAS_SETRESUID: - * This symbol, if defined, indicates that the setresuid routine is - * available to change the real, effective and saved uid of the current - * process. - */ -/*#define HAS_SETREUID /**/ -/*#define HAS_SETRESUID / **/ - -/* HAS_SETRGID: - * This symbol, if defined, indicates that the setrgid routine is available - * to change the real gid of the current program. - */ -/*#define HAS_SETRGID /**/ - -/* HAS_SETRUID: - * This symbol, if defined, indicates that the setruid routine is available - * to change the real uid of the current program. - */ -/*#define HAS_SETRUID /**/ - -/* HAS_SETSID: - * This symbol, if defined, indicates that the setsid routine is - * available to set the process group ID. - */ -/*#define HAS_SETSID /**/ - -/* Shmat_t: - * This symbol holds the return type of the shmat() system call. - * Usually set to 'void *' or 'char *'. - */ -/* HAS_SHMAT_PROTOTYPE: - * This symbol, if defined, indicates that the sys/shm.h includes - * a prototype for shmat(). Otherwise, it is up to the program to - * guess one. Shmat_t shmat _((int, Shmat_t, int)) is a good guess, - * but not always right so it should be emitted by the program only - * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs. - */ -/*#define Shmat_t void * /**/ -/*#define HAS_SHMAT_PROTOTYPE /**/ - -/* HAS_STRCHR: - * This symbol is defined to indicate that the strchr()/strrchr() - * functions are available for string searching. If not, try the - * index()/rindex() pair. - */ -/* HAS_INDEX: - * This symbol is defined to indicate that the index()/rindex() - * functions are available for string searching. - */ -#define HAS_STRCHR /**/ -/*#define HAS_INDEX / **/ - -/* HAS_STRCOLL: - * This symbol, if defined, indicates that the strcoll routine is - * available to compare strings using collating information. - */ -#define HAS_STRCOLL /**/ - -/* USE_STRUCT_COPY: - * This symbol, if defined, indicates that this C compiler knows how - * to copy structures. If undefined, you'll need to use a block copy - * routine of some sort instead. - */ -#define USE_STRUCT_COPY /**/ - -/* HAS_STRTOD: - * This symbol, if defined, indicates that the strtod routine is - * available to provide better numeric string conversion than atof(). - */ -#define HAS_STRTOD /**/ - -/* HAS_STRTOL: - * This symbol, if defined, indicates that the strtol routine is available - * to provide better numeric string conversion than atoi() and friends. - */ -#define HAS_STRTOL /**/ - -/* HAS_STRTOUL: - * This symbol, if defined, indicates that the strtoul routine is - * available to provide conversion of strings to unsigned long. - */ -#define HAS_STRTOUL /**/ - -/* HAS_STRXFRM: - * This symbol, if defined, indicates that the strxfrm() routine is - * available to transform strings. - */ -#define HAS_STRXFRM /**/ - -/* HAS_SYMLINK: - * This symbol, if defined, indicates that the symlink routine is available - * to create symbolic links. - */ -/*#define HAS_SYMLINK /**/ - -/* HAS_SYSCALL: - * This symbol, if defined, indicates that the syscall routine is - * available to call arbitrary system calls. If undefined, that's tough. - */ -/*#define HAS_SYSCALL /**/ - -/* HAS_SYSCONF: - * This symbol, if defined, indicates that sysconf() is available - * to determine system related limits and options. - */ -#define HAS_SYSCONF /**/ - -/* HAS_SYSTEM: - * This symbol, if defined, indicates that the system routine is - * available to issue a shell command. - */ -#define HAS_SYSTEM /**/ - -/* HAS_TCGETPGRP: - * This symbol, if defined, indicates that the tcgetpgrp routine is - * available to get foreground process group ID. - */ -/*#define HAS_TCGETPGRP /**/ - -/* HAS_TCSETPGRP: - * This symbol, if defined, indicates that the tcsetpgrp routine is - * available to set foreground process group ID. - */ -/*#define HAS_TCSETPGRP /**/ - -/* HAS_TRUNCATE: - * This symbol, if defined, indicates that the truncate routine is - * available to truncate files. - */ -/*#define HAS_TRUNCATE /**/ - -/* HAS_TZNAME: - * This symbol, if defined, indicates that the tzname[] array is - * available to access timezone names. - */ -/*#define HAS_TZNAME /**/ - -/* HAS_UMASK: - * This symbol, if defined, indicates that the umask routine is - * available to set and get the value of the file creation mask. - */ -/*#define HAS_UMASK /**/ - -/* HASVOLATILE: - * This symbol, if defined, indicates that this C compiler knows about - * the volatile declaration. - */ -#define HASVOLATILE /**/ -#ifndef HASVOLATILE -#define volatile -#endif - -/* HAS_WAIT4: - * This symbol, if defined, indicates that wait4() exists. - */ -/*#define HAS_WAIT4 /**/ - -/* HAS_WAITPID: - * This symbol, if defined, indicates that the waitpid routine is - * available to wait for child process. - */ -/*#define HAS_WAITPID /**/ - -/* HAS_WCSTOMBS: - * This symbol, if defined, indicates that the wcstombs routine is - * available to convert wide character strings to multibyte strings. - */ -/*#define HAS_WCSTOMBS /**/ - -/* HAS_WCTOMB: - * This symbol, if defined, indicates that the wctomb routine is available - * to covert a wide character to a multibyte. - */ -/*#define HAS_WCTOMB /**/ - -/* I_ARPA_INET: - * This symbol, if defined, indicates to the C program that it should - * include <arpa/inet.h> to get inet_addr and friends declarations. - */ -#define I_ARPA_INET /**/ - -/* I_DBM: - * This symbol, if defined, indicates that <dbm.h> exists and should - * be included. - */ -/* I_RPCSVC_DBM: - * This symbol, if defined, indicates that <rpcsvc/dbm.h> exists and - * should be included. - */ -/*#define I_DBM /**/ -/*#define I_RPCSVC_DBM / **/ - -/* I_DIRENT: - * This symbol, if defined, indicates to the C program that it should - * include <dirent.h>. Using this symbol also triggers the definition - * of the Direntry_t define which ends up being 'struct dirent' or - * 'struct direct' depending on the availability of <dirent.h>. - */ -/* DIRNAMLEN: - * This symbol, if defined, indicates to the C program that the length - * of directory entry names is provided by a d_namlen field. Otherwise - * you need to do strlen() on the d_name field. - */ -/* Direntry_t: - * This symbol is set to 'struct direct' or 'struct dirent' depending on - * whether dirent is available or not. You should use this pseudo type to - * portably declare your directory entries. - */ -#define I_DIRENT /**/ -/*#define DIRNAMLEN /**/ -#define Direntry_t struct dirent - -/* I_DLFCN: - * This symbol, if defined, indicates that <dlfcn.h> exists and should - * be included. - */ -/*#define I_DLFCN /**/ - -/* I_FCNTL: - * This manifest constant tells the C program to include <fcntl.h>. - */ -#define I_FCNTL / **/ - -/* I_FLOAT: - * This symbol, if defined, indicates to the C program that it should - * include <float.h> to get definition of symbols like DBL_MAX or - * DBL_MIN, i.e. machine dependent floating point values. - */ -/*#define I_FLOAT /**/ - -/* I_LIMITS: - * This symbol, if defined, indicates to the C program that it should - * include <limits.h> to get definition of symbols like WORD_BIT or - * LONG_MAX, i.e. machine dependant limitations. - */ -#define I_LIMITS /**/ - -/* I_LOCALE: - * This symbol, if defined, indicates to the C program that it should - * include <locale.h>. - */ -/*#define I_LOCALE /**/ - -/* I_MATH: - * This symbol, if defined, indicates to the C program that it should - * include <math.h>. - */ -#define I_MATH /**/ - -/* I_MEMORY: - * This symbol, if defined, indicates to the C program that it should - * include <memory.h>. - */ -/*#define I_MEMORY / **/ - -/* I_NDBM: - * This symbol, if defined, indicates that <ndbm.h> exists and should - * be included. - */ -/*#define I_NDBM /**/ - -/* I_NET_ERRNO: - * This symbol, if defined, indicates that <net/errno.h> exists and - * should be included. - */ -/*#define I_NET_ERRNO / **/ - -/* I_NETINET_IN: - * This symbol, if defined, indicates to the C program that it should - * include <netinet/in.h>. Otherwise, you may try <sys/in.h>. - */ -#define I_NETINET_IN /**/ - -/* I_SFIO: - * This symbol, if defined, indicates to the C program that it should - * include <sfio.h>. - */ -/*#define I_SFIO / **/ - -/* I_STDDEF: - * This symbol, if defined, indicates that <stddef.h> exists and should - * be included. - */ -#define I_STDDEF /**/ - -/* I_STDLIB: - * This symbol, if defined, indicates that <stdlib.h> exists and should - * be included. - */ -#define I_STDLIB /**/ - -/* I_STRING: - * This symbol, if defined, indicates to the C program that it should - * include <string.h> (USG systems) instead of <strings.h> (BSD systems). - */ -#define I_STRING /**/ - -/* I_SYS_DIR: - * This symbol, if defined, indicates to the C program that it should - * include <sys/dir.h>. - */ -/*#define I_SYS_DIR /**/ - -/* I_SYS_FILE: - * This symbol, if defined, indicates to the C program that it should - * include <sys/file.h> to get definition of R_OK and friends. - */ -/*#define I_SYS_FILE /**/ - -/* I_SYS_IOCTL: - * This symbol, if defined, indicates that <sys/ioctl.h> exists and should - * be included. Otherwise, include <sgtty.h> or <termio.h>. - */ -#define I_SYS_IOCTL /**/ - -/* I_SYS_NDIR: - * This symbol, if defined, indicates to the C program that it should - * include <sys/ndir.h>. - */ -/*#define I_SYS_NDIR / **/ - -/* I_SYS_PARAM: - * This symbol, if defined, indicates to the C program that it should - * include <sys/param.h>. - */ -#define I_SYS_PARAM /**/ - -/* I_SYS_RESOURCE: - * This symbol, if defined, indicates to the C program that it should - * include <sys/resource.h>. - */ -#define I_SYS_RESOURCE /**/ - -/* I_SYS_SELECT: - * This symbol, if defined, indicates to the C program that it should - * include <sys/select.h> in order to get definition of struct timeval. - */ -/*#define I_SYS_SELECT /**/ - -/* I_SYS_STAT: - * This symbol, if defined, indicates to the C program that it should - * include <sys/stat.h>. - */ -#define I_SYS_STAT /**/ - -/* I_SYS_TIMES: - * This symbol, if defined, indicates to the C program that it should - * include <sys/times.h>. - */ -#define I_SYS_TIMES /**/ - -/* I_SYS_TYPES: - * This symbol, if defined, indicates to the C program that it should - * include <sys/types.h>. - */ -#define I_SYS_TYPES /**/ - -/* I_SYS_UN: - * This symbol, if defined, indicates to the C program that it should - * include <sys/un.h> to get UNIX domain socket definitions. - */ -/*#define I_SYS_UN /**/ - -/* I_SYS_WAIT: - * This symbol, if defined, indicates to the C program that it should - * include <sys/wait.h>. - */ -#define I_SYS_WAIT /**/ - -/* I_TERMIO: - * This symbol, if defined, indicates that the program should include - * <termio.h> rather than <sgtty.h>. There are also differences in - * the ioctl() calls that depend on the value of this symbol. - */ -/* I_TERMIOS: - * This symbol, if defined, indicates that the program should include - * the POSIX termios.h rather than sgtty.h or termio.h. - * There are also differences in the ioctl() calls that depend on the - * value of this symbol. - */ -/* I_SGTTY: - * This symbol, if defined, indicates that the program should include - * <sgtty.h> rather than <termio.h>. There are also differences in - * the ioctl() calls that depend on the value of this symbol. - */ -/*#define I_TERMIO / **/ -/*#define I_TERMIOS /**/ -/*#define I_SGTTY / **/ - -/* I_UNISTD: - * This symbol, if defined, indicates to the C program that it should - * include <unistd.h>. - */ -#define I_UNISTD /**/ - -/* I_UTIME: - * This symbol, if defined, indicates to the C program that it should - * include <utime.h>. - */ -/*#define I_UTIME /**/ - -/* I_VALUES: - * This symbol, if defined, indicates to the C program that it should - * include <values.h> to get definition of symbols like MINFLOAT or - * MAXLONG, i.e. machine dependant limitations. Probably, you - * should use <limits.h> instead, if it is available. - */ -/*#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. - */ -/*#define I_VFORK / **/ - -/* CAN_PROTOTYPE: - * If defined, this macro indicates that the C compiler can handle - * function prototypes. - */ -/* _: - * This macro is used to declare function parameters for folks who want - * to make declarations with prototypes using a different style than - * the above macros. Use double parentheses. For example: - * - * int main _((int argc, char *argv[])); - */ -#define CAN_PROTOTYPE /**/ -#ifdef CAN_PROTOTYPE -#define _(args) args -#else -#define _(args) () -#endif - -/* SH_PATH: - * This symbol contains the full pathname to the shell used on this - * on this system to execute Bourne shell scripts. Usually, this will be - * /bin/sh, though it's possible that some systems will have /bin/ksh, - * /bin/pdksh, /bin/ash, /bin/bash, or even something such as - * D:/bin/sh.exe. - */ -#define SH_PATH "/bin/sh" /**/ - -/* STDCHAR: - * This symbol is defined to be the type of char used in stdio.h. - * It has the values "unsigned char" or "char". - */ -#define STDCHAR char /**/ - -/* HAS_ACCESSX: - * This symbol, if defined, indicates that the accessx routine is - * available to do extended access checks. - */ -/*#define HAS_ACCESSX / **/ - -/* HAS_EACCESS: - * This symbol, if defined, indicates that the eaccess routine is - * available to do extended access checks. - */ -/*#define HAS_EACCESS / **/ - -/* I_SYS_ACCESS: - * This symbol, if defined, indicates to the C program that it should - * include <sys/access.h>. - */ -/*#define I_SYS_ACCESS /**/ - -/* I_SYS_SECURITY: - * This symbol, if defined, indicates to the C program that it should - * include <sys/security.h>. - */ -/*#define I_SYS_SECURITY /**/ - -/* CROSSCOMPILE: - * This symbol, if defined, signifies that we our - * build process is a cross-compilation. - */ -#define CROSSCOMPILE / **/ - -/* INTSIZE: - * This symbol contains the value of sizeof(int) so that the C - * preprocessor can make decisions based on it. - */ -/* LONGSIZE: - * This symbol contains the value of sizeof(long) so that the C - * preprocessor can make decisions based on it. - */ -/* SHORTSIZE: - * This symbol contains the value of sizeof(short) so that the C - * preprocessor can make decisions based on it. - */ -#define INTSIZE 4 /**/ -#define LONGSIZE 4 /**/ -#define SHORTSIZE 2 /**/ - -/* MULTIARCH: - * This symbol, if defined, signifies that the build - * process will produce some binary files that are going to be - * used in a cross-platform environment. This is the case for - * example with the NeXT "fat" binaries that contain executables - * for several CPUs. - */ -#define MULTIARCH / **/ - -/* MEM_ALIGNBYTES: - * This symbol contains the number of bytes required to align a - * double. Usual values are 2, 4 and 8. The default is eight, - * for safety. - */ -#if defined(CROSSCOMPILE) || defined(MULTIARCH) -# define MEM_ALIGNBYTES 8 -#else -#define MEM_ALIGNBYTES 8 -#endif - -/* BYTEORDER: - * This symbol holds the hexadecimal constant defined in byteorder, - * i.e. 0x1234 or 0x4321, etc... - * If the compiler supports cross-compiling or multiple-architecture - * binaries (eg. on NeXT systems), use compiler-defined macros to - * determine the byte order. - * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture - * Binaries (MAB) on either big endian or little endian machines. - * The endian-ness is available at compile-time. This only matters - * for perl, where the config.h can be generated and installed on - * one system, and used by a different architecture to build an - * extension. Older versions of NeXT that might not have - * defined either *_ENDIAN__ were all on Motorola 680x0 series, - * so the default case (for NeXT) is big endian to catch them. - * This might matter for NeXT 3.0. - */ -#if defined(CROSSCOMPILE) || defined(MULTIARCH) -# ifdef __LITTLE_ENDIAN__ -# if LONGSIZE == 4 -# define BYTEORDER 0x1234 -# else -# if LONGSIZE == 8 -# define BYTEORDER 0x12345678 -# endif -# endif -# else -# ifdef __BIG_ENDIAN__ -# if LONGSIZE == 4 -# define BYTEORDER 0x4321 -# else -# if LONGSIZE == 8 -# define BYTEORDER 0x87654321 -# endif -# endif -# endif -# endif -# if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__)) -# define BYTEORDER 0x4321 -# endif -#else -#define BYTEORDER 0x12345678 /* large digits for MSB */ -#endif /* NeXT */ - -/* CASTI32: - * This symbol is defined if the C compiler can cast negative - * or large floating point numbers to 32-bit ints. - */ -/*#define CASTI32 / **/ - -/* CASTNEGFLOAT: - * This symbol is defined if the C compiler can cast negative - * numbers to unsigned longs, ints and shorts. - */ -/* CASTFLAGS: - * This symbol contains flags that say what difficulties the compiler - * has casting odd floating values to unsigned long: - * 0 = ok - * 1 = couldn't cast < 0 - * 2 = couldn't cast >= 0x80000000 - * 4 = couldn't cast in argument expression list - */ -/*#define CASTNEGFLOAT /**/ -/*#define CASTFLAGS 0 /**/ - -/* VOID_CLOSEDIR: - * This symbol, if defined, indicates that the closedir() routine - * does not return a value. - */ -/*#define VOID_CLOSEDIR / **/ - -/* HAS_FD_SET: - * This symbol, when defined, indicates presence of the fd_set typedef - * in <sys/types.h> - */ -#define HAS_FD_SET /**/ - -/* Gconvert: - * This preprocessor macro is defined to convert a floating point - * number to a string without a trailing decimal point. This - * emulates the behavior of sprintf("%g"), but is sometimes much more - * efficient. If gconvert() is not available, but gcvt() drops the - * trailing decimal point, then gcvt() is used. If all else fails, - * a macro using sprintf("%g") is used. Arguments for the Gconvert - * macro are: value, number of digits, whether trailing zeros should - * be retained, and the output buffer. - * Possible values are: - * d_Gconvert='gconvert((x),(n),(t),(b))' - * d_Gconvert='gcvt((x),(n),(b))' - * d_Gconvert='sprintf((b),"%.*g",(n),(x))' - * The last two assume trailing zeros should not be kept. - */ -#define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x)) - -/* HAS_GNULIBC: - * This symbol, if defined, indicates to the C program that - * the GNU C library is being used. - */ -/*#define HAS_GNULIBC / **/ -/* HAS_ISASCII: - * This manifest constant lets the C program know that isascii - * is available. - */ -#define HAS_ISASCII /**/ - -/* HAS_LCHOWN: - * This symbol, if defined, indicates that the lchown routine is - * available to operate on a symbolic link (instead of following the - * link). - */ -/*##define HAS_LCHOWN /**/ - -/* HAS_OPEN3: - * This manifest constant lets the C program know that the three - * argument form of open(2) is available. - */ -#define HAS_OPEN3 /**/ - -/* HAS_SAFE_BCOPY: - * This symbol, if defined, indicates that the bcopy routine is available - * to copy potentially overlapping memory blocks. Otherwise you should - * probably use memmove() or memcpy(). If neither is defined, roll your - * own version. - */ -/*##define HAS_SAFE_BCOPY /**/ - -/* HAS_SAFE_MEMCPY: - * This symbol, if defined, indicates that the memcpy routine is available - * to copy potentially overlapping memory blocks. Otherwise you should - * probably use memmove() or memcpy(). If neither is defined, roll your - * own version. - */ -/*#define HAS_SAFE_MEMCPY / **/ - -/* HAS_SANE_MEMCMP: - * This symbol, if defined, indicates that the memcmp routine is available - * and can be used to compare relative magnitudes of chars with their high - * bits set. If it is not defined, roll your own version. - */ -#define HAS_SANE_MEMCMP /**/ - -/* HAS_SIGACTION: - * This symbol, if defined, indicates that Vr4's sigaction() routine - * is available. - */ -/*##define HAS_SIGACTION /**/ - -/* HAS_SIGSETJMP: - * This variable indicates to the C program that the sigsetjmp() - * routine is available to save the calling process's registers - * and stack environment for later use by siglongjmp(), and - * to optionally save the process's signal mask. See - * Sigjmp_buf, Sigsetjmp, and Siglongjmp. - */ -/* Sigjmp_buf: - * This is the buffer type to be used with Sigsetjmp and Siglongjmp. - */ -/* Sigsetjmp: - * This macro is used in the same way as sigsetjmp(), but will invoke - * traditional setjmp() if sigsetjmp isn't available. - * See HAS_SIGSETJMP. - */ -/* Siglongjmp: - * This macro is used in the same way as siglongjmp(), but will invoke - * traditional longjmp() if siglongjmp isn't available. - * See HAS_SIGSETJMP. - */ -/*##define HAS_SIGSETJMP /**/ -#ifdef HAS_SIGSETJMP -#define Sigjmp_buf sigjmp_buf -#define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask)) -#define Siglongjmp(buf,retval) siglongjmp((buf),(retval)) -#else -#define Sigjmp_buf jmp_buf -#define Sigsetjmp(buf,save_mask) setjmp((buf)) -#define Siglongjmp(buf,retval) longjmp((buf),(retval)) -#endif - -/* USE_STDIO_PTR: - * This symbol is defined if the _ptr and _cnt fields (or similar) - * of the stdio FILE structure can be used to access the stdio buffer - * for a file handle. If this is defined, then the FILE_ptr(fp) - * and FILE_cnt(fp) macros will also be defined and should be used - * to access these fields. - */ -/* FILE_ptr: - * This macro is used to access the _ptr field (or equivalent) of the - * FILE structure pointed to by its argument. This macro will always be - * defined if USE_STDIO_PTR is defined. - */ -/* STDIO_PTR_LVALUE: - * This symbol is defined if the FILE_ptr macro can be used as an - * lvalue. - */ -/* FILE_cnt: - * This macro is used to access the _cnt field (or equivalent) of the - * FILE structure pointed to by its argument. This macro will always be - * defined if USE_STDIO_PTR is defined. - */ -/* STDIO_CNT_LVALUE: - * This symbol is defined if the FILE_cnt macro can be used as an - * lvalue. - */ -/*##define USE_STDIO_PTR /**/ -#ifdef USE_STDIO_PTR -#define FILE_ptr(fp) ((fp)->_ptr) -#define STDIO_PTR_LVALUE /**/ -#define FILE_cnt(fp) ((fp)->_cnt) -#define STDIO_CNT_LVALUE /**/ -#endif - -/* USE_STDIO_BASE: - * This symbol is defined if the _base field (or similar) of the - * stdio FILE structure can be used to access the stdio buffer for - * a file handle. If this is defined, then the FILE_base(fp) macro - * will also be defined and should be used to access this field. - * Also, the FILE_bufsiz(fp) macro will be defined and should be used - * to determine the number of bytes in the buffer. USE_STDIO_BASE - * will never be defined unless USE_STDIO_PTR is. - */ -/* FILE_base: - * This macro is used to access the _base field (or equivalent) of the - * FILE structure pointed to by its argument. This macro will always be - * defined if USE_STDIO_BASE is defined. - */ -/* FILE_bufsiz: - * This macro is used to determine the number of bytes in the I/O - * buffer pointed to by _base field (or equivalent) of the FILE - * structure pointed to its argument. This macro will always be defined - * if USE_STDIO_BASE is defined. - */ -/*##define USE_STDIO_BASE /**/ -#ifdef USE_STDIO_BASE -#define FILE_base(fp) ((fp)->_base) -#define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base) -#endif - -/* HAS_VPRINTF: - * This symbol, if defined, indicates that the vprintf routine is available - * to printf with a pointer to an argument list. If unavailable, you - * may need to write your own, probably in terms of _doprnt(). - */ -/* USE_CHAR_VSPRINTF: - * This symbol is defined if this system has vsprintf() returning type - * (char*). The trend seems to be to declare it as "int vsprintf()". It - * is up to the package author to declare vsprintf correctly based on the - * symbol. - */ -#define HAS_VPRINTF /**/ -/*#define USE_CHAR_VSPRINTF / **/ - -/* DOUBLESIZE: - * This symbol contains the size of a double, so that the C preprocessor - * can make decisions based on it. - */ -#define DOUBLESIZE 8 /**/ - -/* I_TIME: - * This symbol, if defined, indicates to the C program that it should - * include <time.h>. - */ -/* I_SYS_TIME: - * This symbol, if defined, indicates to the C program that it should - * include <sys/time.h>. - */ -/* I_SYS_TIME_KERNEL: - * This symbol, if defined, indicates to the C program that it should - * include <sys/time.h> with KERNEL defined. - */ -#define I_TIME / **/ -#define I_SYS_TIME /**/ -/*#define I_SYS_TIME_KERNEL / **/ - -/* VAL_O_NONBLOCK: - * This symbol is to be used during open() or fcntl(F_SETFL) to turn on - * non-blocking I/O for the file descriptor. Note that there is no way - * back, i.e. you cannot turn it blocking again this way. If you wish to - * alternatively switch between blocking and non-blocking, use the - * ioctl(FIOSNBIO) call instead, but that is not supported by all devices. - */ -/* VAL_EAGAIN: - * This symbol holds the errno error code set by read() when no data was - * present on the non-blocking file descriptor. - */ -/* RD_NODATA: - * This symbol holds the return code from read() when no data is present - * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is - * not defined, then you can't distinguish between no data and EOF by - * issuing a read(). You'll have to find another way to tell for sure! - */ -/* EOF_NONBLOCK: - * This symbol, if defined, indicates to the C program that a read() on - * a non-blocking file descriptor will return 0 on EOF, and not the value - * held in RD_NODATA (-1 usually, in that case!). - */ -#define VAL_O_NONBLOCK O_NONBLOCK -#define VAL_EAGAIN EAGAIN -#define RD_NODATA -1 -#define EOF_NONBLOCK - -/* PTRSIZE: - * This symbol contains the size of a pointer, so that the C preprocessor - * can make decisions based on it. It will be sizeof(void *) if - * the compiler supports (void *); otherwise it will be - * sizeof(char *). - */ -#define PTRSIZE 8 /**/ - -/* Drand01: - * This macro is to be used to generate uniformly distributed - * random numbers over the range [0., 1.[. You may have to supply - * an 'extern double drand48();' in your program since SunOS 4.1.3 - * doesn't provide you with anything relevant in it's headers. - * See HAS_DRAND48_PROTO. - */ -/* Rand_seed_t: - * This symbol defines the type of the argument of the - * random seed function. - */ -/* seedDrand01: - * This symbol defines the macro to be used in seeding the - * random number generator (see Drand01). - */ -/* RANDBITS: - * This symbol indicates how many bits are produced by the - * function used to generate normalized random numbers. - * Values include 15, 16, 31, and 48. - */ -#define Drand01() (rand()/(double)((unsigned)1<<RANDBITS)) -#define Rand_seed_t unsigned /**/ -#define seedDrand01(x) srand((Rand_seed_t)x) /**/ -#define RANDBITS 15 /**/ - -/* SSize_t: - * This symbol holds the type used by functions that return - * a count of bytes or an error condition. It must be a signed type. - * It is usually ssize_t, but may be long or int, etc. - * It may be necessary to include <sys/types.h> or <unistd.h> - * to get any typedef'ed information. - * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). - */ -#define SSize_t long /* signed count of bytes */ - -/* EBCDIC: - * This symbol, if defined, indicates that this system uses - * EBCDIC encoding. - */ -/*#define EBCDIC / **/ - -/* OSNAME: - * This symbol contains the name of the operating system, as determined - * by Configure. You shouldn't rely on it too much; the specific - * feature tests from Configure are generally more reliable. - */ -#define OSNAME "epoc" /**/ - -/* CAT2: - * This macro catenates 2 tokens together. - */ -/* STRINGIFY: - * This macro surrounds its token with double quotes. - */ -#if 42 == 1 -#define CAT2(a,b)a/**/b -#define STRINGIFY(a)"a" - /* If you can get stringification with catify, tell me how! */ -#endif -#if 42 == 42 -#define CAT2(a,b)a ## b -#define StGiFy(a)# a -#define STRINGIFY(a)StGiFy(a) -#endif -#if 42 != 1 && 42 != 42 -#include "Bletch: How does this C preprocessor catenate tokens?" -#endif - -/* CPPSTDIN: - * This symbol contains the first part of the string which will invoke - * the C preprocessor on the standard input and produce to standard - * output. Typical value of "cc -E" or "/lib/cpp", but it can also - * call a wrapper. See CPPRUN. - */ -/* CPPMINUS: - * This symbol contains the second part of the string which will invoke - * the C preprocessor on the standard input and produce to standard - * output. This symbol will have the value "-" if CPPSTDIN needs a minus - * to specify standard input, otherwise the value is "". - */ -/* CPPRUN: - * This symbol contains the string which will invoke a C preprocessor on - * the standard input and produce to standard output. It needs to end - * with CPPLAST, after all other preprocessor flags have been specified. - * The main difference with CPPSTDIN is that this program will never be a - * pointer to a shell wrapper, i.e. it will be empty if no preprocessor is - * available directly to the user. Note that it may well be different from - * the preprocessor used to compile the C program. - */ -#define CPPSTDIN "cppstdin" -#define CPPMINUS "" -#define CPPRUN "/usr/bin/cpp" - -/* HAS_ACCESS: - * This manifest constant lets the C program know that the access() - * system call is available to check for accessibility using real UID/GID. - * (always present on UNIX.) - */ -/*#define HAS_ACCESS /**/ - -/* HAS_CSH: - * This symbol, if defined, indicates that the C-shell exists. - */ -/* CSH: - * This symbol, if defined, contains the full pathname of csh. - */ -/*#define HAS_CSH /**/ -#ifdef HAS_CSH -#define CSH "/usr/bin/csh" /**/ -#endif - -/* HAS_ENDGRENT: - * This symbol, if defined, indicates that the getgrent routine is - * available for finalizing sequential access of the group database. - */ -/*#define HAS_ENDGRENT /**/ - -/* HAS_ENDHOSTENT: - * This symbol, if defined, indicates that the endhostent() routine is - * available to close whatever was being used for host queries. - */ -/*#define HAS_ENDHOSTENT /**/ - -/* HAS_ENDNETENT: - * This symbol, if defined, indicates that the endnetent() routine is - * available to close whatever was being used for network queries. - */ -/*#define HAS_ENDNETENT /**/ - -/* HAS_ENDPROTOENT: - * This symbol, if defined, indicates that the endprotoent() routine is - * available to close whatever was being used for protocol queries. - */ -/*#define HAS_ENDPROTOENT /**/ - -/* HAS_ENDPWENT: - * This symbol, if defined, indicates that the getgrent routine is - * available for finalizing sequential access of the passwd database. - */ -/*#define HAS_ENDPWENT /**/ - -/* HAS_ENDSERVENT: - * This symbol, if defined, indicates that the endservent() routine is - * available to close whatever was being used for service queries. - */ -/*#define HAS_ENDSERVENT /**/ - -/* HAS_GETGRENT: - * This symbol, if defined, indicates that the getgrent routine is - * available for sequential access of the group database. - */ -/*#define HAS_GETGRENT /**/ - -/* HAS_GETHOSTBYADDR: - * This symbol, if defined, indicates that the gethostbyaddr() routine is - * available to look up hosts by their IP addresses. - */ -#define HAS_GETHOSTBYADDR /**/ - -/* HAS_GETHOSTBYNAME: - * This symbol, if defined, indicates that the gethostbyname() routine is - * available to look up host names in some data base or other. - */ -#define HAS_GETHOSTBYNAME /**/ - -/* HAS_GETHOSTENT: - * This symbol, if defined, indicates that the gethostent() routine is - * available to look up host names in some data base or another. - */ -/*#define HAS_GETHOSTENT /**/ - -/* HAS_GETHOSTNAME: - * This symbol, if defined, indicates that the C program may use the - * gethostname() routine to derive the host name. See also HAS_UNAME - * and PHOSTNAME. - */ -/* HAS_UNAME: - * This symbol, if defined, indicates that the C program may use the - * uname() routine to derive the host name. See also HAS_GETHOSTNAME - * and PHOSTNAME. - */ -/* PHOSTNAME: - * This symbol, if defined, indicates the command to feed to the - * popen() routine to derive the host name. See also HAS_GETHOSTNAME - * and HAS_UNAME. Note that the command uses a fully qualified path, - * so that it is safe even if used by a process with super-user - * privileges. - */ -/*#define HAS_GETHOSTNAME /**/ -/*#define HAS_UNAME /**/ -#undef HAS_PHOSTNAME -#ifdef HAS_PHOSTNAME -#define PHOSTNAME "" /* How to get the host name */ -#endif - -/* HAS_GETNETBYADDR: - * This symbol, if defined, indicates that the getnetbyaddr() routine is - * available to look up networks by their IP addresses. - */ -/*#define HAS_GETNETBYADDR /**/ - -/* HAS_GETNETBYNAME: - * This symbol, if defined, indicates that the getnetbyname() routine is - * available to look up networks by their names. - */ -/*#define HAS_GETNETBYNAME /**/ - -/* HAS_GETNETENT: - * This symbol, if defined, indicates that the getnetent() routine is - * available to look up network names in some data base or another. - */ -/*#define HAS_GETNETENT /**/ - -/* HAS_GETPROTOENT: - * This symbol, if defined, indicates that the getprotoent() routine is - * available to look up protocols in some data base or another. - */ -/*#define HAS_GETPROTOENT /**/ - -/* HAS_GETPROTOBYNAME: - * This symbol, if defined, indicates that the getprotobyname() - * routine is available to look up protocols by their name. - */ -/* HAS_GETPROTOBYNUMBER: - * This symbol, if defined, indicates that the getprotobynumber() - * routine is available to look up protocols by their number. - */ -/*#define HAS_GETPROTOBYNAME /**/ -/*#define HAS_GETPROTOBYNUMBER /**/ - -/* HAS_GETPWENT: - * This symbol, if defined, indicates that the getpwent routine is - * available for sequential access of the passwd database. - * If this is not available, the older getpw() function may be available. - */ -/*#define HAS_GETPWENT /**/ - -/* HAS_GETSERVENT: - * This symbol, if defined, indicates that the getservent() routine is - * available to look up network services in some data base or another. - */ -/*#define HAS_GETSERVENT /**/ - -/* HAS_GETSERVBYNAME: - * This symbol, if defined, indicates that the getservbyname() - * routine is available to look up services by their name. - */ -/* HAS_GETSERVBYPORT: - * This symbol, if defined, indicates that the getservbyport() - * routine is available to look up services by their port. - */ -/*#define HAS_GETSERVBYNAME /**/ -/*#define HAS_GETSERVBYPORT /**/ -/* -/* HAS_HTONL: - * This symbol, if defined, indicates that the htonl() routine (and - * friends htons() ntohl() ntohs()) are available to do network - * order byte swapping. - */ -/* HAS_HTONS: - * This symbol, if defined, indicates that the htons() routine (and - * friends htonl() ntohl() ntohs()) are available to do network - * order byte swapping. - */ -/* HAS_NTOHL: - * This symbol, if defined, indicates that the ntohl() routine (and - * friends htonl() htons() ntohs()) are available to do network - * order byte swapping. - */ -/* HAS_NTOHS: - * This symbol, if defined, indicates that the ntohs() routine (and - * friends htonl() htons() ntohl()) are available to do network - * order byte swapping. - */ -#define HAS_HTONL /**/ -#define HAS_HTONS /**/ -#define HAS_NTOHL /**/ -#define HAS_NTOHS /**/ - -/* HAS_LONG_DOUBLE: - * This symbol will be defined if the C compiler supports long - * doubles. - */ -/* LONG_DOUBLESIZE: - * This symbol contains the size of a long double, so that the - * C preprocessor can make decisions based on it. It is only - * defined if the system supports long doubles. - */ -/*#define HAS_LONG_DOUBLE /**/ -#ifdef HAS_LONG_DOUBLE -#define LONG_DOUBLESIZE 8 /**/ -#endif - -/* HAS_LONG_LONG: - * This symbol will be defined if the C compiler supports long long. - */ -/* LONGLONGSIZE: - * This symbol contains the size of a long long, so that the - * C preprocessor can make decisions based on it. It is only - * defined if the system supports long long. - */ -/*#define HAS_LONG_LONG /**/ -#ifdef HAS_LONG_LONG -#define LONGLONGSIZE 8 /**/ -#endif - -/* HAS_MEMCHR: - * This symbol, if defined, indicates that the memchr routine is available - * to locate characters within a C string. - */ -#define HAS_MEMCHR /**/ - -/* HAS_MSG: - * This symbol, if defined, indicates that the entire msg*(2) library is - * supported (IPC mechanism based on message queues). - */ -/*#define HAS_MSG /**/ - -/* HAS_SEM: - * This symbol, if defined, indicates that the entire sem*(2) library is - * supported. - */ -/*#define HAS_SEM /**/ - -/* HAS_SETGRENT: - * This symbol, if defined, indicates that the setgrent routine is - * available for initializing sequential access of the group database. - */ -/*#define HAS_SETGRENT /**/ - -/* HAS_SETGROUPS: - * This symbol, if defined, indicates that the setgroups() routine is - * available to set the list of process groups. If unavailable, multiple - * groups are probably not supported. - */ -/*#define HAS_SETGROUPS /**/ - -/* HAS_SETHOSTENT: - * This symbol, if defined, indicates that the sethostent() routine is - * available. - */ -/*#define HAS_SETHOSTENT /**/ - -/* HAS_SETNETENT: - * This symbol, if defined, indicates that the setnetent() routine is - * available. - */ -/*#define HAS_SETNETENT /**/ - -/* HAS_SETPROTOENT: - * This symbol, if defined, indicates that the setprotoent() routine is - * available. - */ -/*#define HAS_SETPROTOENT /**/ - -/* HAS_SETPWENT: - * This symbol, if defined, indicates that the setpwent routine is - * available for initializing sequential access of the passwd database. - */ -/*#define HAS_SETPWENT /**/ - -/* HAS_SETSERVENT: - * This symbol, if defined, indicates that the setservent() routine is - * available. - */ -/*#define HAS_SETSERVENT /**/ - -/* HAS_SETVBUF: - * This symbol, if defined, indicates that the setvbuf routine is - * available to change buffering on an open stdio stream. - * to a line-buffered mode. - */ -/*#define HAS_SETVBUF /**/ - -/* HAS_SHM: - * This symbol, if defined, indicates that the entire shm*(2) library is - * supported. - */ -/*#define HAS_SHM /**/ - -/* HAS_SOCKET: - * This symbol, if defined, indicates that the BSD socket interface is - * supported. - */ -/* HAS_SOCKETPAIR: - * This symbol, if defined, indicates that the BSD socketpair() call is - * supported. - */ -/* HAS_MSG_CTRUNC: - * This symbol, if defined, indicates that the MSG_CTRUNC is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_DONTROUTE: - * This symbol, if defined, indicates that the MSG_DONTROUTE is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_OOB: - * This symbol, if defined, indicates that the MSG_OOB is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_PEEK: - * This symbol, if defined, indicates that the MSG_PEEK is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_PROXY: - * This symbol, if defined, indicates that the MSG_PROXY is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_SCM_RIGHTS: - * This symbol, if defined, indicates that the SCM_RIGHTS is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -#define HAS_SOCKET /**/ -/*#define HAS_SOCKETPAIR /**/ -/*#define HAS_MSG_CTRUNC /**/ -/*#define HAS_MSG_DONTROUTE /**/ -/*#define HAS_MSG_OOB /**/ -/*#define HAS_MSG_PEEK /**/ -/*#define HAS_MSG_PROXY / **/ -/*#define HAS_SCM_RIGHTS /**/ - -/* USE_STAT_BLOCKS: - * This symbol is defined if this system has a stat structure declaring - * st_blksize and st_blocks. - */ -#define USE_STAT_BLOCKS /**/ - -/* HAS_STRERROR: - * This symbol, if defined, indicates that the strerror routine is - * available to translate error numbers to strings. See the writeup - * of Strerror() in this file before you try to define your own. - */ -/* HAS_SYS_ERRLIST: - * This symbol, if defined, indicates that the sys_errlist array is - * available to translate error numbers to strings. The extern int - * sys_nerr gives the size of that table. - */ -/* Strerror: - * This preprocessor symbol is defined as a macro if strerror() is - * not available to translate error numbers to strings but sys_errlist[] - * array is there. - */ -#define HAS_STRERROR /**/ -/*##define HAS_SYS_ERRLIST /**/ -#define Strerror(e) strerror(e) - -/* HAS_UNION_SEMUN: - * This symbol, if defined, indicates that the union semun is - * defined by including <sys/sem.h>. If not, the user code - * probably needs to define it as: - * union semun { - * int val; - * struct semid_ds *buf; - * unsigned short *array; - * } - */ -/* USE_SEMCTL_SEMUN: - * This symbol, if defined, indicates that union semun is - * used for semctl IPC_STAT. - */ -/* USE_SEMCTL_SEMID_DS: - * This symbol, if defined, indicates that struct semid_ds * is - * used for semctl IPC_STAT. - */ -/*#define HAS_UNION_SEMUN / **/ -#define USE_SEMCTL_SEMUN /**/ -#define USE_SEMCTL_SEMID_DS /**/ - -/* HAS_VFORK: - * This symbol, if defined, indicates that vfork() exists. - */ -/*#define HAS_VFORK / **/ - -/* Signal_t: - * This symbol's value is either "void" or "int", corresponding to the - * appropriate return type of a signal handler. Thus, you can declare - * a signal handler using "Signal_t (*handler)()", and define the - * handler using "Signal_t handler(sig)". - */ -#define Signal_t void /* Signal handler's return type */ - -/* Groups_t: - * This symbol holds the type used for the second argument to - * getgroups() and setgropus(). Usually, this is the same as - * gidtype (gid_t) , but sometimes it isn't. - * It can be int, ushort, uid_t, etc... - * It may be necessary to include <sys/types.h> to get any - * typedef'ed information. This is only required if you have - * getgroups() or setgropus().. - */ -#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) -#define Groups_t gid_t /* Type for 2nd arg to [sg]etgroups() */ -#endif - -/* I_GRP: - * This symbol, if defined, indicates to the C program that it should - * include <grp.h>. - */ -/* GRPASSWD: - * This symbol, if defined, indicates to the C program that struct group - * in <grp.h> contains gr_passwd. - */ -/*##define I_GRP /**/ -/*##define GRPASSWD /**/ - -/* I_NETDB: - * This symbol, if defined, indicates that <netdb.h> exists and - * should be included. - */ -#define I_NETDB /**/ - -/* I_PWD: - * This symbol, if defined, indicates to the C program that it should - * include <pwd.h>. - */ -/* PWQUOTA: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_quota. - */ -/* PWAGE: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_age. - */ -/* PWCHANGE: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_change. - */ -/* PWCLASS: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_class. - */ -/* PWEXPIRE: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_expire. - */ -/* PWCOMMENT: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_comment. - */ -/* PWGECOS: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_gecos. - */ -/* PWPASSWD: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_passwd. - */ -/*#define I_PWD /**/ -/*#define PWQUOTA /**/ -/*#define PWAGE / **/ -/*#define PWCHANGE / **/ -/*#define PWCLASS / **/ -/*#define PWEXPIRE / **/ -/*#define PWCOMMENT /**/ -/*#define PWGECOS /**/ -/*#define PWPASSWD /**/ - -/* Free_t: - * This variable contains the return type of free(). It is usually - * void, but occasionally int. - */ -/* Malloc_t: - * This symbol is the type of pointer returned by malloc and realloc. - */ -#define Malloc_t void * /**/ -#define Free_t void /**/ - -/* MYMALLOC: - * This symbol, if defined, indicates that we're using our own malloc. - */ -/*#define MYMALLOC / **/ - -/* SIG_NAME: - * This symbol contains a list of signal names in order of - * signal number. This is intended - * to be used as a static array initialization, like this: - * char *sig_name[] = { SIG_NAME }; - * The signals in the list are separated with commas, and each signal - * is surrounded by double quotes. There is no leading SIG in the signal - * name, i.e. SIGQUIT is known as "QUIT". - * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn, - * etc., where nn is the actual signal number (e.g. NUM37). - * The signal number for sig_name[i] is stored in sig_num[i]. - * The last element is 0 to terminate the list with a NULL. This - * corresponds to the 0 at the end of the sig_num list. - */ -/* SIG_NUM: - * This symbol contains a list of signal numbers, in the same order as the - * SIG_NAME list. It is suitable for static array initialization, as in: - * int sig_num[] = { SIG_NUM }; - * The signals in the list are separated with commas, and the indices - * within that list and the SIG_NAME list match, so it's easy to compute - * the signal name from a number or vice versa at the price of a small - * dynamic linear lookup. - * Duplicates are allowed, but are moved to the end of the list. - * The signal number corresponding to sig_name[i] is sig_number[i]. - * if (i < NSIG) then sig_number[i] == i. - * The last element is 0, corresponding to the 0 at the end of - * the sig_name list. - */ -#define SIG_NAME "ZERO", 0 /**/ -#define SIG_NUM 0, 0 /**/ - -/* VOIDFLAGS: - * This symbol indicates how much support of the void type is given by this - * compiler. What various bits mean: - * - * 1 = supports declaration of void - * 2 = supports arrays of pointers to functions returning void - * 4 = supports comparisons between pointers to void functions and - * addresses of void functions - * 8 = suports declaration of generic void pointers - * - * The package designer should define VOIDUSED to indicate the requirements - * of the package. This can be done either by #defining VOIDUSED before - * including config.h, or by defining defvoidused in Myinit.U. If the - * latter approach is taken, only those flags will be tested. If the - * level of void support necessary is not present, defines void to int. - */ -#ifndef VOIDUSED -#define VOIDUSED 15 -#endif -#define VOIDFLAGS 15 -#if (VOIDFLAGS & VOIDUSED) != VOIDUSED -#define void int /* is void to be avoided? */ -#define M_VOID /* Xenix strikes again */ -#endif - -/* ARCHLIB: - * This variable, if defined, holds the name of the directory in - * which the user wants to put architecture-dependent public - * library files for perl5. It is most often a local directory - * such as /usr/local/lib. Programs using this variable must be - * prepared to deal with filename expansion. If ARCHLIB is the - * same as PRIVLIB, it is not defined, since presumably the - * program already searches PRIVLIB. - */ -/* ARCHLIB_EXP: - * This symbol contains the ~name expanded version of ARCHLIB, to be used - * in programs that are not prepared to deal with ~ expansion at run-time. - */ -#define ARCHLIB "/perl/lib/5.00562/epoc" /**/ -#define ARCHLIB_EXP "/perl/lib/5.00562/epoc" /**/ - -/* DLSYM_NEEDS_UNDERSCORE: - * This symbol, if defined, indicates that we need to prepend an - * underscore to the symbol name before calling dlsym(). This only - * makes sense if you *have* dlsym, which we will presume is the - * case if you're using dl_dlopen.xs. - */ -/*#define DLSYM_NEEDS_UNDERSCORE / **/ - -/* HAS_FSEEKO: - * This symbol, if defined, indicates that the fseeko routine is - * available to fseek beyond 32 bits (useful for ILP32 hosts). - */ -/*#define HAS_FSEEKO / **/ - -/* HAS_FTELLO: - * This symbol, if defined, indicates that the ftello routine is - * available to ftell from beyond 32 bits (useful for ILP32 hosts). - */ -/*#define HAS_FTELLO / **/ - -/* HAS_GETMNTENT: - * This symbol, if defined, indicates that the getmntent routine is - * available to iterate through mounted file systems. - */ -/*#define HAS_GETMNTENT / **/ - -/* HAS_HASMNTOPT: - * This symbol, if defined, indicates that the hasmntopt routine is - * available to query the mount options of file systems. - */ -/*#define HAS_HASMNTOPT / **/ - -/* USE_SFIO: - * This symbol, if defined, indicates that sfio should - * be used. - */ -/*#define USE_SFIO / **/ - -/* HAS_FSTATFS: - * This symbol, if defined, indicates that the fstatfs routine is - * available to stat filesystems of file descriptors. - */ -/* HAS_STRUCT_STATFS_FLAGS: - * This symbol, if defined, indicates that the struct statfs - * does have the f_flags member containing the mount flags of - * the filesystem holding the file. - * This kind of struct statfs is coming from sys/mount.h (BSD), - * not from sys/statfs.h (SYSV). - */ -#define HAS_FSTATFS /**/ -#define HAS_STRUCT_STATFS_FLAGS /**/ - -/* HAS_FSTATVFS: - * This symbol, if defined, indicates that the fstatvfs routine is - * available to stat filesystems of file descriptors. - */ -/*#define HAS_FSTATVFS /**/ - -/* HAS_TELLDIR_PROTO: - * This symbol, if defined, indicates that the system provides - * a prototype for the telldir() function. Otherwise, it is up - * to the program to supply one. A good guess is - * extern long telldir _((DIR*)); - */ -#define HAS_TELLDIR_PROTO /**/ - -/* USE_DYNAMIC_LOADING: - * This symbol, if defined, indicates that dynamic loading of - * some sort is available. - */ -/*#define USE_DYNAMIC_LOADING /**/ - -/* FFLUSH_NULL: - * This symbol, if defined, tells that fflush(NULL) does flush - * all pending stdio output. - */ -/* FFLUSH_ALL: - * This symbol, if defined, tells that to flush - * all pending stdio output one must loop through all - * the stdio file handles stored in an array and fflush them. - * Note that if fflushNULL is defined, fflushall will not - * even be probed for and will be left undefined. - */ -/*#define FFLUSH_NULL /**/ -#define FFLUSH_ALL / **/ - -/* DB_Prefix_t: - * This symbol contains the type of the prefix structure element - * in the <db.h> header file. In older versions of DB, it was - * int, while in newer ones it is u_int32_t. - */ -/* DB_Hash_t: - * This symbol contains the type of the prefix structure element - * in the <db.h> header file. In older versions of DB, it was - * int, while in newer ones it is size_t. - */ -/*#define DB_Hash_t u_int32_t /**/ -/*#define DB_Prefix_t size_t /**/ - -/* I_INTTYPES: - * This symbol, if defined, indicates to the C program that it should - * include <inttypes.h>. - */ -/* HAS_INT64_T: - * This symbol will defined if the C compiler supports int64_t. - * Usually the <inttypes.h> needs to be included, but sometimes - * <sys/types.h> is enough. - */ -/*#define I_INTTYPES / **/ -/*#define HAS_INT64_T / **/ - -/* I_MNTENT: - * This symbol, if defined, indicates that <mntent.h> exists and - * should be included. - */ -/*#define I_MNTENT / **/ - -/* I_NETINET_TCP: - * This symbol, if defined, indicates to the C program that it should - * include <netinet/tcp.h>. - */ -#define I_NETINET_TCP /**/ - -/* I_POLL: - * This symbol, if defined, indicates that <poll.h> exists and - * should be included. - */ -/*#define I_POLL /**/ - -/* I_SYS_MOUNT: - * This symbol, if defined, indicates that <sys/mount.h> exists and - * should be included. - */ -/*#define I_SYS_MOUNT /**/ - -/* I_SYS_STATVFS: - * This symbol, if defined, indicates that <sys/statvfs.h> exists and - * should be included. - */ -/*#define I_SYS_STATVFS /**/ - -/* INSTALL_USR_BIN_PERL: - * This symbol, if defined, indicates that Perl is to be installed - * also as /usr/bin/perl. - */ -/*#define INSTALL_USR_BIN_PERL /**/ - -/* PRIVLIB: - * This symbol contains the name of the private library for this package. - * The library is private in the sense that it needn't be in anyone's - * execution path, but it should be accessible by the world. The program - * should be prepared to do ~ expansion. - */ -/* PRIVLIB_EXP: - * This symbol contains the ~name expanded version of PRIVLIB, to be used - * in programs that are not prepared to deal with ~ expansion at run-time. - */ -#define PRIVLIB "/perl/lib/5.00562" /**/ -#define PRIVLIB_EXP "/perl/lib/5.00562" /**/ - -/* SELECT_MIN_BITS: - * This symbol holds the minimum number of bits operated by select. - * That is, if you do select(n, ...), how many bits at least will be - * cleared in the masks if some activity is detected. Usually this - * is either n or 32*ceil(n/32), especially many little-endians do - * the latter. This is only useful if you have select(), naturally. - */ -#define SELECT_MIN_BITS 32 /**/ - -/* SITEARCH: - * This symbol contains the name of the private library for this package. - * The library is private in the sense that it needn't be in anyone's - * execution path, but it should be accessible by the world. The program - * should be prepared to do ~ expansion. - * The standard distribution will put nothing in this directory. - * Individual sites may place their own extensions and modules in - * this directory. - */ -/* SITEARCH_EXP: - * This symbol contains the ~name expanded version of SITEARCH, to be used - * in programs that are not prepared to deal with ~ expansion at run-time. - */ -#define SITEARCH "/perl/lib/site_perl/5.00562/epoc" /**/ -#define SITEARCH_EXP "/perl/lib/site_perl/5.00562/epoc" /**/ - -/* SITELIB: - * This symbol contains the name of the private library for this package. - * The library is private in the sense that it needn't be in anyone's - * execution path, but it should be accessible by the world. The program - * should be prepared to do ~ expansion. - * The standard distribution will put nothing in this directory. - * Individual sites may place their own extensions and modules in - * this directory. - */ -/* SITELIB_EXP: - * This symbol contains the ~name expanded version of SITELIB, to be used - * in programs that are not prepared to deal with ~ expansion at run-time. - */ -#define SITELIB "/perl/lib/site_perl/5.00562" /**/ -#define SITELIB_EXP "/perl/lib/site_perl/5.00562" /**/ - -/* STARTPERL: - * This variable contains the string to put in front of a perl - * script to make sure (one hopes) that it runs with perl and not - * some shell. - */ -#define STARTPERL "#!/opt/perl/bin/perl" /**/ - -/* HAS_STDIO_STREAM_ARRAY: - * This symbol, if defined, tells that there is an array - * holding the stdio streams. - */ -/* STDIO_STREAM_ARRAY: - * This symbol tells the name of the array holding the stdio streams. - * Usual values include _iob, __iob, and __sF. - */ -/*#define HAS_STDIO_STREAM_ARRAY /**/ -/*#define STDIO_STREAM_ARRAY _iob - -/* USE_64_BITS: - * This symbol, if defined, indicates that 64-bit interfaces should - * be used when available. If not defined, the native default interfaces - * will be used (be they 32 or 64 bits). - */ -/*#define USE_64_BITS /**/ - -/* MULTIPLICITY: - * This symbol, if defined, indicates that Perl should - * be built to use multiplicity. - */ -/*#define MULTIPLICITY / **/ - -/* USE_PERLIO: - * This symbol, if defined, indicates that the PerlIO abstraction should - * be used throughout. If not defined, stdio should be - * used in a fully backward compatible manner. - */ -/*#define USE_PERLIO / **/ - -/* HAS_DRAND48_PROTO: - * This symbol, if defined, indicates that the system provides - * a prototype for the drand48() function. Otherwise, it is up - * to the program to supply one. A good guess is - * extern double drand48 _((void)); - */ -#define HAS_DRAND48_PROTO /**/ - -/* HAS_GETHOST_PROTOS: - * This symbol, if defined, indicates that <netdb.h> includes - * prototypes for gethostent(), gethostbyname(), and - * gethostbyaddr(). Otherwise, it is up to the program to guess - * them. See netdbtype.U for probing for various Netdb_xxx_t types. - */ -#define HAS_GETHOST_PROTOS /**/ - -/* HAS_GETNET_PROTOS: - * This symbol, if defined, indicates that <netdb.h> includes - * prototypes for getnetent(), getnetbyname(), and - * getnetbyaddr(). Otherwise, it is up to the program to guess - * them. See netdbtype.U for probing for various Netdb_xxx_t types. - */ -#define HAS_GETNET_PROTOS /**/ - -/* HAS_GETPROTO_PROTOS: - * This symbol, if defined, indicates that <netdb.h> includes - * prototypes for getprotoent(), getprotobyname(), and - * getprotobyaddr(). Otherwise, it is up to the program to guess - * them. See netdbtype.U for probing for various Netdb_xxx_t types. - */ -#define HAS_GETPROTO_PROTOS /**/ - -/* HAS_GETSERV_PROTOS: - * This symbol, if defined, indicates that <netdb.h> includes - * prototypes for getservent(), getservbyname(), and - * getservbyaddr(). Otherwise, it is up to the program to guess - * them. See netdbtype.U for probing for various Netdb_xxx_t types. - */ -#define HAS_GETSERV_PROTOS /**/ - -/* Netdb_host_t: - * This symbol holds the type used for the 1st argument - * to gethostbyaddr(). - */ -/* Netdb_hlen_t: - * This symbol holds the type used for the 2nd argument - * to gethostbyaddr(). - */ -/* Netdb_name_t: - * This symbol holds the type used for the argument to - * gethostbyname(). - */ -/* Netdb_net_t: - * This symbol holds the type used for the 1st argument to - * getnetbyaddr(). - */ -#define Netdb_host_t const char * /**/ -#define Netdb_hlen_t int /**/ -#define Netdb_name_t const char * /**/ -#define Netdb_net_t int /**/ - -/* Select_fd_set_t: - * This symbol holds the type used for the 2nd, 3rd, and 4th - * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET - * is defined, and 'int *' otherwise. This is only useful if you - * have select(), of course. - */ -#define Select_fd_set_t fd_set * /**/ - -/* ARCHNAME: - * This symbol holds a string representing the architecture name. - * It may be used to construct an architecture-dependant pathname - * where library files may be held under a private library, for - * instance. - */ -#define ARCHNAME "epoc" /**/ - -/* OLD_PTHREAD_CREATE_JOINABLE: - * This symbol, if defined, indicates how to create pthread - * in joinable (aka undetached) state. NOTE: not defined - * if pthread.h already has defined PTHREAD_CREATE_JOINABLE - * (the new version of the constant). - * If defined, known values are PTHREAD_CREATE_UNDETACHED - * and __UNDETACHED. - */ -/*#define OLD_PTHREAD_CREATE_JOINABLE / **/ - -/* HAS_PTHREAD_YIELD: - * This symbol, if defined, indicates that the pthread_yield - * routine is available to yield the execution of the current - * thread. sched_yield is preferable to pthread_yield. - */ -/* SCHED_YIELD: - * This symbol defines the way to yield the execution of - * the current thread. Known ways are sched_yield, - * pthread_yield, and pthread_yield with NULL. - */ -/* HAS_SCHED_YIELD: - * This symbol, if defined, indicates that the sched_yield - * routine is available to yield the execution of the current - * thread. sched_yield is preferable to pthread_yield. - */ -/*#define HAS_PTHREAD_YIELD / **/ -/*#define SCHED_YIELD sched_yield() /**/ -/*#define HAS_SCHED_YIELD /**/ - -/* I_MACH_CTHREADS: - * This symbol, if defined, indicates to the C program that it should - * include <mach/cthreads.h>. - */ -/*#define I_MACH_CTHREADS / **/ - -/* USE_THREADS: - * This symbol, if defined, indicates that Perl should - * be built to use threads. - */ -/* OLD_PTHREADS_API: - * This symbol, if defined, indicates that Perl should - * be built to use the old draft POSIX threads API. - */ -/*#define USE_THREADS /**/ -/*#define OLD_PTHREADS_API / **/ - -/* Time_t: - * This symbol holds the type returned by time(). It can be long, - * or time_t on BSD sites (in which case <sys/types.h> should be - * included). - */ -#define Time_t time_t /* Time type */ - -/* HAS_TIMES: - * This symbol, if defined, indicates that the times() routine exists. - * Note that this became obsolete on some systems (SUNOS), which now - * use getrusage(). It may be necessary to include <sys/times.h>. - */ -/*#define HAS_TIMES /**/ - -/* Fpos_t: - * This symbol holds the type used to declare file positions in libc. - * It can be fpos_t, long, uint, etc... It may be necessary to include - * <sys/types.h> to get any typedef'ed information. - */ -#define Fpos_t fpos_t /* File position type */ - -/* Gid_t: - * This symbol holds the return type of getgid() and the type of - * argument to setrgid() and related functions. Typically, - * it is the type of group ids in the kernel. It can be int, ushort, - * uid_t, etc... It may be necessary to include <sys/types.h> to get - * any typedef'ed information. - */ -#define Gid_t gid_t /* Type for getgid(), etc... */ - -/* Off_t: - * This symbol holds the type used to declare offsets in the kernel. - * It can be int, long, off_t, etc... It may be necessary to include - * <sys/types.h> to get any typedef'ed information. - */ -/* LSEEKSIZE: - * This symbol holds the number of bytes used by the Off_t. - */ -#define Off_t off_t /* <offset> type */ -#define LSEEKSIZE 8 /* <offset> size */ - -/* Mode_t: - * This symbol holds the type used to declare file modes - * for systems calls. It is usually mode_t, but may be - * int or unsigned short. It may be necessary to include <sys/types.h> - * to get any typedef'ed information. - */ -#define Mode_t mode_t /* file mode parameter for system calls */ - -/* Pid_t: - * This symbol holds the type used to declare process ids in the kernel. - * It can be int, uint, pid_t, etc... It may be necessary to include - * <sys/types.h> to get any typedef'ed information. - */ -#define Pid_t pid_t /* PID type */ - -/* Size_t: - * This symbol holds the type used to declare length parameters - * for string functions. It is usually size_t, but may be - * unsigned long, int, etc. It may be necessary to include - * <sys/types.h> to get any typedef'ed information. - */ -#define Size_t size_t /* length paramater for string functions */ - -/* Uid_t: - * This symbol holds the type used to declare user ids in the kernel. - * It can be int, ushort, uid_t, etc... It may be necessary to include - * <sys/types.h> to get any typedef'ed information. - */ -#define Uid_t uid_t /* UID type */ - -/* PERL_PRIfldbl: - * This symbol, if defined, contains the string used by stdio to - * format long doubles (format 'f') for output. - */ -/* PERL_PRIgldbl: - * This symbol, if defined, contains the string used by stdio to - * format long doubles (format 'g') for output. - */ -#define PERL_PRIfldbl "f" /**/ -#define PERL_PRIgldbl "g" /**/ - -#endif - diff --git a/epoc/config.sh b/epoc/config.sh new file mode 100644 index 0000000000..55ca6bd51c --- /dev/null +++ b/epoc/config.sh @@ -0,0 +1,764 @@ +#!/bin/sh +# +# This file was produced by running the Configure script. It holds all the +# definitions figured out by Configure. Should you modify one of these values, +# do not forget to propagate your changes by running "Configure -der". You may +# instead choose to run each of the .SH files by yourself, or "Configure -S". +# + +# Package name : perl5 +# Source directory : . +# Configuration time: Sun Oct 3 02:17:38 EET DST 1999 +# Configured by : jhi +# Target system : osf1 alpha.hut.fi v4.0 878 alpha + +Author='' +Date='$Date' +Header='' +Id='$Id' +Locker='' +Log='$Log' +Mcc='' +RCSfile='$RCSfile' +Revision='$Revision' +Source='' +State='' +_a='.a' +_exe='.exe' +_o='.o' +afs='false' +alignbytes='8' +ansi2knr='' +aphostname='' +apirevision='' +apisubversion='' +apiversion='' +ar='arm-pe-ar' +archlib='/perl/lib/5.5.640/epoc' +archlibexp='/perl/lib/5.5.640/epoc' +archname64='' +archname='epoc' +archobjs='epoc.o epocish.o epoc_stubs.o' +awk='awk' +baserev='5.0' +bash='' +bin='' +bincompat5005='false' +binexp='' +bison='bison' +byacc='' +byteorder='1234' +c='' +castflags='0' +cat='cat' +cc='arm-pe-gcc -B/usr/local/lib/gcc-lib/arm-pe/cygnus-2.7.2-960323/ -nostdinc -D__SYMBIAN32__ -D__PSISOFT32__ -D__GCC32__ -D__EPOC32__ -D__MARM__ -D__EXE__ -I/usr/local/epoc/include/ -I/usr/local/epoc/include/libc -DEPOC' +cccdlflags='' +ccdlflags='' +ccflags='-Wno-ctor-dtor-privacy -mcpu-arm710 -mapcs-32 -mshort-load-bytes -msoft-float -fcheck-new -fvtable-thunks' +ccsymbols='' +cf_by='olaf' +cf_email='o.flebbe@gmx.de' +cf_time='Dec 1999' +chgrp='' +chmod='' +chown='' +clocktype='' +comm='' +compress='' +contains='grep' +cp='cp' +cpio='' +cpp='arm-pe-cpp' +cpp_stuff='42' +cppccsymbols='EPOC=1' +cppflags=' -nostdinc -D__SYMBIAN32__ -D__PSISOFT32__ -D__GCC32__ -D__EPOC32__ -D__MARM__ -D__EXE__ -I/usr/local/epoc/include/ -I/usr/local/epoc/include/libc' +cpplast='-' +cppminus='-' +cpprun='arm-pe-gcc -E -B/usr/local/lib/gcc-lib/arm-pe/cygnus-2.7.2-960323/' +cppstdin='arm-pe-gcc -E -B/usr/local/lib/gcc-lib/arm-pe/cygnus-2.7.2-960323/' +cppsymbols='' +crosscompile='define' +cryptlib='' +csh='csh' +d_Gconvert='sprintf((b),"%.*g",(n),(x))' +d_PRIEldbl='undef' +d_PRIFldbl='undef' +d_PRIGldbl='undef' +d_PRIX64='undef' +d_PRId64='undef' +d_PRIeldbl='undef' +d_PRIfldbl='define' +d_PRIgldbl='define' +d_PRIi64='undef' +d_PRIo64='undef' +d_PRIu64='undef' +d_PRIx64='undef' +d_access='undef' +d_accessx='undef' +d_alarm='undef' +d_archlib='define' +d_atolf='undef' +d_atoll='undef' +d_attribut='undef' +d_bcmp='define' +d_bcopy='define' +d_bincompat5005='undef' +d_bsd='undef' +d_bsdgetpgrp='undef' +d_bsdsetpgrp='undef' +d_bzero='define' +d_casti32='undef' +d_castneg='undef' +d_charvspr='undef' +d_chown='undef' +d_chroot='undef' +d_chsize='undef' +d_closedir='undef' +d_cmsghdr_s='undef' +d_const='define' +d_crypt='undef' +d_csh='undef' +d_cuserid='undef' +d_dbl_dig='undef' +d_difftime='define' +d_dirnamlen='undef' +d_dlerror='undef' +d_dlopen='undef' +d_dlsymun='undef' +d_dosuid='undef' +d_drand48proto='define' +d_dup2='undef' +d_eaccess='undef' +d_endgrent='undef' +d_endhent='undef' +d_endnent='undef' +d_endpent='undef' +d_endpwent='undef' +d_endsent='undef' +d_endspent='undef' +d_eofnblk='define' +d_eunice='undef' +d_fchmod='undef' +d_fchown='undef' +d_fcntl='undef' +d_fd_macros='undef' +d_fd_set='define' +d_fds_bits='undef' +d_fgetpos='define' +d_flexfnam='define' +d_flock='undef' +d_fork='undef' +d_fpathconf='undef' +d_fpos64_t='undef' +d_fseeko='undef' +d_fsetpos='define' +d_fstatfs='define' +d_fstatvfs='undef' +d_ftello='undef' +d_ftime='undef' +d_getgrent='undef' +d_getgrps='undef' +d_gethbyaddr='define' +d_gethbyname='define' +d_gethent='undef' +d_gethname='undef' +d_gethostprotos='define' +d_getlogin='undef' +d_getmntent='undef' +d_getnbyaddr='undef' +d_getnbyname='undef' +d_getnent='undef' +d_getnetprotos='define' +d_getpbyname='define' +d_getpbynumber='define' +d_getpent='undef' +d_getpgid='undef' +d_getpgrp2='undef' +d_getpgrp='undef' +d_getppid='undef' +d_getprior='undef' +d_getprotoprotos='define' +d_getpwent='undef' +d_getsbyname='undef' +d_getsbyport='undef' +d_getsent='undef' +d_getservprotos='define' +d_getspent='undef' +d_getspnam='undef' +d_gettimeod='define' +d_gnulibc='undef' +d_grpasswd='undef' +d_hasmntopt='undef' +d_htonl='define' +d_index='undef' +d_inetaton='define' +d_int64t='undef' +d_iovec_s='undef' +d_isascii='define' +d_killpg='undef' +d_lchown='undef' +d_ldbl_dig='undef' +d_link='undef' +d_llseek='undef' +d_locconv='undef' +d_lockf='undef' +d_longdbl='undef' +d_longlong='define' +d_lstat='undef' +d_madvise='undef' +d_mblen='undef' +d_mbstowcs='undef' +d_mbtowc='undef' +d_memchr='define' +d_memcmp='define' +d_memcpy='define' +d_memmove='define' +d_memset='define' +d_mkdir='define' +d_mkfifo='undef' +d_mktime='define' +d_mmap='undef' +d_mprotect='undef' +d_msg='undef' +d_msg_ctrunc='undef' +d_msg_dontroute='undef' +d_msg_oob='undef' +d_msg_peek='undef' +d_msg_proxy='undef' +d_msgctl='undef' +d_msgget='undef' +d_msghdr_s='undef' +d_msgrcv='undef' +d_msgsnd='undef' +d_msync='undef' +d_munmap='undef' +d_mymalloc='undef' +d_nice='undef' +d_off64_t='undef' +d_old_pthread_create_joinable='undef' +d_oldpthreads='undef' +d_oldsock='undef' +d_open3='define' +d_pathconf='undef' +d_pause='undef' +d_phostname='undef' +d_pipe='undef' +d_poll='undef' +d_portable='undef' +d_pthread_yield='undef' +d_pwage='undef' +d_pwchange='undef' +d_pwclass='undef' +d_pwcomment='undef' +d_pwexpire='undef' +d_pwgecos='undef' +d_pwpasswd='undef' +d_pwquota='undef' +d_readdir='define' +d_readlink='undef' +d_readv='undef' +d_recvmsg='undef' +d_rename='define' +d_rewinddir='define' +d_rmdir='define' +d_safebcpy='undef' +d_safemcpy='undef' +d_sanemcmp='define' +d_sched_yield='undef' +d_scm_rights='undef' +d_seekdir='define' +d_select='undef' +d_sem='undef' +d_semctl='undef' +d_semctl_semid_ds='define' +d_semctl_semun='define' +d_semget='undef' +d_semop='undef' +d_sendmsg='undef' +d_setegid='undef' +d_seteuid='undef' +d_setgrent='undef' +d_setgrps='undef' +d_sethent='undef' +d_setlinebuf='undef' +d_setlocale='undef' +d_setnent='undef' +d_setpent='undef' +d_setpgid='undef' +d_setpgrp2='undef' +d_setpgrp='undef' +d_setprior='undef' +d_setpwent='undef' +d_setregid='undef' +d_setresgid='undef' +d_setresuid='undef' +d_setreuid='undef' +d_setrgid='undef' +d_setruid='undef' +d_setsent='undef' +d_setsid='undef' +d_setspent='undef' +d_setvbuf='undef' +d_sfio='undef' +d_shm='undef' +d_shmat='undef' +d_shmatprototype='undef' +d_shmctl='undef' +d_shmdt='undef' +d_shmget='undef' +d_sigaction='undef' +d_sigsetjmp='undef' +d_socket='define' +d_sockpair='undef' +d_statblks='define' +d_statfs='undef' +d_statfsflags='define' +d_statvfs='undef' +d_stdio_cnt_lval='define' +d_stdio_ptr_lval='define' +d_stdio_stream_array='undef' +d_stdiobase='undef' +d_stdstdio='undef' +d_strchr='define' +d_strcoll='define' +d_strctcpy='define' +d_strerrm='strerror(e)' +d_strerror='define' +d_strtod='define' +d_strtol='define' +d_strtoul='define' +d_strtoull='undef' +d_strxfrm='define' +d_suidsafe='undef' +d_symlink='undef' +d_syscall='undef' +d_sysconf='define' +d_sysernlst='undef' +d_syserrlst='undef' +d_system='define' +d_tcgetpgrp='undef' +d_tcsetpgrp='undef' +d_telldir='define' +d_telldirproto='define' +d_time='undef' +d_times='undef' +d_truncate='undef' +d_tzname='undef' +d_umask='undef' +d_uname='undef' +d_union_semun='undef' +d_vendorlib='undef' +d_vfork='undef' +d_void_closedir='undef' +d_voidsig='undef' +d_voidtty='undef' +d_volatile='define' +d_vprintf='define' +d_wait4='undef' +d_waitpid='undef' +d_wcstombs='undef' +d_wctomb='undef' +d_writev='undef' +d_xenix='undef' +date='date' +db_hashtype='undef' +db_prefixtype='undef' +defvoidused='15' +direntrytype='struct dirent' +dlext='none' +dlsrc='dl_none.xs' +doublesize='8' +drand01='(rand()/(double)(1U<<RANDBITS))' +dynamic_ext='' +eagain='EAGAIN' +ebcdic='undef' +echo='echo' +egrep='egrep' +emacs='' +eunicefix=':' +exe_ext='' +expr='expr' +extensions='Data/Dumper File/Glob IO Socket' +fflushNULL='undef' +fflushall='define' +find='' +firstmakefile='makefile' +flex='' +fpostype='fpos_t' +freetype='void' +full_ar='/usr/local/bin/arm-pe-ar' +full_csh='' +full_sed='/usr/bin/sed' +gccversion='' +gidtype='gid_t' +glibpth='' +grep='grep' +groupcat='' +groupstype='gid_t' +gzip='gzip' +h_fcntl='' +h_sysfile='' +hint='' +hostcat='' +huge='' +i_arpainet='define' +i_bsdioctl='undef' +i_db='undef' +i_dbm='undef' +i_dirent='define' +i_dld='undef' +i_dlfcn='undef' +i_fcntl='define' +i_float='undef' +i_gdbm='undef' +i_grp='undef' +i_inttypes='undef' +i_limits='define' +i_locale='undef' +i_machcthr='undef' +i_malloc='undef' +i_math='define' +i_memory='undef' +i_mntent='undef' +i_ndbm='undef' +i_netdb='define' +i_neterrno='undef' +i_netinettcp='define' +i_niin='define' +i_poll='undef' +i_pthread='undef' +i_pwd='undef' +i_rpcsvcdbm='undef' +i_sfio='undef' +i_sgtty='undef' +i_shadow='undef' +i_socks='undef' +i_stdarg='define' +i_stddef='define' +i_stdlib='define' +i_string='define' +i_sysaccess='undef' +i_sysdir='undef' +i_sysfile='undef' +i_sysfilio='undef' +i_sysin='undef' +i_sysioctl='define' +i_sysmman='undef' +i_sysmount='undef' +i_sysndir='undef' +i_sysparam='define' +i_sysresrc='define' +i_syssecrt='undef' +i_sysselct='undef' +i_syssockio='undef' +i_sysstat='define' +i_sysstatvfs='undef' +i_systime='define' +i_systimek='undef' +i_systimes='define' +i_systypes='define' +i_sysuio='undef' +i_sysun='undef' +i_syswait='define' +i_termio='undef' +i_termios='undef' +i_time='define' +i_unistd='define' +i_utime='undef' +i_values='undef' +i_varargs='undef' +i_varhdr='undef' +i_vfork='undef' +ignore_versioned_solibs='' +incpath='' +inews='' +installarchlib='/home/olaf/E/lib' +installbin='/home/olaf/E/bin' +installman1dir='' +installman3dir='' +installprefix='/home/olaf/' +installprefixexp='' +installprivlib='' +installscript='' +installsitearch='/home/olaf/E/site/' +installsitelib='/home/olaf/E/site/lib' +installstyle='' +installusrbinperl='undef' +installvendorlib='' +intsize='4' +known_extensions='Data/Dumper File/Glob IO Socket' +ksh='' +large='' +ld='echo' +lddlflags='' +ldflags='' +ldlibpthname='' +less='' +lib_ext='' +libc='' +libperl='perl.a' +libpth='' +libs='' +libswanted='' +line='' +lint='' +lkflags='' +ln='ln' +lns='/bin/ln -s' +locincpth='' +loclibpth='' +longdblsize='8' +longlongsize='8' +longsize='4' +lp='' +lpr='' +ls='ls' +lseeksize='8' +lseektype='off_t' +mail='' +mailx='' +make='make' +make_set_make='#' +mallocobj='' +mallocsrc='' +malloctype='void *' +man1dir='' +man1direxp='' +man1ext='' +man3dir='' +man3direxp='' +man3ext='' +medium='' +mips='' +mips_type='' +mkdir='mkdir' +mmaptype='' +models='none' +modetype='mode_t' +more='more' +multiarch='define' +mv='' +myarchname='epoc' +mydomain='.gmx.de' +myhostname='dragon' +myuname='' +n='-n' +netdb_hlen_type='int' +netdb_host_type='const char *' +netdb_name_type='const char *' +netdb_net_type='int' +nm='arm-pe-nm' +nm_opt='' +nm_so_opt='' +nonxs_ext='' +nroff='nroff' +o_nonblock='O_NONBLOCK' +obj_ext='' +old_pthread_create_joinable='' +optimize='-fomit-frame-pointer -DNDEBUG -O' +orderlib='' +osname='epoc' +osvers='' +package='' +pager='' +passcat='' +patchlevel='' +path_sep='' +perl='' +perladmin='' +perlpath='' +pg='' +phostname='' +pidtype='pid_t' +plibpth='' +pmake='' +pr='' +prefix='' +prefixexp='' +privlib='/perl/lib/5.5.640' +privlibexp='/perl/lib/5.5.640' +prototype='define' +ptrsize='4' +randbits='31' +randfunc='' +randseedtype='unsigned' +ranlib='arm-pe-ranlib' +rd_nodata='-1' +rm='rm' +rmail='' +runnm='false' +sPRIEldbl='' +sPRIFldbl='' +sPRIGldbl='' +sPRIX64='' +sPRId64='' +sPRIeldbl='' +sPRIfldbl='"f"' +sPRIgldbl='"g"' +sPRIi64='' +sPRIo64='' +sPRIu64='' +sPRIx64='' +sched_yield='' +scriptdir='' +scriptdirexp='' +sed='sed' +seedfunc='srand' +selectminbits='32' +selecttype='' +sendmail='' +sh='/bin/sh' +shar='' +sharpbang='#!' +shmattype='' +shortsize='2' +shrpenv='' +shsharp='' +sig_count='ZERO ' +sig_name='' +sig_name_init='"ZERO", 0' +sig_num='0' +sig_num_init='0, 0' +signal_t='void' +sitearch='/perl/lib/site_perl/5.5.640/epoc' +sitearchexp='/perl/lib/site_perl/5.5.640/epoc' +sitelib='/perl/lib/site_perl/5.5.640/' +sitelibexp='/perl/lib/site_perl/5.5.640/' +siteprefix='' +siteprefixexp='' +sizetype='size_t' +sleep='' +smail='' +small='' +so='' +sockethdr='' +socketlib='' +sort='sort' +spackage='' +spitshell='cat' +split='' +src='.' +ssizetype='long' +startperl='' +startsh='#!/bin/sh' +static_ext='Data/Dumper File/Glob IO Socket' +stdchar='char' +stdio_base='' +stdio_bufsiz='' +stdio_cnt='' +stdio_filbuf='' +stdio_ptr='' +stdio_stream_array='' +strings='' +submit='' +subversion='' +sysman='' +tail='' +tar='' +tbl='' +tee='tee' +test='test' +timeincl='' +timetype='time_t' +touch='touch' +tr='tr' +trnl='\n' +troff='' +uidsign='1' +uidtype='uid_t' +uname='uname' +uniq='uniq' +use64bits='undef' +usedl='undef' +uselargefiles='undef' +uselongdouble='undef' +usemorebits='undef' +usemultiplicity='undef' +usemymalloc='n' +usenm='' +useopcode='' +useperlio='undef' +useposix='' +usesfio='' +useshrplib='' +usesocks='undef' +usethreads='undef' +usevendorprefix='' +usevfork='' +usrinc='' +uuname='' +vendorlib='' +vendorlibexp='' +vendorprefix='' +vendorprefixexp='' +version='5.5.640' +vi='' +voidflags='15' +xlibpth='' +zcat='' +zip='' +# Configure command line arguments. +config_arg0='' +config_args='' +config_argc=11 +config_arg1='' +config_arg2='' +config_arg3='' +config_arg4='' +config_arg5='' +config_arg6='' +config_arg7='' +config_arg8='' +config_arg9='' +config_arg10='' +config_arg11='' +PERL_REVISION=5 +PERL_VERSION=5 +PERL_SUBVERSION=640 +PERL_API_REVISION=5 +PERL_API_VERSION=5 +PERL_API_SUBVERSION=640 +CONFIGDOTSH=true +# Variables propagated from previous config.sh file. +pp_sys_cflags='' +epocish_cflags='ccflags="$cflags -xc++"' +ivtype='int' +uvtype='unsigned int' +i8type='char' +u8type='unsigned char' +i16type='short' +u16type='unsigned short' +i32type='int' +u32type='unsigned int' +i64type='long long' +u64type='unsigned long long' +d_quad='define' +quadtype='long long' +quadtype='unsigned long long' +quadkind='QUAD_IS_LONG_LONG' +nvtype='double' +ivsize='4' +uvsize='4' +i8size='1' +u8size='1' +i16size='2' +u16size='2' +i32size='4' +u32size='4' +i64size='8' +u64size='8' +d_fs_data_s='undef' +d_fseeko='undef' +d_ldbl_dig='undef' +d_sqrtl='undef' +d_getmnt='undef' +d_statfs_f_flags='undef' +d_statfs_s='undef' +d_ustat='undef' +i_sysstatfs='undef' +i_sysvfs='undef' +i_ustat='undef' +uselonglong='define' +uidsize='2' +gidsize='2' + diff --git a/epoc/createpkg.pl b/epoc/createpkg.pl index 5123262520..7270504974 100644 --- a/epoc/createpkg.pl +++ b/epoc/createpkg.pl @@ -4,15 +4,16 @@ use File::Find; use Cwd; $VERSION="5.005"; -$PATCH=62; -$EPOC_VERSION=11; -$CROSSCOMPILEPATH="Y:"; +$PATCH=63; +$EPOC_VERSION=16; +$CROSSCOMPILEPATH=cwd; +$CROSSREPLACEPATH="H:\\devel\\perl5.005_63"; sub filefound { my $f = $File::Find::name; - return if ( $f =~ /ExtUtils|unicode|CGI|CPAN|Net|IPC|User|DB.pm/i); + return if ( $f =~ /unicode|CPAN|ExtUtils|IPC|User|DB.pm|\.a$|\.ld$|\.exists$/i); my $back = $f; $back =~ s|$CROSSCOMPILEPATH||; @@ -21,25 +22,19 @@ sub filefound { my $psiback = $back; - $psiback =~ s/\\perl$VERSION\\perl$VERSION\_$PATCH\\lib\\/\\perl\\lib\\$VERSION$PATCH\\/i; + $psiback =~ s/\\lib\\/\\perl\\lib\\$VERSION$PATCH\\/i; - print OUT "\"$back\"-\"!:$psiback\"\n" if ( -f $f ); + print OUT "\"$CROSSREPLACEPATH$back\"-\"!:$psiback\"\n" if ( -f $f ); ; } - - - - open OUT,">perl.pkg"; print OUT "#{\"perl$VERSION\"},(0x100051d8),$PATCH,$EPOC_VERSION,0\n"; -print OUT "\"\\epoc32\\release\\marm\\rel\\perl.exe\"-\"!:\\perl.exe\"\n"; -print OUT "\"\\perl$VERSION\\perl${VERSION}_$PATCH\\epoc\\Config.pm\"-\"!:\\perl\\lib\\$VERSION$PATCH\\Config.pm\"\n"; +print OUT "\"$CROSSREPLACEPATH\\perlmain.exe\"-\"!:\\perl.exe\"\n"; find(\&filefound, cwd.'/lib'); - -print OUT "@\"\\epoc32\\release\\marm\\rel\\stdlib.sis\",(0x010002c3)\n" +print OUT "@\"G:\\lib\\stdlib.sis\",(0x010002c3)\n" diff --git a/epoc/epoc.c b/epoc/epoc.c index d0fae23f7e..498036dbc0 100644 --- a/epoc/epoc.c +++ b/epoc/epoc.c @@ -11,7 +11,6 @@ #include <stdio.h> #include <sys/unistd.h> -char *environ = NULL; void Perl_epoc_init(int *argcp, char ***argvp) { int i; @@ -87,4 +86,62 @@ __fixunsdfsi (a) return (SItype) a; } +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +int +do_aspawn( pTHX_ SV *really,SV **mark,SV **sp) { + return do_spawn( really, mark, sp); +} + +int +do_spawn (pTHX_ SV *really,SV **mark,SV **sp) +{ + dTHR; + int rc; + char **a,*cmd,**ptr, *cmdline, **argv, *p2; + STRLEN n_a; + size_t len = 0; + + if (sp<=mark) + return -1; + + a=argv=ptr=(char**) malloc ((sp-mark+3)*sizeof (char*)); + + while (++mark <= sp) { + if (*mark) + *a = SvPVx(*mark, n_a); + else + *a = ""; + len += strlen( *a) + 1; + a++; + } + *a = Nullch; + + if (!(really && *(cmd = SvPV(really, n_a)))) { + cmd = argv[0]; + argv++; + } + + cmdline = (char * ) malloc( len + 1); + cmdline[ 0] = '\0'; + while (*argv != NULL) { + strcat( cmdline, *argv++); + strcat( cmdline, " "); + } + + for (p2=cmd; *p2 != '\0'; p2++) { + /* Change / to \ */ + if ( *p2 == '/') + *p2 = '\\'; + } + rc = epoc_spawn( cmd, cmdline); + free( ptr); + free( cmdline); + + return rc; +} + + #endif diff --git a/epoc/epoc_stubs.c b/epoc/epoc_stubs.c index 02430b7378..b11da400d6 100644 --- a/epoc/epoc_stubs.c +++ b/epoc/epoc_stubs.c @@ -6,6 +6,10 @@ * */ +#include <string.h> + +char *environ = 0; + int getgid() {return 0;} int getegid() {return 0;} int geteuid() {return 0;} @@ -13,19 +17,53 @@ int getuid() {return 0;} int setgid() {return -1;} int setuid() {return -1;} + int Perl_my_popen( int a, int b) { - return 0; + return NULL; } int Perl_my_pclose( int a) { - return 0; + return NULL; +} + +int kill() {return -1;} +signal() { } + +int execv() { return -1;} +int execvp() { return -1;} + +void Perl_do_exec() {} + +/*------------------------------------------------------------------*/ +/* Two dummy functions implement getproto* */ +/*------------------------------------------------------------------*/ +#include <sys/types.h> +#include <netdb.h> +#include <netinet/in.h> + + +static struct protoent protos[2] = { + {"tcp", NULL, IPPROTO_TCP} , + {"udp", NULL, IPPROTO_UDP}}; + +struct protoent *getprotobyname (const char *st) { + + if (!strcmp( st, "tcp")) { + return &protos[0]; + } + if (!strcmp( st, "udp")) { + return &protos[1]; + } + return NULL; } -kill() {} -signal() {} +struct protoent *getprotobynumber ( int i) { + if (i == IPPROTO_TCP) { + return &protos[0]; + } + if (i == IPPROTO_UDP) { + return &protos[1]; + } + return NULL; +} -void execv() {} -void execvp() {} -void do_spawn() {} -void do_aspawn() {} -void Perl_do_exec() {} diff --git a/epoc/epocish.c b/epoc/epocish.c new file mode 100644 index 0000000000..134eaef0e0 --- /dev/null +++ b/epoc/epocish.c @@ -0,0 +1,34 @@ +/* + * Copyright (c) 1999 Olaf Flebbe o.flebbe@gmx.de + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + */ + +/* This is indeed C++ Code !! */ + +#include <e32std.h> + +extern "C" { + +epoc_spawn( char *cmd, char *cmdline) { + RProcess p; + TRequestStatus status; + TInt rc; + + rc = p.Create( _L( cmd), _L( cmdline)); + if (rc != KErrNone) + return -1; + + p.Resume(); + + p.Logon( status); + User::WaitForRequest( status); + if (status!=KErrNone) { + return -1; + } + return 0; +} + +} diff --git a/epoc/epocish.h b/epoc/epocish.h index 49cac27000..ca992cfdfb 100644 --- a/epoc/epocish.h +++ b/epoc/epocish.h @@ -118,3 +118,18 @@ #define dXSUB_SYS +/* getsockname returns the size of struct sockaddr_in *without* padding */ +#define BOGUS_GETNAME_RETURN 8 + +/* Yes, size_t is size_t */ +#define Sock_size_t size_t + +/* + read() on a socket blocks until buf is filled completly, + recv() returns each massage +*/ +#define PERL_SOCK_SYSREAD_IS_RECV + +/* No /dev/random available*/ + +#define PERL_NO_DEV_RANDOM diff --git a/epoc/link.pl b/epoc/link.pl new file mode 100644 index 0000000000..9da8a356ca --- /dev/null +++ b/epoc/link.pl @@ -0,0 +1,25 @@ +#!/usr/bin/perl -w + +$epoc="/usr/local/epoc"; +@objs=@ARGV; +$basname=$objs[0]; +$basname =~ s/.o//; +$baspe = $basname . "pe"; + + +system("arm-pe-ld -s -e _E32Startup --base-file $basname.bas " . + "-o $baspe.exe $epoc/lib/eexe.o @objs " . + "$epoc/lib/ecrt0.o $epoc/lib/estlib.lib $epoc/lib/euser.lib"); + +system("arm-pe-dlltool --as=arm-pe-as --output-exp $basname.exp " . + "--base-file $basname.bas $epoc/lib/eexe.o @objs " . + "$epoc/lib/ecrt0.o $epoc/lib/estlib.lib $epoc/lib/euser.lib"); + +system("arm-pe-ld -s -e _E32Startup -o $basname.exe $basname.exp " . + "-o $baspe.exe $epoc/lib/eexe.o @objs " . + "$epoc/lib/ecrt0.o $epoc/lib/estlib.lib $epoc/lib/euser.lib"); + +system( "wine \"$epoc/bin/petran.exe $baspe.exe $basname.exe " . + "-nocall -heap 0x00000400 0x00400000 -stack 0x0000c000 " . + "-uid1 0x1000007a -uid2 0x100051d8 -uid3 0x00000000 \" "); + diff --git a/epoc/perl.mmp b/epoc/perl.mmp deleted file mode 100644 index 926f6a7b26..0000000000 --- a/epoc/perl.mmp +++ /dev/null @@ -1,20 +0,0 @@ -target perl.exe -targettype exe -uid 0x100051d8 - -project perl5.005 -subproject perl5.005_62 - -SOURCE av.c deb.c doio.c doop.c dump.c globals.c gv.c hv.c mg.c miniperlmain.c op.c perl.c perlapi.c perlio.c perly.c pp.c pp_ctl.c pp_hot.c pp_sys.c regcomp.c regexec.c run.c scope.c sv.c taint.c toke.c universal.c utf8.c util.c xsutils.c epoc.c epoc_stubs.c -systeminclude \epoc32\include\libc \epoc32\include - -#if defined(MARM) -LIBRARY ecrt0.o -#else -LIBRARY ecrt0.obj -#endif - -epocstacksize 49152 -epocheapsize 1024 2097152 - -LIBRARY estlib.lib euser.lib diff --git a/epoc/perl.pkg b/epoc/perl.pkg deleted file mode 100644 index 8e5914850a..0000000000 --- a/epoc/perl.pkg +++ /dev/null @@ -1,141 +0,0 @@ -#{"perl5.005"},(0x100051d8),62,11,0 -"\epoc32\release\marm\rel\perl.exe"-"!:\perl.exe" -"\perl5.005\perl5.005_62\epoc\Config.pm"-"!:\perl\lib\5.00562\Config.pm" -"\PERL5.005\perl5.005_62\lib\AnyDBM_File.pm"-"!:\perl\lib\5.00562\AnyDBM_File.pm" -"\PERL5.005\perl5.005_62\lib\AutoLoader.pm"-"!:\perl\lib\5.00562\AutoLoader.pm" -"\PERL5.005\perl5.005_62\lib\AutoSplit.pm"-"!:\perl\lib\5.00562\AutoSplit.pm" -"\PERL5.005\perl5.005_62\lib\Benchmark.pm"-"!:\perl\lib\5.00562\Benchmark.pm" -"\PERL5.005\perl5.005_62\lib\Carp.pm"-"!:\perl\lib\5.00562\Carp.pm" -"\PERL5.005\perl5.005_62\lib\Carp\Heavy.pm"-"!:\perl\lib\5.00562\Carp\Heavy.pm" -"\PERL5.005\perl5.005_62\lib\Class\Struct.pm"-"!:\perl\lib\5.00562\Class\Struct.pm" -"\PERL5.005\perl5.005_62\lib\Cwd.pm"-"!:\perl\lib\5.00562\Cwd.pm" -"\PERL5.005\perl5.005_62\lib\Devel\SelfStubber.pm"-"!:\perl\lib\5.00562\Devel\SelfStubber.pm" -"\PERL5.005\perl5.005_62\lib\DirHandle.pm"-"!:\perl\lib\5.00562\DirHandle.pm" -"\PERL5.005\perl5.005_62\lib\Dumpvalue.pm"-"!:\perl\lib\5.00562\Dumpvalue.pm" -"\PERL5.005\perl5.005_62\lib\English.pm"-"!:\perl\lib\5.00562\English.pm" -"\PERL5.005\perl5.005_62\lib\Env.pm"-"!:\perl\lib\5.00562\Env.pm" -"\PERL5.005\perl5.005_62\lib\Exporter.pm"-"!:\perl\lib\5.00562\Exporter.pm" -"\PERL5.005\perl5.005_62\lib\Exporter\Heavy.pm"-"!:\perl\lib\5.00562\Exporter\Heavy.pm" -"\PERL5.005\perl5.005_62\lib\Fatal.pm"-"!:\perl\lib\5.00562\Fatal.pm" -"\PERL5.005\perl5.005_62\lib\File\Basename.pm"-"!:\perl\lib\5.00562\File\Basename.pm" -"\PERL5.005\perl5.005_62\lib\File\CheckTree.pm"-"!:\perl\lib\5.00562\File\CheckTree.pm" -"\PERL5.005\perl5.005_62\lib\File\Compare.pm"-"!:\perl\lib\5.00562\File\Compare.pm" -"\PERL5.005\perl5.005_62\lib\File\Copy.pm"-"!:\perl\lib\5.00562\File\Copy.pm" -"\PERL5.005\perl5.005_62\lib\File\DosGlob.pm"-"!:\perl\lib\5.00562\File\DosGlob.pm" -"\PERL5.005\perl5.005_62\lib\File\Find.pm"-"!:\perl\lib\5.00562\File\Find.pm" -"\PERL5.005\perl5.005_62\lib\File\Path.pm"-"!:\perl\lib\5.00562\File\Path.pm" -"\PERL5.005\perl5.005_62\lib\File\Spec.pm"-"!:\perl\lib\5.00562\File\Spec.pm" -"\PERL5.005\perl5.005_62\lib\File\Spec\Functions.pm"-"!:\perl\lib\5.00562\File\Spec\Functions.pm" -"\PERL5.005\perl5.005_62\lib\File\Spec\Mac.pm"-"!:\perl\lib\5.00562\File\Spec\Mac.pm" -"\PERL5.005\perl5.005_62\lib\File\Spec\OS2.pm"-"!:\perl\lib\5.00562\File\Spec\OS2.pm" -"\PERL5.005\perl5.005_62\lib\File\Spec\Unix.pm"-"!:\perl\lib\5.00562\File\Spec\Unix.pm" -"\PERL5.005\perl5.005_62\lib\File\Spec\VMS.pm"-"!:\perl\lib\5.00562\File\Spec\VMS.pm" -"\PERL5.005\perl5.005_62\lib\File\Spec\Win32.pm"-"!:\perl\lib\5.00562\File\Spec\Win32.pm" -"\PERL5.005\perl5.005_62\lib\File\STAT.PM"-"!:\perl\lib\5.00562\File\STAT.PM" -"\PERL5.005\perl5.005_62\lib\FileCache.pm"-"!:\perl\lib\5.00562\FileCache.pm" -"\PERL5.005\perl5.005_62\lib\FileHandle.pm"-"!:\perl\lib\5.00562\FileHandle.pm" -"\PERL5.005\perl5.005_62\lib\FindBin.pm"-"!:\perl\lib\5.00562\FindBin.pm" -"\PERL5.005\perl5.005_62\lib\Getopt\Long.pm"-"!:\perl\lib\5.00562\Getopt\Long.pm" -"\PERL5.005\perl5.005_62\lib\Getopt\Std.pm"-"!:\perl\lib\5.00562\Getopt\Std.pm" -"\PERL5.005\perl5.005_62\lib\I18N\Collate.pm"-"!:\perl\lib\5.00562\I18N\Collate.pm" -"\PERL5.005\perl5.005_62\lib\Math\BigFloat.pm"-"!:\perl\lib\5.00562\Math\BigFloat.pm" -"\PERL5.005\perl5.005_62\lib\Math\BigInt.pm"-"!:\perl\lib\5.00562\Math\BigInt.pm" -"\PERL5.005\perl5.005_62\lib\Math\Complex.pm"-"!:\perl\lib\5.00562\Math\Complex.pm" -"\PERL5.005\perl5.005_62\lib\Math\Trig.pm"-"!:\perl\lib\5.00562\Math\Trig.pm" -"\PERL5.005\perl5.005_62\lib\Pod\Checker.pm"-"!:\perl\lib\5.00562\Pod\Checker.pm" -"\PERL5.005\perl5.005_62\lib\Pod\Functions.pm"-"!:\perl\lib\5.00562\Pod\Functions.pm" -"\PERL5.005\perl5.005_62\lib\Pod\Html.pm"-"!:\perl\lib\5.00562\Pod\Html.pm" -"\PERL5.005\perl5.005_62\lib\Pod\InputObjects.pm"-"!:\perl\lib\5.00562\Pod\InputObjects.pm" -"\PERL5.005\perl5.005_62\lib\Pod\Man.pm"-"!:\perl\lib\5.00562\Pod\Man.pm" -"\PERL5.005\perl5.005_62\lib\Pod\Parser.pm"-"!:\perl\lib\5.00562\Pod\Parser.pm" -"\PERL5.005\perl5.005_62\lib\Pod\Select.pm"-"!:\perl\lib\5.00562\Pod\Select.pm" -"\PERL5.005\perl5.005_62\lib\Pod\Text.pm"-"!:\perl\lib\5.00562\Pod\Text.pm" -"\PERL5.005\perl5.005_62\lib\Pod\Text\Color.pm"-"!:\perl\lib\5.00562\Pod\Text\Color.pm" -"\PERL5.005\perl5.005_62\lib\Pod\Text\Termcap.pm"-"!:\perl\lib\5.00562\Pod\Text\Termcap.pm" -"\PERL5.005\perl5.005_62\lib\Pod\Usage.pm"-"!:\perl\lib\5.00562\Pod\Usage.pm" -"\PERL5.005\perl5.005_62\lib\Search\Dict.pm"-"!:\perl\lib\5.00562\Search\Dict.pm" -"\PERL5.005\perl5.005_62\lib\SelectSaver.pm"-"!:\perl\lib\5.00562\SelectSaver.pm" -"\PERL5.005\perl5.005_62\lib\SelfLoader.pm"-"!:\perl\lib\5.00562\SelfLoader.pm" -"\PERL5.005\perl5.005_62\lib\Shell.pm"-"!:\perl\lib\5.00562\Shell.pm" -"\PERL5.005\perl5.005_62\lib\Symbol.pm"-"!:\perl\lib\5.00562\Symbol.pm" -"\PERL5.005\perl5.005_62\lib\Sys\Hostname.pm"-"!:\perl\lib\5.00562\Sys\Hostname.pm" -"\PERL5.005\perl5.005_62\lib\Sys\Syslog.pm"-"!:\perl\lib\5.00562\Sys\Syslog.pm" -"\PERL5.005\perl5.005_62\lib\Term\Cap.pm"-"!:\perl\lib\5.00562\Term\Cap.pm" -"\PERL5.005\perl5.005_62\lib\Term\Complete.pm"-"!:\perl\lib\5.00562\Term\Complete.pm" -"\PERL5.005\perl5.005_62\lib\Term\ReadLine.pm"-"!:\perl\lib\5.00562\Term\ReadLine.pm" -"\PERL5.005\perl5.005_62\lib\Test.pm"-"!:\perl\lib\5.00562\Test.pm" -"\PERL5.005\perl5.005_62\lib\Test\Harness.pm"-"!:\perl\lib\5.00562\Test\Harness.pm" -"\PERL5.005\perl5.005_62\lib\Text\Abbrev.pm"-"!:\perl\lib\5.00562\Text\Abbrev.pm" -"\PERL5.005\perl5.005_62\lib\Text\ParseWords.pm"-"!:\perl\lib\5.00562\Text\ParseWords.pm" -"\PERL5.005\perl5.005_62\lib\Text\Soundex.pm"-"!:\perl\lib\5.00562\Text\Soundex.pm" -"\PERL5.005\perl5.005_62\lib\Text\Tabs.pm"-"!:\perl\lib\5.00562\Text\Tabs.pm" -"\PERL5.005\perl5.005_62\lib\Text\Wrap.pm"-"!:\perl\lib\5.00562\Text\Wrap.pm" -"\PERL5.005\perl5.005_62\lib\Tie\Array.pm"-"!:\perl\lib\5.00562\Tie\Array.pm" -"\PERL5.005\perl5.005_62\lib\Tie\Handle.pm"-"!:\perl\lib\5.00562\Tie\Handle.pm" -"\PERL5.005\perl5.005_62\lib\Tie\Hash.pm"-"!:\perl\lib\5.00562\Tie\Hash.pm" -"\PERL5.005\perl5.005_62\lib\Tie\RefHash.pm"-"!:\perl\lib\5.00562\Tie\RefHash.pm" -"\PERL5.005\perl5.005_62\lib\Tie\Scalar.pm"-"!:\perl\lib\5.00562\Tie\Scalar.pm" -"\PERL5.005\perl5.005_62\lib\Tie\SubstrHash.pm"-"!:\perl\lib\5.00562\Tie\SubstrHash.pm" -"\PERL5.005\perl5.005_62\lib\Time\Local.pm"-"!:\perl\lib\5.00562\Time\Local.pm" -"\PERL5.005\perl5.005_62\lib\Time\GMTIME.PM"-"!:\perl\lib\5.00562\Time\GMTIME.PM" -"\PERL5.005\perl5.005_62\lib\Time\localtime.pm"-"!:\perl\lib\5.00562\Time\localtime.pm" -"\PERL5.005\perl5.005_62\lib\Time\TM.PM"-"!:\perl\lib\5.00562\Time\TM.PM" -"\PERL5.005\perl5.005_62\lib\UNIVERSAL.pm"-"!:\perl\lib\5.00562\UNIVERSAL.pm" -"\PERL5.005\perl5.005_62\lib\ABBREV.PL"-"!:\perl\lib\5.00562\ABBREV.PL" -"\PERL5.005\perl5.005_62\lib\ASSERT.PL"-"!:\perl\lib\5.00562\ASSERT.PL" -"\PERL5.005\perl5.005_62\lib\attributes.pm"-"!:\perl\lib\5.00562\attributes.pm" -"\PERL5.005\perl5.005_62\lib\AUTOUSE.PM"-"!:\perl\lib\5.00562\AUTOUSE.PM" -"\PERL5.005\perl5.005_62\lib\BASE.PM"-"!:\perl\lib\5.00562\BASE.PM" -"\PERL5.005\perl5.005_62\lib\BIGFLOAT.PL"-"!:\perl\lib\5.00562\BIGFLOAT.PL" -"\PERL5.005\perl5.005_62\lib\BIGINT.PL"-"!:\perl\lib\5.00562\BIGINT.PL" -"\PERL5.005\perl5.005_62\lib\BIGRAT.PL"-"!:\perl\lib\5.00562\BIGRAT.PL" -"\PERL5.005\perl5.005_62\lib\BLIB.PM"-"!:\perl\lib\5.00562\BLIB.PM" -"\PERL5.005\perl5.005_62\lib\CACHEOUT.PL"-"!:\perl\lib\5.00562\CACHEOUT.PL" -"\PERL5.005\perl5.005_62\lib\CALLER.PM"-"!:\perl\lib\5.00562\CALLER.PM" -"\PERL5.005\perl5.005_62\lib\charnames.pm"-"!:\perl\lib\5.00562\charnames.pm" -"\PERL5.005\perl5.005_62\lib\CHAT2.PL"-"!:\perl\lib\5.00562\CHAT2.PL" -"\PERL5.005\perl5.005_62\lib\COMPLETE.PL"-"!:\perl\lib\5.00562\COMPLETE.PL" -"\PERL5.005\perl5.005_62\lib\CONSTANT.PM"-"!:\perl\lib\5.00562\CONSTANT.PM" -"\PERL5.005\perl5.005_62\lib\CTIME.PL"-"!:\perl\lib\5.00562\CTIME.PL" -"\PERL5.005\perl5.005_62\lib\diagnostics.pm"-"!:\perl\lib\5.00562\diagnostics.pm" -"\PERL5.005\perl5.005_62\lib\DOTSH.PL"-"!:\perl\lib\5.00562\DOTSH.PL" -"\PERL5.005\perl5.005_62\lib\DUMPVAR.PL"-"!:\perl\lib\5.00562\DUMPVAR.PL" -"\PERL5.005\perl5.005_62\lib\exceptions.pl"-"!:\perl\lib\5.00562\exceptions.pl" -"\PERL5.005\perl5.005_62\lib\FASTCWD.PL"-"!:\perl\lib\5.00562\FASTCWD.PL" -"\PERL5.005\perl5.005_62\lib\FIELDS.PM"-"!:\perl\lib\5.00562\FIELDS.PM" -"\PERL5.005\perl5.005_62\lib\FILETEST.PM"-"!:\perl\lib\5.00562\FILETEST.PM" -"\PERL5.005\perl5.005_62\lib\FIND.PL"-"!:\perl\lib\5.00562\FIND.PL" -"\PERL5.005\perl5.005_62\lib\finddepth.pl"-"!:\perl\lib\5.00562\finddepth.pl" -"\PERL5.005\perl5.005_62\lib\FLUSH.PL"-"!:\perl\lib\5.00562\FLUSH.PL" -"\PERL5.005\perl5.005_62\lib\FTP.PL"-"!:\perl\lib\5.00562\FTP.PL" -"\PERL5.005\perl5.005_62\lib\GETCWD.PL"-"!:\perl\lib\5.00562\GETCWD.PL" -"\PERL5.005\perl5.005_62\lib\GETOPT.PL"-"!:\perl\lib\5.00562\GETOPT.PL" -"\PERL5.005\perl5.005_62\lib\GETOPTS.PL"-"!:\perl\lib\5.00562\GETOPTS.PL" -"\PERL5.005\perl5.005_62\lib\HOSTNAME.PL"-"!:\perl\lib\5.00562\HOSTNAME.PL" -"\PERL5.005\perl5.005_62\lib\importenv.pl"-"!:\perl\lib\5.00562\importenv.pl" -"\PERL5.005\perl5.005_62\lib\INTEGER.PM"-"!:\perl\lib\5.00562\INTEGER.PM" -"\PERL5.005\perl5.005_62\lib\LESS.PM"-"!:\perl\lib\5.00562\LESS.PM" -"\PERL5.005\perl5.005_62\lib\LIB.PM"-"!:\perl\lib\5.00562\LIB.PM" -"\PERL5.005\perl5.005_62\lib\LOCALE.PM"-"!:\perl\lib\5.00562\LOCALE.PM" -"\PERL5.005\perl5.005_62\lib\LOOK.PL"-"!:\perl\lib\5.00562\LOOK.PL" -"\PERL5.005\perl5.005_62\lib\newgetopt.pl"-"!:\perl\lib\5.00562\newgetopt.pl" -"\PERL5.005\perl5.005_62\lib\OPEN2.PL"-"!:\perl\lib\5.00562\OPEN2.PL" -"\PERL5.005\perl5.005_62\lib\OPEN3.PL"-"!:\perl\lib\5.00562\OPEN3.PL" -"\PERL5.005\perl5.005_62\lib\OVERLOAD.PM"-"!:\perl\lib\5.00562\OVERLOAD.PM" -"\PERL5.005\perl5.005_62\lib\PERL5DB.PL"-"!:\perl\lib\5.00562\PERL5DB.PL" -"\PERL5.005\perl5.005_62\lib\PWD.PL"-"!:\perl\lib\5.00562\PWD.PL" -"\PERL5.005\perl5.005_62\lib\shellwords.pl"-"!:\perl\lib\5.00562\shellwords.pl" -"\PERL5.005\perl5.005_62\lib\SIGTRAP.PM"-"!:\perl\lib\5.00562\SIGTRAP.PM" -"\PERL5.005\perl5.005_62\lib\STAT.PL"-"!:\perl\lib\5.00562\STAT.PL" -"\PERL5.005\perl5.005_62\lib\STRICT.PM"-"!:\perl\lib\5.00562\STRICT.PM" -"\PERL5.005\perl5.005_62\lib\SUBS.PM"-"!:\perl\lib\5.00562\SUBS.PM" -"\PERL5.005\perl5.005_62\lib\SYSLOG.PL"-"!:\perl\lib\5.00562\SYSLOG.PL" -"\PERL5.005\perl5.005_62\lib\TAINTED.PL"-"!:\perl\lib\5.00562\TAINTED.PL" -"\PERL5.005\perl5.005_62\lib\TERMCAP.PL"-"!:\perl\lib\5.00562\TERMCAP.PL" -"\PERL5.005\perl5.005_62\lib\timelocal.pl"-"!:\perl\lib\5.00562\timelocal.pl" -"\PERL5.005\perl5.005_62\lib\UTF8.PM"-"!:\perl\lib\5.00562\UTF8.PM" -"\PERL5.005\perl5.005_62\lib\utf8_heavy.pl"-"!:\perl\lib\5.00562\utf8_heavy.pl" -"\PERL5.005\perl5.005_62\lib\VALIDATE.PL"-"!:\perl\lib\5.00562\VALIDATE.PL" -"\PERL5.005\perl5.005_62\lib\VARS.PM"-"!:\perl\lib\5.00562\VARS.PM" -"\PERL5.005\perl5.005_62\lib\WARNINGS.PM"-"!:\perl\lib\5.00562\WARNINGS.PM" -@"\epoc32\release\marm\rel\stdlib.sis",(0x010002c3) diff --git a/ext/B/B.pm b/ext/B/B.pm index 6661ebac93..8c46479c75 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -6,9 +6,9 @@ # License or the Artistic License, as specified in the README file. # package B; -require DynaLoader; +use XSLoader (); require Exporter; -@ISA = qw(Exporter DynaLoader); +@ISA = qw(Exporter); @EXPORT_OK = qw(minus_c ppname class peekop cast_I32 cstring cchar hash threadsv_names main_root main_start main_cv svref_2object opnumber amagic_generation @@ -259,7 +259,7 @@ sub walksymtable { } } -bootstrap B; +XSLoader::load 'B'; 1; diff --git a/ext/B/B.xs b/ext/B/B.xs index 7d0fc742fc..260c0c7b41 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -679,9 +679,8 @@ PMOP_precomp(o) if (rx) sv_setpvn(ST(0), rx->precomp, rx->prelen); -#define SVOP_sv(o) o->op_sv -#define SVOP_gv(o) ((SvTYPE(o->op_sv) == SVt_PVGV) \ - ? (GV*)o->op_sv : Nullgv) +#define SVOP_sv(o) cSVOPx_sv(o) +#define SVOP_gv(o) cGVOPx_gv(o) MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_ diff --git a/ext/B/B/Bytecode.pm b/ext/B/B/Bytecode.pm index 8764a0d588..cb061f3038 100644 --- a/ext/B/B/Bytecode.pm +++ b/ext/B/B/Bytecode.pm @@ -299,7 +299,6 @@ cop_arybase %d cop_line $line cop_warnings $warningsix EOT - $stash->bytecode; } sub B::PMOP::bytecode { @@ -705,6 +704,10 @@ sub compile { $arg ||= shift @options; open(OUT, ">$arg") or return "$arg: $!\n"; binmode OUT; + } elsif ($opt eq "a") { + $arg ||= shift @options; + open(OUT, ">>$arg") or return "$arg: $!\n"; + binmode OUT; } elsif ($opt eq "D") { $arg ||= shift @options; foreach $arg (split(//, $arg)) { @@ -814,6 +817,10 @@ extra arguments, it saves the main program. Output to filename instead of STDOUT. +=item B<-afilename> + +Append output to filename. + =item B<--> Force end of options. diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm index f8607444f4..6e3af0d5bc 100644 --- a/ext/B/B/C.pm +++ b/ext/B/B/C.pm @@ -269,10 +269,11 @@ sub B::SVOP::save { my $sym = objsym($op); return $sym if defined $sym; my $svsym = $op->sv->save; - $svopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, %s", + $svopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, Nullsv", ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op_seq, $op->flags, - $op->private, "(SV*)$svsym")); + $op->private)); + $init->add(sprintf("svop_list[%d].op_sv = %s;", $svopsect->index, "(SV*)$svsym")); savesym($op, sprintf("(OP*)&svop_list[%d]", $svopsect->index)); } @@ -302,7 +303,7 @@ sub B::COP::save { $op->arybase, $op->line)); my $copix = $copsect->index; $init->add(sprintf("CopFILE_set(&cop_list[%d], %s);", $copix, cstring($op->file)), - sprintf("CopSTASHPV_set(&cop_list[%d], %s);", $copix, cstring($op->stashpv)); + sprintf("CopSTASHPV_set(&cop_list[%d], %s);", $copix, cstring($op->stashpv))); savesym($op, "(OP*)&cop_list[$copix]"); } @@ -682,7 +683,7 @@ sub B::CV::save { $cvstashname, $cvname); # debug } $pv = '' unless defined $pv; # Avoid use of undef warnings - $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, Nullgv, %d, s\\_%x, (CV*)s\\_%x, 0x%x", + $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, \"\", %d, s\\_%x, (CV*)s\\_%x, 0x%x", $xpvcv_ix, cstring($pv), length($pv), $cv->IVX, $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH, $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS)); @@ -1045,10 +1046,10 @@ sub output_boilerplate { #undef Perl_pp_mapstart #define Perl_pp_mapstart Perl_pp_grepstart #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader -EXTERN_C void boot_DynaLoader (CV* cv); +EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); -static void xs_init (void); -static void dl_init (void); +static void xs_init (pTHX); +static void dl_init (pTHX); static PerlInterpreter *my_perl; EOT } @@ -1056,28 +1057,20 @@ EOT sub output_main { print <<'EOT'; int -#ifndef CAN_PROTOTYPE -main(argc, argv, env) -int argc; -char **argv; -char **env; -#else /* def(CAN_PROTOTYPE) */ main(int argc, char **argv, char **env) -#endif /* def(CAN_PROTOTYPE) */ { int exitstatus; int i; char **fakeargv; - PERL_SYS_INIT(&argc,&argv); + PERL_SYS_INIT3(&argc,&argv,&env); - perl_init_i18nl10n(1); - if (!PL_do_undump) { my_perl = perl_alloc(); if (!my_perl) exit(1); perl_construct( my_perl ); + PL_perl_destruct_level = 0; } #ifdef CSH @@ -1113,19 +1106,21 @@ main(int argc, char **argv, char **env) exitstatus = perl_init(); if (exitstatus) exit( exitstatus ); - dl_init(); + dl_init(aTHX); exitstatus = perl_run( my_perl ); perl_destruct( my_perl ); perl_free( my_perl ); + PERL_SYS_TERM(); + exit( exitstatus ); } /* yanked from perl.c */ static void -xs_init() +xs_init(pTHX) { char *file = __FILE__; dTARG; @@ -1142,7 +1137,7 @@ EOT print "\tPUSHMARK(sp);\n"; print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/; print qq/\tPUTBACK;\n/; - print "\tboot_DynaLoader(NULL);\n"; + print "\tboot_DynaLoader(aTHX_ NULL);\n"; print qq/\tSPAGAIN;\n/; print "#endif\n"; foreach my $stashname (keys %xsub){ @@ -1152,7 +1147,7 @@ EOT print "\tPUSHMARK(sp);\n"; print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/; print qq/\tPUTBACK;\n/; - print "\tboot_$stashxsub(NULL);\n"; + print "\tboot_$stashxsub(aTHX_ NULL);\n"; print qq/\tSPAGAIN;\n/; } } @@ -1161,7 +1156,7 @@ EOT print <<'EOT'; static void -dl_init() +dl_init(pTHX) { char *file = __FILE__; dTARG; @@ -1181,7 +1176,7 @@ EOT warn "bootstrapping $stashname added to xs_init\n"; print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/; print "\n#else\n"; - print "\tboot_$stashxsub(NULL);\n"; + print "\tboot_$stashxsub(aTHX_ NULL);\n"; print "#endif\n"; print qq/\tSPAGAIN;\n/; } diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm index 0fe5e7d8d5..cf0e81f92e 100644 --- a/ext/B/B/CC.pm +++ b/ext/B/B/CC.pm @@ -1644,8 +1644,8 @@ XS(boot_$cmodule) perl_init(); ENTER; SAVETMPS; - SAVESPTR(PL_curpad); - SAVESPTR(PL_op); + SAVEVPTR(PL_curpad); + SAVEVPTR(PL_op); PL_curpad = AvARRAY($curpad_sym); PL_op = $start; pp_main(aTHX); diff --git a/ext/B/Makefile.PL b/ext/B/Makefile.PL index dcff65a50b..cb9696bf41 100644 --- a/ext/B/Makefile.PL +++ b/ext/B/Makefile.PL @@ -26,7 +26,7 @@ WriteMakefile( package MY; sub post_constants { - "\nLIBS = $Config{libs}\n" + "\nLIBS = $Config::Config{libs}\n" } sub postamble { diff --git a/ext/B/ramblings/runtime.porting b/ext/B/ramblings/runtime.porting index 4699b255cf..d58b01105e 100644 --- a/ext/B/ramblings/runtime.porting +++ b/ext/B/ramblings/runtime.porting @@ -33,8 +33,10 @@ glob 5 2 do_readline readline 8 2 do_readline rcatline 8 2 regcmaybe 8 1 +regcreset 8 1 regcomp 8 9 pregcomp match 8 10 +qr 8 1 subst 8 10 substcont 8 7 trans 7 4 do_trans @@ -170,6 +172,7 @@ orassign 7 3 modifies flow of control method 8 5 entersub 10 7 leavesub 10 5 +leavesublv caller 2 8 warn 9 3 die 9 3 @@ -212,6 +215,7 @@ leavewrite 4 5 prtf 4 4 do_sprintf print 8 6 sysopen 8 2 +sysseek 8 2 sysread 8 4 syswrite 8 4 pp_send send 8 4 @@ -347,4 +351,7 @@ sgrent egrent getlogin syscall -
\ No newline at end of file +lock 6 1 +threadsv 6 2 unused if not USE_THREADS +setstate 1 1 currently unused anywhere +method_named 10 2 diff --git a/ext/ByteLoader/ByteLoader.pm b/ext/ByteLoader/ByteLoader.pm index 46870105d8..286d74697e 100644 --- a/ext/ByteLoader/ByteLoader.pm +++ b/ext/ByteLoader/ByteLoader.pm @@ -1,12 +1,10 @@ package ByteLoader; -require DynaLoader; - -@ISA = qw(DynaLoader); +use XSLoader (); $VERSION = 0.03; -bootstrap ByteLoader $VERSION; +XSLoader::load 'ByteLoader', $VERSION; # Preloaded methods go here. diff --git a/ext/ByteLoader/ByteLoader.xs b/ext/ByteLoader/ByteLoader.xs index c9d7d16d06..7c3746bba7 100644 --- a/ext/ByteLoader/ByteLoader.xs +++ b/ext/ByteLoader/ByteLoader.xs @@ -4,12 +4,22 @@ #include "XSUB.h" #include "byterun.h" -#ifdef NEED_FGETC_PROTOTYPE -extern int fgetc(); -#endif -#ifdef NEED_FREAD_PROTOTYPE -extern int fread(); -#endif +static int +xgetc(PerlIO *io) +{ + dTHX; + return PerlIO_getc(io); +} + +static int +xfread(char *buf, size_t size, size_t n, PerlIO *io) +{ + dTHX; + int i = PerlIO_read(io, buf, n * size); + if (i > 0) + i /= size; + return i; +} static void freadpv(U32 len, void *data, XPV *pv) @@ -30,8 +40,8 @@ byteloader_filter(pTHXo_ int idx, SV *buf_sv, int maxlen) struct bytestream bs; bs.data = PL_rsfp; - bs.pfgetc = (int(*) (void*))fgetc; - bs.pfread = (int(*) (char*,size_t,size_t,void*))fread; + bs.pfgetc = (int(*) (void*))xgetc; + bs.pfread = (int(*) (char*,size_t,size_t,void*))xfread; bs.pfreadpv = freadpv; byterun(aTHXo_ bs); diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm index 44bdad61f6..661a523983 100644 --- a/ext/DB_File/DB_File.pm +++ b/ext/DB_File/DB_File.pm @@ -155,8 +155,8 @@ $DB_RECNO = new DB_File::RECNOINFO ; require Tie::Hash; require Exporter; use AutoLoader; -require DynaLoader; -@ISA = qw(Tie::Hash Exporter DynaLoader); +use XSLoader (); +@ISA = qw(Tie::Hash Exporter); @EXPORT = qw( $DB_BTREE $DB_HASH $DB_RECNO @@ -231,7 +231,7 @@ eval { # }; #} -bootstrap DB_File $VERSION; +XSLoader::load 'DB_File', $VERSION; # Preloaded methods go here. Autoload methods go after __END__, and are # processed by the autosplit program. diff --git a/ext/Data/Dumper/Dumper.pm b/ext/Data/Dumper/Dumper.pm index c37e6b54dd..a4aa3288a6 100644 --- a/ext/Data/Dumper/Dumper.pm +++ b/ext/Data/Dumper/Dumper.pm @@ -9,22 +9,22 @@ package Data::Dumper; -$VERSION = $VERSION = '2.101'; +$VERSION = '2.101'; #$| = 1; require 5.004_02; require Exporter; -require DynaLoader; +use XSLoader (); require overload; use Carp; -@ISA = qw(Exporter DynaLoader); +@ISA = qw(Exporter); @EXPORT = qw(Dumper); @EXPORT_OK = qw(DumperX); -bootstrap Data::Dumper; +XSLoader::load 'Data::Dumper'; # module vars and their defaults $Indent = 2 unless defined $Indent; @@ -550,25 +550,35 @@ my %esc = ( sub qquote { local($_) = shift; s/([\\\"\@\$])/\\$1/g; - return qq("$_") unless /[^\040-\176]/; # fast exit + return qq("$_") unless + /[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~]/; # fast exit my $high = shift || ""; s/([\a\b\t\n\f\r\e])/$esc{$1}/g; - # no need for 3 digits in escape for these - s/([\0-\037])(?!\d)/'\\'.sprintf('%o',ord($1))/eg; - - s/([\0-\037\177])/'\\'.sprintf('%03o',ord($1))/eg; - if ($high eq "iso8859") { - s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg; - } elsif ($high eq "utf8") { -# use utf8; -# $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge; - } elsif ($high eq "8bit") { - # leave it as it is - } else { - s/([\0-\037\177-\377])/'\\'.sprintf('%03o',ord($1))/eg; + if (ord('^')==94) { # ascii + # no need for 3 digits in escape for these + s/([\0-\037])(?!\d)/'\\'.sprintf('%o',ord($1))/eg; + s/([\0-\037\177])/'\\'.sprintf('%03o',ord($1))/eg; + # all but last branch below not supported --BEHAVIOR SUBJECT TO CHANGE-- + if ($high eq "iso8859") { + s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg; + } elsif ($high eq "utf8") { +# use utf8; +# $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge; + } elsif ($high eq "8bit") { + # leave it as it is + } else { + s/([\200-\377])/'\\'.sprintf('%03o',ord($1))/eg; + } + } + else { # ebcdic + s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])(?!\d)} + {my $v = ord($1); '\\'.sprintf(($v <= 037 ? '%o' : '%03o'), $v)}eg; + s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])} + {'\\'.sprintf('%03o',ord($1))}eg; } + return qq("$_"); } @@ -1029,7 +1039,7 @@ SCALAR objects have the weirdest looking C<bless> workaround. =head1 AUTHOR -Gurusamy Sarathy gsar@umich.edu +Gurusamy Sarathy gsar@activestate.com Copyright (c) 1996-98 Gurusamy Sarathy. All rights reserved. This program is free software; you can redistribute it and/or diff --git a/ext/Devel/DProf/DProf.pm b/ext/Devel/DProf/DProf.pm index 4c43f4d3d5..e9372ff038 100644 --- a/ext/Devel/DProf/DProf.pm +++ b/ext/Devel/DProf/DProf.pm @@ -133,6 +133,9 @@ C<PERL_DPROF_BUFFER> sets size of output buffer in words. Defaults to 2**14. C<PERL_DPROF_TICKS> sets number of ticks per second on some systems where a replacement for times() is used. Defaults to the value of C<HZ> macro. +C<PERL_DPROF_OUT_FILE_NAME> sets the name of the output file. If not set, +defaults to tmon.out. + =head1 BUGS Builtin functions cannot be measured by Devel::DProf. @@ -182,11 +185,11 @@ sub DB { # print "nonXS DBDB\n"; } -require DynaLoader; -@Devel::DProf::ISA = 'DynaLoader'; +use XSLoader (); + $Devel::DProf::VERSION = '19990108'; # this version not authorized by # Dean Roehrich. See "Changes" file. -bootstrap Devel::DProf $Devel::DProf::VERSION; +XSLoader::load 'Devel::DProf', $Devel::DProf::VERSION; 1; diff --git a/ext/Devel/DProf/DProf.xs b/ext/Devel/DProf/DProf.xs index e8898cb97b..d59c9dfe11 100644 --- a/ext/Devel/DProf/DProf.xs +++ b/ext/Devel/DProf/DProf.xs @@ -1,7 +1,4 @@ -/* XXX DProf could use some cleanups for PERL_IMPLICIT_CONTEXT */ - -#define PERL_POLLUTE - +#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" @@ -15,49 +12,23 @@ /*#define DBG_TIMER 1 */ #ifdef DBG_SUB -# define DBG_SUB_NOTIFY(A,B) warn( A, B ) +# define DBG_SUB_NOTIFY(A,B) warn(A, B) #else # define DBG_SUB_NOTIFY(A,B) /* nothing */ #endif #ifdef DBG_TIMER -# define DBG_TIMER_NOTIFY(A) warn( A ) +# define DBG_TIMER_NOTIFY(A) warn(A) #else # define DBG_TIMER_NOTIFY(A) /* nothing */ #endif -static U32 dprof_ticks; - /* HZ == clock ticks per second */ #ifdef VMS # define HZ ((I32)CLK_TCK) # define DPROF_HZ HZ # include <starlet.h> /* prototype for sys$gettim() */ - clock_t dprof_times(struct tms *bufptr) { - clock_t retval; - dTHX; - /* Get wall time and convert to 10 ms intervals to - * produce the return value dprof expects */ -# if defined(__DECC) && defined (__ALPHA) -# include <ints.h> - uint64 vmstime; - _ckvmssts(sys$gettim(&vmstime)); - vmstime /= 100000; - retval = vmstime & 0x7fffffff; -# else - /* (Older hw or ccs don't have an atomic 64-bit type, so we - * juggle 32-bit ints (and a float) to produce a time_t result - * with minimal loss of information.) */ - long int vmstime[2],remainder,divisor = 100000; - _ckvmssts(sys$gettim((unsigned long int *)vmstime)); - vmstime[1] &= 0x7fff; /* prevent overflow in EDIV */ - _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder)); -# endif - /* Fill in the struct tms using the CRTL routine . . .*/ - times((tbuffer_t *)bufptr); - return (clock_t) retval; - } -# define Times(ptr) (dprof_times(ptr)) +# define Times(ptr) (dprof_times(aTHX_ ptr)) #else # ifndef HZ # ifdef CLK_TCK @@ -67,37 +38,12 @@ static U32 dprof_ticks; # endif # endif # ifdef OS2 /* times() has significant overhead */ -# define Times(ptr) (dprof_times(ptr)) +# define Times(ptr) (dprof_times(aTHX_ ptr)) # define INCL_DOSPROFILE # define INCL_DOSERRORS # include <os2.h> # define toLongLong(arg) (*(long long*)&(arg)) -# define DPROF_HZ dprof_ticks - -static ULONG frequ; -static long long start_cnt; -clock_t -dprof_times(struct tms *t) -{ - ULONG rc; - QWORD cnt; - - if (!frequ) { - if (CheckOSError(DosTmrQueryFreq(&frequ))) - croak("DosTmrQueryFreq: %s", SvPV(perl_get_sv("!",TRUE),na)); - else - frequ = frequ/DPROF_HZ; /* count per tick */ - if (CheckOSError(DosTmrQueryTime(&cnt))) - croak("DosTmrQueryTime: %s", - SvPV(perl_get_sv("!",TRUE),na)); - start_cnt = toLongLong(cnt); - } - - if (CheckOSError(DosTmrQueryTime(&cnt))) - croak("DosTmrQueryTime: %s", SvPV(perl_get_sv("!",TRUE),na)); - t->tms_stime = 0; - return (t->tms_utime = (toLongLong(cnt) - start_cnt)/frequ); -} +# define DPROF_HZ g_dprof_ticks # else # define Times(ptr) (times(ptr)) # define DPROF_HZ HZ @@ -106,28 +52,10 @@ dprof_times(struct tms *t) XS(XS_Devel__DProf_END); /* used by prof_mark() */ -static PerlIO *fp; /* pointer to tmon.out file */ - -/* Added -JH */ -static long TIMES_LOCATION=42;/* Where in the file to store the time totals */ -static int SAVE_STACK = 1<<14; /* How much data to buffer until */ - /* end of run */ - -static int prof_pid; /* pid of profiled process */ - /* Everything is built on times(2). See its manpage for a description * of the timings. */ -static -struct tms prof_start, - prof_end; - -static -clock_t rprof_start, /* elapsed real time, in ticks */ - rprof_end, - wprof_u, wprof_s, wprof_r; - union prof_any { clock_t tms_utime; /* cpu time spent in user space */ clock_t tms_stime; /* cpu time spent in system */ @@ -139,57 +67,161 @@ union prof_any { typedef union prof_any PROFANY; -static PROFANY *profstack; -static int profstack_max = 128; -static int profstack_ix = 0; +typedef struct { + U32 dprof_ticks; + char* out_file_name; /* output file (defaults to tmon.out) */ + PerlIO* fp; /* pointer to tmon.out file */ + long TIMES_LOCATION; /* Where in the file to store the time totals */ + int SAVE_STACK; /* How much data to buffer until end of run */ + int prof_pid; /* pid of profiled process */ + struct tms prof_start; + struct tms prof_end; + clock_t rprof_start; /* elapsed real time ticks */ + clock_t rprof_end; + clock_t wprof_u; + clock_t wprof_s; + clock_t wprof_r; + clock_t otms_utime; + clock_t otms_stime; + clock_t orealtime; + PROFANY* profstack; + int profstack_max; + int profstack_ix; + HV* cv_hash; + U32 total; + U32 lastid; + U32 default_perldb; + U32 depth; +#ifdef OS2 + ULONG frequ; + long long start_cnt; +#endif +#ifdef PERL_IMPLICIT_CONTEXT +# define register + pTHX; +# undef register +#endif +} prof_state_t; + +prof_state_t g_prof_state; + +#define g_dprof_ticks g_prof_state.dprof_ticks +#define g_out_file_name g_prof_state.out_file_name +#define g_fp g_prof_state.fp +#define g_TIMES_LOCATION g_prof_state.TIMES_LOCATION +#define g_SAVE_STACK g_prof_state.SAVE_STACK +#define g_prof_pid g_prof_state.prof_pid +#define g_prof_start g_prof_state.prof_start +#define g_prof_end g_prof_state.prof_end +#define g_rprof_start g_prof_state.rprof_start +#define g_rprof_end g_prof_state.rprof_end +#define g_wprof_u g_prof_state.wprof_u +#define g_wprof_s g_prof_state.wprof_s +#define g_wprof_r g_prof_state.wprof_r +#define g_otms_utime g_prof_state.otms_utime +#define g_otms_stime g_prof_state.otms_stime +#define g_orealtime g_prof_state.orealtime +#define g_profstack g_prof_state.profstack +#define g_profstack_max g_prof_state.profstack_max +#define g_profstack_ix g_prof_state.profstack_ix +#define g_cv_hash g_prof_state.cv_hash +#define g_total g_prof_state.total +#define g_lastid g_prof_state.lastid +#define g_default_perldb g_prof_state.default_perldb +#define g_depth g_prof_state.depth +#ifdef PERL_IMPLICIT_CONTEXT +# define g_THX g_prof_state.aTHX +#endif +#ifdef OS2 +# define g_frequ g_prof_state.frequ +# define g_start_cnt g_prof_state.start_cnt +#endif -static void -prof_dump(opcode ptype, char *name) +clock_t +dprof_times(pTHX_ struct tms *t) { - if(ptype == OP_LEAVESUB){ - PerlIO_printf(fp,"- & %s\n", name ); - } else if(ptype == OP_ENTERSUB) { - PerlIO_printf(fp,"+ & %s\n", name ); - } else if(ptype == OP_DIE) { - PerlIO_printf(fp,"/ & %s\n", name ); - } else { - PerlIO_printf(fp,"Profiler unknown prof code %d\n", ptype); +#ifdef OS2 + ULONG rc; + QWORD cnt; + + if (!g_frequ) { + if (CheckOSError(DosTmrQueryFreq(&g_frequ))) + croak("DosTmrQueryFreq: %s", SvPV(perl_get_sv("!",TRUE),na)); + else + g_frequ = g_frequ/DPROF_HZ; /* count per tick */ + if (CheckOSError(DosTmrQueryTime(&cnt))) + croak("DosTmrQueryTime: %s", + SvPV(perl_get_sv("!",TRUE),na)); + g_start_cnt = toLongLong(cnt); } - safefree(name); -} + + if (CheckOSError(DosTmrQueryTime(&cnt))) + croak("DosTmrQueryTime: %s", SvPV(perl_get_sv("!",TRUE),na)); + t->tms_stime = 0; + return (t->tms_utime = (toLongLong(cnt) - g_start_cnt)/g_frequ); +#else /* !OS2 */ +# ifdef VMS + clock_t retval; + /* Get wall time and convert to 10 ms intervals to + * produce the return value dprof expects */ +# if defined(__DECC) && defined (__ALPHA) +# include <ints.h> + uint64 vmstime; + _ckvmssts(sys$gettim(&vmstime)); + vmstime /= 100000; + retval = vmstime & 0x7fffffff; +# else + /* (Older hw or ccs don't have an atomic 64-bit type, so we + * juggle 32-bit ints (and a float) to produce a time_t result + * with minimal loss of information.) */ + long int vmstime[2],remainder,divisor = 100000; + _ckvmssts(sys$gettim((unsigned long int *)vmstime)); + vmstime[1] &= 0x7fff; /* prevent overflow in EDIV */ + _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder)); +# endif + /* Fill in the struct tms using the CRTL routine . . .*/ + times((tbuffer_t *)t); + return (clock_t) retval; +# else /* !VMS && !OS2 */ + return times(t); +# endif +#endif +} static void -prof_dumpa(opcode ptype, U32 id) +prof_dumpa(pTHX_ opcode ptype, U32 id) { - if(ptype == OP_LEAVESUB){ - PerlIO_printf(fp,"- %"UVxf"\n", (UV)id ); - } else if(ptype == OP_ENTERSUB) { - PerlIO_printf(fp,"+ %"UVxf"\n", (UV)id ); - } else if(ptype == OP_GOTO) { - PerlIO_printf(fp,"* %"UVxf"\n", (UV)id ); - } else if(ptype == OP_DIE) { - PerlIO_printf(fp,"/ %"UVxf"\n", (UV)id ); - } else { - PerlIO_printf(fp,"Profiler unknown prof code %d\n", ptype); + if (ptype == OP_LEAVESUB) { + PerlIO_printf(g_fp,"- %"UVxf"\n", (UV)id); + } + else if(ptype == OP_ENTERSUB) { + PerlIO_printf(g_fp,"+ %"UVxf"\n", (UV)id); + } + else if(ptype == OP_GOTO) { + PerlIO_printf(g_fp,"* %"UVxf"\n", (UV)id); + } + else if(ptype == OP_DIE) { + PerlIO_printf(g_fp,"/ %"UVxf"\n", (UV)id); + } + else { + PerlIO_printf(g_fp,"Profiler unknown prof code %d\n", ptype); } } static void -prof_dumps(U32 id, char *pname, char *gname) +prof_dumps(pTHX_ U32 id, char *pname, char *gname) { - PerlIO_printf(fp,"& %"UVxf" %s %s\n", (UV)id, pname, gname); + PerlIO_printf(g_fp,"& %"UVxf" %s %s\n", (UV)id, pname, gname); } -static clock_t otms_utime, otms_stime, orealtime; - static void -prof_dumpt(long tms_utime, long tms_stime, long realtime) +prof_dumpt(pTHX_ long tms_utime, long tms_stime, long realtime) { - PerlIO_printf(fp,"@ %ld %ld %ld\n", tms_utime, tms_stime, realtime); + PerlIO_printf(g_fp,"@ %ld %ld %ld\n", tms_utime, tms_stime, realtime); } static void -prof_dump_until(long ix) +prof_dump_until(pTHX_ long ix) { long base = 0; struct tms t1, t2; @@ -197,271 +229,202 @@ prof_dump_until(long ix) realtime1 = Times(&t1); - while( base < ix ){ - opcode ptype = profstack[base++].ptype; + while (base < ix) { + opcode ptype = g_profstack[base++].ptype; if (ptype == OP_TIME) { - long tms_utime = profstack[base++].tms_utime; - long tms_stime = profstack[base++].tms_stime; - long realtime = profstack[base++].realtime; - - prof_dumpt(tms_utime, tms_stime, realtime); - } else if (ptype == OP_GV) { - U32 id = profstack[base++].id; - char *pname = profstack[base++].name; - char *gname = profstack[base++].name; - - prof_dumps(id, pname, gname); - } else { -#ifdef PERLDBf_NONAME - U32 id = profstack[base++].id; - prof_dumpa(ptype, id); -#else - char *name = profstack[base++].name; - prof_dump(ptype, name); -#endif + long tms_utime = g_profstack[base++].tms_utime; + long tms_stime = g_profstack[base++].tms_stime; + long realtime = g_profstack[base++].realtime; + + prof_dumpt(aTHX_ tms_utime, tms_stime, realtime); + } + else if (ptype == OP_GV) { + U32 id = g_profstack[base++].id; + char *pname = g_profstack[base++].name; + char *gname = g_profstack[base++].name; + + prof_dumps(aTHX_ id, pname, gname); + } + else { + U32 id = g_profstack[base++].id; + prof_dumpa(aTHX_ ptype, id); } } - PerlIO_flush(fp); + PerlIO_flush(g_fp); realtime2 = Times(&t2); if (realtime2 != realtime1 || t1.tms_utime != t2.tms_utime || t1.tms_stime != t2.tms_stime) { - wprof_r += realtime2 - realtime1; - wprof_u += t2.tms_utime - t1.tms_utime; - wprof_s += t2.tms_stime - t1.tms_stime; + g_wprof_r += realtime2 - realtime1; + g_wprof_u += t2.tms_utime - t1.tms_utime; + g_wprof_s += t2.tms_stime - t1.tms_stime; - PerlIO_printf(fp,"+ & Devel::DProf::write\n" ); - PerlIO_printf(fp,"@ %"IVdf" %"IVdf" %"IVdf"\n", + PerlIO_printf(g_fp,"+ & Devel::DProf::write\n"); + PerlIO_printf(g_fp,"@ %"IVdf" %"IVdf" %"IVdf"\n", /* The (IV) casts are one possibility: * the Painfully Correct Way would be to * have Clock_t_f. */ (IV)(t2.tms_utime - t1.tms_utime), (IV)(t2.tms_stime - t1.tms_stime), (IV)(realtime2 - realtime1)); - PerlIO_printf(fp,"- & Devel::DProf::write\n" ); - otms_utime = t2.tms_utime; - otms_stime = t2.tms_stime; - orealtime = realtime2; - PerlIO_flush(fp); + PerlIO_printf(g_fp,"- & Devel::DProf::write\n"); + g_otms_utime = t2.tms_utime; + g_otms_stime = t2.tms_stime; + g_orealtime = realtime2; + PerlIO_flush(g_fp); } } -static HV* cv_hash; -static U32 total = 0; - static void -prof_mark( opcode ptype ) +prof_mark(pTHX_ opcode ptype) { - struct tms t; - clock_t realtime, rdelta, udelta, sdelta; - char *name, *pv; - char *hvname; - STRLEN len; - SV *sv; - U32 id; - SV *Sub = GvSV(DBsub); /* name of current sub */ - - if( SAVE_STACK ){ - if( profstack_ix + 5 > profstack_max ){ - profstack_max = profstack_max * 3 / 2; - Renew( profstack, profstack_max, PROFANY ); - } - } + struct tms t; + clock_t realtime, rdelta, udelta, sdelta; + char *name, *pv; + char *hvname; + STRLEN len; + SV *sv; + U32 id; + SV *Sub = GvSV(PL_DBsub); /* name of current sub */ + + if (g_SAVE_STACK) { + if (g_profstack_ix + 5 > g_profstack_max) { + g_profstack_max = g_profstack_max * 3 / 2; + Renew(g_profstack, g_profstack_max, PROFANY); + } + } - realtime = Times(&t); - rdelta = realtime - orealtime; - udelta = t.tms_utime - otms_utime; - sdelta = t.tms_stime - otms_stime; - if (rdelta || udelta || sdelta) { - if (SAVE_STACK) { - profstack[profstack_ix++].ptype = OP_TIME; - profstack[profstack_ix++].tms_utime = udelta; - profstack[profstack_ix++].tms_stime = sdelta; - profstack[profstack_ix++].realtime = rdelta; - } else { /* Write it to disk now so's not to eat up core */ - if (prof_pid == (int)getpid()) { - prof_dumpt(udelta, sdelta, rdelta); - PerlIO_flush(fp); - } + realtime = Times(&t); + rdelta = realtime - g_orealtime; + udelta = t.tms_utime - g_otms_utime; + sdelta = t.tms_stime - g_otms_stime; + if (rdelta || udelta || sdelta) { + if (g_SAVE_STACK) { + g_profstack[g_profstack_ix++].ptype = OP_TIME; + g_profstack[g_profstack_ix++].tms_utime = udelta; + g_profstack[g_profstack_ix++].tms_stime = sdelta; + g_profstack[g_profstack_ix++].realtime = rdelta; + } + else { /* Write it to disk now so's not to eat up core */ + if (g_prof_pid == (int)getpid()) { + prof_dumpt(aTHX_ udelta, sdelta, rdelta); + PerlIO_flush(g_fp); } - orealtime = realtime; - otms_stime = t.tms_stime; - otms_utime = t.tms_utime; } + g_orealtime = realtime; + g_otms_stime = t.tms_stime; + g_otms_utime = t.tms_utime; + } -#ifdef PERLDBf_NONAME - { - dTHX; - SV **svp; - char *gname, *pname; - static U32 lastid; - CV *cv; - - cv = INT2PTR(CV*,SvIVX(Sub)); - svp = hv_fetch(cv_hash, (char*)&cv, sizeof(CV*), TRUE); - if (!SvOK(*svp)) { - GV *gv = CvGV(cv); - - sv_setiv(*svp, id = ++lastid); - pname = ((GvSTASH(gv) && HvNAME(GvSTASH(gv))) - ? HvNAME(GvSTASH(gv)) - : "(null)"); - gname = GvNAME(gv); - if (CvXSUB(cv) == XS_Devel__DProf_END) - return; - if (SAVE_STACK) { /* Store it for later recording -JH */ - profstack[profstack_ix++].ptype = OP_GV; - profstack[profstack_ix++].id = id; - profstack[profstack_ix++].name = pname; - profstack[profstack_ix++].name = gname; - } else { /* Write it to disk now so's not to eat up core */ - - /* Only record the parent's info */ - if (prof_pid == (int)getpid()) { - prof_dumps(id, pname, gname); - PerlIO_flush(fp); - } else - perldb = 0; /* Do not debug the kid. */ + { + SV **svp; + char *gname, *pname; + CV *cv; + + cv = INT2PTR(CV*,SvIVX(Sub)); + svp = hv_fetch(g_cv_hash, (char*)&cv, sizeof(CV*), TRUE); + if (!SvOK(*svp)) { + GV *gv = CvGV(cv); + + sv_setiv(*svp, id = ++g_lastid); + pname = ((GvSTASH(gv) && HvNAME(GvSTASH(gv))) + ? HvNAME(GvSTASH(gv)) + : "(null)"); + gname = GvNAME(gv); + if (CvXSUB(cv) == XS_Devel__DProf_END) + return; + if (g_SAVE_STACK) { /* Store it for later recording -JH */ + g_profstack[g_profstack_ix++].ptype = OP_GV; + g_profstack[g_profstack_ix++].id = id; + g_profstack[g_profstack_ix++].name = pname; + g_profstack[g_profstack_ix++].name = gname; + } + else { /* Write it to disk now so's not to eat up core */ + /* Only record the parent's info */ + if (g_prof_pid == (int)getpid()) { + prof_dumps(aTHX_ id, pname, gname); + PerlIO_flush(g_fp); } - } else { - id = SvIV(*svp); + else + PL_perldb = 0; /* Do not debug the kid. */ } } -#else - pv = SvPV( Sub, len ); - - if( SvROK(Sub) ){ - /* Attempt to make CODE refs slightly identifiable by - * including their package name. - */ - sv = (SV*)SvRV(Sub); - if( sv && SvTYPE(sv) == SVt_PVCV ){ - if( CvSTASH(sv) ){ - hvname = HvNAME(CvSTASH(sv)); - } - else if( CvXSUB(sv) == &XS_Devel__DProf_END ){ - /*warn( "prof_mark() found dprof::end");*/ - return; /* don't profile Devel::DProf::END */ - } - else{ - croak( "DProf prof_mark() lost on CODE ref %s\n", pv ); - } - len += strlen( hvname ) + 2; /* +2 for ::'s */ - - } - else{ - croak( "DProf prof_mark() lost on supposed CODE ref %s.\n", pv ); - } - name = (char *)safemalloc( len * sizeof(char) + 1 ); - strcpy( name, hvname ); - strcat( name, "::" ); - strcat( name, pv ); - } - else{ - if( *(pv+len-1) == 'D' ){ - /* It could be an &AUTOLOAD. */ - - /* I measured a bunch of *.pl and *.pm (from Perl - * distribution and other misc things) and found - * 780 fully-qualified names. They averaged - * about 19 chars each. Only 1 of those names - * ended with 'D' and wasn't an &AUTOLOAD--it - * was &overload::OVERLOAD. - * --dmr 2/19/96 - */ - - if( strcmp( pv+len-9, ":AUTOLOAD" ) == 0 ){ - /* The sub name is in $AUTOLOAD */ - sv = perl_get_sv( pv, 0 ); - if( sv == NULL ){ - croak("DProf prof_mark() lost on AUTOLOAD (%s).\n", pv ); - } - pv = SvPV( sv, na ); - DBG_SUB_NOTIFY( " AUTOLOAD(%s)\n", pv ); - } - } - name = savepv( pv ); - } -#endif /* PERLDBf_NONAME */ + else { + id = SvIV(*svp); + } + } - total++; - if (SAVE_STACK) { /* Store it for later recording -JH */ - profstack[profstack_ix++].ptype = ptype; -#ifdef PERLDBf_NONAME - profstack[profstack_ix++].id = id; -#else - profstack[profstack_ix++].name = name; -#endif - /* Only record the parent's info */ - if (SAVE_STACK < profstack_ix) { - if (prof_pid == (int)getpid()) - prof_dump_until(profstack_ix); - else - perldb = 0; /* Do not debug the kid. */ - profstack_ix = 0; - } - } else { /* Write it to disk now so's not to eat up core */ + g_total++; + if (g_SAVE_STACK) { /* Store it for later recording -JH */ + g_profstack[g_profstack_ix++].ptype = ptype; + g_profstack[g_profstack_ix++].id = id; + + /* Only record the parent's info */ + if (g_SAVE_STACK < g_profstack_ix) { + if (g_prof_pid == (int)getpid()) + prof_dump_until(aTHX_ g_profstack_ix); + else + PL_perldb = 0; /* Do not debug the kid. */ + g_profstack_ix = 0; + } + } + else { /* Write it to disk now so's not to eat up core */ - /* Only record the parent's info */ - if (prof_pid == (int)getpid()) { -#ifdef PERLDBf_NONAME - prof_dumpa(ptype, id); -#else - prof_dump(ptype, name); -#endif - PerlIO_flush(fp); - } else - perldb = 0; /* Do not debug the kid. */ - } + /* Only record the parent's info */ + if (g_prof_pid == (int)getpid()) { + prof_dumpa(aTHX_ ptype, id); + PerlIO_flush(g_fp); + } + else + PL_perldb = 0; /* Do not debug the kid. */ + } } -static U32 default_perldb; - #ifdef PL_NEEDED # define defstash PL_defstash #endif /* Counts overhead of prof_mark and extra XS call. */ static void -test_time(clock_t *r, clock_t *u, clock_t *s) +test_time(pTHX_ clock_t *r, clock_t *u, clock_t *s) { dTHR; - dTHX; CV *cv = perl_get_cv("Devel::DProf::NONESUCH_noxs", FALSE); int i, j, k = 0; - HV *oldstash = curstash; + HV *oldstash = PL_curstash; struct tms t1, t2; clock_t realtime1, realtime2; - U32 ototal = total; - U32 ostack = SAVE_STACK; - U32 operldb = perldb; + U32 ototal = g_total; + U32 ostack = g_SAVE_STACK; + U32 operldb = PL_perldb; - SAVE_STACK = 1000000; + g_SAVE_STACK = 1000000; realtime1 = Times(&t1); while (k < 2) { i = 0; /* Disable debugging of perl_call_sv on second pass: */ - curstash = (k == 0 ? defstash : debstash); - perldb = default_perldb; + PL_curstash = (k == 0 ? PL_defstash : PL_debstash); + PL_perldb = g_default_perldb; while (++i <= 100) { j = 0; - profstack_ix = 0; /* Do not let the stack grow */ + g_profstack_ix = 0; /* Do not let the stack grow */ while (++j <= 100) { -/* prof_mark( OP_ENTERSUB ); */ +/* prof_mark(aTHX_ OP_ENTERSUB); */ - PUSHMARK( stack_sp ); - perl_call_sv( (SV*)cv, G_SCALAR ); - stack_sp--; -/* prof_mark( OP_LEAVESUB ); */ + PUSHMARK(PL_stack_sp); + perl_call_sv((SV*)cv, G_SCALAR); + PL_stack_sp--; +/* prof_mark(aTHX_ OP_LEAVESUB); */ } } - curstash = oldstash; + PL_curstash = oldstash; if (k == 0) { /* Put time with debugging */ realtime2 = Times(&t2); *r = realtime2 - realtime1; *u = t2.tms_utime - t1.tms_utime; *s = t2.tms_stime - t1.tms_stime; - } else { /* Subtract time without debug */ + } + else { /* Subtract time without debug */ realtime1 = Times(&t1); *r -= realtime1 - realtime2; *u -= t1.tms_utime - t2.tms_utime; @@ -469,89 +432,88 @@ test_time(clock_t *r, clock_t *u, clock_t *s) } k++; } - total = ototal; - SAVE_STACK = ostack; - perldb = operldb; + g_total = ototal; + g_SAVE_STACK = ostack; + PL_perldb = operldb; } static void -prof_recordheader(void) +prof_recordheader(pTHX) { - clock_t r, u, s; - - /* fp is opened in the BOOT section */ - PerlIO_printf(fp, "#fOrTyTwO\n" ); - PerlIO_printf(fp, "$hz=%"IVdf";\n", (IV)DPROF_HZ ); - PerlIO_printf(fp, "$XS_VERSION='DProf %s';\n", XS_VERSION ); - PerlIO_printf(fp, "# All values are given in HZ\n" ); - test_time(&r, &u, &s); - PerlIO_printf(fp, - "$over_utime=%"IVdf"; $over_stime=%"IVdf"; $over_rtime=%"IVdf";\n", - /* The (IV) casts are one possibility: - * the Painfully Correct Way would be to - * have Clock_t_f. */ - (IV)u, (IV)s, (IV)r); - PerlIO_printf(fp, "$over_tests=10000;\n"); - - TIMES_LOCATION = PerlIO_tell(fp); - - /* Pad with whitespace. */ - /* This should be enough even for very large numbers. */ - PerlIO_printf(fp, "%*s\n", 240 , ""); - - PerlIO_printf(fp, "\n"); - PerlIO_printf(fp, "PART2\n" ); - - PerlIO_flush(fp); + clock_t r, u, s; + + /* g_fp is opened in the BOOT section */ + PerlIO_printf(g_fp, "#fOrTyTwO\n"); + PerlIO_printf(g_fp, "$hz=%"IVdf";\n", (IV)DPROF_HZ); + PerlIO_printf(g_fp, "$XS_VERSION='DProf %s';\n", XS_VERSION); + PerlIO_printf(g_fp, "# All values are given in HZ\n"); + test_time(aTHX_ &r, &u, &s); + PerlIO_printf(g_fp, + "$over_utime=%"IVdf"; $over_stime=%"IVdf"; $over_rtime=%"IVdf";\n", + /* The (IV) casts are one possibility: + * the Painfully Correct Way would be to + * have Clock_t_f. */ + (IV)u, (IV)s, (IV)r); + PerlIO_printf(g_fp, "$over_tests=10000;\n"); + + g_TIMES_LOCATION = PerlIO_tell(g_fp); + + /* Pad with whitespace. */ + /* This should be enough even for very large numbers. */ + PerlIO_printf(g_fp, "%*s\n", 240 , ""); + + PerlIO_printf(g_fp, "\n"); + PerlIO_printf(g_fp, "PART2\n"); + + PerlIO_flush(g_fp); } static void -prof_record(void) +prof_record(pTHX) { - /* fp is opened in the BOOT section */ + /* g_fp is opened in the BOOT section */ - /* Now that we know the runtimes, fill them in at the recorded - location -JH */ + /* Now that we know the runtimes, fill them in at the recorded + location -JH */ - clock_t r, u, s; + clock_t r, u, s; + + if (g_SAVE_STACK) { + prof_dump_until(aTHX_ g_profstack_ix); + } + PerlIO_seek(g_fp, g_TIMES_LOCATION, SEEK_SET); + /* Write into reserved 240 bytes: */ + PerlIO_printf(g_fp, + "$rrun_utime=%"IVdf"; $rrun_stime=%"IVdf"; $rrun_rtime=%"IVdf";", + /* The (IV) casts are one possibility: + * the Painfully Correct Way would be to + * have Clock_t_f. */ + (IV)(g_prof_end.tms_utime-g_prof_start.tms_utime-g_wprof_u), + (IV)(g_prof_end.tms_stime-g_prof_start.tms_stime-g_wprof_s), + (IV)(g_rprof_end-g_rprof_start-g_wprof_r)); + PerlIO_printf(g_fp, "\n$total_marks=%"IVdf, (IV)g_total); - if(SAVE_STACK){ - prof_dump_until(profstack_ix); - } - PerlIO_seek(fp, TIMES_LOCATION, SEEK_SET); - /* Write into reserved 240 bytes: */ - PerlIO_printf(fp, - "$rrun_utime=%"IVdf"; $rrun_stime=%"IVdf"; $rrun_rtime=%"IVdf";", - /* The (IV) casts are one possibility: - * the Painfully Correct Way would be to - * have Clock_t_f. */ - (IV)(prof_end.tms_utime-prof_start.tms_utime-wprof_u), - (IV)(prof_end.tms_stime-prof_start.tms_stime-wprof_s), - (IV)(rprof_end-rprof_start-wprof_r) ); - PerlIO_printf(fp, "\n$total_marks=%"IVdf, (IV)total); - - PerlIO_close( fp ); + PerlIO_close(g_fp); } #define NONESUCH() -static U32 depth = 0; - static void check_depth(pTHX_ void *foo) { U32 need_depth = (U32)foo; - if (need_depth != depth) { - if (need_depth > depth) { + if (need_depth != g_depth) { + if (need_depth > g_depth) { warn("garbled call depth when profiling"); - } else { - I32 marks = depth - need_depth; + } + else { + I32 marks = g_depth - need_depth; -/* warn("Check_depth: got %d, expected %d\n", depth, need_depth); */ +/* warn("Check_depth: got %d, expected %d\n", g_depth, need_depth); */ while (marks--) { - prof_mark( OP_DIE ); + prof_mark(aTHX_ OP_DIE); } - depth = need_depth; + g_depth = need_depth; } } } @@ -561,49 +523,44 @@ check_depth(pTHX_ void *foo) XS(XS_DB_sub) { - dXSARGS; - dORIGMARK; - HV *oldstash = curstash; - SV *Sub = GvSV(DBsub); /* name of current sub */ - - SP -= items; - - DBG_SUB_NOTIFY( "XS DBsub(%s)\n", SvPV(Sub, na) ); - -#ifndef PERLDBf_NONAME /* Was needed on older Perls */ - sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */ -#endif - - SAVEDESTRUCTOR_X(check_depth, (void*)depth); - depth++; - - prof_mark( OP_ENTERSUB ); - PUSHMARK( ORIGMARK ); + dXSARGS; + dORIGMARK; + SV *Sub = GvSV(PL_DBsub); /* name of current sub */ + +#ifdef PERL_IMPLICIT_CONTEXT + /* profile only the interpreter that loaded us */ + if (g_THX != aTHX) { + PUSHMARK(ORIGMARK); + perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG); + } + else +#endif + { + HV *oldstash = PL_curstash; -#ifdef G_NODEBUG - perl_call_sv( INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG); -#else - curstash = debstash; /* To disable debugging of perl_call_sv */ -#ifdef PERLDBf_NONAME - perl_call_sv( (SV*)SvIV(Sub), GIMME ); -#else - perl_call_sv( Sub, GIMME ); -#endif - curstash = oldstash; -#endif + DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV(Sub, na)); - prof_mark( OP_LEAVESUB ); - depth--; + SAVEDESTRUCTOR_X(check_depth, (void*)g_depth); + g_depth++; - SPAGAIN; - PUTBACK; - return; + prof_mark(aTHX_ OP_ENTERSUB); + PUSHMARK(ORIGMARK); + perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG); + prof_mark(aTHX_ OP_LEAVESUB); + g_depth--; + } + return; } XS(XS_DB_goto) { - prof_mark( OP_GOTO ); +#ifdef PERL_IMPLICIT_CONTEXT + if (g_THX == aTHX) +#endif + { + prof_mark(aTHX_ OP_GOTO); return; + } } #endif /* for_real */ @@ -614,27 +571,27 @@ XS(XS_DB_goto) void sub(...) - PPCODE: - + PPCODE: + { dORIGMARK; - HV *oldstash = curstash; - SV *Sub = GvSV(DBsub); /* name of current sub */ + HV *oldstash = PL_curstash; + SV *Sub = GvSV(PL_DBsub); /* name of current sub */ /* SP -= items; added by xsubpp */ - DBG_SUB_NOTIFY( "XS DBsub(%s)\n", SvPV(Sub, na) ); + DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV(Sub, na)); - sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */ + sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */ - prof_mark( OP_ENTERSUB ); - PUSHMARK( ORIGMARK ); + prof_mark(aTHX_ OP_ENTERSUB); + PUSHMARK(ORIGMARK); - curstash = debstash; /* To disable debugging of perl_call_sv -*/ - perl_call_sv( Sub, GIMME ); - curstash = oldstash; + PL_curstash = PL_debstash; /* To disable debugging of perl_call_sv */ + perl_call_sv(Sub, GIMME); + PL_curstash = oldstash; - prof_mark( OP_LEAVESUB ); + prof_mark(aTHX_ OP_LEAVESUB); SPAGAIN; /* PUTBACK; added by xsubpp */ + } #endif /* testing */ @@ -642,79 +599,90 @@ MODULE = Devel::DProf PACKAGE = Devel::DProf void END() - PPCODE: - if( DBsub ){ - /* maybe the process forked--we want only - * the parent's profile. - */ - if( prof_pid == (int)getpid() ){ - rprof_end = Times(&prof_end); - DBG_TIMER_NOTIFY("Profiler timer is off.\n"); - prof_record(); - } - } +PPCODE: + { + if (PL_DBsub) { + /* maybe the process forked--we want only + * the parent's profile. + */ + if ( +#ifdef PERL_IMPLICIT_CONTEXT + g_THX == aTHX && +#endif + g_prof_pid == (int)getpid()) + { + g_rprof_end = Times(&g_prof_end); + DBG_TIMER_NOTIFY("Profiler timer is off.\n"); + prof_record(aTHX); + } + } + } void NONESUCH() BOOT: + { + g_TIMES_LOCATION = 42; + g_SAVE_STACK = 1<<14; + g_profstack_max = 128; +#ifdef PERL_IMPLICIT_CONTEXT + g_THX = aTHX; +#endif + /* Before we go anywhere make sure we were invoked * properly, else we'll dump core. */ - if( ! DBsub ) - croak("DProf: run perl with -d to use DProf.\n"); + if (!PL_DBsub) + croak("DProf: run perl with -d to use DProf.\n"); /* When we hook up the XS DB::sub we'll be redefining * the DB::sub from the PM file. Turn off warnings * while we do this. */ { - I32 warn_tmp = dowarn; - dowarn = 0; - newXS("DB::sub", XS_DB_sub, file); - newXS("DB::goto", XS_DB_goto, file); - dowarn = warn_tmp; + I32 warn_tmp = PL_dowarn; + PL_dowarn = 0; + newXS("DB::sub", XS_DB_sub, file); + newXS("DB::goto", XS_DB_goto, file); + PL_dowarn = warn_tmp; } - sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */ + sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */ { char *buffer = getenv("PERL_DPROF_BUFFER"); if (buffer) { - SAVE_STACK = atoi(buffer); + g_SAVE_STACK = atoi(buffer); } buffer = getenv("PERL_DPROF_TICKS"); if (buffer) { - dprof_ticks = atoi(buffer); /* Used under OS/2 only */ - } else { - dprof_ticks = HZ; + g_dprof_ticks = atoi(buffer); /* Used under OS/2 only */ + } + else { + g_dprof_ticks = HZ; } - } - if( (fp = PerlIO_open( "tmon.out", "w" )) == NULL ) - croak("DProf: unable to write tmon.out, errno = %d\n", errno ); -#ifdef PERLDBf_NONAME - default_perldb = PERLDBf_NONAME | PERLDBf_SUB; /* no name needed. */ -#ifdef PERLDBf_GOTO - default_perldb = default_perldb | PERLDBf_GOTO; -#endif - cv_hash = newHV(); -#else -# ifdef PERLDBf_SUB - default_perldb = PERLDBf_SUB; /* debug subroutines only. */ -# endif -#endif - prof_pid = (int)getpid(); + buffer = getenv("PERL_DPROF_OUT_FILE_NAME"); + g_out_file_name = savepv(buffer ? buffer : "tmon.out"); + } - New( 0, profstack, profstack_max, PROFANY ); + if ((g_fp = PerlIO_open(g_out_file_name, "w")) == NULL) + croak("DProf: unable to write '%s', errno = %d\n", + g_out_file_name, errno); - prof_recordheader(); + g_default_perldb = PERLDBf_NONAME | PERLDBf_SUB | PERLDBf_GOTO; + g_cv_hash = newHV(); + g_prof_pid = (int)getpid(); + New(0, g_profstack, g_profstack_max, PROFANY); + prof_recordheader(aTHX); DBG_TIMER_NOTIFY("Profiler timer is on.\n"); - orealtime = rprof_start = Times(&prof_start); - otms_utime = prof_start.tms_utime; - otms_stime = prof_start.tms_stime; - perldb = default_perldb; + g_orealtime = g_rprof_start = Times(&g_prof_start); + g_otms_utime = g_prof_start.tms_utime; + g_otms_stime = g_prof_start.tms_stime; + PL_perldb = g_default_perldb; + } diff --git a/ext/Devel/Peek/Peek.pm b/ext/Devel/Peek/Peek.pm index 2e990b0a3a..4b472ad8a8 100644 --- a/ext/Devel/Peek/Peek.pm +++ b/ext/Devel/Peek/Peek.pm @@ -3,17 +3,17 @@ package Devel::Peek; -$VERSION = $VERSION = 0.95; +$VERSION = 0.95; require Exporter; -require DynaLoader; +use XSLoader (); -@ISA = qw(Exporter DynaLoader); +@ISA = qw(Exporter); @EXPORT = qw(Dump mstat DeadCode DumpArray DumpWithOP DumpProg); @EXPORT_OK = qw(SvREFCNT SvREFCNT_inc SvREFCNT_dec); %EXPORT_TAGS = ('ALL' => [@EXPORT, @EXPORT_OK]); -bootstrap Devel::Peek; +XSLoader::load 'Devel::Peek'; sub DumpWithOP ($;$) { local($Devel::Peek::dump_ops)=1; diff --git a/ext/DynaLoader/DynaLoader_pm.PL b/ext/DynaLoader/DynaLoader_pm.PL index a02f5bfae5..5cc5aead11 100644 --- a/ext/DynaLoader/DynaLoader_pm.PL +++ b/ext/DynaLoader/DynaLoader_pm.PL @@ -28,7 +28,7 @@ package DynaLoader; # # Tim.Bunce@ig.co.uk, August 1994 -$VERSION = $VERSION = "1.03"; # avoid typo warning +$VERSION = "1.03"; # avoid typo warning require AutoLoader; *AUTOLOAD = \&AutoLoader::AUTOLOAD; @@ -129,6 +129,14 @@ if ($dl_debug) { sub croak { require Carp; Carp::croak(@_) } +sub bootstrap_inherit { + my $module = $_[0]; + local *isa = *{"$module\::ISA"}; + local @isa = (@isa, 'DynaLoader'); + # Cannot goto due to delocalization. Will report errors on a wrong line? + bootstrap(@_); +} + # The bootstrap function cannot be autoloaded (without complications) # so we define it here: diff --git a/ext/DynaLoader/Makefile.PL b/ext/DynaLoader/Makefile.PL index 2141fdeb2f..e4493b4332 100644 --- a/ext/DynaLoader/Makefile.PL +++ b/ext/DynaLoader/Makefile.PL @@ -8,14 +8,17 @@ WriteMakefile( SKIP => [qw(dynamic dynamic_lib dynamic_bs)], XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'DynaLoader_pm.PL', - PL_FILES => {'DynaLoader_pm.PL'=>'DynaLoader.pm'}, - PM => {'DynaLoader.pm' => '$(INST_LIBDIR)/DynaLoader.pm'}, + PL_FILES => {'DynaLoader_pm.PL'=>'DynaLoader.pm', + 'XSLoader_pm.PL'=>'XSLoader.pm'}, + PM => {'DynaLoader.pm' => '$(INST_LIBDIR)/DynaLoader.pm', + 'XSLoader.pm' => '$(INST_LIBDIR)/XSLoader.pm'}, clean => {FILES => 'DynaLoader.c DynaLoader.xs DynaLoader.pm'}, ); sub MY::postamble { ' DynaLoader.xs: $(DLSRC) + $(RM_F) $@ $(CP) $? $@ # Perform very simple tests just to check for major gaffs. diff --git a/ext/DynaLoader/XSLoader_pm.PL b/ext/DynaLoader/XSLoader_pm.PL new file mode 100644 index 0000000000..8cdfd63425 --- /dev/null +++ b/ext/DynaLoader/XSLoader_pm.PL @@ -0,0 +1,158 @@ +use Config; + +sub to_string { + my ($value) = @_; + $value =~ s/\\/\\\\/g; + $value =~ s/'/\\'/g; + return "'$value'"; +} + +unlink "XSLoader.pm" if -f "XSLoader.pm"; +open OUT, ">XSLoader.pm" or die $!; +print OUT <<'EOT'; +# Generated from XSLoader.pm.PL (resolved %Config::Config value) + +package XSLoader; + +# And Gandalf said: 'Many folk like to know beforehand what is to +# be set on the table; but those who have laboured to prepare the +# feast like to keep their secret; for wonder makes the words of +# praise louder.' + +# (Quote from Tolkien sugested by Anno Siegel.) +# +# See pod text at end of file for documentation. +# See also ext/DynaLoader/README in source tree for other information. +# +# Tim.Bunce@ig.co.uk, August 1994 + +$VERSION = "0.01"; # avoid typo warning + +# enable debug/trace messages from DynaLoader perl code +# $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; + +EOT + +print OUT ' my $dl_dlext = ', to_string($Config::Config{'dlext'}), ";\n" ; + +print OUT <<'EOT'; + +# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. +package DynaLoader; +boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) && + !defined(&dl_load_file); +package XSLoader; + +1; # End of main code + +# The bootstrap function cannot be autoloaded (without complications) +# so we define it here: + +sub load { + package DynaLoader; + + my($module) = $_[0]; + + # work with static linking too + my $b = "$module\::bootstrap"; + goto &$b if defined &$b; + + goto retry unless $module and defined &dl_load_file; + + my @modparts = split(/::/,$module); + my $modfname = $modparts[-1]; + +EOT + +print OUT <<'EOT' if defined &DynaLoader::mod2fname; + # Some systems have restrictions on files names for DLL's etc. + # mod2fname returns appropriate file base name (typically truncated) + # It may also edit @modparts if required. + $modfname = &mod2fname(\@modparts) if defined &mod2fname; + +EOT + +print OUT <<'EOT'; + my $modpname = join('/',@modparts); + my $modlibname = (caller())[1]; + my $c = @modparts; + $modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename + my $file = "$modlibname/auto/$modpname/$modfname.$dl_dlext"; + +# print STDERR "XSLoader::load for $module ($file)\n" if $dl_debug; + + my $bs = $file; + $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library + + goto retry if not -f $file or -s $bs; + + my $bootname = "boot_$module"; + $bootname =~ s/\W/_/g; + @dl_require_symbols = ($bootname); + + # Many dynamic extension loading problems will appear to come from + # this section of code: XYZ failed at line 123 of DynaLoader.pm. + # Often these errors are actually occurring in the initialisation + # C code of the extension XS file. Perl reports the error as being + # in this perl code simply because this was the last perl code + # it executed. + + my $libref = dl_load_file($file, 0) or do { + require Carp; + Carp::croak("Can't load '$file' for module $module: " . dl_error()); + }; + push(@dl_librefs,$libref); # record loaded object + + my @unresolved = dl_undef_symbols(); + if (@unresolved) { + require Carp; + Carp::carp("Undefined symbols present after loading $file: @unresolved\n"); + } + + my $boot_symbol_ref = dl_find_symbol($libref, $bootname) or do { + require Carp; + Carp::croak("Can't find '$bootname' symbol in $file\n"); + }; + + my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file); + + push(@dl_modules, $module); # record loaded module + + # See comment block above + return &$xs(@_); + + retry: + require DynaLoader; + goto &DynaLoader::bootstrap_inherit; +} + +__END__ + +=head1 NAME + +XSLoader - Dynamically load C libraries into Perl code + +=head1 SYNOPSIS + + package YourPackage; + use XSLoader; + + XSLoader::load 'YourPackage', @args; + +=head1 DESCRIPTION + +This module defines a standard I<simplified> interface to the dynamic +linking mechanisms available on many platforms. Its primary purpose is +to implement cheap automatic dynamic loading of Perl modules. + +For more complicated interface see L<DynaLoader>. + +=head1 AUTHOR + +Ilya Zakharevich: extraction from DynaLoader. + +=cut +EOT + +close OUT or die $!; + diff --git a/ext/DynaLoader/dl_aix.xs b/ext/DynaLoader/dl_aix.xs index 798ed58d31..f845681ae1 100644 --- a/ext/DynaLoader/dl_aix.xs +++ b/ext/DynaLoader/dl_aix.xs @@ -558,7 +558,7 @@ static int readExports(ModulePtr mp) /* dl_dlopen.xs * * Platform: SunOS/Solaris, possibly others which use dlopen. - * Author: Paul Marquess (pmarquess@bfsec.bt.co.uk) + * Author: Paul Marquess (Paul.Marquess@btinternet.com) * Created: 10th July 1994 * * Modified: diff --git a/ext/DynaLoader/dl_beos.xs b/ext/DynaLoader/dl_beos.xs index 8779d3c95d..705c8bc4d0 100644 --- a/ext/DynaLoader/dl_beos.xs +++ b/ext/DynaLoader/dl_beos.xs @@ -67,7 +67,7 @@ dl_find_symbol(libhandle, symbolname) status_t retcode; void *adr = 0; #ifdef DLSYM_NEEDS_UNDERSCORE - symbolname = form("_%s", symbolname); + symbolname = Perl_form_nocontext("_%s", symbolname); #endif RETVAL = NULL; DLDEBUG(2, PerlIO_printf(Perl_debug_log, diff --git a/ext/DynaLoader/dl_cygwin.xs b/ext/DynaLoader/dl_cygwin.xs deleted file mode 100644 index 4055b058ef..0000000000 --- a/ext/DynaLoader/dl_cygwin.xs +++ /dev/null @@ -1,148 +0,0 @@ -/* dl_cygwin.xs - * - * Platform: Win32 (Windows NT/Windows 95) - * Author: Wei-Yuen Tan (wyt@hip.com) - * Created: A warm day in June, 1995 - * - * Modified: - * August 23rd 1995 - rewritten after losing everything when I - * wiped off my NT partition (eek!) - */ -/* Modified from the original dl_win32.xs to work with cygwin - -John Cerney 3/26/97 -*/ -/* Porting notes: - -I merely took Paul's dl_dlopen.xs, took out extraneous stuff and -replaced the appropriate SunOS calls with the corresponding Win32 -calls. - -*/ - -#define WIN32_LEAN_AND_MEAN -// Defines from windows needed for this function only. Can't include full -// Cygwin windows headers because of problems with CONTEXT redefinition -// Removed logic to tell not dynamically load static modules. It is assumed that all -// modules are dynamically built. This should be similar to the behavoir on sunOS. -// Leaving in the logic would have required changes to the standard perlmain.c code -// -#include <stdio.h> - -//#include <windows.h> -#define LOAD_WITH_ALTERED_SEARCH_PATH (8) -typedef void *HANDLE; -typedef HANDLE HINSTANCE; -#define STDCALL __attribute__ ((stdcall)) -typedef int STDCALL (*FARPROC)(); -#define MAX_PATH 260 - -HINSTANCE -STDCALL -LoadLibraryExA( - char* lpLibFileName, - HANDLE hFile, - unsigned int dwFlags - ); -unsigned int -STDCALL -GetLastError( - void - ); -FARPROC -STDCALL -GetProcAddress( - HINSTANCE hModule, - char* lpProcName - ); - -#include <string.h> - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#include "dlutils.c" /* SaveError() etc */ - -static void -dl_private_init(pTHX) -{ - (void)dl_generic_private_init(aTHX); -} - - -MODULE = DynaLoader PACKAGE = DynaLoader - -BOOT: - (void)dl_private_init(aTHX); - -void * -dl_load_file(filename,flags=0) - char * filename - int flags - PREINIT: - CODE: - { - char win32_path[MAX_PATH]; - cygwin_conv_to_full_win32_path(filename, win32_path); - filename = win32_path; - - DLDEBUG(1,PerlIO_printf(Perl_debug_log,"dl_load_file(%s):\n", filename)); - - RETVAL = (void*) LoadLibraryExA(filename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH ) ; - - DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%x\n", RETVAL)); - ST(0) = sv_newmortal() ; - if (RETVAL == NULL){ - SaveError(aTHX_ "%d",GetLastError()) ; - } else { - sv_setiv( ST(0), PTR2IV(RETVAL) ); - } - } - - - -void * -dl_find_symbol(libhandle, symbolname) - void * libhandle - char * symbolname - CODE: - DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_find_symbol(handle=%x, symbol=%s)\n", - libhandle, symbolname)); - RETVAL = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname); - DLDEBUG(2,PerlIO_printf(Perl_debug_log," symbolref = %x\n", RETVAL)); - ST(0) = sv_newmortal() ; - if (RETVAL == NULL) - SaveError(aTHX_ "%d",GetLastError()) ; - else - sv_setiv( ST(0), PTR2IV(RETVAL)); - - -void -dl_undef_symbols() - PPCODE: - - - -# These functions should not need changing on any platform: - -void -dl_install_xsub(perl_name, symref, filename="$Package") - char * perl_name - void * symref - char * filename - CODE: - DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_install_xsub(name=%s, symref=%x)\n", - perl_name, symref)); - ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, - (void(*)(pTHX_ CV *))symref, - filename))); - - -char * -dl_error() - CODE: - RETVAL = LastError ; - OUTPUT: - RETVAL - -# end. diff --git a/ext/DynaLoader/dl_dld.xs b/ext/DynaLoader/dl_dld.xs index 6910739663..d8fad2ac5e 100644 --- a/ext/DynaLoader/dl_dld.xs +++ b/ext/DynaLoader/dl_dld.xs @@ -52,8 +52,8 @@ dl_private_init(pTHX) { int dlderr; dl_generic_private_init(aTHX); - dl_resolve_using = get_av("DynaLoader::dl_resolve_using", 0x4); - dl_require_symbols = get_av("DynaLoader::dl_require_symbols", 0x4); + dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); + dl_require_symbols = get_av("DynaLoader::dl_require_symbols", GV_ADDMULTI); #ifdef __linux__ dlderr = dld_init("/proc/self/exe"); if (dlderr) { diff --git a/ext/DynaLoader/dl_dlopen.xs b/ext/DynaLoader/dl_dlopen.xs index 94cd0173a1..135f5112f2 100644 --- a/ext/DynaLoader/dl_dlopen.xs +++ b/ext/DynaLoader/dl_dlopen.xs @@ -1,7 +1,7 @@ /* dl_dlopen.xs * * Platform: SunOS/Solaris, possibly others which use dlopen. - * Author: Paul Marquess (pmarquess@bfsec.bt.co.uk) + * Author: Paul Marquess (Paul.Marquess@btinternet.com) * Created: 10th July 1994 * * Modified: @@ -146,9 +146,20 @@ void * dl_load_file(filename, flags=0) char * filename int flags - PREINIT: + PREINIT: int mode = RTLD_LAZY; - CODE: + CODE: +{ +#if defined(DLOPEN_WONT_DO_RELATIVE_PATHS) + char pathbuf[PATH_MAX + 2]; + if (*filename != '/' && strchr(filename, '/')) { + if (getcwd(pathbuf, PATH_MAX - strlen(filename))) { + strcat(pathbuf, "/"); + strcat(pathbuf, filename); + filename = pathbuf; + } + } +#endif #ifdef RTLD_NOW if (dl_nonlazy) mode = RTLD_NOW; @@ -167,7 +178,7 @@ dl_load_file(filename, flags=0) SaveError(aTHX_ "%s",dlerror()) ; else sv_setiv( ST(0), PTR2IV(RETVAL)); - +} void * dl_find_symbol(libhandle, symbolname) @@ -175,7 +186,7 @@ dl_find_symbol(libhandle, symbolname) char * symbolname CODE: #ifdef DLSYM_NEEDS_UNDERSCORE - symbolname = form("_%s", symbolname); + symbolname = Perl_form_nocontext("_%s", symbolname); #endif DLDEBUG(2, PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%lx, symbol=%s)\n", diff --git a/ext/DynaLoader/dl_hpux.xs b/ext/DynaLoader/dl_hpux.xs index 2155165cdc..582c047be8 100644 --- a/ext/DynaLoader/dl_hpux.xs +++ b/ext/DynaLoader/dl_hpux.xs @@ -36,7 +36,7 @@ static void dl_private_init(pTHX) { (void)dl_generic_private_init(aTHX); - dl_resolve_using = get_av("DynaLoader::dl_resolve_using", 0x4); + dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); } MODULE = DynaLoader PACKAGE = DynaLoader @@ -104,7 +104,7 @@ dl_find_symbol(libhandle, symbolname) void *symaddr = NULL; int status; #ifdef __hp9000s300 - symbolname = form("_%s", symbolname); + symbolname = Perl_form_nocontext("_%s", symbolname); #endif DLDEBUG(2, PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%lx, symbol=%s)\n", diff --git a/ext/DynaLoader/dl_mpeix.xs b/ext/DynaLoader/dl_mpeix.xs index eb46f037f1..7d27901e65 100644 --- a/ext/DynaLoader/dl_mpeix.xs +++ b/ext/DynaLoader/dl_mpeix.xs @@ -36,7 +36,7 @@ static void dl_private_init(pTHX) { (void)dl_generic_private_init(aTHX); - dl_resolve_using = get_av("DynaLoader::dl_resolve_using", 0x4); + dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); } MODULE = DynaLoader PACKAGE = DynaLoader diff --git a/ext/DynaLoader/dl_next.xs b/ext/DynaLoader/dl_next.xs index 36ef8b8d4f..b8c19f203e 100644 --- a/ext/DynaLoader/dl_next.xs +++ b/ext/DynaLoader/dl_next.xs @@ -93,11 +93,11 @@ static void TranslateError index = number; if (index > NUM_OFI_ERRORS - 1) index = NUM_OFI_ERRORS - 1; - error = form(OFIErrorStrings[index], path, number); + error = Perl_form_nocontext(OFIErrorStrings[index], path, number); break; default: - error = form("%s(%d): Totally unknown error type %d\n", + error = Perl_form_nocontext("%s(%d): Totally unknown error type %d\n", path, number, type); break; } @@ -210,7 +210,7 @@ char *symbol; NXStream *nxerr = OpenError(); unsigned long symref = 0; - if (!rld_lookup(nxerr, form("_%s", symbol), &symref)) + if (!rld_lookup(nxerr, Perl_form_nocontext("_%s", symbol), &symref)) TransferError(nxerr); CloseError(nxerr); return (void*) symref; @@ -226,7 +226,7 @@ static void dl_private_init(pTHX) { (void)dl_generic_private_init(aTHX); - dl_resolve_using = get_av("DynaLoader::dl_resolve_using", 0x4); + dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); } MODULE = DynaLoader PACKAGE = DynaLoader @@ -261,7 +261,7 @@ dl_find_symbol(libhandle, symbolname) char * symbolname CODE: #if NS_TARGET_MAJOR >= 4 - symbolname = form("_%s", symbolname); + symbolname = Perl_form_nocontext("_%s", symbolname); #endif DLDEBUG(2, PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%lx, symbol=%s)\n", diff --git a/ext/DynaLoader/dl_rhapsody.xs b/ext/DynaLoader/dl_rhapsody.xs index 6cf2df794d..768e99ed2f 100644 --- a/ext/DynaLoader/dl_rhapsody.xs +++ b/ext/DynaLoader/dl_rhapsody.xs @@ -85,11 +85,11 @@ static void TranslateError index = number; if (index > NUM_OFI_ERRORS - 1) index = NUM_OFI_ERRORS - 1; - error = form(OFIErrorStrings[index], path, number); + error = Perl_form_nocontext(OFIErrorStrings[index], path, number); break; default: - error = form("%s(%d): Totally unknown error type %d\n", + error = Perl_form_nocontext("%s(%d): Totally unknown error type %d\n", path, number, type); break; } @@ -140,7 +140,7 @@ static void dl_private_init(pTHX) { (void)dl_generic_private_init(aTHX); - dl_resolve_using = get_av("DynaLoader::dl_resolve_using", 0x4); + dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); } MODULE = DynaLoader PACKAGE = DynaLoader @@ -174,7 +174,7 @@ dl_find_symbol(libhandle, symbolname) void * libhandle char * symbolname CODE: - symbolname = form("_%s", symbolname); + symbolname = Perl_form_nocontext("_%s", symbolname); DLDEBUG(2, PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%lx, symbol=%s)\n", (unsigned long) libhandle, symbolname)); diff --git a/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c index 377d6dd5ad..664e331e7b 100644 --- a/ext/DynaLoader/dlutils.c +++ b/ext/DynaLoader/dlutils.c @@ -30,7 +30,8 @@ dl_generic_private_init(pTHXo) /* called by dl_*.xs dl_private_init() */ { char *perl_dl_nonlazy; #ifdef DEBUGGING - dl_debug = SvIV(get_sv("DynaLoader::dl_debug", 0x04) ); + SV *sv = get_sv("DynaLoader::dl_debug", 0); + dl_debug = sv ? SvIV(sv) : 0; #endif if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL ) dl_nonlazy = atoi(perl_dl_nonlazy); diff --git a/ext/DynaLoader/hints/openbsd.pl b/ext/DynaLoader/hints/openbsd.pl new file mode 100644 index 0000000000..aeaa92c5a5 --- /dev/null +++ b/ext/DynaLoader/hints/openbsd.pl @@ -0,0 +1,3 @@ +# XXX Configure test needed? +# Some OpenBSDs seem to have a dlopen() that won't accept relative paths +$self->{CCFLAGS} = $Config{ccflags} . ' -DDLOPEN_WONT_DO_RELATIVE_PATHS'; diff --git a/ext/Fcntl/Fcntl.pm b/ext/Fcntl/Fcntl.pm index 44bb0ae0b2..1eb14e9eb2 100644 --- a/ext/Fcntl/Fcntl.pm +++ b/ext/Fcntl/Fcntl.pm @@ -45,8 +45,8 @@ what constants are implemented in your system. use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD); require Exporter; -require DynaLoader; -@ISA = qw(Exporter DynaLoader); +use XSLoader (); +@ISA = qw(Exporter); $VERSION = "1.03"; # Items to export into callers namespace by default # (move infrequently used names to @EXPORT_OK below) @@ -161,6 +161,6 @@ sub AUTOLOAD { goto &$AUTOLOAD; } -bootstrap Fcntl $VERSION; +XSLoader::load 'Fcntl', $VERSION; 1; diff --git a/ext/File/Glob/Changes b/ext/File/Glob/Changes index 7b8ef7d706..e246c6d684 100644 --- a/ext/File/Glob/Changes +++ b/ext/File/Glob/Changes @@ -36,3 +36,12 @@ Revision history for Perl extension File::Glob - ansified prototypes - s/struct stat/Stat_t/ - split on spaces to make <*.c *.h> work (for compatibility) +0.991 Tue Oct 26 09:48:00 BST 1999 + - Add case-insensitive matching (GLOB_NOCASE) + - Make glob_csh case insensitive by default on Win32, VMS, + OS/2, DOS, RISC OS, and Mac OS + - Add support for :case and :nocase tags + - Hack to make patterns like C:* work on DOSISH systems + - Add support for either \ or / as separators on DOSISH systems + - Limit effect of \ as a quoting operator on DOSISH systems to + when it precedes one of []{}-~\ (to minimise backslashitis). diff --git a/ext/File/Glob/Glob.pm b/ext/File/Glob/Glob.pm index c3b25fa92c..6b5ff84f46 100644 --- a/ext/File/Glob/Glob.pm +++ b/ext/File/Glob/Glob.pm @@ -2,24 +2,26 @@ package File::Glob; use strict; use Carp; -use vars qw($VERSION @ISA @EXPORT_OK @EXPORT_FAIL %EXPORT_TAGS $AUTOLOAD); +use vars qw($VERSION @ISA @EXPORT_OK @EXPORT_FAIL + %EXPORT_TAGS $AUTOLOAD $DEFAULT_FLAGS); require Exporter; -require DynaLoader; +use XSLoader (); require AutoLoader; -@ISA = qw(Exporter DynaLoader AutoLoader); +@ISA = qw(Exporter AutoLoader); @EXPORT_OK = qw( - globally csh_glob glob GLOB_ABEND GLOB_ALTDIRFUNC GLOB_BRACE + GLOB_CSH GLOB_ERR GLOB_ERROR GLOB_MARK + GLOB_NOCASE GLOB_NOCHECK GLOB_NOMAGIC GLOB_NOSORT @@ -28,16 +30,16 @@ require AutoLoader; GLOB_TILDE ); -@EXPORT_FAIL = ( 'globally' ); - %EXPORT_TAGS = ( 'glob' => [ qw( GLOB_ABEND GLOB_ALTDIRFUNC GLOB_BRACE + GLOB_CSH GLOB_ERR GLOB_ERROR GLOB_MARK + GLOB_NOCASE GLOB_NOCHECK GLOB_NOMAGIC GLOB_NOSORT @@ -48,18 +50,24 @@ require AutoLoader; ) ], ); -$VERSION = '0.99'; - -sub export_fail { - shift; - - if ($_[0] eq 'globally') { - local $^W; - *CORE::GLOBAL::glob = \&File::Glob::csh_glob; - shift; +$VERSION = '0.991'; + +sub import { + my $i = 1; + while ($i < @_) { + if ($_[$i] =~ /^:(case|nocase|globally)$/) { + splice(@_, $i, 1); + $DEFAULT_FLAGS &= ~GLOB_NOCASE() if $1 eq 'case'; + $DEFAULT_FLAGS |= GLOB_NOCASE() if $1 eq 'nocase'; + if ($1 eq 'globally') { + local $^W; + *CORE::GLOBAL::glob = \&File::Glob::csh_glob; + } + next; + } + ++$i; } - - @_; + goto &Exporter::import; } sub AUTOLOAD { @@ -83,7 +91,7 @@ sub AUTOLOAD { goto &$AUTOLOAD; } -bootstrap File::Glob $VERSION; +XSLoader::load 'File::Glob', $VERSION; # Preloaded methods go here. @@ -93,6 +101,11 @@ sub GLOB_ERROR { sub GLOB_CSH () { GLOB_BRACE() | GLOB_NOMAGIC() | GLOB_QUOTE() | GLOB_TILDE() } +$DEFAULT_FLAGS = GLOB_CSH(); +if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos|MacOS)$/) { + $DEFAULT_FLAGS |= GLOB_NOCASE(); +} + # Autoload methods go after =cut, and are processed by the autosplit program. sub glob { @@ -127,10 +140,10 @@ sub csh_glob { # if we're just beginning, do it all first if ($iter{$cxix} == 0) { if (@pat) { - $entries{$cxix} = [ map { doglob($_, GLOB_CSH) } @pat ]; + $entries{$cxix} = [ map { doglob($_, $DEFAULT_FLAGS) } @pat ]; } else { - $entries{$cxix} = [ doglob($pat, GLOB_CSH) ]; + $entries{$cxix} = [ doglob($pat, $DEFAULT_FLAGS) ]; } } @@ -169,7 +182,15 @@ File::Glob - Perl extension for BSD glob routine } ## override the core glob (even with -T) - use File::Glob 'globally'; + use File::Glob ':globally'; + my @sources = <*.{c,h,y}> + + ## override the core glob, forcing case sensitivity + use File::Glob qw(:globally :case); + my @sources = <*.{c,h,y}> + + ## override the core glob forcing case insensitivity + use File::Glob qw(:globally :nocase); my @sources = <*.{c,h,y}> =head1 DESCRIPTION @@ -193,6 +214,11 @@ cannot open or read. Ordinarily glob() continues to find matches. Each pathname that is a directory that matches the pattern has a slash appended. +=item C<GLOB_NOCASE> + +By default, file names are assumed to be case sensitive; this flag +makes glob() treat case differences as not significant. + =item C<GLOB_NOCHECK> If the pattern does not match any pathname, then glob() returns a list @@ -228,6 +254,7 @@ behaviour and should probably not be used anywhere else. Use the backslash ('\') character for quoting: every occurrence of a backslash followed by a character in the pattern is replaced by that character, avoiding any special interpretation of the character. +(But see below for exceptions on DOSISH systems). =item C<GLOB_TILDE> @@ -288,6 +315,18 @@ that you can use a backslash to escape things. =item * +On DOSISH systems, backslash is a valid directory separator character. +In this case, use of backslash as a quoting character (via GLOB_QUOTE) +interferes with the use of backslash as a directory separator. The +best (simplest, most portable) solution is to use forward slashes for +directory separators, and backslashes for quoting. However, this does +not match "normal practice" on these systems. As a concession to user +expectation, therefore, backslashes (under GLOB_QUOTE) only quote the +glob metacharacters '[', ']', '{', '}', '-', '~', and backslash itself. +All other backslashes are passed through unchanged. + +=item * + Win32 users should use the real slash. If you really want to use backslashes, consider using Sarathy's File::DosGlob, which comes with the standard Perl distribution. diff --git a/ext/File/Glob/Glob.xs b/ext/File/Glob/Glob.xs index 98e366c401..1805f68a96 100644 --- a/ext/File/Glob/Glob.xs +++ b/ext/File/Glob/Glob.xs @@ -80,6 +80,12 @@ constant(char *name, int arg) #endif break; case 'N': + if (strEQ(name, "GLOB_NOCASE")) +#ifdef GLOB_NOCASE + return GLOB_NOCASE; +#else + goto not_there; +#endif if (strEQ(name, "GLOB_NOCHECK")) #ifdef GLOB_NOCHECK return GLOB_NOCHECK; diff --git a/ext/File/Glob/bsd_glob.c b/ext/File/Glob/bsd_glob.c index f42b689cd7..c422d608bd 100644 --- a/ext/File/Glob/bsd_glob.c +++ b/ext/File/Glob/bsd_glob.c @@ -91,6 +91,9 @@ static char sccsid[] = "@(#)glob.c 8.3 (Berkeley) 10/13/93"; #define BG_RANGE '-' #define BG_RBRACKET ']' #define BG_SEP '/' +#ifdef DOSISH +#define BG_SEP2 '\\' +#endif #define BG_STAR '*' #define BG_TILDE '~' #define BG_UNDERSCORE '_' @@ -132,6 +135,7 @@ typedef U8 Char; static int compare(const void *, const void *); +static int ci_compare(const void *, const void *); static void g_Ctoc(const Char *, char *); static int g_lstat(Char *, Stat_t *, glob_t *); static DIR *g_opendir(Char *, glob_t *); @@ -148,7 +152,7 @@ static int globextend(const Char *, glob_t *); static const Char * globtilde(const Char *, Char *, glob_t *); static int globexp1(const Char *, glob_t *); static int globexp2(const Char *, const Char *, glob_t *, int *); -static int match(Char *, Char *, Char *); +static int match(Char *, Char *, Char *, int); #ifdef GLOB_DEBUG static void qprintf(const char *, Char *); #endif /* GLOB_DEBUG */ @@ -186,11 +190,41 @@ bsd_glob(const char *pattern, int flags, bufnext = patbuf; bufend = bufnext + MAXPATHLEN; +#ifdef DOSISH + /* Nasty hack to treat patterns like "C:*" correctly. In this + * case, the * should match any file in the current directory + * on the C: drive. However, the glob code does not treat the + * colon specially, so it looks for files beginning "C:" in + * the current directory. To fix this, change the pattern to + * add an explicit "./" at the start (just after the drive + * letter and colon - ie change to "C:./*"). + */ + if (isalpha(pattern[0]) && pattern[1] == ':' && + pattern[2] != BG_SEP && pattern[2] != BG_SEP2 && + bufend - bufnext > 4) { + *bufnext++ = pattern[0]; + *bufnext++ = ':'; + *bufnext++ = '.'; + *bufnext++ = BG_SEP; + patnext += 2; + } +#endif if (flags & GLOB_QUOTE) { /* Protect the quoted characters. */ while (bufnext < bufend && (c = *patnext++) != BG_EOS) if (c == BG_QUOTE) { +#ifdef DOSISH + /* To avoid backslashitis on Win32, + * we only treat \ as a quoting character + * if it precedes one of the + * metacharacters []-{}~\ + */ + if ((c = *patnext++) != '[' && c != ']' && + c != '-' && c != '{' && c != '}' && + c != '~' && c != '\\') { +#else if ((c = *patnext++) == BG_EOS) { +#endif c = BG_QUOTE; --patnext; } @@ -496,12 +530,27 @@ glob0(const Char *pattern, glob_t *pglob) } else if (!(pglob->gl_flags & GLOB_NOSORT)) qsort(pglob->gl_pathv + pglob->gl_offs + oldpathc, - pglob->gl_pathc - oldpathc, sizeof(char *), compare); + pglob->gl_pathc - oldpathc, sizeof(char *), + (pglob->gl_flags & GLOB_NOCASE) ? ci_compare : compare); pglob->gl_flags = oldflags; return(0); } static int +ci_compare(const void *p, const void *q) +{ + const char *pp = *(const char **)p; + const char *qq = *(const char **)q; + while (*pp && *qq) { + if (tolower(*pp) != tolower(*qq)) + break; + ++pp; + ++qq; + } + return (tolower(*pp) - tolower(*qq)); +} + +static int compare(const void *p, const void *q) { return(strcmp(*(char **)p, *(char **)q)); @@ -542,7 +591,11 @@ glob2(Char *pathbuf, Char *pathend, Char *pattern, glob_t *pglob) return(0); if (((pglob->gl_flags & GLOB_MARK) && - pathend[-1] != BG_SEP) && (S_ISDIR(sb.st_mode) + pathend[-1] != BG_SEP +#ifdef DOSISH + && pathend[-1] != BG_SEP2 +#endif + ) && (S_ISDIR(sb.st_mode) || (S_ISLNK(sb.st_mode) && (g_stat(pathbuf, &sb, pglob) == 0) && S_ISDIR(sb.st_mode)))) { @@ -559,7 +612,11 @@ glob2(Char *pathbuf, Char *pathend, Char *pattern, glob_t *pglob) /* Find end of next segment, copy tentatively to pathend. */ q = pathend; p = pattern; - while (*p != BG_EOS && *p != BG_SEP) { + while (*p != BG_EOS && *p != BG_SEP +#ifdef DOSISH + && *p != BG_SEP2 +#endif + ) { if (ismeta(*p)) anymeta = 1; *q++ = *p++; @@ -568,7 +625,11 @@ glob2(Char *pathbuf, Char *pathend, Char *pattern, glob_t *pglob) if (!anymeta) { /* No expansion, do next segment. */ pathend = q; pattern = p; - while (*pattern == BG_SEP) + while (*pattern == BG_SEP +#ifdef DOSISH + || *pattern == BG_SEP2 +#endif + ) *pathend++ = *pattern++; } else /* Need expansion, recurse. */ return(glob3(pathbuf, pathend, pattern, p, pglob)); @@ -583,6 +644,7 @@ glob3(Char *pathbuf, Char *pathend, Char *pattern, register Direntry_t *dp; DIR *dirp; int err; + int nocase; char buf[MAXPATHLEN]; /* @@ -608,6 +670,7 @@ glob3(Char *pathbuf, Char *pathend, Char *pattern, } err = 0; + nocase = ((pglob->gl_flags & GLOB_NOCASE) != 0); /* Search directory for matching names. */ if (pglob->gl_flags & GLOB_ALTDIRFUNC) @@ -624,7 +687,7 @@ glob3(Char *pathbuf, Char *pathend, Char *pattern, for (sc = (U8 *) dp->d_name, dc = pathend; (*dc++ = *sc++) != BG_EOS;) continue; - if (!match(pathend, pattern, restpattern)) { + if (!match(pathend, pattern, restpattern, nocase)) { *pathend = BG_EOS; continue; } @@ -703,7 +766,7 @@ globextend(const Char *path, glob_t *pglob) * pattern causes a recursion level. */ static int -match(register Char *name, register Char *pat, register Char *patend) +match(register Char *name, register Char *pat, register Char *patend, int nocase) { int ok, negate_range; Char c, k; @@ -715,7 +778,7 @@ match(register Char *name, register Char *pat, register Char *patend) if (pat == patend) return(1); do - if (match(name, pat, patend)) + if (match(name, pat, patend, nocase)) return(1); while (*name++ != BG_EOS); return(0); @@ -731,16 +794,22 @@ match(register Char *name, register Char *pat, register Char *patend) ++pat; while (((c = *pat++) & M_MASK) != M_END) if ((*pat & M_MASK) == M_RNG) { - if (c <= k && k <= pat[1]) - ok = 1; + if (nocase) { + if (tolower(c) <= tolower(k) && tolower(k) <= tolower(pat[1])) + ok = 1; + } else { + if (c <= k && k <= pat[1]) + ok = 1; + } pat += 2; - } else if (c == k) + } else if (nocase ? (tolower(c) == tolower(k)) : (c == k)) ok = 1; if (ok == negate_range) return(0); break; default: - if (*name++ != c) + k = *name++; + if (nocase ? (tolower(k) != tolower(c)) : (k != c)) return(0); break; } diff --git a/ext/File/Glob/bsd_glob.h b/ext/File/Glob/bsd_glob.h index 410b007a2d..10d1de534c 100644 --- a/ext/File/Glob/bsd_glob.h +++ b/ext/File/Glob/bsd_glob.h @@ -71,6 +71,7 @@ typedef struct { #define GLOB_NOMAGIC 0x0200 /* GLOB_NOCHECK without magic chars (csh). */ #define GLOB_QUOTE 0x0400 /* Quote special chars with \. */ #define GLOB_TILDE 0x0800 /* Expand tilde names from the passwd file. */ +#define GLOB_NOCASE 0x1000 /* Treat filenames without regard for case. */ #define GLOB_NOSPACE (-1) /* Malloc call failed. */ #define GLOB_ABEND (-2) /* Unignored error. */ diff --git a/ext/GDBM_File/GDBM_File.pm b/ext/GDBM_File/GDBM_File.pm index 99ad60b70e..663a679a4d 100644 --- a/ext/GDBM_File/GDBM_File.pm +++ b/ext/GDBM_File/GDBM_File.pm @@ -46,8 +46,8 @@ require Carp; require Tie::Hash; require Exporter; use AutoLoader; -require DynaLoader; -@ISA = qw(Tie::Hash Exporter DynaLoader); +use XSLoader (); +@ISA = qw(Tie::Hash Exporter); @EXPORT = qw( GDBM_CACHESIZE GDBM_FAST @@ -78,7 +78,7 @@ sub AUTOLOAD { goto &$AUTOLOAD; } -bootstrap GDBM_File $VERSION; +XSLoader::load 'GDBM_File', $VERSION; # Preloaded methods go here. Autoload methods go after __END__, and are # processed by the autosplit program. diff --git a/ext/IO/IO.pm b/ext/IO/IO.pm index b6ce21686d..0087530c7e 100644 --- a/ext/IO/IO.pm +++ b/ext/IO/IO.pm @@ -2,15 +2,11 @@ package IO; -require DynaLoader; -require Exporter; +use XSLoader (); use Carp; -use vars qw(@ISA $VERSION @EXPORT); - -@ISA = qw(DynaLoader); $VERSION = "1.20"; -bootstrap IO $VERSION; +XSLoader::load 'IO', $VERSION; sub import { shift; diff --git a/ext/IO/lib/IO/Select.pm b/ext/IO/lib/IO/Select.pm index f021a797ec..79171023e6 100644 --- a/ext/IO/lib/IO/Select.pm +++ b/ext/IO/lib/IO/Select.pm @@ -46,7 +46,9 @@ sub remove sub exists { my $vec = shift; - $vec->[$vec->_fileno(shift) + FIRST_FD]; + my $fno = $vec->_fileno(shift); + return undef unless defined $fno; + $vec->[$fno + FIRST_FD]; } diff --git a/ext/IO/lib/IO/Socket.pm b/ext/IO/lib/IO/Socket.pm index 01cdc40cce..b843999180 100644 --- a/ext/IO/lib/IO/Socket.pm +++ b/ext/IO/lib/IO/Socket.pm @@ -18,7 +18,7 @@ use Exporter; # legacy require IO::Socket::INET; -require IO::Socket::UNIX; +require IO::Socket::UNIX if ($^O ne 'epoc'); @ISA = qw(IO::Handle); diff --git a/ext/IPC/SysV/hints/cygwin.pl b/ext/IPC/SysV/hints/cygwin.pl new file mode 100644 index 0000000000..e1a1dea217 --- /dev/null +++ b/ext/IPC/SysV/hints/cygwin.pl @@ -0,0 +1,2 @@ +# SysV IPC is an optional Cygwin package +$self->{LIBS} = ['-lcygipc'] diff --git a/ext/NDBM_File/NDBM_File.pm b/ext/NDBM_File/NDBM_File.pm index 8db59ee03c..578148c56e 100644 --- a/ext/NDBM_File/NDBM_File.pm +++ b/ext/NDBM_File/NDBM_File.pm @@ -8,13 +8,13 @@ BEGIN { use vars qw($VERSION @ISA); require Tie::Hash; -require DynaLoader; +use DynaLoader (); -@ISA = qw(Tie::Hash DynaLoader); +@ISA = qw(Tie::Hash); $VERSION = "1.03"; -bootstrap NDBM_File $VERSION; +XSLoader::load 'NDBM_File', $VERSION; 1; diff --git a/ext/NDBM_File/hints/cygwin.pl b/ext/NDBM_File/hints/cygwin.pl new file mode 100644 index 0000000000..0a4b7628a4 --- /dev/null +++ b/ext/NDBM_File/hints/cygwin.pl @@ -0,0 +1,2 @@ +# uses GDBM ndbm compatibility feature +$self->{LIBS} = ['-lgdbm']; diff --git a/ext/ODBM_File/ODBM_File.pm b/ext/ODBM_File/ODBM_File.pm index 0af875dc36..6199443a32 100644 --- a/ext/ODBM_File/ODBM_File.pm +++ b/ext/ODBM_File/ODBM_File.pm @@ -4,13 +4,13 @@ use strict; use vars qw($VERSION @ISA); require Tie::Hash; -require DynaLoader; +use DynaLoader (); -@ISA = qw(Tie::Hash DynaLoader); +@ISA = qw(Tie::Hash); $VERSION = "1.02"; -bootstrap ODBM_File $VERSION; +XSLoader::load 'ODBM_File', $VERSION; 1; diff --git a/ext/ODBM_File/hints/cygwin.pl b/ext/ODBM_File/hints/cygwin.pl new file mode 100644 index 0000000000..a0d33c8807 --- /dev/null +++ b/ext/ODBM_File/hints/cygwin.pl @@ -0,0 +1,2 @@ +# uses GDBM dbm compatibility feature +$self->{LIBS} = ['-lgdbm']; diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm index ff3899f835..3915b40980 100644 --- a/ext/Opcode/Opcode.pm +++ b/ext/Opcode/Opcode.pm @@ -10,8 +10,8 @@ $XS_VERSION = "1.03"; use strict; use Carp; use Exporter (); -use DynaLoader (); -@ISA = qw(Exporter DynaLoader); +use XSLoader (); +@ISA = qw(Exporter); BEGIN { @EXPORT_OK = qw( @@ -28,7 +28,7 @@ sub opset_to_hex ($); sub opdump (;$); use subs @EXPORT_OK; -bootstrap Opcode $XS_VERSION; +XSLoader::load 'Opcode', $XS_VERSION; _init_optags(); diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs index 63ff8aa711..581cbc94d9 100644 --- a/ext/Opcode/Opcode.xs +++ b/ext/Opcode/Opcode.xs @@ -204,7 +204,7 @@ static void opmask_addlocal(pTHX_ SV *opset, char *op_mask_buf) /* Localise PL_op_mask then opmask_add() */ { char *orig_op_mask = PL_op_mask; - SAVEPPTR(PL_op_mask); + SAVEVPTR(PL_op_mask); #if !defined(PERL_OBJECT) /* XXX casting to an ordinary function ptr from a member function ptr * is disallowed by Borland diff --git a/ext/POSIX/Makefile.PL b/ext/POSIX/Makefile.PL index fda7528857..15256cf198 100644 --- a/ext/POSIX/Makefile.PL +++ b/ext/POSIX/Makefile.PL @@ -1,9 +1,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'POSIX', - ($^O eq 'MSWin32' ? () : ($^O =~ /cygwin/ ? () : - (LIBS => ["-lm -lposix -lcposix"]) - )), + ($^O eq 'MSWin32' ? () : (LIBS => ["-lm -lposix -lcposix"])), MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'POSIX.pm', diff --git a/ext/POSIX/POSIX.pm b/ext/POSIX/POSIX.pm index d43b8ca282..a38c74dcca 100644 --- a/ext/POSIX/POSIX.pm +++ b/ext/POSIX/POSIX.pm @@ -9,10 +9,10 @@ require Config; use Symbol; require Exporter; -require DynaLoader; -@ISA = qw(Exporter DynaLoader); +use XSLoader (); +@ISA = qw(Exporter); -$VERSION = $VERSION = "1.03" ; +$VERSION = "1.03" ; %EXPORT_TAGS = ( @@ -195,7 +195,7 @@ sub import { } -bootstrap POSIX $VERSION; +XSLoader::load 'POSIX', $VERSION; my $EINVAL = constant("EINVAL", 0); my $EAGAIN = constant("EAGAIN", 0); diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index 6fc32b1bd5..4c96f12e4f 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -108,7 +108,6 @@ #else #if defined (CYGWIN) # define tzname _tzname -# undef MB_CUR_MAX /* XXX: bug in b20.1 */ #endif #if defined (WIN32) # undef mkfifo @@ -290,7 +289,7 @@ unsigned long strtoul (const char *, char **, int); #endif #ifdef HAS_TZNAME -# ifndef WIN32 +# if !defined(WIN32) && !defined(CYGWIN) extern char *tzname[]; # endif #else diff --git a/ext/SDBM_File/Makefile.PL b/ext/SDBM_File/Makefile.PL index afce3f1a54..a1debb92a3 100644 --- a/ext/SDBM_File/Makefile.PL +++ b/ext/SDBM_File/Makefile.PL @@ -20,13 +20,26 @@ WriteMakefile( ); sub MY::postamble { - if ($^O ne 'VMS') { + if ($^O =~ /MSWin32/ && Win32::IsWin95()) { + # XXX: dmake-specific, like rest of Win95 port + return + ' +$(MYEXTLIB): sdbm/Makefile +@[ + cd sdbm + $(MAKE) all + cd .. +] +'; + } + elsif ($^O ne 'VMS') { ' $(MYEXTLIB): sdbm/Makefile cd sdbm && $(MAKE) all '; - } else { - ' + } + else { + ' $(MYEXTLIB) : [.sdbm]descrip.mms set def [.sdbm] $(MMS) all diff --git a/ext/SDBM_File/SDBM_File.pm b/ext/SDBM_File/SDBM_File.pm index 34c971734c..1f3b4000e2 100644 --- a/ext/SDBM_File/SDBM_File.pm +++ b/ext/SDBM_File/SDBM_File.pm @@ -4,13 +4,13 @@ use strict; use vars qw($VERSION @ISA); require Tie::Hash; -require DynaLoader; +use XSLoader (); -@ISA = qw(Tie::Hash DynaLoader); +@ISA = qw(Tie::Hash); $VERSION = "1.02" ; -bootstrap SDBM_File $VERSION; +XSLoader::load 'SDBM_File', $VERSION; 1; diff --git a/ext/SDBM_File/sdbm/pair.c b/ext/SDBM_File/sdbm/pair.c index a30894b780..c2ed213036 100644 --- a/ext/SDBM_File/sdbm/pair.c +++ b/ext/SDBM_File/sdbm/pair.c @@ -9,7 +9,6 @@ #include "config.h" #ifdef CYGWIN -# define EXT extern # define EXTCONST extern const #else # include "EXTERN.h" diff --git a/ext/Socket/Socket.pm b/ext/Socket/Socket.pm index a0bb95d6e4..1fa108fd72 100644 --- a/ext/Socket/Socket.pm +++ b/ext/Socket/Socket.pm @@ -162,8 +162,8 @@ have AF_UNIX in the right place. use Carp; require Exporter; -require DynaLoader; -@ISA = qw(Exporter DynaLoader); +use XSLoader (); +@ISA = qw(Exporter); @EXPORT = qw( inet_aton inet_ntoa pack_sockaddr_in unpack_sockaddr_in pack_sockaddr_un unpack_sockaddr_un @@ -333,6 +333,6 @@ sub AUTOLOAD { goto &$AUTOLOAD; } -bootstrap Socket $VERSION; +XSLoader::load 'Socket', $VERSION; 1; diff --git a/ext/Thread/Thread.pm b/ext/Thread/Thread.pm index 7956a7984f..f15883e029 100644 --- a/ext/Thread/Thread.pm +++ b/ext/Thread/Thread.pm @@ -1,11 +1,11 @@ package Thread; require Exporter; -require DynaLoader; +use XSLoader (); use vars qw($VERSION @ISA @EXPORT); $VERSION = "1.0"; -@ISA = qw(Exporter DynaLoader); +@ISA = qw(Exporter); @EXPORT_OK = qw(yield cond_signal cond_broadcast cond_wait async); =head1 NAME @@ -204,6 +204,6 @@ sub eval { return eval { shift->join; }; } -bootstrap Thread; +XSLoader::load 'Thread'; 1; diff --git a/ext/attrs/attrs.pm b/ext/attrs/attrs.pm index cec5ea5fcd..f744e36c66 100644 --- a/ext/attrs/attrs.pm +++ b/ext/attrs/attrs.pm @@ -1,9 +1,6 @@ package attrs; -require DynaLoader; -use vars '@ISA'; -@ISA = 'DynaLoader'; +use XSLoader (); -use vars qw($VERSION); $VERSION = "1.0"; =head1 NAME @@ -56,6 +53,6 @@ subroutine is entered. =cut -bootstrap attrs $VERSION; +XSLoader::load 'attrs', $VERSION; 1; diff --git a/ext/re/re.pm b/ext/re/re.pm index 842e39ad75..3f142d9de4 100644 --- a/ext/re/re.pm +++ b/ext/re/re.pm @@ -105,9 +105,8 @@ sub bits { foreach my $s (@_){ if ($s eq 'debug' or $s eq 'debugcolor') { setcolor() if $s eq 'debugcolor'; - require DynaLoader; - @ISA = ('DynaLoader'); - bootstrap re; + require XSLoader; + XSLoader::load('re'); install() if $on; uninstall() unless $on; next; diff --git a/global.sym b/global.sym index e21903093c..0fc9739a73 100644 --- a/global.sym +++ b/global.sym @@ -4,17 +4,34 @@ # and run 'make regen_headers' to effect changes. # +perl_alloc_using +perl_alloc +perl_construct +perl_destruct +perl_free +perl_run +perl_parse +perl_clone +perl_clone_using +Perl_malloc +Perl_calloc +Perl_realloc +Perl_mfree +Perl_malloced_size Perl_amagic_call Perl_Gv_AMupdate Perl_append_elem Perl_append_list Perl_apply +Perl_avhv_delete_ent Perl_avhv_exists_ent Perl_avhv_fetch_ent Perl_avhv_iternext Perl_avhv_iterval Perl_avhv_keys Perl_av_clear +Perl_av_delete +Perl_av_exists Perl_av_extend Perl_av_fake Perl_av_fetch @@ -292,7 +309,6 @@ Perl_magic_set_all_env Perl_magic_sizepack Perl_magic_wipepack Perl_magicname -Perl_malloced_size Perl_markstack_grow Perl_mem_collxfrm Perl_mess @@ -393,17 +409,6 @@ Perl_pad_free Perl_pad_reset Perl_pad_swipe Perl_peep -perl_construct -perl_destruct -perl_free -perl_run -perl_parse -perl_alloc -perl_construct -perl_destruct -perl_free -perl_run -perl_parse Perl_new_struct_thread Perl_call_atexit Perl_call_argv @@ -477,6 +482,7 @@ Perl_save_hints Perl_save_hptr Perl_save_I16 Perl_save_I32 +Perl_save_I8 Perl_save_int Perl_save_item Perl_save_iv @@ -486,6 +492,7 @@ Perl_save_nogv Perl_save_op Perl_save_scalar Perl_save_pptr +Perl_save_vptr Perl_save_re_context Perl_save_sptr Perl_save_svref @@ -516,11 +523,15 @@ Perl_sv_2iv Perl_sv_2mortal Perl_sv_2nv Perl_sv_2pv +Perl_sv_2pvutf8 +Perl_sv_2pvbyte Perl_sv_2uv Perl_sv_iv Perl_sv_uv Perl_sv_nv Perl_sv_pvn +Perl_sv_pvutf8n +Perl_sv_pvbyten Perl_sv_true Perl_sv_add_arena Perl_sv_backoff @@ -560,6 +571,8 @@ Perl_sv_peek Perl_sv_pos_u2b Perl_sv_pos_b2u Perl_sv_pvn_force +Perl_sv_pvutf8n_force +Perl_sv_pvbyten_force Perl_sv_reftype Perl_sv_replace Perl_sv_report_used @@ -607,6 +620,7 @@ Perl_uv_to_utf8 Perl_vivify_defelem Perl_vivify_ref Perl_wait4pid +Perl_report_uninit Perl_warn Perl_vwarn Perl_warner @@ -619,10 +633,6 @@ Perl_yylex Perl_yyparse Perl_yywarn Perl_dump_mstats -Perl_malloc -Perl_calloc -Perl_realloc -Perl_mfree Perl_safesysmalloc Perl_safesyscalloc Perl_safesysrealloc @@ -665,7 +675,11 @@ Perl_default_protect Perl_vdefault_protect Perl_reginitcolors Perl_sv_2pv_nolen +Perl_sv_2pvutf8_nolen +Perl_sv_2pvbyte_nolen Perl_sv_pv +Perl_sv_pvutf8 +Perl_sv_pvbyte Perl_sv_force_normal Perl_tmps_grow Perl_sv_rvweaken @@ -678,6 +692,7 @@ Perl_boot_core_xsutils Perl_cx_dup Perl_si_dup Perl_ss_dup +Perl_any_dup Perl_he_dup Perl_re_dup Perl_fp_dup @@ -690,5 +705,3 @@ Perl_ptr_table_new Perl_ptr_table_fetch Perl_ptr_table_store Perl_ptr_table_split -perl_clone -perl_clone_using @@ -9,11 +9,12 @@ #undef PERLVARA #define PERLVARA(x, n, y) #undef PERLVARI -#define PERLVARI(x, y, z) PL_##x = z; +#define PERLVARI(x, y, z) interp.x = z; #undef PERLVARIC -#define PERLVARIC(x, y, z) PL_##x = z; +#define PERLVARIC(x, y, z) interp.x = z; -CPerlObj::CPerlObj(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd, +CPerlObj::CPerlObj(IPerlMem* ipM, IPerlMem* ipMS, IPerlMem* ipMP, + IPerlEnv* ipE, IPerlStdIO* ipStd, IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP) { @@ -21,9 +22,10 @@ CPerlObj::CPerlObj(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd, #include "thrdvar.h" #include "intrpvar.h" -#include "perlvars.h" PL_Mem = ipM; + PL_MemShared = ipMS; + PL_MemParse = ipMP; PL_Env = ipE; PL_StdIO = ipStd; PL_LIO = ipLIO; @@ -43,17 +45,14 @@ CPerlObj::operator new(size_t nSize, IPerlMem *pvtbl) #endif } +#ifndef __BORLANDC__ void CPerlObj::operator delete(void *pPerl, IPerlMem *pvtbl) { if(pvtbl) pvtbl->pFree(pvtbl, pPerl); } - -void -CPerlObj::Init(void) -{ -} +#endif #ifdef WIN32 /* XXX why are these needed? */ bool diff --git a/globvar.sym b/globvar.sym index 3cb8ccc3e4..0d768889a8 100644 --- a/globvar.sym +++ b/globvar.sym @@ -32,8 +32,6 @@ opargs ppaddr sig_name sig_num -psig_name -psig_ptr regkind simple utf8skip @@ -655,10 +655,15 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) if (strEQ(name, "SIG")) { HV *hv; I32 i; + if (!PL_psig_ptr) { + int sig_num[] = { SIG_NUM }; + New(73, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*); + New(73, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*); + } GvMULTI_on(gv); hv = GvHVn(gv); hv_magic(hv, gv, 'S'); - for(i = 1; PL_sig_name[i]; i++) { + for (i = 1; PL_sig_name[i]; i++) { SV ** init; init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1); if (init) @@ -808,8 +813,9 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) if (len == 1) { SV *sv = GvSV(gv); (void)SvUPGRADE(sv, SVt_PVNV); - sv_setpv(sv, PL_patchlevel); - (void)sv_2nv(sv); + SvNVX(sv) = SvNVX(PL_patchlevel); + SvNOK_on(sv); + (void)SvPV_nolen(sv); SvREADONLY_on(sv); } break; diff --git a/hints/aix.sh b/hints/aix.sh index 56496e535e..fec963b8f8 100644 --- a/hints/aix.sh +++ b/hints/aix.sh @@ -117,10 +117,10 @@ esac # symbol: boot_$(EXP) can it be auto-generated? case "$osvers" in 3*) - lddlflags="$lddlflags -H512 -T512 -bhalt:4 -bM:SRE -bI:$(PERL_INC)/perl.exp -bE:$(BASEEXT).exp -e _nostart -lc" + lddlflags="$lddlflags -H512 -T512 -bhalt:4 -bM:SRE -bI:\$(PERL_INC)/perl.exp -bE:\$(BASEEXT).exp -e _nostart -lc" ;; *) - lddlflags="$lddlflags -bhalt:4 -bM:SRE -bI:$(PERL_INC)/perl.exp -bE:$(BASEEXT).exp -b noentry -lc" + lddlflags="$lddlflags -bhalt:4 -bM:SRE -bI:\$(PERL_INC)/perl.exp -bE:\$(BASEEXT).exp -b noentry -lc" ;; esac diff --git a/hints/cygwin.sh b/hints/cygwin.sh index de48cdfeb2..71c9a8334e 100644 --- a/hints/cygwin.sh +++ b/hints/cygwin.sh @@ -1,46 +1,40 @@ #! /bin/sh # cygwin.sh - hints for building perl using the Cygwin environment for Win32 # -# Many of these inflexible settings should be changed to allow command- -# line overrides and allow for variations in local set-ups. -# I have made first guesses at some of these, but would welcome -# corrections from someone actually using Cygwin. -# Andy Dougherty <doughera@lafayette.edu> Tue Sep 28 12:39:38 EDT 1999 -_exe='.exe' +# not otherwise settable exe_ext='.exe' -# work around case-insensitive file names firstmakefile='GNUmakefile' -sharpbang='#!' -startsh='#!/bin/sh' +case "$ldlibpthname" in +'') ldlibpthname=PATH ;; +esac -archname='cygwin' +# mandatory (overrides incorrect defaults) test -z "$cc" && cc='gcc' -libpth='/usr/i586-cygwin32/lib /usr/lib /usr/local/lib' +if test -z "$plibpth" +then + plibpth=`gcc -print-file-name=libc.a` + plibpth=`dirname $plibpth` + plibpth=`cd $plibpth && pwd` +fi so='dll' -libs='-lcygwin -lm -lkernel32' -#optimize='-g' -# Is -I/usr/include *really* needed? -# Is -I/usr/local/include *really* needed? I thought gcc always looked there. -ccflags="$ccflags -DCYGWIN -I/usr/include -I/usr/local/include" -# Is -L/usr/lib *really* needed? -ldflags="$ldflags -L/usr/i586-cygwin32/lib -L/usr/lib -L/usr/local/lib" -test -z "$usemymalloc" && usemymalloc='n' -dlsrc='dl_cygwin.xs' -cccdlflags=' ' +# - eliminate -lc, implied by gcc +libswanted=`echo " $libswanted " | sed -e 's/ c / /g'` +libswanted="$libswanted cygipc cygwin kernel32" +ccflags="$ccflags -DCYGWIN" +# - otherwise i686-cygwin +archname='cygwin' + +# dynamic loading ld='ld2' -# Is -L/usr/local/lib *really* needed? -lddlflags="$lddlflags -L/usr/local/lib" -useshrplib='true' -libperl='libperl.a' -dlext='dll' -dynamic_ext=' ' +# - otherwise -fpic +cccdlflags=' ' -# What if they aren't using $prefix=/usr/local ?? -# Why is this needed at all? Doesn't Configure suggest this? -test -z "$man1dir" && man1dir=/usr/local/man/man1 -test -z "$man3dir" && man3dir=/usr/local/man/man3 +# optional(ish) +# - perl malloc needs to be unpolluted +bincompat5005='undef' -case "$ldlibpthname" in -'') ldlibpthname=PATH ;; -esac +# strip exe's and dll's +#ldflags="$ldflags -s" +#ccdlflags="$ccdlflags -s" +#lddlflags="$lddlflags -s" diff --git a/hints/svr5.sh b/hints/svr5.sh index 6a76ea5406..f73689507a 100644 --- a/hints/svr5.sh +++ b/hints/svr5.sh @@ -1,5 +1,6 @@ # svr5 hints, System V Release 5.x (UnixWare 7) -# Reworked by hops@sco.com Sept 1999 for better platform support +# mods after mail fm Andy Dougherty +# Reworked by hops@sco.com Sept/Oct 1999 for UW7.1 platform support # Boyd Gerber, gerberb@zenez.com 1999/09/21 for threads support. # Originally taken from svr4 hints.sh 21-Sep-98 hops@sco.com # which was version of 1996/10/25 by Tye McQueen, tye@metronet.com @@ -7,9 +8,6 @@ # Use Configure -Dusethreads to enable threads. # Use Configure -Dcc=gcc to use gcc. case "$cc" in -'') cc='/bin/cc' - test -f $cc || cc='/usr/ccs/bin/cc' - ;; *gcc*) # "$gccversion" not set yet vers=`gcc -v 2>&1 | sed -n -e 's@.*version \([^ ][^ ]*\) .*@\1@p'` @@ -43,17 +41,18 @@ esac # Leave leading tabs so Configure doesn't propagate variables to config.sh - want_ucb='' # don't use anything from /usr/ucblib - icky - want_dbm='yes' # use dbm if can find library in /usr/local/lib - want_gdbm='yes' # use gdbm if can find library in /usr/local/lib - want_udk70='' # link with old static libc pieces - # link with udk70 if want resulting binary to run on uw7.0* - # - it will link in referenced static symbols of libc that are (now) - # in the shared libc.so on 7.1 but were not in 7.0. + want_ucb='' # don't use anything from /usr/ucblib - icky + want_dbm='yes' # use dbm if can find library in /usr/local/lib + want_gdbm='yes' # use gdbm if can find library in /usr/local/lib + want_udk70='' # link with old static libc pieces + # link with udk70 if building on 7.1 abd want resulting binary + # to run on uw7.0* - it will link in referenced static symbols + # of libc that are (now) in the shared libc.so on 7.1 but were + # not there in 7.0. # There are still scenarios where this is still insufficient so # overall it is preferable to get ptf7051e # ftp://ftp.sco.com/SLS/ptf7051e.Z - # installed on any/all 7.0 systems. + # installed on any/all 7.0 systems and leave the above unset. if [ "$want_ucb" ] ; then ldflags= '-L/usr/ucblib' @@ -71,10 +70,8 @@ else fi fi -if [ "$want_gdbm" -a -f /usr/local/lib/libgdbm.so ] ; then - i_gdbm='define' -else - i_gdbm='undef' +if [ ! "$want_gdbm" ] ; then + i_gdbm='undef' libswanted=`echo " $libswanted " | sed -e 's/ gdbm / /'` fi @@ -84,10 +81,6 @@ fi # libc: on UW7 don't want -lc explicitly as native cc gives warnings/errors libswanted=`echo " $libswanted " | sed -e 's/ malloc / /' -e 's/ c / /'` -# Don't use irrelevant (but existing) lib dirs -# don't want /usr/gnu/lib - original(older) system supplied distrib of perl5 -loclibpth=`echo " $loclibpth " | sed -e 's@ /usr/gnu/lib @ @'` - # remove /shlib and /lib from library search path as both symlink to /usr/lib # where runtime shared libc is glibpth=`echo " $glibpth " | sed -e 's/ \/shlib / /' -e 's/ \/lib / /` @@ -101,11 +94,6 @@ d_setlinebuf='undef' d_setregid='undef' d_setreuid='undef' # -- in /usr/lib/libc.so.1 -# use nm to probe libs - its fast enough on uw7 -case "$usenm" in -'') usenm=true;; -esac - # Broken C-Shell tests (Thanks to Tye McQueen): # The OS-specific checks may be obsoleted by the this generic test. sh_cnt=`sh -c 'echo /*' | wc -c` @@ -158,39 +146,33 @@ fi # End of Unixware-specific tests. ############################################################### -# Dynamic loading section: +# Dynamic loading section: Is default so it should just happen. +# set below to explicitly force. +# usedl='define' +# dlext='so' +# dlsrc='dl_dlopen.xs' # # ccdlflags : must tell the linker to export all global symbols # cccdlflags: must tell the compiler to generate relocatable code # lddlflags : must tell the linker to output a shared library -# -# /usr/local/lib is added for convenience, since additional libraries -# are usually put there -# + # use shared perl lib useshrplib='true' case "$cc" in *gcc*) - ccdlflags='-Xlinker -Bexport -L/usr/local/lib' + ccdlflags='-Xlinker -Bexport ' cccdlflags='-fpic' - lddlflags='-G -L/usr/local/lib' + lddlflags='-G ' ;; *) - ccdlflags='-Wl,-Bexport -L/usr/local/lib' + ccdlflags='-Wl,-Bexport' cccdlflags='-Kpic' - lddlflags='-G -Wl,-Bexport -L/usr/local/lib' + lddlflags='-G -Wl,-Bexport' ;; esac -############################################################### -# Use dynamic loading -usedl='define' -dlext='so' -dlsrc='dl_dlopen.xs' - - ############################################################################ # Thread support # use Configure -Dusethreads to enable @@ -200,28 +182,40 @@ cat > UU/usethreads.cbu <<'EOCBU' case "$usethreads" in $define|true|[yY]*) ccflags="$ccflags" - set `echo X "$libswanted "| sed -e 's/ c / pthread c /'` shift libswanted="$*" case "$cc" in *gcc*) ccflags="-D_REENTRANT $ccflags -fpic -pthread" cccdlflags='-fpic' - lddlflags='-pthread -G -L/usr/local/lib ' + lddlflags='-pthread -G ' ;; *) ccflags="-D_REENTRANT $ccflags -KPIC -Kthread" - ccdlflags='-Kthread -Wl,-Bexport -L/usr/local/lib' + ccdlflags='-Kthread -Wl,-Bexport' cccdlflags='-KPIC -Kthread' - lddlflags='-G -Kthread -Wl,-Bexport -L/usr/local/lib' - ldflags='-Kthread -L/usr/local/lib' + lddlflags='-G -Kthread -Wl,-Bexport ' + ldflags='-Kthread' ;; esac esac EOCBU -# Just in case Configure fails to find lstat() Its in /usr/lib/libc.so.1. -d_lstat=define - d_suidsafe='define' # "./Configure -d" can't figure this out easily + +################## final caveat msgs to builder ############### +cat <<'EOM' >&4 + +If you wish to use dynamic linking, you must use + LD_LIBRARY_PATH=`pwd`; export LD_LIBRARY_PATH +or + setenv LD_LIBRARY_PATH `pwd` +before running make. + +If you are using shared libraries from /usr/local/lib +for libdbm or libgdbm you may need to set + LD_RUN_PATH=/usr/local/lib; export LD_RUN_PATH +in order for Configure to compile the simple test program + +EOM @@ -81,8 +81,16 @@ Perl_he_dup(pTHX_ HE *e, bool shared) if (!e) return Nullhe; + /* look for it in the table first */ + ret = (HE*)ptr_table_fetch(PL_ptr_table, e); + if (ret) + return ret; + + /* create anew and remember what it is */ ret = new_he(); - HeNEXT(ret) = (HE*)NULL; + ptr_table_store(PL_ptr_table, e, ret); + + HeNEXT(ret) = he_dup(HeNEXT(e),shared); if (HeKLEN(e) == HEf_SVKEY) HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e))); else if (shared) @@ -494,8 +502,10 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, U32 klen, I32 flags) xhv->xhv_fill--; if (flags & G_DISCARD) sv = Nullsv; - else - sv = sv_mortalcopy(HeVAL(entry)); + else { + sv = sv_2mortal(HeVAL(entry)); + HeVAL(entry) = &PL_sv_undef; + } if (entry == xhv->xhv_eiter) HvLAZYDEL_on(hv); else @@ -568,8 +578,10 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) xhv->xhv_fill--; if (flags & G_DISCARD) sv = Nullsv; - else - sv = sv_mortalcopy(HeVAL(entry)); + else { + sv = sv_2mortal(HeVAL(entry)); + HeVAL(entry) = &PL_sv_undef; + } if (entry == xhv->xhv_eiter) HvLAZYDEL_on(hv); else diff --git a/installhtml b/installhtml index d73124ce13..c268f54b36 100755 --- a/installhtml +++ b/installhtml @@ -9,8 +9,6 @@ use Getopt::Long; # for command-line parsing use Cwd; use Pod::Html; -umask 022; - =head1 NAME installhtml - converts a collection of POD pages to HTML format. diff --git a/installman b/installman index a70fdd3ba9..c9fb0fe18c 100755 --- a/installman +++ b/installman @@ -10,12 +10,11 @@ use subs qw(unlink chmod rename link); use vars qw($packlist); require Cwd; -umask 022; $ENV{SHELL} = 'sh' if $^O eq 'os2'; -$ver = $]; -$release = substr($ver,0,3); # Not used presently. -$patchlevel = substr($ver,3,2); +$ver = $Config{version}; +$release = substr($],0,3); # Not used presently. +$patchlevel = substr($],3,2); die "Patchlevel of perl ($patchlevel)", "and patchlevel of config.sh ($Config{'PERL_VERSION'}) don't match\n" if $patchlevel != $Config{'PERL_VERSION'}; @@ -142,7 +141,7 @@ sub runpod2man { # Convert name from File/Basename.pm to File::Basename.3 format, # if necessary. $manpage =~ s#\.p(m|od)$##; - if ($^O eq 'os2' || $^O eq 'amigaos' || $^O eq 'uwin' || $^O =~ /cygwin/) { + if ($^O eq 'os2' || $^O eq 'amigaos' || $^O eq 'uwin' || $^O eq 'cygwin') { $manpage =~ s#/#.#g; } else { diff --git a/installperl b/installperl index ddd06fa6d7..dae86a5c0e 100755 --- a/installperl +++ b/installperl @@ -14,7 +14,7 @@ BEGIN { $Is_VMS = $^O eq 'VMS'; $Is_W32 = $^O eq 'MSWin32'; $Is_OS2 = $^O eq 'os2'; - $Is_Cygwin = $^O =~ /cygwin/i; + $Is_Cygwin = $^O eq 'cygwin'; if ($Is_VMS) { eval 'use VMS::Filespec;' } } @@ -40,10 +40,10 @@ my $exe_ext = $Config{exe_ext}; # Allow ``make install PERLNAME=something_besides_perl'': my $perl = defined($ENV{PERLNAME}) ? $ENV{PERLNAME} : 'perl'; -# This is the base used for versioned names, like "perl5.005". +# This is the base used for versioned names, like "perl5.6.0". # It's separate because a common use of $PERLNAME is to install # perl as "perl5", if that's used as base for versioned files you -# get "perl55.005". +# get "perl55.6.0". my $perl_verbase = defined($ENV{PERLNAME_VERBASE}) ? $ENV{PERLNAME_VERBASE} : $perl; @@ -54,8 +54,6 @@ while (@ARGV) { shift; } -umask 022 unless $Is_VMS; - my @scripts = qw(utils/c2ph utils/h2ph utils/h2xs utils/perlbug utils/perldoc utils/pl2pm utils/splain utils/perlcc utils/dprofpp x2p/s2p x2p/find2perl @@ -93,9 +91,9 @@ find(sub { } }, 'ext'); -my $ver = $]; -my $release = substr($ver,0,3); # Not used presently. -my $patchlevel = substr($ver,3,2); +my $ver = $Config{version}; +my $release = substr($],0,3); # Not used presently. +my $patchlevel = substr($],3,2); die "Patchlevel of perl ($patchlevel)", "and patchlevel of config.sh ($Config{'PERL_VERSION'}) don't match\n" if $patchlevel != $Config{'PERL_VERSION'}; @@ -164,13 +162,13 @@ if ($Is_Cygwin) { if ($dlsrc ne "dl_none.xs") { -f $perldll || die "No perl DLL built\n"; - + } # Install the DLL - safe_unlink("$installbin/$perldll"); - copy("$perldll", "$installbin/$perldll"); - chmod(0755, "$installbin/$perldll"); - } + safe_unlink("$installbin/$perldll"); + copy("$perldll", "$installbin/$perldll"); + chmod(0755, "$installbin/$perldll"); + } # if ($Is_W32 or $Is_Cygwin) # This will be used to store the packlist @@ -225,7 +223,7 @@ mkpath($installsitearch, 1, 0777) if ($installsitearch); if (chdir "lib") { $do_installarchlib = ! samepath($installarchlib, '.'); $do_installprivlib = ! samepath($installprivlib, '.'); - $do_installprivlib = 0 if $versiononly && !($installprivlib =~ m/\Q$]/); + $do_installprivlib = 0 if $versiononly && !($installprivlib =~ m/\Q$ver/); if ($do_installarchlib || $do_installprivlib) { find(\&installlib, '.'); @@ -240,7 +238,7 @@ else { mkpath("$installarchlib/CORE", 1, 0777); my @corefiles; if ($Is_VMS) { # We did core file selection during build - my $coredir = "lib/$Config{'arch'}/$]"; + my $coredir = "lib/$Config{'arch'}/$ver"; $coredir =~ tr/./_/; @corefiles = <$coredir/*.*>; } @@ -372,7 +370,7 @@ if (! $versiononly) { # ($installprivlib/pods for cygwin). my $pod = $Is_Cygwin ? 'pods' : 'pod'; -unless ( $versiononly && !($installprivlib =~ m/\Q$]/)) { +unless ( $versiononly && !($installprivlib =~ m/\Q$ver/)) { mkpath("${installprivlib}/$pod", 1, 0777); # If Perl 5.003's perldiag.pod is there, rename it. @@ -405,7 +403,7 @@ unless ( $versiononly && !($installprivlib =~ m/\Q$]/)) { # installed perl. if (!$versiononly) { - my ($path, @path); + my ($path, @path); my $dirsep = ($Is_OS2 || $Is_W32) ? ';' : ':' ; ($path = $ENV{"PATH"}) =~ s:\\:/:g ; @path = split(/$dirsep/, $path); @@ -514,11 +512,13 @@ sub link { ? $success++ : ($from =~ m#^/afs/# || $to =~ m#^/afs/#) ? die "AFS" # okay inside eval {} - : warn "Couldn't link $from to $to: $!\n" + : die "Couldn't link $from to $to: $!\n" unless $nonono; $packlist->{$to} = { from => $from, type => 'link' }; }; if ($@) { + warn $@; + print " cp $from $to\n"; print " creating new version of $to\n" if $Is_VMS and -e $to; File::Copy::copy($from, $to) ? $success++ diff --git a/intrpvar.h b/intrpvar.h index c772d797ec..606a892374 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -25,7 +25,7 @@ PERLVAR(Iwarnhook, SV *) /* switches */ PERLVAR(Iminus_c, bool) -PERLVARA(Ipatchlevel,10,char) +PERLVAR(Ipatchlevel, SV *) PERLVAR(Ilocalpatches, char **) PERLVARI(Isplitstr, char *, " ") PERLVAR(Ipreprocess, bool) @@ -56,6 +56,7 @@ PERLVARI(Imaxsysfd, I32, MAXSYSFD) /* top fd to pass to subprocesses */ PERLVAR(Imultiline, int) /* $*--do strings hold >1 line? */ PERLVAR(Istatusvalue, I32) /* $? */ +PERLVAR(Iexit_flags, U8) /* was exit() unexpected, etc. */ #ifdef VMS PERLVAR(Istatusvalue_vms,U32) #endif @@ -169,7 +170,6 @@ PERLVAR(Isys_intern, struct interp_intern) /* more statics moved here */ PERLVARI(Igeneration, int, 100) /* from op.c */ PERLVAR(IDBcv, CV *) /* from perl.c */ -PERLVAR(Iarchpat_auto, char*) /* from perl.c */ PERLVARI(Iin_clean_objs,bool, FALSE) /* from sv.c */ PERLVARI(Iin_clean_all, bool, FALSE) /* from sv.c */ @@ -233,10 +233,9 @@ PERLVAR(Icshlen, I32) PERLVAR(Ilex_state, U32) /* next token is determined */ PERLVAR(Ilex_defer, U32) /* state after determined token */ -PERLVAR(Ilex_expect, expectation) /* expect after determined token */ +PERLVAR(Ilex_expect, int) /* expect after determined token */ PERLVAR(Ilex_brackets, I32) /* bracket count */ PERLVAR(Ilex_formbrack, I32) /* bracket count at outer format level */ -PERLVAR(Ilex_fakebrack, I32) /* outer bracket is mere delimiter */ PERLVAR(Ilex_casemods, I32) /* casemod count */ PERLVAR(Ilex_dojoin, I32) /* doing an array interpolation */ PERLVAR(Ilex_starts, I32) /* how many interps done on level */ @@ -258,7 +257,7 @@ PERLVAR(Ibufptr, char *) PERLVAR(Ioldbufptr, char *) PERLVAR(Ioldoldbufptr, char *) PERLVAR(Ibufend, char *) -PERLVARI(Iexpect,expectation, XSTATE) /* how to interpret ambiguous tokens */ +PERLVARI(Iexpect,int, XSTATE) /* how to interpret ambiguous tokens */ PERLVAR(Imulti_start, I32) /* 1st line of multi-line string */ PERLVAR(Imulti_end, I32) /* last line of multi-line string */ @@ -369,8 +368,13 @@ PERLVAR(Icred_mutex, perl_mutex) /* altered credentials in effect */ #endif /* USE_THREADS */ +PERLVAR(Ipsig_ptr, SV**) +PERLVAR(Ipsig_name, SV**) + #if defined(PERL_IMPLICIT_SYS) PERLVAR(IMem, struct IPerlMem*) +PERLVAR(IMemShared, struct IPerlMem*) +PERLVAR(IMemParse, struct IPerlMem*) PERLVAR(IEnv, struct IPerlEnv*) PERLVAR(IStdIO, struct IPerlStdIO*) PERLVAR(ILIO, struct IPerlLIO*) diff --git a/iperlsys.h b/iperlsys.h index 9404d184c8..7b20d5dd5b 100644 --- a/iperlsys.h +++ b/iperlsys.h @@ -86,6 +86,7 @@ typedef struct _PerlIO PerlIO; /* IPerlStdIO */ struct IPerlStdIO; +struct IPerlStdIOInfo; typedef PerlIO* (*LPStdin)(struct IPerlStdIO*); typedef PerlIO* (*LPStdout)(struct IPerlStdIO*); typedef PerlIO* (*LPStderr)(struct IPerlStdIO*); @@ -132,6 +133,7 @@ typedef int (*LPSetpos)(struct IPerlStdIO*, PerlIO*, const Fpos_t*); typedef void (*LPInit)(struct IPerlStdIO*); typedef void (*LPInitOSExtras)(struct IPerlStdIO*); +typedef PerlIO* (*LPFdupopen)(struct IPerlStdIO*, PerlIO*); struct IPerlStdIO { @@ -173,6 +175,7 @@ struct IPerlStdIO LPSetpos pSetpos; LPInit pInit; LPInitOSExtras pInitOSExtras; + LPFdupopen pFdupopen; }; struct IPerlStdIOInfo @@ -283,11 +286,14 @@ struct IPerlStdIOInfo #undef init_os_extras #define init_os_extras() \ (*PL_StdIO->pInitOSExtras)(PL_StdIO) +#define PerlIO_fdupopen(f) \ + (*PL_StdIO->pFdupopen)(PL_StdIO, (f)) #else /* PERL_IMPLICIT_SYS */ #include "perlsdio.h" #include "perl.h" +#define PerlIO_fdupopen(f) (f) #endif /* PERL_IMPLICIT_SYS */ @@ -338,7 +344,7 @@ struct _PerlIO; #ifndef PerlIO_stdoutf extern int PerlIO_stdoutf (const char *,...) - __attribute__((format (printf, 1, 2))); + __attribute__((__format__ (__printf__, 1, 2))); #endif #ifndef PerlIO_puts extern int PerlIO_puts (PerlIO *,const char *); @@ -399,11 +405,11 @@ extern void PerlIO_setlinebuf (PerlIO *); #endif #ifndef PerlIO_printf extern int PerlIO_printf (PerlIO *, const char *,...) - __attribute__((format (printf, 2, 3))); + __attribute__((__format__ (__printf__, 2, 3))); #endif #ifndef PerlIO_sprintf extern int PerlIO_sprintf (char *, int, const char *,...) - __attribute__((format (printf, 3, 4))); + __attribute__((__format__ (__printf__, 3, 4))); #endif #ifndef PerlIO_vprintf extern int PerlIO_vprintf (PerlIO *, const char *, va_list); @@ -465,6 +471,9 @@ extern int PerlIO_getpos (PerlIO *,Fpos_t *); #ifndef PerlIO_setpos extern int PerlIO_setpos (PerlIO *,const Fpos_t *); #endif +#ifndef PerlIO_fdupopen +extern PerlIO * PerlIO_fdupopen (PerlIO *); +#endif /* @@ -475,6 +484,7 @@ extern int PerlIO_setpos (PerlIO *,const Fpos_t *); /* IPerlDir */ struct IPerlDir; +struct IPerlDirInfo; typedef int (*LPMakedir)(struct IPerlDir*, const char*, int); typedef int (*LPChdir)(struct IPerlDir*, const char*); typedef int (*LPRmdir)(struct IPerlDir*, const char*); @@ -484,6 +494,10 @@ typedef struct direct* (*LPDirRead)(struct IPerlDir*, DIR*); typedef void (*LPDirRewind)(struct IPerlDir*, DIR*); typedef void (*LPDirSeek)(struct IPerlDir*, DIR*, long); typedef long (*LPDirTell)(struct IPerlDir*, DIR*); +#ifdef WIN32 +typedef char* (*LPDirMapPathA)(struct IPerlDir*, const char*); +typedef WCHAR* (*LPDirMapPathW)(struct IPerlDir*, const WCHAR*); +#endif struct IPerlDir { @@ -496,6 +510,10 @@ struct IPerlDir LPDirRewind pRewind; LPDirSeek pSeek; LPDirTell pTell; +#ifdef WIN32 + LPDirMapPathA pMapPathA; + LPDirMapPathW pMapPathW; +#endif }; struct IPerlDirInfo @@ -522,6 +540,12 @@ struct IPerlDirInfo (*PL_Dir->pSeek)(PL_Dir, (dir), (loc)) #define PerlDir_tell(dir) \ (*PL_Dir->pTell)(PL_Dir, (dir)) +#ifdef WIN32 +#define PerlDir_mapA(dir) \ + (*PL_Dir->pMapPathA)(PL_Dir, (dir)) +#define PerlDir_mapW(dir) \ + (*PL_Dir->pMapPathW)(PL_Dir, (dir)) +#endif #else /* PERL_IMPLICIT_SYS */ @@ -538,6 +562,10 @@ struct IPerlDirInfo #define PerlDir_rewind(dir) rewinddir((dir)) #define PerlDir_seek(dir, loc) seekdir((dir), (loc)) #define PerlDir_tell(dir) telldir((dir)) +#ifdef WIN32 +#define PerlDir_mapA(dir) dir +#define PerlDir_mapW(dir) dir +#endif #endif /* PERL_IMPLICIT_SYS */ @@ -549,6 +577,7 @@ struct IPerlDirInfo /* IPerlEnv */ struct IPerlEnv; +struct IPerlEnvInfo; typedef char* (*LPEnvGetenv)(struct IPerlEnv*, const char*); typedef int (*LPEnvPutenv)(struct IPerlEnv*, const char*); typedef char* (*LPEnvGetenv_len)(struct IPerlEnv*, @@ -641,7 +670,7 @@ struct IPerlEnvInfo #define PerlEnv_putenv(str) putenv((str)) #define PerlEnv_getenv(str) getenv((str)) #define PerlEnv_getenv_len(str,l) getenv_len((str), (l)) -#define PerlEnv_clear() clearenv() +#define PerlEnv_clearenv() clearenv() #define PerlEnv_get_childenv() get_childenv() #define PerlEnv_free_childenv(e) free_childenv((e)) #define PerlEnv_get_childdir() get_childdir() @@ -669,6 +698,7 @@ struct IPerlEnvInfo /* IPerlLIO */ struct IPerlLIO; +struct IPerlLIOInfo; typedef int (*LPLIOAccess)(struct IPerlLIO*, const char*, int); typedef int (*LPLIOChmod)(struct IPerlLIO*, const char*, int); typedef int (*LPLIOChown)(struct IPerlLIO*, const char*, uid_t, @@ -836,15 +866,24 @@ struct IPerlLIOInfo /* IPerlMem */ struct IPerlMem; +struct IPerlMemInfo; typedef void* (*LPMemMalloc)(struct IPerlMem*, size_t); typedef void* (*LPMemRealloc)(struct IPerlMem*, void*, size_t); typedef void (*LPMemFree)(struct IPerlMem*, void*); +typedef void* (*LPMemCalloc)(struct IPerlMem*, size_t, size_t); +typedef void (*LPMemGetLock)(struct IPerlMem*); +typedef void (*LPMemFreeLock)(struct IPerlMem*); +typedef int (*LPMemIsLocked)(struct IPerlMem*); struct IPerlMem { LPMemMalloc pMalloc; LPMemRealloc pRealloc; LPMemFree pFree; + LPMemCalloc pCalloc; + LPMemGetLock pGetLock; + LPMemFreeLock pFreeLock; + LPMemIsLocked pIsLocked; }; struct IPerlMemInfo @@ -853,18 +892,84 @@ struct IPerlMemInfo struct IPerlMem perlMemList; }; +/* Interpreter specific memory macros */ #define PerlMem_malloc(size) \ (*PL_Mem->pMalloc)(PL_Mem, (size)) #define PerlMem_realloc(buf, size) \ (*PL_Mem->pRealloc)(PL_Mem, (buf), (size)) #define PerlMem_free(buf) \ (*PL_Mem->pFree)(PL_Mem, (buf)) +#define PerlMem_calloc(num, size) \ + (*PL_Mem->pCalloc)(PL_Mem, (num), (size)) +#define PerlMem_get_lock() \ + (*PL_Mem->pGetLock)(PL_Mem) +#define PerlMem_free_lock() \ + (*PL_Mem->pFreeLock)(PL_Mem) +#define PerlMem_is_locked() \ + (*PL_Mem->pIsLocked)(PL_Mem) + +/* Shared memory macros */ +#define PerlMemShared_malloc(size) \ + (*PL_MemShared->pMalloc)(PL_Mem, (size)) +#define PerlMemShared_realloc(buf, size) \ + (*PL_MemShared->pRealloc)(PL_Mem, (buf), (size)) +#define PerlMemShared_free(buf) \ + (*PL_MemShared->pFree)(PL_Mem, (buf)) +#define PerlMemShared_calloc(num, size) \ + (*PL_MemShared->pCalloc)(PL_Mem, (num), (size)) +#define PerlMemShared_get_lock() \ + (*PL_MemShared->pGetLock)(PL_Mem) +#define PerlMemShared_free_lock() \ + (*PL_MemShared->pFreeLock)(PL_Mem) +#define PerlMemShared_is_locked() \ + (*PL_MemShared->pIsLocked)(PL_Mem) + + +/* Parse tree memory macros */ +#define PerlMemParse_malloc(size) \ + (*PL_MemParse->pMalloc)(PL_Mem, (size)) +#define PerlMemParse_realloc(buf, size) \ + (*PL_MemParse->pRealloc)(PL_Mem, (buf), (size)) +#define PerlMemParse_free(buf) \ + (*PL_MemParse->pFree)(PL_Mem, (buf)) +#define PerlMemParse_calloc(num, size) \ + (*PL_MemParse->pCalloc)(PL_Mem, (num), (size)) +#define PerlMemParse_get_lock() \ + (*PL_MemParse->pGetLock)(PL_Mem) +#define PerlMemParse_free_lock() \ + (*PL_MemParse->pFreeLock)(PL_Mem) +#define PerlMemParse_is_locked() \ + (*PL_MemParse->pIsLocked)(PL_Mem) + #else /* PERL_IMPLICIT_SYS */ +/* Interpreter specific memory macros */ #define PerlMem_malloc(size) malloc((size)) #define PerlMem_realloc(buf, size) realloc((buf), (size)) #define PerlMem_free(buf) free((buf)) +#define PerlMem_calloc(num, size) calloc((num), (size)) +#define PerlMem_get_lock() +#define PerlMem_free_lock() +#define PerlMem_is_locked() 0 + +/* Shared memory macros */ +#define PerlMemShared_malloc(size) malloc((size)) +#define PerlMemShared_realloc(buf, size) realloc((buf), (size)) +#define PerlMemShared_free(buf) free((buf)) +#define PerlMemShared_calloc(num, size) calloc((num), (size)) +#define PerlMemShared_get_lock() +#define PerlMemShared_free_lock() +#define PerlMemShared_is_locked() 0 + +/* Parse tree memory macros */ +#define PerlMemParse_malloc(size) malloc((size)) +#define PerlMemParse_realloc(buf, size) realloc((buf), (size)) +#define PerlMemParse_free(buf) free((buf)) +#define PerlMemParse_calloc(num, size) calloc((num), (size)) +#define PerlMemParse_get_lock() +#define PerlMemParse_free_lock() +#define PerlMemParse_is_locked() 0 #endif /* PERL_IMPLICIT_SYS */ @@ -881,6 +986,7 @@ struct IPerlMemInfo /* IPerlProc */ struct IPerlProc; +struct IPerlProcInfo; typedef void (*LPProcAbort)(struct IPerlProc*); typedef char* (*LPProcCrypt)(struct IPerlProc*, const char*, const char*); @@ -912,8 +1018,10 @@ typedef int (*LPProcTimes)(struct IPerlProc*, struct tms*); typedef int (*LPProcWait)(struct IPerlProc*, int*); typedef int (*LPProcWaitpid)(struct IPerlProc*, int, int*, int); typedef Sighandler_t (*LPProcSignal)(struct IPerlProc*, int, Sighandler_t); -typedef void* (*LPProcDynaLoader)(struct IPerlProc*, const char*); +typedef int (*LPProcFork)(struct IPerlProc*); +typedef int (*LPProcGetpid)(struct IPerlProc*); #ifdef WIN32 +typedef void* (*LPProcDynaLoader)(struct IPerlProc*, const char*); typedef void (*LPProcGetOSError)(struct IPerlProc*, SV* sv, DWORD dwErr); typedef void (*LPProcFreeBuf)(struct IPerlProc*, char*); @@ -951,6 +1059,8 @@ struct IPerlProc LPProcWait pWait; LPProcWaitpid pWaitpid; LPProcSignal pSignal; + LPProcFork pFork; + LPProcGetpid pGetpid; #ifdef WIN32 LPProcDynaLoader pDynaLoader; LPProcGetOSError pGetOSError; @@ -1017,6 +1127,10 @@ struct IPerlProcInfo (*PL_Proc->pWaitpid)(PL_Proc, (p), (s), (f)) #define PerlProc_signal(n, h) \ (*PL_Proc->pSignal)(PL_Proc, (n), (h)) +#define PerlProc_fork() \ + (*PL_Proc->pFork)(PL_Proc) +#define PerlProc_getpid() \ + (*PL_Proc->pGetpid)(PL_Proc) #define PerlProc_setjmp(b, n) Sigsetjmp((b), (n)) #define PerlProc_longjmp(b, n) Siglongjmp((b), (n)) @@ -1065,6 +1179,8 @@ struct IPerlProcInfo #define PerlProc_setjmp(b, n) Sigsetjmp((b), (n)) #define PerlProc_longjmp(b, n) Siglongjmp((b), (n)) #define PerlProc_signal(n, h) signal((n), (h)) +#define PerlProc_fork() fork() +#define PerlProc_getpid() getpid() #ifdef WIN32 #define PerlProc_DynaLoad(f) \ @@ -1082,6 +1198,7 @@ struct IPerlProcInfo /* PerlSock */ struct IPerlSock; +struct IPerlSockInfo; typedef u_long (*LPHtonl)(struct IPerlSock*, u_long); typedef u_short (*LPHtons)(struct IPerlSock*, u_short); typedef u_long (*LPNtohl)(struct IPerlSock*, u_long); diff --git a/lib/AutoLoader.pm b/lib/AutoLoader.pm index 8e15c1f60c..4bbcb33e10 100644 --- a/lib/AutoLoader.pm +++ b/lib/AutoLoader.pm @@ -11,7 +11,7 @@ BEGIN { @EXPORT_OK = @EXPORT_OK = qw(AUTOLOAD); $is_dosish = $^O eq 'dos' || $^O eq 'os2' || $^O eq 'MSWin32'; $is_vms = $^O eq 'VMS'; - $VERSION = $VERSION = '5.57'; + $VERSION = '5.57'; } AUTOLOAD { diff --git a/lib/Benchmark.pm b/lib/Benchmark.pm index 83331aab39..487ddd5717 100644 --- a/lib/Benchmark.pm +++ b/lib/Benchmark.pm @@ -2,17 +2,7 @@ package Benchmark; =head1 NAME -Benchmark - benchmark running times of code - -timethis - run a chunk of code several times - -timethese - run several chunks of code several times - -cmpthese - print results of timethese as a comparison chart - -timeit - run a chunk of code and see how long it goes - -countit - see how many times a chunk of code runs in a given time +Benchmark - benchmark running times of Perl code =head1 SYNOPSIS @@ -63,6 +53,17 @@ countit - see how many times a chunk of code runs in a given time The Benchmark module encapsulates a number of routines to help you figure out how long it takes to execute some code. +timethis - run a chunk of code several times + +timethese - run several chunks of code several times + +cmpthese - print results of timethese as a comparison chart + +timeit - run a chunk of code and see how long it goes + +countit - see how many times a chunk of code runs in a given time + + =head2 Methods =over 10 @@ -322,6 +323,10 @@ The system time of the null loop might be slightly more than the system time of the loop with the actual code and therefore the difference might end up being E<lt> 0. +=head1 SEE ALSO + +L<Devel::DProf> - a Perl code profiler + =head1 AUTHORS Jarkko Hietaniemi <F<jhi@iki.fi>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>> @@ -357,6 +362,8 @@ use Exporter; @EXPORT_OK=qw(timesum cmpthese countit clearcache clearallcache disablecache enablecache); +$VERSION = 1.00; + &init; sub init { diff --git a/lib/CPAN.pm b/lib/CPAN.pm index 432e72da05..2f22b773c7 100644 --- a/lib/CPAN.pm +++ b/lib/CPAN.pm @@ -3325,7 +3325,8 @@ sub perl { $perl ||= $candidate if MM->maybe_command($candidate); unless ($perl) { my ($component,$perl_name); - DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") { + DIST_PERLNAME: + foreach $perl_name ($^X, 'perl', 'perl5', "perl$Config::Config{version}") { PATH_COMPONENT: foreach $component (MM->path(), $Config::Config{'binexp'}) { next unless defined($component) && $component; diff --git a/lib/Cwd.pm b/lib/Cwd.pm index 8a99da975a..ee1bc28367 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -372,7 +372,7 @@ sub _qnx_abs_path { *abs_path = \&_qnx_abs_path; *fast_abs_path = \&_qnx_abs_path; } - elsif ($^O =~ /cygwin/) { + elsif ($^O eq 'cygwin') { *getcwd = \&cwd; *fastgetcwd = \&cwd; *fastcwd = \&cwd; @@ -794,7 +794,7 @@ highly experimental and subject to change. =head1 AUTHOR -Gurusamy Sarathy gsar@umich.edu +Gurusamy Sarathy gsar@activestate.com This code heavily adapted from an early version of perl5db.pl attributable to Larry Wall and the Perl Porters. diff --git a/lib/ExtUtils/Embed.pm b/lib/ExtUtils/Embed.pm index e0ea0685f0..b649b6b77b 100644 --- a/lib/ExtUtils/Embed.pm +++ b/lib/ExtUtils/Embed.pm @@ -332,7 +332,7 @@ B<[@modules]> is an array ref, same as additional arguments mentioned above. This will generate code with an B<xs_init> function that glues the perl B<Socket::bootstrap> function -to the C B<boot_Socket> function and writes it to a file named "xsinit.c". +to the C B<boot_Socket> function and writes it to a file named F<xsinit.c>. Note that B<DynaLoader> is a special case where it must call B<boot_DynaLoader> directly. @@ -378,7 +378,7 @@ we should find B<auto/Socket/Socket.a> When looking for B<DBD::Oracle> relative to a search path, we should find B<auto/DBD/Oracle/Oracle.a> -Keep in mind, you can always supply B</my/own/path/ModuleName.a> +Keep in mind that you can always supply B</my/own/path/ModuleName.a> as an additional linker argument. B<--> E<lt>list of linker argsE<gt> @@ -392,7 +392,7 @@ When invoked with parameters the following are accepted and optional: C<ldopts($std,[@modules],[@link_args],$path)> -Where, +Where: B<$std> is boolean, equivalent to the B<-std> option. diff --git a/lib/ExtUtils/Install.pm b/lib/ExtUtils/Install.pm index 47bde0deb0..d6b1375fb6 100644 --- a/lib/ExtUtils/Install.pm +++ b/lib/ExtUtils/Install.pm @@ -67,7 +67,6 @@ sub install { } $packlist->read($pack{"read"}) if (-f $pack{"read"}); my $cwd = cwd(); - my $umask = umask 0 unless $Is_VMS; my($source); MOD_INSTALL: foreach $source (sort keys %hash) { @@ -140,7 +139,6 @@ sub install { print "Writing $pack{'write'}\n"; $packlist->write($pack{'write'}); } - umask $umask unless $Is_VMS; } sub directory_not_empty ($) { @@ -193,7 +191,6 @@ sub uninstall { forceunlink($_) unless $nonono; } print "unlink $fil\n" if $verbose; - close P; forceunlink($fil) unless $nonono; } @@ -259,7 +256,6 @@ sub pm_to_blib { close(FROMTO); } - my $umask = umask 0022 unless $Is_VMS; mkpath($autodir,0,0755); foreach (keys %$fromto) { next if -f $fromto->{$_} && -M $fromto->{$_} < -M $_; @@ -280,7 +276,6 @@ sub pm_to_blib { next unless /\.pm$/; autosplit($fromto->{$_},$autodir); } - umask $umask unless $Is_VMS; } package ExtUtils::Install::Warn; @@ -343,7 +338,7 @@ There are two keys with a special meaning in the hash: "read" and target files to the file named by C<$hashref-E<gt>{write}>. If there is another file named by C<$hashref-E<gt>{read}>, the contents of this file will be merged into the written file. The read and the written file may be -identical, but on AFS it is quite likely, people are installing to a +identical, but on AFS it is quite likely that people are installing to a different directory than the one where the files later appear. install_default() takes one or less arguments. If no arguments are @@ -356,7 +351,7 @@ The argument-less form is convenient for install scripts like perl -MExtUtils::Install -e install_default Tk/Canvas -Assuming this command is executed in a directory with populated F<blib> +Assuming this command is executed in a directory with a populated F<blib> directory, it will proceed as if the F<blib> was build by MakeMaker on this machine. This is useful for binary distributions. diff --git a/lib/ExtUtils/Installed.pm b/lib/ExtUtils/Installed.pm index dda594e784..41f3c9b3b8 100644 --- a/lib/ExtUtils/Installed.pm +++ b/lib/ExtUtils/Installed.pm @@ -56,7 +56,7 @@ my $self = {}; # Read the core packlist $self->{Perl}{packlist} = ExtUtils::Packlist->new("$Config{installarchlib}/.packlist"); -$self->{Perl}{version} = $]; +$self->{Perl}{version} = $Config{version}; # Read the module packlists my $sub = sub diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index 13e4e29e88..b992ec0116 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/lib/ExtUtils/Liblist.pm @@ -540,7 +540,7 @@ below. =head2 EXTRALIBS List of libraries that need to be linked with when linking a perl -binary which includes this extension Only those libraries that +binary which includes this extension. Only those libraries that actually exist are included. These are written to a file and used when linking perl. @@ -562,7 +562,7 @@ object file. This list is used to create a .bs (bootstrap) file. =head1 PORTABILITY This module deals with a lot of system dependencies and has quite a -few architecture specific B<if>s in the code. +few architecture specific C<if>s in the code. =head2 VMS implementation @@ -682,7 +682,7 @@ enable searching for default libraries specified by C<$Config{libs}>. The libraries specified may be a mixture of static libraries and import libraries (to link with DLLs). Since both kinds are used -pretty transparently on the win32 platform, we do not attempt to +pretty transparently on the Win32 platform, we do not attempt to distinguish between them. =item * diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index f9fdcaaf58..f4329e13d7 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -377,10 +377,22 @@ sub cflags { if ($Is_PERL_OBJECT) { $self->{CCFLAGS} =~ s/-DPERL_OBJECT(\b|$)/-DPERL_CAPI/g; - if ($Is_Win32 && $Config{'cc'} =~ /^cl/i) { - # Turn off C++ mode of the MSC compiler - $self->{CCFLAGS} =~ s/-TP(\s|$)//; - $self->{OPTIMIZE} =~ s/-TP(\s|$)//; + if ($Is_Win32) { + if ($Config{'cc'} =~ /^cl/i) { + # Turn off C++ mode of the MSC compiler + $self->{CCFLAGS} =~ s/-TP(\s|$)//g; + $self->{OPTIMIZE} =~ s/-TP(\s|$)//g; + } + elsif ($Config{'cc'} =~ /^bcc32/i) { + # Turn off C++ mode of the Borland compiler + $self->{CCFLAGS} =~ s/-P(\s|$)//g; + $self->{OPTIMIZE} =~ s/-P(\s|$)//g; + } + elsif ($Config{'cc'} =~ /^gcc/i) { + # Turn off C++ mode of the GCC compiler + $self->{CCFLAGS} =~ s/-xc\+\+(\s|$)//g; + $self->{OPTIMIZE} =~ s/-xc\+\+(\s|$)//g; + } } } @@ -1992,7 +2004,8 @@ usually solves this kind of problem. push @defpath, $component if defined $component; } $self->{PERL} ||= - $self->find_perl(5.0, [ $self->canonpath($^X), 'miniperl','perl','perl5',"perl$]" ], + $self->find_perl(5.0, [ $self->canonpath($^X), 'miniperl', + 'perl','perl5',"perl$Config{version}" ], \@defpath, $Verbose ); # don't check if perl is executable, maybe they have decided to # supply switches with perl @@ -3233,11 +3246,14 @@ sub subdir_x { my($self, $subdir) = @_; my(@m); if ($Is_Win32 && Win32::IsWin95()) { + # XXX: dmake-specific, like rest of Win95 port return <<EOT; subdirs :: +@[ cd $subdir \$(MAKE) all \$(PASTHRU) cd .. +] EOT } else { @@ -3596,12 +3612,6 @@ config :: $(INST_AUTODIR)/.exists '.$self->{NOECHO}.'$(NOOP) '; - push @m, qq{ -config :: Version_check - $self->{NOECHO}\$(NOOP) - -} unless $self->{PARENT} or ($self->{PERL_SRC} && $self->{INSTALLDIRS} eq "perl") or $self->{NO_VC}; - push @m, $self->dir_target(qw[$(INST_AUTODIR) $(INST_LIBDIR) $(INST_ARCHAUTODIR)]); if (%{$self->{HTMLLIBPODS}}) { diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index 31ca69067e..f3de323e53 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -1106,13 +1106,6 @@ config :: $(INST_AUTODIR).exists $(NOECHO) $(NOOP) '; - push @m, q{ -config :: Version_check - $(NOECHO) $(NOOP) - -} unless $self->{PARENT} or ($self->{PERL_SRC} && $self->{INSTALLDIRS} eq "perl") or $self->{NO_VC}; - - push @m, $self->dir_target(qw[$(INST_AUTODIR) $(INST_LIBDIR) $(INST_ARCHAUTODIR)]); if (%{$self->{MAN1PODS}}) { push @m, q[ diff --git a/lib/ExtUtils/MM_Win32.pm b/lib/ExtUtils/MM_Win32.pm index e1cb83ba80..534f26d823 100644 --- a/lib/ExtUtils/MM_Win32.pm +++ b/lib/ExtUtils/MM_Win32.pm @@ -37,9 +37,14 @@ $PERLMAKE = 1 if $Config{'make'} =~ /^pmake/i; $OBJ = 1 if $Config{'ccflags'} =~ /PERL_OBJECT/i; # a few workarounds for command.com (very basic) -if (Win32::IsWin95()) { +{ package ExtUtils::MM_Win95; - unshift @MM::ISA, 'ExtUtils::MM_Win95'; + + # the $^O test may be overkill, but we want to be sure Win32::IsWin95() + # exists before we try it + + unshift @MM::ISA, 'ExtUtils::MM_Win95' + if ($^O =~ /Win32/ && Win32::IsWin95()); sub xs_c { my($self) = shift; @@ -65,8 +70,6 @@ if (Win32::IsWin95()) { sub xs_o { my($self) = shift; return '' unless $self->needs_linking(); - # Dmake gets confused with 2 ways of making things - return '' if $ExtUtils::MM_Win32::DMAKE; ' .xs$(OBJ_EXT): $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) \\ @@ -74,7 +77,7 @@ if (Win32::IsWin95()) { $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c '; } -} +} # end of command.com workarounds sub dlsyms { my($self,%attribs) = @_; @@ -481,6 +484,18 @@ sub dynamic_lib { my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || ""; my($ldfrom) = '$(LDFROM)'; my(@m); + +# one thing for GCC/Mingw32: +# we try to overcome non-relocateable-DLL problems by generating +# a (hopefully unique) image-base from the dll's name +# -- BKS, 10-19-1999 + if ($GCC) { + my $dllname = $self->{BASEEXT} . "." . $self->{DLEXT}; + $dllname =~ /(....)(.{0,4})/; + my $baseaddr = unpack("n", $1 ^ $2); + $otherldflags .= sprintf("-Wl,--image-base,0x%x0000 ", $baseaddr); + } + push(@m,' # This section creates the dynamically loadable $(INST_DYNAMIC) # from $(OBJECT) and possibly $(MYEXTLIB). @@ -734,12 +749,6 @@ config :: $(INST_AUTODIR)\.exists '.$self->{NOECHO}.'$(NOOP) '; - push @m, qq{ -config :: Version_check - $self->{NOECHO}\$(NOOP) - -} unless $self->{PARENT} or ($self->{PERL_SRC} && $self->{INSTALLDIRS} eq "perl") or $self->{NO_VC}; - push @m, $self->dir_target(qw[$(INST_AUTODIR) $(INST_LIBDIR) $(INST_ARCHAUTODIR)]); if (%{$self->{HTMLLIBPODS}}) { diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index 0f00e39afc..0426575f87 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -2,7 +2,7 @@ BEGIN {require 5.002;} # MakeMaker 5.17 was the last MakeMaker that was compatib package ExtUtils::MakeMaker; -$VERSION = "5.4302"; +$VERSION = "5.44"; $Version_OK = "5.17"; # Makefiles older than $Version_OK will die # (Will be checked from MakeMaker version 4.13 onwards) ($Revision = substr(q$Revision: 1.222 $, 10)) =~ s/\s+$//; @@ -17,7 +17,7 @@ use Carp (); use vars qw( @ISA @EXPORT @EXPORT_OK $AUTOLOAD - $ISA_TTY $Is_Mac $Is_OS2 $Is_VMS $Revision $Setup_done + $ISA_TTY $Is_Mac $Is_OS2 $Is_VMS $Revision $VERSION $Verbose $Version_OK %Config %Keep_after_flush %MM_Sections %Prepend_dot_dot %Recognized_Att_Keys @Get_from_Config @MM_Sections @Overridable @Parent @@ -70,7 +70,7 @@ $Is_VMS = $^O eq 'VMS'; $Is_OS2 = $^O eq 'os2'; $Is_Mac = $^O eq 'MacOS'; $Is_Win32 = $^O eq 'MSWin32'; -$Is_Cygwin= $^O =~ /cygwin/i; +$Is_Cygwin= $^O eq 'cygwin'; require ExtUtils::MM_Unix; @@ -91,35 +91,11 @@ if ($Is_Cygwin) { require ExtUtils::MM_Cygwin; } -# The SelfLoader would bring a lot of overhead for MakeMaker, because -# we know for sure we will use most of the autoloaded functions once -# we have to use one of them. So we write our own loader - -sub AUTOLOAD { - my $code; - if (defined fileno(DATA)) { - my $fh = select DATA; - my $o = $/; # For future reads from the file. - $/ = "\n__END__\n"; - $code = <DATA>; - $/ = $o; - select $fh; - close DATA; - eval $code; - if ($@) { - $@ =~ s/ at .*\n//; - Carp::croak $@; - } - } else { - warn "AUTOLOAD called unexpectedly for $AUTOLOAD"; - } - defined(&$AUTOLOAD) or die "Myloader inconsistency error"; - goto &$AUTOLOAD; -} +full_setup(); -# The only subroutine we do not SelfLoad is Version_Check because it's -# called so often. Loading this minimum still requires 1.2 secs on my -# Indy :-( +# The use of the Version_check target has been dropped between perl +# 5.5.63 and 5.5.64. We must keep the subroutine for a while so that +# old Makefiles can satisfy the Version_check target. sub Version_check { my($checkversion) = @_; @@ -140,38 +116,10 @@ sub warnhandler { warn @_; } -sub ExtUtils::MakeMaker::eval_in_subdirs ; -sub ExtUtils::MakeMaker::eval_in_x ; -sub ExtUtils::MakeMaker::full_setup ; -sub ExtUtils::MakeMaker::writeMakefile ; -sub ExtUtils::MakeMaker::new ; -sub ExtUtils::MakeMaker::check_manifest ; -sub ExtUtils::MakeMaker::parse_args ; -sub ExtUtils::MakeMaker::check_hints ; -sub ExtUtils::MakeMaker::mv_all_methods ; -sub ExtUtils::MakeMaker::skipcheck ; -sub ExtUtils::MakeMaker::flush ; -sub ExtUtils::MakeMaker::mkbootstrap ; -sub ExtUtils::MakeMaker::mksymlists ; -sub ExtUtils::MakeMaker::neatvalue ; -sub ExtUtils::MakeMaker::selfdocument ; -sub ExtUtils::MakeMaker::WriteMakefile ; -sub ExtUtils::MakeMaker::prompt ($;$) ; - -1; - -__DATA__ - -package ExtUtils::MakeMaker; - sub WriteMakefile { Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; local $SIG{__WARN__} = \&warnhandler; - unless ($Setup_done++){ - full_setup(); - undef &ExtUtils::MakeMaker::full_setup; #safe memory - } my %att = @_; MM->new(\%att)->flush; } @@ -382,9 +330,13 @@ sub ExtUtils::MakeMaker::new { my($prereq); foreach $prereq (sort keys %{$self->{PREREQ_PM}}) { - my $eval = "use $prereq $self->{PREREQ_PM}->{$prereq}"; + my $eval = "require $prereq"; eval $eval; - if ($@){ + + if ($@) { + warn "Warning: prerequisite $prereq failed to load: $@"; + } + elsif ($prereq->VERSION < $self->{PREREQ_PM}->{$prereq} ){ warn "Warning: prerequisite $prereq $self->{PREREQ_PM}->{$prereq} not found"; # Why is/was this 'delete' here? We need PREREQ_PM later to make PPDs. # } else { @@ -1183,7 +1135,7 @@ MakeMaker gives you much more freedom than needed to configure internal variables and get different results. It is worth to mention, that make(1) also lets you configure most of the variables that are used in the Makefile. But in the majority of situations this will not -be necessary, and should only be done, if the author of a package +be necessary, and should only be done if the author of a package recommends it (or you know what you're doing). =head2 Using Attributes and Parameters @@ -1598,9 +1550,9 @@ Makefile.PL. =item NEEDS_LINKING -MakeMaker will figure out, if an extension contains linkable code +MakeMaker will figure out if an extension contains linkable code anywhere down the directory tree, and will set this variable -accordingly, but you can speed it up a very little bit, if you define +accordingly, but you can speed it up a very little bit if you define this boolean variable yourself. =item NOECHO @@ -1615,7 +1567,7 @@ Boolean. Attribute to inhibit descending into subdirectories. =item NO_VC -In general any generated Makefile checks for the current version of +In general, any generated Makefile checks for the current version of MakeMaker and the version the Makefile was built under. If NO_VC is set, the version check is neglected. Do not write this into your Makefile.PL, use it interactively instead. @@ -1642,7 +1594,7 @@ to $(CC). =item PERL_ARCHLIB -Same as above for architecture dependent files +Same as above for architecture dependent files. =item PERL_LIB @@ -1699,14 +1651,14 @@ Defining PM in the Makefile.PL will override PMLIBDIRS. =item POLLUTE Release 5.005 grandfathered old global symbol names by providing preprocessor -macros for extension source compatibility. As of release 5.006, these +macros for extension source compatibility. As of release 5.6, these preprocessor definitions are not available by default. The POLLUTE flag specifies that the old names should still be defined: perl Makefile.PL POLLUTE=1 Please inform the module author if this is necessary to successfully install -a module under 5.006 or later. +a module under 5.6 or later. =item PPM_INSTALL_EXEC @@ -1736,8 +1688,8 @@ only check if any version is installed already. =item SKIP Arryref. E.g. [qw(name1 name2)] skip (do not write) sections of the -Makefile. Caution! Do not use the SKIP attribute for the neglectible -speedup. It may seriously damage the resulting Makefile. Only use it, +Makefile. Caution! Do not use the SKIP attribute for the negligible +speedup. It may seriously damage the resulting Makefile. Only use it if you really need it. =item TYPEMAPS @@ -1860,7 +1812,7 @@ NB: Extensions that have nothing but *.pm files had to say {LINKTYPE => ''} with Pre-5.0 MakeMakers. Since version 5.00 of MakeMaker such a line -can be deleted safely. MakeMaker recognizes, when there's nothing to +can be deleted safely. MakeMaker recognizes when there's nothing to be linked. =item macro @@ -1963,7 +1915,7 @@ details) =item make distclean does a realclean first and then the distcheck. Note that this is not -needed to build a new distribution as long as you are sure, that the +needed to build a new distribution as long as you are sure that the MANIFEST file is ok. =item make manifest diff --git a/lib/ExtUtils/Manifest.pm b/lib/ExtUtils/Manifest.pm index 52cfc2a80a..58c91bc44b 100644 --- a/lib/ExtUtils/Manifest.pm +++ b/lib/ExtUtils/Manifest.pm @@ -187,7 +187,6 @@ sub manicopy { require File::Basename; my(%dirs,$file); $target = VMS::Filespec::unixify($target) if $Is_VMS; - umask 0 unless $Is_VMS; File::Path::mkpath([ $target ],1,$Is_VMS ? undef : 0755); foreach $file (keys %$read){ $file = VMS::Filespec::unixify($file) if $Is_VMS; diff --git a/lib/ExtUtils/Mkbootstrap.pm b/lib/ExtUtils/Mkbootstrap.pm index 25c374c153..323c3ab6ba 100644 --- a/lib/ExtUtils/Mkbootstrap.pm +++ b/lib/ExtUtils/Mkbootstrap.pm @@ -81,8 +81,8 @@ C<mkbootstrap> Mkbootstrap typically gets called from an extension Makefile. -There is no C<*.bs> file supplied with the extension. Instead a -C<*_BS> file which has code for the special cases, like posix for +There is no C<*.bs> file supplied with the extension. Instead, there may +be a C<*_BS> file which has code for the special cases, like posix for berkeley db on the NeXT. This file will get parsed, and produce a maybe empty diff --git a/lib/ExtUtils/Mksymlists.pm b/lib/ExtUtils/Mksymlists.pm index cfc1e7dff8..9dcedbf35e 100644 --- a/lib/ExtUtils/Mksymlists.pm +++ b/lib/ExtUtils/Mksymlists.pm @@ -78,7 +78,7 @@ sub _write_os2 { } my $distname = $data->{DISTNAME} || $data->{NAME}; $distname = "Distribution $distname"; - my $comment = "Perl (v$]$threaded) module $data->{NAME}"; + my $comment = "Perl (v$Config::Config{version}$threaded) module $data->{NAME}"; if ($data->{INSTALLDIRS} and $data->{INSTALLDIRS} eq 'perl') { $distname = 'perl5-porters@perl.org'; $comment = "Core $comment"; diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index 6db993c521..ff9b452caf 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -6,10 +6,12 @@ xsubpp - compiler to convert Perl XS code into C code =head1 SYNOPSIS -B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-typemap typemap>] ... file.xs +B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-nooptimize>] [B<-typemap typemap>] ... file.xs =head1 DESCRIPTION +This compiler is typically run by the makefiles created by L<ExtUtils::MakeMaker>. + I<xsubpp> will compile XS code into C code by embedding the constructs necessary to let C functions manipulate Perl values and creates the glue necessary to let Perl access those functions. The compiler uses typemaps to @@ -23,13 +25,15 @@ typemap taking precedence. =head1 OPTIONS +Note that the C<XSOPT> MakeMaker option may be used to add these options to +any makefiles generated by MakeMaker. + =over 5 =item B<-C++> Adds ``extern "C"'' to the C code. - =item B<-except> Adds exception handling stubs to the C code. @@ -59,6 +63,13 @@ number. Prevents the inclusion of `#line' directives in the output. +=item B<-nooptimize> + +Disables certain optimizations. The only optimization that is currently +affected is the use of I<target>s by the output C code (see L<perlguts>). +This may significantly slow down the generated code, but this is the way +B<xsubpp> of 5.005 and earlier operated. + =back =head1 ENVIRONMENT @@ -103,7 +114,7 @@ if ($^O eq 'VMS') { $FH = 'File0000' ; -$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-s pattern] [-typemap typemap]... file.xs\n"; +$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-s pattern] [-typemap typemap]... file.xs\n"; $proto_re = "[" . quotemeta('\$%&*@;') . "]" ; # mjn @@ -114,6 +125,7 @@ $WantPrototypes = -1 ; $WantVersionChk = 1 ; $ProtoUsed = 0 ; $WantLineNumbers = 1 ; +$WantOptimize = 1 ; SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { $flag = shift @ARGV; $flag =~ s/^-// ; @@ -129,7 +141,9 @@ SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { push(@tm,shift), next SWITCH if $flag eq 'typemap'; $WantLineNumbers = 0, next SWITCH if $flag eq 'nolinenumbers'; $WantLineNumbers = 1, next SWITCH if $flag eq 'linenumbers'; - (print "xsubpp version $XSUBPP_version\n"), exit + $WantOptimize = 0, next SWITCH if $flag eq 'nooptimize'; + $WantOptimize = 1, next SWITCH if $flag eq 'optimize'; + (print "xsubpp version $XSUBPP_version\n"), exit if $flag eq 'v'; die $usage; } @@ -235,6 +249,24 @@ foreach $key (keys %input_expr) { $input_expr{$key} =~ s/\n+$//; } +$bal = qr[(?:(?>[^()]+)|\((?p{ $bal })\))*]; # ()-balanced +$cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast +$size = qr[,\s* (?p{ $bal }) ]x; # Third arg (to setpvn) + +foreach $key (keys %output_expr) { + use re 'eval'; + + my ($t, $with_size, $arg, $sarg) = + ($output_expr{$key} =~ + m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn + \s* \( \s* $cast \$arg \s* , + \s* ( (?p{ $bal }) ) # Set from + ( (?p{ $size }) )? # Possible sizeof set-from + \) \s* ; \s* $ + ]x); + $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t; +} + $END = "!End!\n\n"; # "impossible" keyword (multiple newline) # Match an XS keyword @@ -1099,6 +1131,8 @@ EOF if !$retvaldone; $args_match{"RETVAL"} = 0; $var_types{"RETVAL"} = $ret_type; + print "\tdXSTARG;\n" + if $WantOptimize and $targetable{$type_kind{$ret_type}}; } print $deferred; @@ -1151,8 +1185,32 @@ EOF if ($gotRETVAL && $RETVAL_code) { print "\t$RETVAL_code\n"; } elsif ($gotRETVAL || $wantRETVAL) { - # RETVAL almost never needs SvSETMAGIC() - &generate_output($ret_type, 0, 'RETVAL', 0); + my $t = $WantOptimize && $targetable{$type_kind{$ret_type}}; + my $var = 'RETVAL'; + my $type = $ret_type; + + # 0: type, 1: with_size, 2: how, 3: how_size + if ($t and not $t->[1] and $t->[0] eq 'p') { + # PUSHp corresponds to setpvn. Treate setpv directly + my $what = eval qq("$t->[2]"); + warn $@ if $@; + + print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n"; + } + elsif ($t) { + my $what = eval qq("$t->[2]"); + warn $@ if $@; + + my $size = $t->[3]; + $size = '' unless defined $size; + $size = eval qq("$size"); + warn $@ if $@; + print "\tXSprePUSH; PUSH$t->[0]($what$size);\n"; + } + else { + # RETVAL almost never needs SvSETMAGIC() + &generate_output($ret_type, 0, 'RETVAL', 0); + } } # do cleanup diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm index fd812bc721..8df54e55a8 100644 --- a/lib/File/Copy.pm +++ b/lib/File/Copy.pm @@ -10,14 +10,14 @@ package File::Copy; use strict; use Carp; use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $Too_Big - © &syscopy &cp &mv); + © &syscopy &cp &mv $Syscopy_is_copy); # Note that this module implements only *part* of the API defined by # the File/Copy.pm module of the File-Tools-2.0 package. However, that # package has not yet been updated to work with Perl 5.004, and so it # would be a Bad Thing for the CPAN module to grab it and replace this # module. Therefore, we set this module's version higher than 2.0. -$VERSION = '2.02'; +$VERSION = '2.03'; require Exporter; @ISA = qw(Exporter); @@ -60,12 +60,12 @@ sub copy { $to = _catname($from, $to); } - if (defined &syscopy && \&syscopy != \© + if (defined &syscopy && !$Syscopy_is_copy && !$to_a_handle && !($from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle handles && !($from_a_handle && $^O eq 'mpeix') # and neither can MPE/iX. && !($from_a_handle && $^O eq 'MSWin32') - ) + ) { return syscopy($from, $to); } @@ -83,16 +83,16 @@ sub copy { open(FROM, "< $from\0") or goto fail_open1; binmode FROM or die "($!,$^E)"; $closefrom = 1; - } - + } + if ($to_a_handle) { *TO = *$to{FILEHANDLE}; - } else { + } else { $to = "./$to" if $to =~ /^\s/; open(TO,"> $to\0") or goto fail_open2; binmode TO or die "($!,$^E)"; $closeto = 1; - } + } if (@_) { $size = shift(@_) + 0; @@ -120,7 +120,7 @@ sub copy { # Use this idiom to avoid uninitialized value warning. return 1; - + # All of these contortions try to preserve error messages... fail_inner: if ($closeto) { @@ -163,10 +163,10 @@ sub move { (($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there ($tosz1 != $tosz2 or $tomt1 != $tomt2) && # and changed $tosz2 == $fromsz; # it's all there - + ($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something return 1 if ($copied = copy($from,$to)) && unlink($from); - + ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1; unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2; ($!,$^E) = ($sts,$ossts); @@ -193,6 +193,7 @@ unless (defined &syscopy) { return Win32::CopyFile(@_, 1); }; } else { + $Syscopy_is_copy = 1; *syscopy = \© } } diff --git a/lib/File/DosGlob.pm b/lib/File/DosGlob.pm index 594ee2ec84..e6fc311e32 100644 --- a/lib/File/DosGlob.pm +++ b/lib/File/DosGlob.pm @@ -206,7 +206,7 @@ pandering to DOS habits. Needs a dose of optimizium too. =head1 AUTHOR -Gurusamy Sarathy <gsar@umich.edu> +Gurusamy Sarathy <gsar@activestate.com> =head1 HISTORY diff --git a/lib/File/Find.pm b/lib/File/Find.pm index 28e2e90e44..c674b2c5f6 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -1,5 +1,5 @@ package File::Find; -require 5.000; +require 5.005; require Exporter; require Cwd; @@ -12,70 +12,163 @@ finddepth - traverse a directory structure depth-first =head1 SYNOPSIS use File::Find; - find(\&wanted, '/foo','/bar'); + find(\&wanted, '/foo', '/bar'); sub wanted { ... } use File::Find; - finddepth(\&wanted, '/foo','/bar'); + finddepth(\&wanted, '/foo', '/bar'); sub wanted { ... } + + use File::Find; + find({ wanted => \&process, follow => 1 }, '.'); =head1 DESCRIPTION The first argument to find() is either a hash reference describing the -operations to be performed for each file, a code reference, or a string -that contains a subroutine name. If it is a hash reference, then the -value for the key C<wanted> should be a code reference. This code -reference is called I<the wanted() function> below. +operations to be performed for each file, or a code reference. -Currently the only other supported key for the above hash is -C<bydepth>, in presense of which the walk over directories is -performed depth-first. Entry point finddepth() is a shortcut for -specifying C<{ bydepth => 1}> in the first argument of find(). +Here are the possible keys for the hash: + +=over 3 + +=item C<wanted> + +The value should be a code reference. This code reference is called +I<the wanted() function> below. + +=item C<bydepth> + +Reports the name of a directory only AFTER all its entries +have been reported. Entry point finddepth() is a shortcut for +specifying C<{ bydepth => 1 }> in the first argument of find(). + +=item C<follow> + +Causes symbolic links to be followed. Since directory trees with symbolic +links (followed) may contain files more than once and may even have +cycles, a hash has to be built up with an entry for each file. +This might be expensive both in space and time for a large +directory tree. See I<follow_fast> and I<follow_skip> below. +If either I<follow> or I<follow_fast> is in effect: + +=over 6 + +=item + +It is guarantueed that an I<lstat> has been called before the user's +I<wanted()> function is called. This enables fast file checks involving S< _>. + +=item + +There is a variable C<$File::Find::fullname> which holds the absolute +pathname of the file with all symbolic links resolved + +=back + +=item C<follow_fast> + +This is similar to I<follow> except that it may report some files +more than once. It does detect cycles however. +Since only symbolic links have to be hashed, this is +much cheaper both in space and time. +If processing a file more than once (by the user's I<wanted()> function) +is worse than just taking time, the option I<follow> should be used. + +=item C<follow_skip> + +C<follow_skip==1>, which is the default, causes all files which are +neither directories nor symbolic links to be ignored if they are about +to be processed a second time. If a directory or a symbolic link +are about to be processed a second time, File::Find dies. +C<follow_skip==0> causes File::Find to die if any file is about to be +processed a second time. +C<follow_skip==2> causes File::Find to ignore any duplicate files and +dirctories but to proceed normally otherwise. -The wanted() function does whatever verifications you want. -$File::Find::dir contains the current directory name, and $_ the -current filename within that directory. $File::Find::name contains -C<"$File::Find::dir/$_">. You are chdir()'d to $File::Find::dir when -the function is called. The function may set $File::Find::prune to -prune the tree. -File::Find assumes that you don't alter the $_ variable. If you do then -make sure you return it to its original value before exiting your function. +=item C<no_chdir> + +Does not C<chdir()> to each directory as it recurses. The wanted() +function will need to be aware of this, of course. In this case, +C<$_> will be the same as C<$File::Find::name>. + +=item C<untaint> + +If find is used in taint-mode (-T command line switch or if EUID != UID +or if EGID != GID) then internally directory names have to be untainted +before they can be cd'ed to. Therefore they are checked against a regular +expression I<untaint_pattern>. Note, that all names passed to the +user's I<wanted()> function are still tainted. + +=item C<untaint_pattern> + +See above. This should be set using the C<qr> quoting operator. +The default is set to C<qr|^([-+@\w./]+)$|>. +Note that the paranthesis which are vital. + +=item C<untaint_skip> + +If set, directories (subtrees) which fail the I<untaint_pattern> +are skipped. The default is to 'die' in such a case. + +=back + +The wanted() function does whatever verifications you want. +C<$File::Find::dir> contains the current directory name, and C<$_> the +current filename within that directory. C<$File::Find::name> contains +the complete pathname to the file. You are chdir()'d to C<$File::Find::dir> when +the function is called, unless C<no_chdir> was specified. +When <follow> or <follow_fast> are in effect there is also a +C<$File::Find::fullname>. +The function may set C<$File::Find::prune> to prune the tree +unless C<bydepth> was specified. +Unless C<follow> or C<follow_fast> is specified, for compatibility +reasons (find.pl, find2perl) there are in addition the following globals +available: C<$File::Find::topdir>, C<$File::Find::topdev>, C<$File::Find::topino>, +C<$File::Find::topmode> and C<$File::Find::topnlink>. This library is useful for the C<find2perl> tool, which when fed, find2perl / -name .nfs\* -mtime +7 \ - -exec rm -f {} \; -o -fstype nfs -prune + -exec rm -f {} \; -o -fstype nfs -prune produces something like: sub wanted { /^\.nfs.*$/ && - (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && + (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_)) && int(-M _) > 7 && unlink($_) || - ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && + ($nlink || (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_))) && $dev < 0 && ($File::Find::prune = 1); } -Set the variable $File::Find::dont_use_nlink if you're using AFS, +Set the variable C<$File::Find::dont_use_nlink> if you're using AFS, since AFS cheats. -C<finddepth> is just like C<find>, except that it does a depth-first -search. Here's another interesting wanted function. It will find all symlinks that don't resolve: sub wanted { - -l && !-e && print "bogus link: $File::Find::name\n"; + -l && !-e && print "bogus link: $File::Find::name\n"; } -=head1 BUGS +See also the script C<pfind> on CPAN for a nice application of this +module. + +=head1 CAVEAT + +Be aware that the option to follow symblic links can be dangerous. +Depending on the structure of the directory tree (including symbolic +links to directories) you might traverse a given (physical) directory +more than once (only if C<follow_fast> is in effect). +Furthermore, deleting or changing files in a symbolically linked directory +might cause very unpleasant surprises, since you delete or change files +in an unknown directory. -There is no way to make find or finddepth follow symlinks. =cut @@ -83,151 +176,522 @@ There is no way to make find or finddepth follow symlinks. @EXPORT = qw(find finddepth); -sub find_opt { - my $wanted = shift; - my $bydepth = $wanted->{bydepth}; - my $cwd = $bydepth ? Cwd::fastcwd() : Cwd::cwd(); - # Localize these rather than lexicalizing them for backwards - # compatibility. - local($topdir,$topdev,$topino,$topmode,$topnlink); - foreach $topdir (@_) { - (($topdev,$topino,$topmode,$topnlink) = - ($Is_VMS ? stat($topdir) : lstat($topdir))) - || (warn("Can't stat $topdir: $!\n"), next); - if (-d _) { - if (chdir($topdir)) { - $prune = 0; - unless ($bydepth) { - ($dir,$_) = ($topdir,'.'); - $name = $topdir; - $wanted->{wanted}->(); - } - next if $prune; - my $fixtopdir = $topdir; - $fixtopdir =~ s,/$,, ; - $fixtopdir =~ s/\.dir$// if $Is_VMS; - &finddir($wanted,$fixtopdir,$topnlink, $bydepth); - if ($bydepth) { - ($dir,$_) = ($fixtopdir,'.'); - $name = $fixtopdir; - $wanted->{wanted}->(); - } +use strict; +my $Is_VMS; + +require File::Basename; + +my %SLnkSeen; +my ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow, + $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat); + +sub contract_name { + my ($cdir,$fn) = @_; + + return substr($cdir,0,rindex($cdir,'/')) if $fn eq '.'; + + $cdir = substr($cdir,0,rindex($cdir,'/')+1); + + $fn =~ s|^\./||; + + my $abs_name= $cdir . $fn; + + if (substr($fn,0,3) eq '../') { + do 1 while ($abs_name=~ s|/(?>[^/]+)/\.\./|/|); + } + + return $abs_name; +} + + +sub PathCombine($$) { + my ($Base,$Name) = @_; + my $AbsName; + + if (substr($Name,0,1) eq '/') { + $AbsName= $Name; + } + else { + $AbsName= contract_name($Base,$Name); + } + + # (simple) check for recursion + my $newlen= length($AbsName); + if ($newlen <= length($Base)) { + if (($newlen == length($Base) || substr($Base,$newlen,1) eq '/') + && $AbsName eq substr($Base,0,$newlen)) + { + return undef; + } + } + return $AbsName; +} + +sub Follow_SymLink($) { + my ($AbsName) = @_; + + my ($NewName,$DEV, $INO); + ($DEV, $INO)= lstat $AbsName; + + while (-l _) { + if ($SLnkSeen{$DEV, $INO}++) { + if ($follow_skip < 2) { + die "$AbsName is encountered a second time"; } else { - warn "Can't cd to $topdir: $!\n"; + return undef; } } - else { - require File::Basename; - unless (($_,$dir) = File::Basename::fileparse($topdir)) { - ($dir,$_) = ('.', $topdir); + $NewName= PathCombine($AbsName, readlink($AbsName)); + unless(defined $NewName) { + if ($follow_skip < 2) { + die "$AbsName is a recursive symbolic link"; + } + else { + return undef; } - if (chdir($dir)) { - $name = $topdir; - $wanted->{wanted}->(); + } + else { + $AbsName= $NewName; + } + ($DEV, $INO) = lstat($AbsName); + return undef unless defined $DEV; # dangling symbolic link + } + + if ($full_check && $SLnkSeen{$DEV, $INO}++) { + if ($follow_skip < 1) { + die "$AbsName encountered a second time"; + } + else { + return undef; + } + } + + return $AbsName; +} + +use vars qw/ $dir $name $fullname $prune /; +sub _find_dir_symlnk($$$); +sub _find_dir($$$); + +sub _find_opt { + my $wanted = shift; + die "invalid top directory" unless defined $_[0]; + + my $cwd = $wanted->{bydepth} ? Cwd::fastcwd() : Cwd::cwd(); + my $cwd_untainted = $cwd; + $wanted_callback = $wanted->{wanted}; + $bydepth = $wanted->{bydepth}; + $no_chdir = $wanted->{no_chdir}; + $full_check = $wanted->{follow}; + $follow = $full_check || $wanted->{follow_fast}; + $follow_skip = $wanted->{follow_skip}; + $untaint = $wanted->{untaint}; + $untaint_pat = $wanted->{untaint_pattern}; + $untaint_skip = $wanted->{untaint_skip}; + + # for compatability reasons (find.pl, find2perl) + our ($topdir, $topdev, $topino, $topmode, $topnlink); + + # a symbolic link to a directory doesn't increase the link count + $avoid_nlink = $follow || $File::Find::dont_use_nlink; + + if ( $untaint ) { + $cwd_untainted= $1 if $cwd_untainted =~ m|$untaint_pat|; + die "insecure cwd in find(depth)" unless defined($cwd_untainted); + } + + my ($abs_dir, $Is_Dir); + + Proc_Top_Item: + foreach my $TOP (@_) { + my $top_item = $TOP; + $top_item =~ s|/$|| unless $top_item eq '/'; + $Is_Dir= 0; + + if ($follow) { + if (substr($top_item,0,1) eq '/') { + $abs_dir = $top_item; + } + elsif ($top_item eq '.') { + $abs_dir = $cwd; } + else { # care about any ../ + $abs_dir = contract_name("$cwd/",$top_item); + } + $abs_dir= Follow_SymLink($abs_dir); + unless (defined $abs_dir) { + warn "$top_item is a dangling symbolic link\n"; + next Proc_Top_Item; + } + if (-d _) { + _find_dir_symlnk($wanted, $abs_dir, $top_item); + $Is_Dir= 1; + } + } + else { # no follow + $topdir = $top_item; + ($topdev,$topino,$topmode,$topnlink) = lstat $top_item; + unless (defined $topnlink) { + warn "Can't stat $top_item: $!\n"; + next Proc_Top_Item; + } + if (-d _) { + $top_item =~ s/\.dir$// if $Is_VMS; + _find_dir($wanted, $top_item, $topnlink); + $Is_Dir= 1; + } else { - warn "Can't cd to $dir: $!\n"; + $abs_dir= $top_item; + } + } + + unless ($Is_Dir) { + unless (($_,$dir) = File::Basename::fileparse($abs_dir)) { + ($dir,$_) = ('.', $top_item); + } + + $abs_dir = $dir; + if ($untaint) { + my $abs_dir_save = $abs_dir; + $abs_dir = $1 if $abs_dir =~ m|$untaint_pat|; + unless (defined $abs_dir) { + if ($untaint_skip == 0) { + die "directory $abs_dir_save is still tainted"; + } + else { + next Proc_Top_Item; + } + } + } + + unless ($no_chdir or chdir $abs_dir) { + warn "Couldn't chdir $abs_dir: $!\n"; + next Proc_Top_Item; + } + + $name = $abs_dir; + + &$wanted_callback; + + } + + $no_chdir or chdir $cwd_untainted; + } +} + +# API: +# $wanted +# $p_dir : "parent directory" +# $nlink : what came back from the stat +# preconditions: +# chdir (if not no_chdir) to dir + +sub _find_dir($$$) { + my ($wanted, $p_dir, $nlink) = @_; + my ($CdLvl,$Level) = (0,0); + my @Stack; + my @filenames; + my ($subcount,$sub_nlink); + my $SE= []; + my $dir_name= $p_dir; + my $dir_pref= ( $p_dir eq '/' ? '/' : "$p_dir/" ); + my $dir_rel= '.'; # directory name relative to current directory + + local ($dir, $name, $prune, *DIR); + + unless ($no_chdir or $p_dir eq '.') { + my $udir = $p_dir; + if ($untaint) { + $udir = $1 if $p_dir =~ m|$untaint_pat|; + unless (defined $udir) { + if ($untaint_skip == 0) { + die "directory $p_dir is still tainted"; + } + else { + return; + } } } + unless (chdir $udir) { + warn "Can't cd to $udir: $!\n"; + return; + } + } + + while (defined $SE) { + unless ($bydepth) { + $dir= $p_dir; + $name= $dir_name; + $_= ($no_chdir ? $dir_name : $dir_rel ); + # prune may happen here + $prune= 0; + &$wanted_callback; + next if $prune; + } + + # change to that directory + unless ($no_chdir or $dir_rel eq '.') { + my $udir= $dir_rel; + if ($untaint) { + $udir = $1 if $dir_rel =~ m|$untaint_pat|; + unless (defined $udir) { + if ($untaint_skip == 0) { + die "directory (" + . ($p_dir ne '/' ? $p_dir : '') + . "/) $dir_rel is still tainted"; + } + } + } + unless (chdir $udir) { + warn "Can't cd to (" + . ($p_dir ne '/' ? $p_dir : '') + . "/) $udir : $!\n"; + next; + } + $CdLvl++; + } + + $dir= $dir_name; + + # Get the list of files in the current directory. + unless (opendir DIR, ($no_chdir ? $dir_name : '.')) { + warn "Can't opendir($dir_name): $!\n"; + next; + } + @filenames = readdir DIR; + closedir(DIR); + + if ($nlink == 2 && !$avoid_nlink) { + # This dir has no subdirectories. + for my $FN (@filenames) { + next if $FN =~ /^\.{1,2}$/; + + $name = $dir_pref . $FN; + $_ = ($no_chdir ? $name : $FN); + &$wanted_callback; + } + + } + else { + # This dir has subdirectories. + $subcount = $nlink - 2; + + for my $FN (@filenames) { + next if $FN =~ /^\.{1,2}$/; + if ($subcount > 0 || $avoid_nlink) { + # Seen all the subdirs? + # check for directoriness. + # stat is faster for a file in the current directory + $sub_nlink = (lstat ($no_chdir ? $dir_pref . $FN : $FN))[3]; + + if (-d _) { + --$subcount; + $FN =~ s/\.dir$// if $Is_VMS; + push @Stack,[$CdLvl,$dir_name,$FN,$sub_nlink]; + } + else { + $name = $dir_pref . $FN; + $_= ($no_chdir ? $name : $FN); + &$wanted_callback; + } + } + else { + $name = $dir_pref . $FN; + $_= ($no_chdir ? $name : $FN); + &$wanted_callback; + } + } + } + if ($bydepth) { + $name = $dir_name; + $dir = $p_dir; + $_ = ($no_chdir ? $dir_name : $dir_rel ); + &$wanted_callback; + } } continue { - chdir $cwd; + if ( defined ($SE = pop @Stack) ) { + ($Level, $p_dir, $dir_rel, $nlink) = @$SE; + if ($CdLvl > $Level && !$no_chdir) { + die "Can't cd to $dir_name" . '../' x ($CdLvl-$Level) + unless chdir '../' x ($CdLvl-$Level); + $CdLvl = $Level; + } + $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel"); + $dir_pref = "$dir_name/"; + } } } -sub finddir { - my($wanted, $nlink, $bydepth); - local($dir, $name); - ($wanted, $dir, $nlink, $bydepth) = @_; - - my($dev, $ino, $mode, $subcount); - - # Get the list of files in the current directory. - opendir(DIR,'.') || (warn("Can't open $dir: $!\n"), $bydepth || return); - my(@filenames) = readdir(DIR); - closedir(DIR); - - if ($nlink == 2 && !$dont_use_nlink) { # This dir has no subdirectories. - for (@filenames) { - next if $_ eq '.'; - next if $_ eq '..'; - $name = "$dir/$_"; - $nlink = 0; - $wanted->{wanted}->(); - } - } - else { # This dir has subdirectories. - $subcount = $nlink - 2; - for (@filenames) { - next if $_ eq '.'; - next if $_ eq '..'; - $nlink = 0; - $prune = 0 unless $bydepth; - $name = "$dir/$_"; - $wanted->{wanted}->() unless $bydepth; - if ($subcount > 0 || $dont_use_nlink) { # Seen all the subdirs? - - # Get link count and check for directoriness. - - $_ = "" if (!defined($_)); - ($dev,$ino,$mode,$nlink) = ($Is_VMS ? stat($_) : lstat($_)); - # unless ($nlink || $dont_use_nlink); - - if (-d _) { - - # It really is a directory, so do it recursively. - - --$subcount; - next if $prune; - if (chdir $_) { - $name =~ s/\.dir$// if $Is_VMS; - &finddir($wanted,$name,$nlink, $bydepth); - chdir '..'; + +# API: +# $wanted +# $dir_loc : absolute location of a dir +# $p_dir : "parent directory" +# preconditions: +# chdir (if not no_chdir) to dir + +sub _find_dir_symlnk($$$) { + my ($wanted, $dir_loc, $p_dir) = @_; + my @Stack; + my @filenames; + my $new_loc; + my $SE = []; + my $dir_name = $p_dir; + my $dir_pref = ( $p_dir eq '/' ? '/' : "$p_dir/" ); + my $loc_pref = ( $dir_loc eq '/' ? '/' : "$dir_loc/" ); + my $dir_rel = '.'; # directory name relative to current directory + + local ($dir, $name, $fullname, $prune, *DIR); + + unless ($no_chdir or $p_dir eq '.') { + my $udir = $dir_loc; + if ($untaint) { + $udir = $1 if $dir_loc =~ m|$untaint_pat|; + unless (defined $udir) { + if ($untaint_skip == 0) { + die "directory $dir_loc is still tainted"; + } + else { + return; + } + } + } + unless (chdir $udir) { + warn "Can't cd to $udir: $!\n"; + return; + } + } + + while (defined $SE) { + + unless ($bydepth) { + $dir= $p_dir; + $name= $dir_name; + $_= ($no_chdir ? $dir_name : $dir_rel ); + $fullname= $dir_loc; + # prune may happen here + $prune= 0; + &$wanted_callback; + next if $prune; + } + + # change to that directory + unless ($no_chdir or $dir_rel eq '.') { + my $udir = $dir_loc; + if ($untaint) { + $udir = $1 if $dir_loc =~ m|$untaint_pat|; + unless (defined $udir ) { + if ($untaint_skip == 0) { + die "directory $dir_loc is still tainted"; } else { - warn "Can't cd to $_: $!\n"; + next; } } } - $wanted->{wanted}->() if $bydepth; + unless (chdir $udir) { + warn "Can't cd to $udir: $!\n"; + next; + } + } + + $dir = $dir_name; + + # Get the list of files in the current directory. + unless (opendir DIR, ($no_chdir ? $dir_loc : '.')) { + warn "Can't opendir($dir_loc): $!\n"; + next; + } + @filenames = readdir DIR; + closedir(DIR); + + for my $FN (@filenames) { + next if $FN =~ /^\.{1,2}$/; + + # follow symbolic links / do an lstat + $new_loc = Follow_SymLink($loc_pref.$FN); + + # ignore if invalid symlink + next unless defined $new_loc; + + if (-d _) { + push @Stack,[$new_loc,$dir_name,$FN]; + } + else { + $fullname = $new_loc; + $name = $dir_pref . $FN; + $_ = ($no_chdir ? $name : $FN); + &$wanted_callback; + } + } + + if ($bydepth) { + $fullname = $dir_loc; + $name = $dir_name; + $_ = ($no_chdir ? $dir_name : $dir_rel); + &$wanted_callback; + } + } + continue { + if (defined($SE = pop @Stack)) { + ($dir_loc, $p_dir, $dir_rel) = @$SE; + $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel"); + $dir_pref = "$dir_name/"; + $loc_pref = "$dir_loc/"; } } } + sub wrap_wanted { - my $wanted = shift; - ref($wanted) eq 'HASH' ? $wanted : { wanted => $wanted }; + my $wanted = shift; + if ( ref($wanted) eq 'HASH' ) { + if ( $wanted->{follow} || $wanted->{follow_fast}) { + $wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip}; + } + if ( $wanted->{untaint} ) { + $wanted->{untaint_pattern} = qr|^([-+@\w./]+)$| + unless defined $wanted->{untaint_pattern}; + $wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip}; + } + return $wanted; + } + else { + return { wanted => $wanted }; + } } sub find { - my $wanted = shift; - find_opt(wrap_wanted($wanted), @_); + my $wanted = shift; + _find_opt(wrap_wanted($wanted), @_); + %SLnkSeen= (); # free memory } sub finddepth { - my $wanted = wrap_wanted(shift); - $wanted->{bydepth} = 1; - find_opt($wanted, @_); + my $wanted = wrap_wanted(shift); + $wanted->{bydepth} = 1; + _find_opt($wanted, @_); + %SLnkSeen= (); # free memory } # These are hard-coded for now, but may move to hint files. if ($^O eq 'VMS') { - $Is_VMS = 1; - $dont_use_nlink = 1; + $Is_VMS = 1; + $File::Find::dont_use_nlink = 1; } -$dont_use_nlink = 1 +$File::Find::dont_use_nlink = 1 if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32'; # Set dont_use_nlink in your hint file if your system's stat doesn't # report the number of links in a directory as an indication # of the number of files. # See, e.g. hints/machten.sh for MachTen 2.2. -unless ($dont_use_nlink) { - require Config; - $dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'}); +unless ($File::Find::dont_use_nlink) { + require Config; + $File::Find::dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'}); } 1; - diff --git a/lib/File/Path.pm b/lib/File/Path.pm index a82fd8004e..634b2cd108 100644 --- a/lib/File/Path.pm +++ b/lib/File/Path.pm @@ -126,13 +126,15 @@ sub mkpath { my $parent = File::Basename::dirname($path); # Allow for creation of new logical filesystems under VMS if (not $Is_VMS or $parent !~ m:/[^/]+/000000/?:) { - push(@created,mkpath($parent, $verbose, $mode)) unless (-d $parent); + unless (-d $parent or $path eq $parent) { + push(@created,mkpath($parent, $verbose, $mode)); + } } print "mkdir $path\n" if $verbose; unless (mkdir($path,$mode)) { - my $e = $!; - # allow for another process to have created it meanwhile - croak "mkdir $path: $e" unless -d $path; + my $e = $!; + # allow for another process to have created it meanwhile + croak "mkdir $path: $e" unless -d $path; } push(@created, $path); } diff --git a/lib/File/Spec.pm b/lib/File/Spec.pm index b71e357cdc..40f5345140 100644 --- a/lib/File/Spec.pm +++ b/lib/File/Spec.pm @@ -86,4 +86,7 @@ Kenneth Albanowski <F<kjahds@kjahds.com>>, Andy Dougherty <F<A.Koenig@franz.ww.TU-Berlin.DE>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>>. VMS support by Charles Bailey <F<bailey@newman.upenn.edu>>. OS/2 support by Ilya Zakharevich <F<ilya@math.ohio-state.edu>>. Mac support by Paul Schinder -<F<schinder@pobox.com>>. +<F<schinder@pobox.com>>. abs2rel() and rel2abs() written by +Shigio Yamaguchi <F<shigio@tamacom.com>>, modified by Barrie Slaymaker +<F<barries@slaysys.com>>. splitpath(), splitdir(), catpath() and catdir() +by Barrie Slaymaker. diff --git a/lib/File/Spec/Unix.pm b/lib/File/Spec/Unix.pm index 87ad643fe2..85df2c2d3b 100644 --- a/lib/File/Spec/Unix.pm +++ b/lib/File/Spec/Unix.pm @@ -41,7 +41,7 @@ ricochet (some scripts depend on it). sub canonpath { my ($self,$path,$reduce_ricochet) = @_; - $path =~ s|/+|/|g unless($^O =~ /cygwin/); # xx////xx -> xx/xx + $path =~ s|/+|/|g unless($^O eq 'cygwin'); # xx////xx -> xx/xx $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx $path =~ s|^(\./)+|| unless $path eq "./"; # ./xx -> xx $path =~ s|^/(\.\./)+|/|; # /../../xx -> xx diff --git a/lib/FindBin.pm b/lib/FindBin.pm index 9e1c0a06bf..9d35f6f9c9 100644 --- a/lib/FindBin.pm +++ b/lib/FindBin.pm @@ -82,7 +82,7 @@ use File::Spec; %EXPORT_TAGS = (ALL => [qw($Bin $Script $RealBin $RealScript $Dir $RealDir)]); @ISA = qw(Exporter); -$VERSION = $VERSION = "1.42"; +$VERSION = "1.42"; BEGIN { diff --git a/lib/Getopt/Std.pm b/lib/Getopt/Std.pm index 390bf14e96..e027bad3d2 100644 --- a/lib/Getopt/Std.pm +++ b/lib/Getopt/Std.pm @@ -42,7 +42,7 @@ the argument or 1 if no argument is specified. @ISA = qw(Exporter); @EXPORT = qw(getopt getopts); -$VERSION = $VERSION = '1.01'; +$VERSION = '1.01'; # Process single-character switches with switch clustering. Pass one argument # which is a string containing all switches that take an argument. For each diff --git a/lib/Math/BigFloat.pm b/lib/Math/BigFloat.pm index 8aa6a6604b..1a9195e185 100644 --- a/lib/Math/BigFloat.pm +++ b/lib/Math/BigFloat.pm @@ -240,12 +240,13 @@ sub fcmp #(fnum_str, fnum_str) return cond_code if ($x eq "NaN" || $y eq "NaN") { undef; } else { + local($xm,$xe,$ym,$ye) = split('E', $x."E$y"); + if ($xm eq '+0' || $ym eq '+0') { + return $xm <=> $ym; + } ord($y) <=> ord($x) - || - ( local($xm,$xe,$ym,$ye) = split('E', $x."E$y"), - (($xe <=> $ye) * (substr($x,$[,1).'1') - || Math::BigInt::cmp($xm,$ym)) - ); + || ($xe <=> $ye) * (substr($x,$[,1).'1') + || Math::BigInt::cmp($xm,$ym); } } diff --git a/lib/Math/Complex.pm b/lib/Math/Complex.pm index 5b69039afc..b339573bc9 100644 --- a/lib/Math/Complex.pm +++ b/lib/Math/Complex.pm @@ -1746,7 +1746,7 @@ Whatever it is, it does not manifest itself anywhere else where Perl runs. =head1 AUTHORS -Raphael Manfredi <F<Raphael_Manfredi@grenoble.hp.com>> and +Raphael Manfredi <F<Raphael_Manfredi@pobox.com>> and Jarkko Hietaniemi <F<jhi@iki.fi>>. Extensive patches by Daniel S. Lewart <F<d-lewart@uiuc.edu>>. diff --git a/lib/Math/Trig.pm b/lib/Math/Trig.pm index d987b5cc76..c659137eba 100644 --- a/lib/Math/Trig.pm +++ b/lib/Math/Trig.pm @@ -435,7 +435,7 @@ an answer instead of giving a fatal runtime error. =head1 AUTHORS Jarkko Hietaniemi <F<jhi@iki.fi>> and -Raphael Manfredi <F<Raphael_Manfredi@grenoble.hp.com>>. +Raphael Manfredi <F<Raphael_Manfredi@pobox.com>>. =cut diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm index 495b82f95b..54540601d3 100644 --- a/lib/Net/Ping.pm +++ b/lib/Net/Ping.pm @@ -4,7 +4,7 @@ package Net::Ping; # # Authors of the original pingecho(): # karrer@bernina.ethz.ch (Andreas Karrer) -# pmarquess@bfsec.bt.co.uk (Paul Marquess) +# Paul.Marquess@btinternet.com (Paul Marquess) # # Copyright (c) 1996 Russell Mosemann. All rights reserved. This # program is free software; you may redistribute it and/or modify it diff --git a/lib/Pod/Html.pm b/lib/Pod/Html.pm index e9c640cf5d..15757ec80d 100644 --- a/lib/Pod/Html.pm +++ b/lib/Pod/Html.pm @@ -1487,7 +1487,7 @@ sub process_L { if (m,^(.*?)/"?(.*?)"?$,) { # yes ($page, $section) = ($1, $2); } else { # no - ($page, $section) = ($str, ""); + ($page, $section) = ($_, ""); } # check if we know that this is a section in this page diff --git a/lib/Pod/Man.pm b/lib/Pod/Man.pm index 87de42efb3..9aadd42dea 100644 --- a/lib/Pod/Man.pm +++ b/lib/Pod/Man.pm @@ -338,9 +338,10 @@ sub initialize { # but we shouldn't need that any more. Get the version from the running # Perl. if (!defined $$self{release}) { - my ($version, $patch) = ($] =~ /^(.{5})(\d{2})?/); - $$self{release} = "perl $version"; - $$self{release} .= ", patch $patch" if $patch; + my ($rev, $ver, $sver) = ($] =~ /^(\d+)\.(\d{3})(\d{0,3})$/); + $sver ||= 0; $sver *= 10 ** (3-length($sver)); + $rev += 0; $ver += 0; $sver += 0; + $$self{release} = "perl v$rev.$ver.$sver"; } # Double quotes in things that will be quoted. diff --git a/lib/Sys/Hostname.pm b/lib/Sys/Hostname.pm index e96822e414..4d93f91f9e 100644 --- a/lib/Sys/Hostname.pm +++ b/lib/Sys/Hostname.pm @@ -65,6 +65,10 @@ sub hostname { chomp($host = `hostname 2> NUL`) unless defined $host; return $host; } + elsif ($^O eq 'epoc') { + $host = 'localhost'; + return $host; + } else { # Unix # method 2 - syscall is preferred since it avoids tainting problems diff --git a/lib/Tie/Array.pm b/lib/Tie/Array.pm index 3f34c3b81f..5ef83c4781 100644 --- a/lib/Tie/Array.pm +++ b/lib/Tie/Array.pm @@ -1,7 +1,8 @@ package Tie::Array; use vars qw($VERSION); use strict; -$VERSION = '1.00'; +use Carp; +$VERSION = '1.01'; # Pod documentation after __END__ below. @@ -74,6 +75,16 @@ sub SPLICE return @result; } +sub EXISTS { + my $pkg = ref $_[0]; + croak "$pkg dosn't define an EXISTS method"; +} + +sub DELETE { + my $pkg = ref $_[0]; + croak "$pkg dosn't define a DELETE method"; +} + package Tie::StdArray; use vars qw(@ISA); @ISA = 'Tie::Array'; @@ -88,6 +99,8 @@ sub POP { pop(@{$_[0]}) } sub PUSH { my $o = shift; push(@$o,@_) } sub SHIFT { shift(@{$_[0]}) } sub UNSHIFT { my $o = shift; unshift(@$o,@_) } +sub EXISTS { exists $_[0]->[$_[1]] } +sub DELETE { delete $_[0]->[$_[1]] } sub SPLICE { @@ -120,6 +133,8 @@ Tie::Array - base class for tied arrays sub STORE { ... } # mandatory if elements writeable sub STORESIZE { ... } # mandatory if elements can be added/deleted + sub EXISTS { ... } # mandatory if exists() expected to work + sub DELETE { ... } # mandatory if delete() expected to work # optional methods - for efficiency sub CLEAR { ... } @@ -150,9 +165,11 @@ Tie::Array - base class for tied arrays This module provides methods for array-tying classes. See L<perltie> for a list of the functions required in order to tie an array -to a package. The basic B<Tie::Array> package provides stub C<DELETE> -and C<EXTEND> methods, and implementations of C<PUSH>, C<POP>, C<SHIFT>, -C<UNSHIFT>, C<SPLICE> and C<CLEAR> in terms of basic C<FETCH>, C<STORE>, +to a package. The basic B<Tie::Array> package provides stub C<DESTROY>, +and C<EXTEND> methods that do nothing, stub C<DELETE> and C<EXISTS> +methods that croak() if the delete() or exists() builtins are ever called +on the tied array, and implementations of C<PUSH>, C<POP>, C<SHIFT>, +C<UNSHIFT>, C<SPLICE> and C<CLEAR> in terms of basic C<FETCH>, C<STORE>, C<FETCHSIZE>, C<STORESIZE>. The B<Tie::StdArray> package provides efficient methods required for tied arrays @@ -203,6 +220,18 @@ deleted. Informative call that array is likely to grow to have I<count> entries. Can be used to optimize allocation. This method need do nothing. +=item EXISTS this, key + +Verify that the element at index I<key> exists in the tied array I<this>. + +The B<Tie::Array> implementation is a stub that simply croaks. + +=item DELETE this, key + +Delete the element at index I<key> from the tied array I<this>. + +The B<Tie::Array> implementation is a stub that simply croaks. + =item CLEAR this Clear (remove, delete, ...) all values from the tied array associated with diff --git a/lib/Tie/Hash.pm b/lib/Tie/Hash.pm index 2902efb4d0..928b798e45 100644 --- a/lib/Tie/Hash.pm +++ b/lib/Tie/Hash.pm @@ -73,6 +73,8 @@ Return the next key for the hash. Verify that I<key> exists with the tied hash I<this>. +The B<Tie::Hash> implementation is a stub that simply croaks. + =item DELETE this, key Delete the key I<key> from the tied hash I<this>. diff --git a/lib/Time/Local.pm b/lib/Time/Local.pm index 8cb6a96f5f..f3f6f542a6 100644 --- a/lib/Time/Local.pm +++ b/lib/Time/Local.pm @@ -5,6 +5,7 @@ use Carp; @ISA = qw( Exporter ); @EXPORT = qw( timegm timelocal ); +@EXPORT_OK = qw( timegm_nocheck timelocal_nocheck ); # Set up constants $SEC = 1; @@ -17,6 +18,8 @@ use Carp; $breakpoint = ($thisYear + 50) % 100; $nextCentury += 100 if $breakpoint < 50; +my %options; + sub timegm { my (@date) = @_; if ($date[5] > 999) { @@ -35,6 +38,11 @@ sub timegm { + ($date[3]-1) * $DAY; } +sub timegm_nocheck { + local $options{no_range_check} = 1; + &timegm; +} + sub timelocal { my $t = &timegm; my $tt = $t; @@ -69,10 +77,15 @@ sub timelocal { $time; } +sub timelocal_nocheck { + local $options{no_range_check} = 1; + &timelocal; +} + sub cheat { $year = $_[5]; $month = $_[4]; - unless ($no_range_check) { + unless ($options{no_range_check}) { croak "Month '$month' out of range 0..11" if $month > 11 || $month < 0; croak "Day '$_[3]' out of range 1..31" if $_[3] > 31 || $_[3] < 1; croak "Hour '$_[2]' out of range 0..23" if $_[2] > 23 || $_[2] < 0; @@ -138,27 +151,25 @@ the values provided. While the day of the month is expected to be in the range 1..31, the month should be in the range 0..11. This is consistent with the values returned from localtime() and gmtime(). -Also worth noting is the ability to disable the range checking that -would normally occur on the input $sec, $min, $hours, $mday, and $mon -values. You can do this by localizing $Time::Local::no_range_check -to 1. +The timelocal() and timegm() functions perform range checking on the +input $sec, $min, $hours, $mday, and $mon values by default. If you'd +rather they didn't, you can explicitly import the timelocal_nocheck() +and timegm_nocheck() functions. - use Time::Local; + use Time::Local 'timelocal_nocheck'; { - local $Time::Local::no_range_check = 1; - # The 365th day of 1999 - print scalar localtime timelocal 0,0,0,365,0,99; + print scalar localtime timelocal_nocheck 0,0,0,365,0,99; # The twenty thousandth day since 1970 - print scalar localtime timelocal 0,0,0,20000,0,70; + print scalar localtime timelocal_nocheck 0,0,0,20000,0,70; # And even the 10,000,000th second since 1999! - print scalar localtime timelocal 10000000,0,0,1,0,99; + print scalar localtime timelocal_nocheck 10000000,0,0,1,0,99; } -Your mileage may vary when trying this trick with minutes and hours, +Your mileage may vary when trying these with minutes and hours, and it doesn't work at all for months. Strictly speaking, the year should also be specified in a form consistent diff --git a/lib/bigfloat.pl b/lib/bigfloat.pl index 6af5f17303..8c28abdcd1 100644 --- a/lib/bigfloat.pl +++ b/lib/bigfloat.pl @@ -79,7 +79,12 @@ sub norm { #(mantissa, exponent) return fnum_str sub main'fneg { #(fnum_str) return fnum_str local($_) = &'fnorm($_[$[]); vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign - s/^H/N/; + if ( ord("\t") == 9 ) { # ascii + s/^H/N/; + } + else { # ebcdic character set + s/\373/N/; + } $_; } diff --git a/lib/byte.pm b/lib/byte.pm new file mode 100644 index 0000000000..cc23b40f4f --- /dev/null +++ b/lib/byte.pm @@ -0,0 +1,33 @@ +package byte; + +sub import { + $^H |= 0x00000010; +} + +sub unimport { + $^H &= ~0x00000010; +} + +sub AUTOLOAD { + require "byte_heavy.pl"; + goto &$AUTOLOAD; +} + +sub length ($); + +1; +__END__ + +=head1 NAME + +byte - Perl pragma to turn force treating strings as bytes not UNICODE + +=head1 SYNOPSIS + + use byte; + no byte; + +=head1 DESCRIPTION + + +=cut diff --git a/lib/byte_heavy.pl b/lib/byte_heavy.pl new file mode 100644 index 0000000000..07c908a689 --- /dev/null +++ b/lib/byte_heavy.pl @@ -0,0 +1,8 @@ +package byte; + +sub length ($) +{ + return CORE::length($_[0]); +} + +1; diff --git a/lib/constant.pm b/lib/constant.pm index 5d3dd91b46..31f47fbf54 100644 --- a/lib/constant.pm +++ b/lib/constant.pm @@ -1,6 +1,112 @@ package constant; -$VERSION = '1.00'; +use strict; +use vars qw( $VERSION %declared ); +$VERSION = '1.01'; + +#======================================================================= + +require 5.005_62; + +# Some names are evil choices. +my %keywords = map +($_, 1), qw{ BEGIN INIT STOP END DESTROY AUTOLOAD }; + +my %forced_into_main = map +($_, 1), + qw{ STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG }; + +my %forbidden = (%keywords, %forced_into_main); + +#======================================================================= +# import() - import symbols into user's namespace +# +# What we actually do is define a function in the caller's namespace +# which returns the value. The function we create will normally +# be inlined as a constant, thereby avoiding further sub calling +# overhead. +#======================================================================= +sub import { + my $class = shift; + return unless @_; # Ignore 'use constant;' + my $name = shift; + unless (defined $name) { + require Carp; + Carp::croak("Can't use undef as constant name"); + } + my $pkg = caller; + + # Normal constant name + if ($name =~ /^(?:[A-Z]\w|_[A-Z])\w*\z/ and !$forbidden{$name}) { + # Everything is okay + + # Name forced into main, but we're not in main. Fatal. + } elsif ($forced_into_main{$name} and $pkg ne 'main') { + require Carp; + Carp::croak("Constant name '$name' is forced into main::"); + + # Starts with double underscore. Fatal. + } elsif ($name =~ /^__/) { + require Carp; + Carp::croak("Constant name '$name' begins with '__'"); + + # Maybe the name is tolerable + } elsif ($name =~ /^[A-Za-z_]\w*\z/) { + # Then we'll warn only if you've asked for warnings + if ($^W) { + require Carp; + if ($keywords{$name}) { + Carp::carp("Constant name '$name' is a Perl keyword"); + } elsif ($forced_into_main{$name}) { + Carp::carp("Constant name '$name' is " . + "forced into package main::"); + } elsif (1 == length $name) { + Carp::carp("Constant name '$name' is too short"); + } elsif ($name =~ /^_?[a-z\d]/) { + Carp::carp("Constant name '$name' should " . + "have an initial capital letter"); + } else { + # Catch-all - what did I miss? If you get this error, + # please let me know what your constant's name was. + # Write to <rootbeer@redcat.com>. Thanks! + Carp::carp("Constant name '$name' has unknown problems"); + } + } + + # Looks like a boolean + # use constant FRED == fred; + } elsif ($name =~ /^[01]?\z/) { + require Carp; + if (@_) { + Carp::croak("Constant name '$name' is invalid"); + } else { + Carp::croak("Constant name looks like boolean value"); + } + + } else { + # Must have bad characters + require Carp; + Carp::croak("Constant name '$name' has invalid characters"); + } + + { + no strict 'refs'; + my $full_name = "${pkg}::$name"; + $declared{$full_name}++; + if (@_ == 1) { + my $scalar = $_[0]; + *$full_name = sub () { $scalar }; + } elsif (@_) { + my @list = @_; + *$full_name = sub () { @list }; + } else { + *$full_name = sub () { }; + } + } + +} + +1; + +__END__ =head1 NAME @@ -20,7 +126,7 @@ constant - Perl pragma to declare constants print "This line does nothing" unless DEBUGGING; - # references can be declared constant + # references can be constants use constant CHASH => { foo => 42 }; use constant CARRAY => [ 1,2,3,4 ]; use constant CPSEUDOHASH => [ { foo => 1}, 42 ]; @@ -30,7 +136,7 @@ constant - Perl pragma to declare constants print CARRAY->[$i]; print CPSEUDOHASH->{foo}; print CCODE->("me"); - print CHASH->[10]; # compile-time error + print CHASH->[10]; # compile-time error =head1 DESCRIPTION @@ -63,7 +169,10 @@ List constants are returned as lists, not as arrays. The use of all caps for constant names is merely a convention, although it is recommended in order to make constants stand out and to help avoid collisions with other barewords, keywords, and -subroutine names. Constant names must begin with a letter. +subroutine names. Constant names must begin with a letter or +underscore. Names beginning with a double underscore are reserved. Some +poor choices for names will generate warnings, if warnings are enabled at +compile time. Constant symbols are package scoped (rather than block scoped, as C<use strict> is). That is, you can refer to a constant from package @@ -98,7 +207,24 @@ constants at compile time, allowing for way cool stuff like this. print E2BIG, "\n"; # something like "Arg list too long" print 0+E2BIG, "\n"; # "7" -Errors in dereferencing constant references are trapped at compile-time. +Dereferencing constant references incorrectly (such as using an array +subscript on a constant hash reference, or vice versa) will be trapped at +compile time. + +In the rare case in which you need to discover at run time whether a +particular constant has been declared via this module, you may use +this function to examine the hash C<%constant::declared>. If the given +constant name does not include a package name, the current package is +used. + + sub declared ($) { + use constant 1.01; # don't omit this! + my $name = shift; + $name =~ s/^::/main::/; + my $pkg = caller; + my $full_name = $name =~ /::/ ? $name : "${pkg}::$name"; + $constant::declared{$full_name}; + } =head1 TECHNICAL NOTE @@ -115,7 +241,19 @@ In the current version of Perl, list constants are not inlined and some symbols may be redefined without generating a warning. It is not possible to have a subroutine or keyword with the same -name as a constant. This is probably a Good Thing. +name as a constant in the same package. This is probably a Good Thing. + +A constant with a name in the list C<STDIN STDOUT STDERR ARGV ARGVOUT +ENV INC SIG> is not allowed anywhere but in package C<main::>, for +technical reasons. + +Even though a reference may be declared as a constant, the reference may +point to data which may be changed, as this code shows. + + use constant CARRAY => [ 1,2,3,4 ]; + print CARRAY->[1]; + CARRAY->[1] = " be changed"; + print CARRAY->[1]; Unlike constants in some languages, these cannot be overridden on the command line or via environment variables. @@ -126,61 +264,20 @@ For example, you can't say C<$hash{CONSTANT}> because C<CONSTANT> will be interpreted as a string. Use C<$hash{CONSTANT()}> or C<$hash{+CONSTANT}> to prevent the bareword quoting mechanism from kicking in. Similarly, since the C<=E<gt>> operator quotes a bareword -immediately to its left you have to say C<CONSTANT() =E<gt> 'value'> -instead of C<CONSTANT =E<gt> 'value'>. +immediately to its left, you have to say C<CONSTANT() =E<gt> 'value'> +(or simply use a comma in place of the big arrow) instead of +C<CONSTANT =E<gt> 'value'>. =head1 AUTHOR -Tom Phoenix, E<lt>F<rootbeer@teleport.com>E<gt>, with help from +Tom Phoenix, E<lt>F<rootbeer@redcat.com>E<gt>, with help from many other folks. =head1 COPYRIGHT -Copyright (C) 1997, Tom Phoenix +Copyright (C) 1997, 1999 Tom Phoenix This module is free software; you can redistribute it or modify it under the same terms as Perl itself. =cut - -use strict; -use Carp; -use vars qw($VERSION); - -#======================================================================= - -# Some of this stuff didn't work in version 5.003, alas. -require 5.003_96; - -#======================================================================= -# import() - import symbols into user's namespace -# -# What we actually do is define a function in the caller's namespace -# which returns the value. The function we create will normally -# be inlined as a constant, thereby avoiding further sub calling -# overhead. -#======================================================================= -sub import { - my $class = shift; - my $name = shift or return; # Ignore 'use constant;' - croak qq{Can't define "$name" as constant} . - qq{ (name contains invalid characters or is empty)} - unless $name =~ /^[^\W_0-9]\w*$/; - - my $pkg = caller; - { - no strict 'refs'; - if (@_ == 1) { - my $scalar = $_[0]; - *{"${pkg}::$name"} = sub () { $scalar }; - } elsif (@_) { - my @list = @_; - *{"${pkg}::$name"} = sub () { @list }; - } else { - *{"${pkg}::$name"} = sub () { }; - } - } - -} - -1; diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm index d405e3673e..e6a9127158 100755 --- a/lib/diagnostics.pm +++ b/lib/diagnostics.pm @@ -167,9 +167,11 @@ Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995. =cut -require 5.001; +require 5.005_64; use Carp; +$VERSION = v1.0; + use Config; ($privlib, $archlib) = @Config{qw(privlibexp archlibexp)}; if ($^O eq 'VMS') { @@ -179,10 +181,10 @@ if ($^O eq 'VMS') { } @trypod = ( "$archlib/pod/perldiag.pod", - "$privlib/pod/perldiag-$].pod", + "$privlib/pod/perldiag-$Config{version}.pod", "$privlib/pod/perldiag.pod", "$archlib/pods/perldiag.pod", - "$privlib/pods/perldiag-$].pod", + "$privlib/pods/perldiag-$Config{version}.pod", "$privlib/pods/perldiag.pod", ); # handy for development testing of new warnings etc @@ -333,7 +335,7 @@ EOFUNC # strip formatting directives in =item line ($header = $1) =~ s/[A-Z]<(.*?)>/$1/g; - if ($header =~ /%[sd]/) { + if ($header =~ /%[csd]/) { $rhs = $lhs = $header; #if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E\$/g) { if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E/g) { @@ -346,6 +348,7 @@ EOFUNC $lhs =~ s/\377//g; $lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all } + $lhs =~ s/\\%c/./g; $transmo .= " s{^$lhs}\n {\Q$rhs\E}s\n\t&& return 1;\n"; } else { $transmo .= " m{^\Q$header\E} && return 1;\n"; @@ -376,7 +379,8 @@ if ($standalone) { } exit; } else { - $old_w = 0; $oldwarn = ''; $olddie = ''; + #$old_w = 0; + $oldwarn = ''; $olddie = ''; } sub import { diff --git a/lib/lib.pm b/lib/lib.pm index d35510df86..afc979bb45 100644 --- a/lib/lib.pm +++ b/lib/lib.pm @@ -4,6 +4,7 @@ use vars qw(@ORIG_INC); use Config; my $archname = $Config{'archname'}; +my $ver = $Config{'version'}; @ORIG_INC = @INC; # take a handy copy of 'original' value @@ -26,7 +27,7 @@ sub import { # looks like $_ has an archlib directory below it. if (-d "$_/$archname") { unshift(@INC, "$_/$archname") if -d "$_/$archname/auto"; - unshift(@INC, "$_/$archname/$]") if -d "$_/$archname/$]/auto"; + unshift(@INC, "$_/$archname/$ver") if -d "$_/$archname/$ver/auto"; } } diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 2314bf7c3d..d2bd98e654 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.0403; +$VERSION = 1.04041; $header = "perl5db.pl version $VERSION"; # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) @@ -76,6 +76,8 @@ $header = "perl5db.pl version $VERSION"; # LineInfo - file or pipe to print line number info to. If it is a # pipe, a short "emacs like" message is used. # +# RemotePort - host:port to connect to on remote host for remote debugging. +# # Example $rcfile: (delete leading hashes!) # # &parse_options("NonStop=1 LineInfo=db.out"); @@ -179,7 +181,8 @@ $inhibit_exit = $option{PrintRet} = 1; TTY noTTY ReadLine NonStop LineInfo maxTraceLen recallCommand ShellBang pager tkRunning ornaments signalLevel warnLevel dieLevel inhibit_exit - ImmediateStop bareStringify); + ImmediateStop bareStringify + RemotePort); %optionVars = ( hashDepth => \$dumpvar::hashDepth, @@ -197,6 +200,7 @@ $inhibit_exit = $option{PrintRet} = 1; inhibit_exit => \$inhibit_exit, maxTraceLen => \$maxtrace, ImmediateStop => \$ImmediateStop, + RemotePort => \$remoteport, ); %optionAction = ( @@ -216,6 +220,7 @@ $inhibit_exit = $option{PrintRet} = 1; dieLevel => \&dieLevel, tkRunning => \&tkRunning, ornaments => \&ornaments, + RemotePort => \&RemotePort, ); %optionRequire = ( @@ -296,7 +301,7 @@ if ($notty) { #require Term::ReadLine; - if ($^O =~ /cygwin/) { + if ($^O eq 'cygwin') { # /dev/tty is binary. use stdin for textmode undef $console; } elsif (-e "/dev/tty") { @@ -322,19 +327,30 @@ if ($notty) { $console = $tty if defined $tty; - if (defined $console) { - open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN"); - open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR") - || open(OUT,">&STDOUT"); # so we don't dongle stdout - } else { - open(IN,"<&STDIN"); - open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout - $console = 'STDIN/OUT'; + if (defined $remoteport) { + require IO::Socket; + $OUT = new IO::Socket::INET( Timeout => '10', + PeerAddr => $remoteport, + Proto => 'tcp', + ); + if (!$OUT) { die "Could not create socket to connect to remote host."; } + $IN = $OUT; } - # so open("|more") can read from STDOUT and so we don't dingle stdin - $IN = \*IN; + else { + if (defined $console) { + open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN"); + open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR") + || open(OUT,">&STDOUT"); # so we don't dongle stdout + } else { + open(IN,"<&STDIN"); + open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout + $console = 'STDIN/OUT'; + } + # so open("|more") can read from STDOUT and so we don't dingle stdin + $IN = \*IN; - $OUT = \*OUT; + $OUT = \*OUT; + } select($OUT); $| = 1; # for DB::OUT select(STDOUT); @@ -434,7 +450,7 @@ Debugged program terminated. Use B<q> to quit or B<R> to restart, B<h q>, B<h R> or B<h O> to get additional info. EOP $package = 'main'; - $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' . + $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' . "package $package;"; # this won't let them modify, alas } else { $sub =~ s/\'/::/; @@ -1525,7 +1541,15 @@ sub readline { } local $frame = 0; local $doret = -2; - $term->readline(@_); + if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) { + print $OUT @_; + my $stuff; + $IN->recv( $stuff, 2048 ); + $stuff; + } + else { + $term->readline(@_); + } } sub dump_option { @@ -1673,6 +1697,14 @@ sub ReadLine { $rl; } +sub RemotePort { + if ($term) { + &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_; + } + $remoteport = shift if @_; + $remoteport; +} + sub tkRunning { if ($ {$term->Features}{tkRunning}) { return $term->tkRunning(@_); @@ -1823,6 +1855,7 @@ B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]... I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity; I<inhibit_exit> Allows stepping off the end of the script. I<ImmediateStop> Debugger should stop as early as possible. + I<RemotePort>: Remote hostname:port for remote debugging The following options affect what happens with B<V>, B<X>, and B<x> commands: I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all); I<compactDump>, I<veryCompact>: change style of array and hash dump; @@ -1839,7 +1872,8 @@ B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]... I<ornaments> affects screen appearance of the command line. During startup options are initialized from \$ENV{PERLDB_OPTS}. You can put additional initialization options I<TTY>, I<noTTY>, - I<ReadLine>, and I<NonStop> there (or use `B<R>' after you set them). + I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use + `B<R>' after you set them). B<<> I<expr> Define Perl command to run before each prompt. B<<<> I<expr> Add to the list of Perl commands to run before each prompt. B<>> I<expr> Define Perl command to run after each prompt. diff --git a/lib/strict.pm b/lib/strict.pm index 940e8bf7ff..99ed01d583 100644 --- a/lib/strict.pm +++ b/lib/strict.pm @@ -56,6 +56,9 @@ L<perlfunc/local>. The local() generated a compile-time error because you just touched a global name without fully qualifying it. +Because of their special use by sort(), the variables $a and $b are +exempted from this check. + =item C<strict subs> This disables the poetry optimization, generating a compile-time error if diff --git a/lib/unicode/UnicodeData-Latest.txt b/lib/unicode/Unicode.300 index 6a54d3d74e..6a54d3d74e 100644 --- a/lib/unicode/UnicodeData-Latest.txt +++ b/lib/unicode/Unicode.300 diff --git a/makedef.pl b/makedef.pl index 40c9be3a26..f640f2f2f7 100644 --- a/makedef.pl +++ b/makedef.pl @@ -38,14 +38,13 @@ my %bincompat5005 = my $bincompat5005 = join("|", keys %bincompat5005); -while (@ARGV) - { - my $flag = shift; - $define{$1} = 1 if ($flag =~ /^-D(\w+)$/); - $define{$1} = $2 if ($flag =~ /^-D(\w+)=(.+)$/); - $CCTYPE = $1 if ($flag =~ /^CCTYPE=(\w+)$/); - $PLATFORM = $1 if ($flag =~ /^PLATFORM=(\w+)$/); - } +while (@ARGV) { + my $flag = shift; + $define{$1} = 1 if ($flag =~ /^-D(\w+)$/); + $define{$1} = $2 if ($flag =~ /^-D(\w+)=(.+)$/); + $CCTYPE = $1 if ($flag =~ /^CCTYPE=(\w+)$/); + $PLATFORM = $1 if ($flag =~ /^PLATFORM=(\w+)$/); +} my @PLATFORM = qw(aix win32 os2); my %PLATFORM; @@ -66,7 +65,8 @@ my $perlio_sym = "perlio.sym"; if ($PLATFORM eq 'aix') { # Nothing for now. -} elsif ($PLATFORM eq 'win32') { +} +elsif ($PLATFORM eq 'win32') { $CCTYPE = "MSVC" unless defined $CCTYPE; foreach ($thrdvar_h, $intrpvar_h, $perlvars_h, $global_sym, $pp_sym, $globvar_sym) { s!^!..\\!; @@ -75,8 +75,7 @@ if ($PLATFORM eq 'aix') { unless ($PLATFORM eq 'win32') { open(CFG,$config_sh) || die "Cannot open $config_sh: $!\n"; - while (<CFG>) - { + while (<CFG>) { if (/^(?:ccflags|optimize)='(.+)'$/) { $_ = $1; $define{$1} = 1 while /-D(\w+)/g; @@ -90,14 +89,14 @@ unless ($PLATFORM eq 'win32') { } open(CFG,$config_h) || die "Cannot open $config_h: $!\n"; -while (<CFG>) - { - $define{$1} = 1 if /^\s*#\s*define\s+(MYMALLOC)\b/; - $define{$1} = 1 if /^\s*#\s*define\s+(USE_THREADS)\b/; - $define{$1} = 1 if /^\s*#\s*define\s+(USE_PERLIO)\b/; - $define{$1} = 1 if /^\s*#\s*define\s+(MULTIPLICITY)\b/; - $define{$1} = 1 if /^\s*#\s*define\s+(PERL_BINCOMPAT_5005)\b/; - } +while (<CFG>) { + $define{$1} = 1 if /^\s*#\s*define\s+(MYMALLOC)\b/; + $define{$1} = 1 if /^\s*#\s*define\s+(USE_5005THREADS)\b/; + $define{$1} = 1 if /^\s*#\s*define\s+(USE_ITHREADS)\b/; + $define{$1} = 1 if /^\s*#\s*define\s+(USE_PERLIO)\b/; + $define{$1} = 1 if /^\s*#\s*define\s+(MULTIPLICITY)\b/; + $define{$1} = 1 if /^\s*#\s*define\s+(PERL_BINCOMPAT_5005)\b/; +} close(CFG); if ($PLATFORM eq 'win32') { @@ -108,7 +107,7 @@ if ($PLATFORM eq 'win32') { print "EXPORTS\n"; # output_symbol("perl_alloc"); output_symbol("perl_get_host_info"); - output_symbol("perl_alloc_using"); + output_symbol("perl_alloc_override"); # output_symbol("perl_construct"); # output_symbol("perl_destruct"); # output_symbol("perl_free"); @@ -118,17 +117,12 @@ if ($PLATFORM eq 'win32') { # exit(0); } else { - if ($CCTYPE ne 'GCC') { - print "LIBRARY Perl\n"; - print "DESCRIPTION 'Perl interpreter, export autogenerated'\n"; - } - else { - $define{'PERL_GLOBAL_STRUCT'} = 1; - $define{'MULTIPLICITY'} = 1; - } + print "LIBRARY Perl\n"; + print "DESCRIPTION 'Perl interpreter, export autogenerated'\n"; print "EXPORTS\n"; } -} elsif ($PLATFORM eq 'os2') { +} +elsif ($PLATFORM eq 'os2') { ($v = $]) =~ s/(\d\.\d\d\d)(\d\d)$/$1_$2/; $v .= '-thread' if $ARCHNAME =~ /-thread/; #$sum = 0; @@ -149,7 +143,8 @@ CODE LOADONCALL DATA LOADONCALL NONSHARED MULTIPLE EXPORTS ---EOP--- -} elsif ($PLATFORM eq 'aix') { +} +elsif ($PLATFORM eq 'aix') { print "#!\n"; } @@ -176,318 +171,319 @@ sub emit_symbols { } if ($PLATFORM eq 'win32') { -skip_symbols [qw( -PL_statusvalue_vms -PL_archpat_auto -PL_cryptseen -PL_DBcv -PL_generation -PL_lastgotoprobe -PL_linestart -PL_modcount -PL_pending_ident -PL_sortcxix -PL_sublex_info -PL_timesbuf -main -Perl_ErrorNo -Perl_GetVars -Perl_do_exec3 -Perl_do_ipcctl -Perl_do_ipcget -Perl_do_msgrcv -Perl_do_msgsnd -Perl_do_semop -Perl_do_shmio -Perl_dump_fds -Perl_init_thread_intern -Perl_my_bzero -Perl_my_htonl -Perl_my_ntohl -Perl_my_swap -Perl_my_chsize -Perl_same_dirent -Perl_setenv_getix -Perl_unlnk -Perl_watch -Perl_safexcalloc -Perl_safexmalloc -Perl_safexfree -Perl_safexrealloc -Perl_my_memcmp -Perl_my_memset -PL_cshlen -PL_cshname -PL_opsave - -Perl_do_exec -Perl_getenv_len -Perl_my_pclose -Perl_my_popen -)]; -} elsif ($PLATFORM eq 'aix') { + skip_symbols [qw( + PL_statusvalue_vms + PL_archpat_auto + PL_cryptseen + PL_DBcv + PL_generation + PL_lastgotoprobe + PL_linestart + PL_modcount + PL_pending_ident + PL_sortcxix + PL_sublex_info + PL_timesbuf + main + Perl_ErrorNo + Perl_GetVars + Perl_do_exec3 + Perl_do_ipcctl + Perl_do_ipcget + Perl_do_msgrcv + Perl_do_msgsnd + Perl_do_semop + Perl_do_shmio + Perl_dump_fds + Perl_init_thread_intern + Perl_my_bzero + Perl_my_htonl + Perl_my_ntohl + Perl_my_swap + Perl_my_chsize + Perl_same_dirent + Perl_setenv_getix + Perl_unlnk + Perl_watch + Perl_safexcalloc + Perl_safexmalloc + Perl_safexfree + Perl_safexrealloc + Perl_my_memcmp + Perl_my_memset + PL_cshlen + PL_cshname + PL_opsave + Perl_do_exec + Perl_getenv_len + Perl_my_pclose + Perl_my_popen + )]; +} +elsif ($PLATFORM eq 'aix') { skip_symbols([qw( -Perl_dump_fds -Perl_ErrorNo -Perl_GetVars -Perl_my_bcopy -Perl_my_bzero -Perl_my_chsize -Perl_my_htonl -Perl_my_memcmp -Perl_my_memset -Perl_my_ntohl -Perl_my_swap -Perl_safexcalloc -Perl_safexfree -Perl_safexmalloc -Perl_safexrealloc -Perl_same_dirent -Perl_unlnk -PL_cryptseen -PL_opsave -PL_statusvalue_vms -PL_sys_intern -)]); -} - -if ($PLATFORM eq 'os2') { + Perl_dump_fds + Perl_ErrorNo + Perl_GetVars + Perl_my_bcopy + Perl_my_bzero + Perl_my_chsize + Perl_my_htonl + Perl_my_memcmp + Perl_my_memset + Perl_my_ntohl + Perl_my_swap + Perl_safexcalloc + Perl_safexfree + Perl_safexmalloc + Perl_safexrealloc + Perl_same_dirent + Perl_unlnk + PL_cryptseen + PL_opsave + PL_statusvalue_vms + PL_sys_intern + )]); +} +elsif ($PLATFORM eq 'os2') { emit_symbols([qw( -ctermid -get_sysinfo -Perl_OS2_init -OS2_Perl_data -dlopen -dlsym -dlerror -my_tmpfile -my_tmpnam -my_flock -malloc_mutex -threads_mutex -nthreads -nthreads_cond -os2_cond_wait -os2_stat -pthread_join -pthread_create -pthread_detach -XS_Cwd_change_drive -XS_Cwd_current_drive -XS_Cwd_extLibpath -XS_Cwd_extLibpath_set -XS_Cwd_sys_abspath -XS_Cwd_sys_chdir -XS_Cwd_sys_cwd -XS_Cwd_sys_is_absolute -XS_Cwd_sys_is_relative -XS_Cwd_sys_is_rooted -XS_DynaLoader_mod2fname -XS_File__Copy_syscopy -Perl_Register_MQ -Perl_Deregister_MQ -Perl_Serve_Messages -Perl_Process_Messages -init_PMWIN_entries -PMWIN_entries -Perl_hab_GET -)]); + ctermid + get_sysinfo + Perl_OS2_init + OS2_Perl_data + dlopen + dlsym + dlerror + my_tmpfile + my_tmpnam + my_flock + malloc_mutex + threads_mutex + nthreads + nthreads_cond + os2_cond_wait + os2_stat + pthread_join + pthread_create + pthread_detach + XS_Cwd_change_drive + XS_Cwd_current_drive + XS_Cwd_extLibpath + XS_Cwd_extLibpath_set + XS_Cwd_sys_abspath + XS_Cwd_sys_chdir + XS_Cwd_sys_cwd + XS_Cwd_sys_is_absolute + XS_Cwd_sys_is_relative + XS_Cwd_sys_is_rooted + XS_DynaLoader_mod2fname + XS_File__Copy_syscopy + Perl_Register_MQ + Perl_Deregister_MQ + Perl_Serve_Messages + Perl_Process_Messages + init_PMWIN_entries + PMWIN_entries + Perl_hab_GET + )]); } -if ($define{'PERL_OBJECT'}) { - skip_symbols [qw( - Perl_getenv_len - Perl_my_popen - Perl_my_pclose - )]; +unless ($define{'DEBUGGING'}) { + skip_symbols [qw( + Perl_deb + Perl_deb_growlevel + Perl_debop + Perl_debprofdump + Perl_debstack + Perl_debstackptrs + Perl_runops_debug + Perl_sv_peek + PL_block_type + PL_watchaddr + PL_watchok + )]; +} + +if ($define{'PERL_IMPLICIT_SYS'}) { + skip_symbols [qw( + Perl_getenv_len + Perl_my_popen + Perl_my_pclose + )]; } else { - skip_symbols [qw( - PL_Dir - PL_Env - PL_LIO - PL_Mem - PL_Proc - PL_Sock - PL_StdIO - )]; -} - -if ($define{'MYMALLOC'}) - { - emit_symbols [qw( - Perl_dump_mstats - Perl_malloc - Perl_mfree - Perl_realloc - Perl_calloc)]; - } -else - { - skip_symbols [qw( - Perl_dump_mstats - Perl_malloc - Perl_mfree - Perl_realloc - Perl_calloc - Perl_malloced_size)]; - } - -unless ($define{'USE_THREADS'}) - { - skip_symbols [qw( -PL_thr_key -PL_sv_mutex -PL_strtab_mutex -PL_svref_mutex -PL_malloc_mutex -PL_cred_mutex -PL_eval_mutex -PL_eval_cond -PL_eval_owner -PL_threads_mutex -PL_nthreads -PL_nthreads_cond -PL_threadnum -PL_threadsv_names -PL_thrsv -PL_vtbl_mutex -Perl_getTHR -Perl_setTHR -Perl_condpair_magic -Perl_new_struct_thread -Perl_per_thread_magicals -Perl_thread_create -Perl_find_threadsv -Perl_unlock_condpair -Perl_magic_mutexfree -)]; - } - -unless ($define{'USE_ITHREADS'}) - { - skip_symbols [qw( -PL_ptr_table -Perl_dirp_dup -Perl_cx_dup -Perl_si_dup -Perl_ss_dup -Perl_fp_dup -Perl_gp_dup -Perl_he_dup -Perl_mg_dup -Perl_re_dup -Perl_sv_dup -Perl_sys_intern_dup -Perl_ptr_table_fetch -Perl_ptr_table_new -Perl_ptr_table_split -Perl_ptr_table_store -perl_clone -perl_clone_using -)]; - } - -unless ($define{'USE_THREADS'} or $define{'PERL_IMPLICIT_CONTEXT'} - or $define{'PERL_OBJECT'}) -{ - skip_symbols [qw( - Perl_croak_nocontext - Perl_die_nocontext - Perl_deb_nocontext - Perl_form_nocontext - Perl_mess_nocontext - Perl_warn_nocontext - Perl_warner_nocontext - Perl_newSVpvf_nocontext - Perl_sv_catpvf_nocontext - Perl_sv_setpvf_nocontext - Perl_sv_catpvf_mg_nocontext - Perl_sv_setpvf_mg_nocontext - )]; - } - -unless ($define{'FAKE_THREADS'}) - { - skip_symbols [qw(PL_curthr)]; - } - -sub readvar -{ - my $file = shift; - my $proc = shift || sub { "PL_$_[2]" }; - open(VARS,$file) || die "Cannot open $file: $!\n"; - my @syms; - while (<VARS>) - { - # All symbols have a Perl_ prefix because that's what embed.h - # sticks in front of them. - push(@syms, &$proc($1,$2,$3)) if (/\bPERLVAR(A?I?C?)\(([IGT])(\w+)/); - } - close(VARS); - return \@syms; -} - -if ($define{'USE_THREADS'} || $define{'MULTIPLICITY'}) - { - my $thrd = readvar($thrdvar_h); - skip_symbols $thrd; - } - -if ($define{'MULTIPLICITY'}) - { - my $interp = readvar($intrpvar_h); - skip_symbols $interp; - } - -if ($define{'PERL_GLOBAL_STRUCT'}) - { - my $global = readvar($perlvars_h); - skip_symbols $global; - emit_symbol('Perl_GetVars'); - emit_symbols [qw(PL_Vars PL_VarsPtr)] unless $CCTYPE eq 'GCC'; - } - -unless ($define{'DEBUGGING'}) - { - skip_symbols [qw( - Perl_deb - Perl_deb_growlevel - Perl_debop - Perl_debprofdump - Perl_debstack - Perl_debstackptrs - Perl_runops_debug - Perl_sv_peek - PL_block_type - PL_watchaddr - PL_watchok)]; - } + skip_symbols [qw( + PL_Mem + PL_MemShared + PL_MemParse + PL_Env + PL_StdIO + PL_LIO + PL_Dir + PL_Sock + PL_Proc + )]; +} + +if ($define{'MYMALLOC'}) { + emit_symbols [qw( + Perl_dump_mstats + Perl_malloc + Perl_mfree + Perl_realloc + Perl_calloc + )]; + if ($define{'USE_5005THREADS'} || $define{'USE_ITHREADS'}) { + emit_symbols [qw( + PL_malloc_mutex + )]; + } +} +else { + skip_symbols [qw( + PL_malloc_mutex + Perl_dump_mstats + Perl_malloc + Perl_mfree + Perl_realloc + Perl_calloc + Perl_malloced_size + )]; +} + +unless ($define{'USE_5005THREADS'}) { + skip_symbols [qw( + PL_thr_key + PL_sv_mutex + PL_strtab_mutex + PL_svref_mutex + PL_cred_mutex + PL_eval_mutex + PL_eval_cond + PL_eval_owner + PL_threads_mutex + PL_nthreads + PL_nthreads_cond + PL_threadnum + PL_threadsv_names + PL_thrsv + PL_vtbl_mutex + Perl_getTHR + Perl_setTHR + Perl_condpair_magic + Perl_new_struct_thread + Perl_per_thread_magicals + Perl_thread_create + Perl_find_threadsv + Perl_unlock_condpair + Perl_magic_mutexfree + )]; +} + +unless ($define{'USE_ITHREADS'}) { + skip_symbols [qw( + PL_ptr_table + Perl_dirp_dup + Perl_cx_dup + Perl_si_dup + Perl_any_dup + Perl_ss_dup + Perl_fp_dup + Perl_gp_dup + Perl_he_dup + Perl_mg_dup + Perl_re_dup + Perl_sv_dup + Perl_sys_intern_dup + Perl_ptr_table_fetch + Perl_ptr_table_new + Perl_ptr_table_split + Perl_ptr_table_store + perl_clone + perl_clone_using + )]; +} + +unless ($define{'PERL_IMPLICIT_CONTEXT'}) { + skip_symbols [qw( + Perl_croak_nocontext + Perl_die_nocontext + Perl_deb_nocontext + Perl_form_nocontext + Perl_mess_nocontext + Perl_warn_nocontext + Perl_warner_nocontext + Perl_newSVpvf_nocontext + Perl_sv_catpvf_nocontext + Perl_sv_setpvf_nocontext + Perl_sv_catpvf_mg_nocontext + Perl_sv_setpvf_mg_nocontext + )]; +} + +unless ($define{'PERL_IMPLICIT_SYS'}) { + skip_symbols [qw( + perl_alloc_using + perl_clone_using + )]; +} + +unless ($define{'FAKE_THREADS'}) { + skip_symbols [qw(PL_curthr)]; +} + +sub readvar { + my $file = shift; + my $proc = shift || sub { "PL_$_[2]" }; + open(VARS,$file) || die "Cannot open $file: $!\n"; + my @syms; + while (<VARS>) { + # All symbols have a Perl_ prefix because that's what embed.h + # sticks in front of them. + push(@syms, &$proc($1,$2,$3)) if (/\bPERLVAR(A?I?C?)\(([IGT])(\w+)/); + } + close(VARS); + return \@syms; +} + +if ($define{'USE_5005THREADS'} || $define{'MULTIPLICITY'}) { + my $thrd = readvar($thrdvar_h); + skip_symbols $thrd; +} + +if ($define{'MULTIPLICITY'}) { + my $interp = readvar($intrpvar_h); + skip_symbols $interp; +} + +if ($define{'PERL_GLOBAL_STRUCT'}) { + my $global = readvar($perlvars_h); + skip_symbols $global; + emit_symbol('Perl_GetVars'); + emit_symbols [qw(PL_Vars PL_VarsPtr)] unless $CCTYPE eq 'GCC'; +} # functions from *.sym files my @syms = ($global_sym, $pp_sym, $globvar_sym); -if ($define{'USE_PERLIO'}) - { +if ($define{'USE_PERLIO'}) { push @syms, $perlio_sym; - } - -for my $syms (@syms) - { - open (GLOBAL, "<$syms") || die "failed to open $syms: $!\n"; - while (<GLOBAL>) - { - next if (!/^[A-Za-z]/); - # Functions have a Perl_ prefix - # Variables have a PL_ prefix - chomp($_); - my $symbol = ($syms =~ /var\.sym$/i ? "PL_" : ""); - $symbol .= $_; - emit_symbol($symbol) unless exists $skip{$symbol}; - } - close(GLOBAL); - } +} + +for my $syms (@syms) { + open (GLOBAL, "<$syms") || die "failed to open $syms: $!\n"; + while (<GLOBAL>) { + next if (!/^[A-Za-z]/); + # Functions have a Perl_ prefix + # Variables have a PL_ prefix + chomp($_); + my $symbol = ($syms =~ /var\.sym$/i ? "PL_" : ""); + $symbol .= $_; + emit_symbol($symbol) unless exists $skip{$symbol}; + } + close(GLOBAL); +} # variables @@ -506,8 +502,7 @@ else { my $glob = readvar($intrpvar_h); emit_symbols $glob; } - - unless ($define{'MULTIPLICITY'} || $define{'USE_THREADS'}) { + unless ($define{'MULTIPLICITY'} || $define{'USE_5005THREADS'}) { my $glob = readvar($thrdvar_h); emit_symbols $glob; } @@ -530,178 +525,184 @@ while (<DATA>) { if ($PLATFORM eq 'win32') { foreach my $symbol (qw( -boot_DynaLoader -Perl_getTHR -Perl_init_os_extras -Perl_setTHR -Perl_thread_create -Perl_win32_init -RunPerl -GetPerlInterpreter -SetPerlInterpreter -win32_errno -win32_environ -win32_stdin -win32_stdout -win32_stderr -win32_ferror -win32_feof -win32_strerror -win32_fprintf -win32_printf -win32_vfprintf -win32_vprintf -win32_fread -win32_fwrite -win32_fopen -win32_fdopen -win32_freopen -win32_fclose -win32_fputs -win32_fputc -win32_ungetc -win32_getc -win32_fileno -win32_clearerr -win32_fflush -win32_ftell -win32_fseek -win32_fgetpos -win32_fsetpos -win32_rewind -win32_tmpfile -win32_abort -win32_fstat -win32_stat -win32_pipe -win32_popen -win32_pclose -win32_rename -win32_setmode -win32_lseek -win32_tell -win32_dup -win32_dup2 -win32_open -win32_close -win32_eof -win32_read -win32_write -win32_spawnvp -win32_mkdir -win32_rmdir -win32_chdir -win32_flock -win32_execv -win32_execvp -win32_htons -win32_ntohs -win32_htonl -win32_ntohl -win32_inet_addr -win32_inet_ntoa -win32_socket -win32_bind -win32_listen -win32_accept -win32_connect -win32_send -win32_sendto -win32_recv -win32_recvfrom -win32_shutdown -win32_closesocket -win32_ioctlsocket -win32_setsockopt -win32_getsockopt -win32_getpeername -win32_getsockname -win32_gethostname -win32_gethostbyname -win32_gethostbyaddr -win32_getprotobyname -win32_getprotobynumber -win32_getservbyname -win32_getservbyport -win32_select -win32_endhostent -win32_endnetent -win32_endprotoent -win32_endservent -win32_getnetent -win32_getnetbyname -win32_getnetbyaddr -win32_getprotoent -win32_getservent -win32_sethostent -win32_setnetent -win32_setprotoent -win32_setservent -win32_getenv -win32_putenv -win32_perror -win32_setbuf -win32_setvbuf -win32_flushall -win32_fcloseall -win32_fgets -win32_gets -win32_fgetc -win32_putc -win32_puts -win32_getchar -win32_putchar -win32_malloc -win32_calloc -win32_realloc -win32_free -win32_sleep -win32_times -win32_alarm -win32_open_osfhandle -win32_get_osfhandle -win32_ioctl -win32_utime -win32_uname -win32_wait -win32_waitpid -win32_kill -win32_str_os_error -win32_opendir -win32_readdir -win32_telldir -win32_seekdir -win32_rewinddir -win32_closedir -win32_longpath -win32_os_id -win32_crypt - )) { + boot_DynaLoader + Perl_getTHR + Perl_init_os_extras + Perl_setTHR + Perl_thread_create + Perl_win32_init + RunPerl + GetPerlInterpreter + SetPerlInterpreter + win32_errno + win32_environ + win32_stdin + win32_stdout + win32_stderr + win32_ferror + win32_feof + win32_strerror + win32_fprintf + win32_printf + win32_vfprintf + win32_vprintf + win32_fread + win32_fwrite + win32_fopen + win32_fdopen + win32_freopen + win32_fclose + win32_fputs + win32_fputc + win32_ungetc + win32_getc + win32_fileno + win32_clearerr + win32_fflush + win32_ftell + win32_fseek + win32_fgetpos + win32_fsetpos + win32_rewind + win32_tmpfile + win32_abort + win32_fstat + win32_stat + win32_pipe + win32_popen + win32_pclose + win32_rename + win32_setmode + win32_lseek + win32_tell + win32_dup + win32_dup2 + win32_open + win32_close + win32_eof + win32_read + win32_write + win32_spawnvp + win32_mkdir + win32_rmdir + win32_chdir + win32_flock + win32_execv + win32_execvp + win32_htons + win32_ntohs + win32_htonl + win32_ntohl + win32_inet_addr + win32_inet_ntoa + win32_socket + win32_bind + win32_listen + win32_accept + win32_connect + win32_send + win32_sendto + win32_recv + win32_recvfrom + win32_shutdown + win32_closesocket + win32_ioctlsocket + win32_setsockopt + win32_getsockopt + win32_getpeername + win32_getsockname + win32_gethostname + win32_gethostbyname + win32_gethostbyaddr + win32_getprotobyname + win32_getprotobynumber + win32_getservbyname + win32_getservbyport + win32_select + win32_endhostent + win32_endnetent + win32_endprotoent + win32_endservent + win32_getnetent + win32_getnetbyname + win32_getnetbyaddr + win32_getprotoent + win32_getservent + win32_sethostent + win32_setnetent + win32_setprotoent + win32_setservent + win32_getenv + win32_putenv + win32_perror + win32_setbuf + win32_setvbuf + win32_flushall + win32_fcloseall + win32_fgets + win32_gets + win32_fgetc + win32_putc + win32_puts + win32_getchar + win32_putchar + win32_malloc + win32_calloc + win32_realloc + win32_free + win32_sleep + win32_times + win32_access + win32_alarm + win32_chmod + win32_open_osfhandle + win32_get_osfhandle + win32_ioctl + win32_link + win32_unlink + win32_utime + win32_uname + win32_wait + win32_waitpid + win32_kill + win32_str_os_error + win32_opendir + win32_readdir + win32_telldir + win32_seekdir + win32_rewinddir + win32_closedir + win32_longpath + win32_os_id + win32_getpid + win32_crypt + win32_dynaload + )) + { try_symbol($symbol); } } elsif ($PLATFORM eq 'os2') { - open MAP, 'miniperl.map' or die 'Cannot read miniperl.map'; - /^\s*[\da-f:]+\s+(\w+)/i and $mapped{$1}++ foreach <MAP>; - close MAP or die 'Cannot close miniperl.map'; - - @missing = grep { !exists $mapped{$_} and !exists $bincompat5005{$_} } - keys %export; - delete $export{$_} foreach @missing; + open MAP, 'miniperl.map' or die 'Cannot read miniperl.map'; + /^\s*[\da-f:]+\s+(\w+)/i and $mapped{$1}++ foreach <MAP>; + close MAP or die 'Cannot close miniperl.map'; + + @missing = grep { !exists $mapped{$_} and !exists $bincompat5005{$_} } + keys %export; + delete $export{$_} foreach @missing; } # Now all symbols should be defined because # next we are going to output them. -foreach my $symbol (sort keys %export) - { - output_symbol($symbol); - } +foreach my $symbol (sort keys %export) { + output_symbol($symbol); +} sub emit_symbol { - my $symbol = shift; - chomp($symbol); - $export{$symbol} = 1; + my $symbol = shift; + chomp($symbol); + $export{$symbol} = 1; } sub output_symbol { @@ -732,9 +733,11 @@ sub output_symbol { # print "\t$symbol\n"; # print "\t_$symbol = $symbol\n"; # } - } elsif ($PLATFORM eq 'os2') { + } + elsif ($PLATFORM eq 'os2') { print qq( "$symbol"\n); - } elsif ($PLATFORM eq 'aix') { + } + elsif ($PLATFORM eq 'aix') { print "$symbol\n"; } } @@ -743,6 +746,9 @@ sub output_symbol { __DATA__ # extra globals not included above. perl_alloc +perl_alloc_using +perl_clone +perl_clone_using perl_construct perl_destruct perl_free diff --git a/makedepend.SH b/makedepend.SH index f03f68b503..994123ecd1 100755 --- a/makedepend.SH +++ b/makedepend.SH @@ -130,6 +130,9 @@ for file in `$cat .clist`; do -e 's|\\$||' \ -e p \ -e '}' ) >UU/$file.c + if [ "$osname" = os390 -a "$file" = perly.c ]; then + $echo '#endif' >>UU/$file.c + fi $cppstdin $finc -I. $cppflags $cppminus <UU/$file.c | $sed \ -e '/^#.*<stdin>/d' \ @@ -406,6 +406,9 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '\004': /* ^D */ sv_setiv(sv, (IV)(PL_debug & 32767)); +#if defined(YYDEBUG) && defined(DEBUGGING) + PL_yydebug = (PL_debug & 1); +#endif break; case '\005': /* ^E */ #ifdef MACOS_TRADITIONAL @@ -822,7 +825,10 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) #if defined(VMS) Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); #else -# ifdef WIN32 +# ifdef PERL_IMPLICIT_SYS + PerlEnv_clearenv(); +# else +# ifdef WIN32 char *envv = GetEnvironmentStrings(); char *cur = envv; STRLEN len; @@ -838,13 +844,13 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) cur += len+1; } FreeEnvironmentStrings(envv); -# else -# ifdef CYGWIN +# else +# ifdef CYGWIN I32 i; for (i = 0; environ[i]; i++) - Safefree(environ[i]); -# else -# ifndef PERL_USE_SAFE_PUTENV + safesysfree(environ[i]); +# else +# ifndef PERL_USE_SAFE_PUTENV I32 i; if (environ == PL_origenviron) @@ -852,12 +858,13 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) else for (i = 0; environ[i]; i++) safesysfree(environ[i]); -# endif /* PERL_USE_SAFE_PUTENV */ -# endif /* CYGWIN */ +# endif /* PERL_USE_SAFE_PUTENV */ +# endif /* CYGWIN */ environ[0] = Nullch; -# endif /* WIN32 */ +# endif /* WIN32 */ +# endif /* PERL_IMPLICIT_SYS */ #endif /* VMS */ return 0; } @@ -1182,7 +1189,7 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) i = SvTRUE(sv); svp = av_fetch(GvAV(gv), atoi(MgPV(mg,n_a)), FALSE); - if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp))) + if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) o->op_private = i; else if (ckWARN_d(WARN_INTERNAL)) Perl_warner(aTHX_ WARN_INTERNAL, "Can't break at that line\n"); @@ -1664,7 +1671,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) case '.': if (PL_localizing) { if (PL_localizing == 1) - save_sptr((SV**)&PL_last_in_gv); + SAVESPTR(PL_last_in_gv); } else if (SvOK(sv) && GvIO(PL_last_in_gv)) IoLINES(GvIOp(PL_last_in_gv)) = (long)SvIV(sv); diff --git a/mpeix/mpeixish.h b/mpeix/mpeixish.h index 23111718ff..b5e4fa4455 100644 --- a/mpeix/mpeixish.h +++ b/mpeix/mpeixish.h @@ -97,7 +97,7 @@ #ifndef SIGILL # define SIGILL 6 /* blech */ #endif -#define ABORT() kill(getpid(),SIGABRT); +#define ABORT() kill(PerlProc_getpid(),SIGABRT); /* * fwrite1() should be a routine with the same calling sequence as fwrite(), diff --git a/myconfig.SH b/myconfig.SH index 83de2faeca..dc76e73175 100644 --- a/myconfig.SH +++ b/myconfig.SH @@ -33,8 +33,9 @@ Summary of my $package (revision $baserev version $PERL_VERSION subversion $PERL uname='$myuname' config_args='$config_args' hint=$hint, useposix=$useposix, d_sigaction=$d_sigaction - usethreads=$usethreads useperlio=$useperlio d_sfio=$d_sfio - use64bits=$use64bits usemultiplicity=$usemultiplicity + usethreads=$usethreads use5005threads=$use5005threads useithreads=$useithreads + usesocks=$usesocks useperlio=$useperlio d_sfio=$d_sfio + use64bits=$use64bits uselargefiles=$uselargefiles usemultiplicity=$usemultiplicity Compiler: cc='$cc', optimize='$optimize', gccversion=$gccversion cppflags='$cppflags' @@ -34,6 +34,10 @@ #define PL_LIO (*Perl_ILIO_ptr(aTHXo)) #undef PL_Mem #define PL_Mem (*Perl_IMem_ptr(aTHXo)) +#undef PL_MemParse +#define PL_MemParse (*Perl_IMemParse_ptr(aTHXo)) +#undef PL_MemShared +#define PL_MemShared (*Perl_IMemShared_ptr(aTHXo)) #undef PL_Proc #define PL_Proc (*Perl_IProc_ptr(aTHXo)) #undef PL_Sock @@ -44,8 +48,6 @@ #define PL_amagic_generation (*Perl_Iamagic_generation_ptr(aTHXo)) #undef PL_an #define PL_an (*Perl_Ian_ptr(aTHXo)) -#undef PL_archpat_auto -#define PL_archpat_auto (*Perl_Iarchpat_auto_ptr(aTHXo)) #undef PL_argvgv #define PL_argvgv (*Perl_Iargvgv_ptr(aTHXo)) #undef PL_argvout_stack @@ -144,6 +146,8 @@ #define PL_eval_start (*Perl_Ieval_start_ptr(aTHXo)) #undef PL_evalseq #define PL_evalseq (*Perl_Ievalseq_ptr(aTHXo)) +#undef PL_exit_flags +#define PL_exit_flags (*Perl_Iexit_flags_ptr(aTHXo)) #undef PL_exitlist #define PL_exitlist (*Perl_Iexitlist_ptr(aTHXo)) #undef PL_exitlistlen @@ -224,8 +228,6 @@ #define PL_lex_dojoin (*Perl_Ilex_dojoin_ptr(aTHXo)) #undef PL_lex_expect #define PL_lex_expect (*Perl_Ilex_expect_ptr(aTHXo)) -#undef PL_lex_fakebrack -#define PL_lex_fakebrack (*Perl_Ilex_fakebrack_ptr(aTHXo)) #undef PL_lex_formbrack #define PL_lex_formbrack (*Perl_Ilex_formbrack_ptr(aTHXo)) #undef PL_lex_inpat @@ -366,6 +368,10 @@ #define PL_preprocess (*Perl_Ipreprocess_ptr(aTHXo)) #undef PL_profiledata #define PL_profiledata (*Perl_Iprofiledata_ptr(aTHXo)) +#undef PL_psig_name +#define PL_psig_name (*Perl_Ipsig_name_ptr(aTHXo)) +#undef PL_psig_ptr +#define PL_psig_ptr (*Perl_Ipsig_ptr_ptr(aTHXo)) #undef PL_ptr_table #define PL_ptr_table (*Perl_Iptr_table_ptr(aTHXo)) #undef PL_replgv @@ -809,7 +815,21 @@ /* XXX soon to be eliminated, only a few things in PERLCORE need these now */ +#if defined(PERL_IMPLICIT_SYS) +#else +#endif +#if defined(USE_ITHREADS) +# if defined(PERL_IMPLICIT_SYS) +# endif +#endif +#if defined(MYMALLOC) +#endif #if defined(PERL_OBJECT) +#ifndef __BORLANDC__ +#endif +#endif +#if defined(PERL_OBJECT) +#else #endif #undef Perl_amagic_call #define Perl_amagic_call pPerl->Perl_amagic_call @@ -831,6 +851,10 @@ #define Perl_apply pPerl->Perl_apply #undef apply #define apply Perl_apply +#undef Perl_avhv_delete_ent +#define Perl_avhv_delete_ent pPerl->Perl_avhv_delete_ent +#undef avhv_delete_ent +#define avhv_delete_ent Perl_avhv_delete_ent #undef Perl_avhv_exists_ent #define Perl_avhv_exists_ent pPerl->Perl_avhv_exists_ent #undef avhv_exists_ent @@ -855,6 +879,14 @@ #define Perl_av_clear pPerl->Perl_av_clear #undef av_clear #define av_clear Perl_av_clear +#undef Perl_av_delete +#define Perl_av_delete pPerl->Perl_av_delete +#undef av_delete +#define av_delete Perl_av_delete +#undef Perl_av_exists +#define Perl_av_exists pPerl->Perl_av_exists +#undef av_exists +#define av_exists Perl_av_exists #undef Perl_av_extend #define Perl_av_extend pPerl->Perl_av_extend #undef av_extend @@ -1983,12 +2015,6 @@ #define Perl_magicname pPerl->Perl_magicname #undef magicname #define magicname Perl_magicname -#if defined(MYMALLOC) -#undef Perl_malloced_size -#define Perl_malloced_size pPerl->Perl_malloced_size -#undef malloced_size -#define malloced_size Perl_malloced_size -#endif #undef Perl_markstack_grow #define Perl_markstack_grow pPerl->Perl_markstack_grow #undef markstack_grow @@ -2404,36 +2430,23 @@ #undef peep #define peep Perl_peep #if defined(PERL_OBJECT) -#undef perl_construct -#define perl_construct pPerl->perl_construct -#undef perl_destruct -#define perl_destruct pPerl->perl_destruct -#undef perl_free -#define perl_free pPerl->perl_free -#undef perl_run -#define perl_run pPerl->perl_run -#undef perl_parse -#define perl_parse pPerl->perl_parse -#else -#undef perl_alloc -#define perl_alloc pPerl->perl_alloc -#undef perl_construct -#define perl_construct pPerl->perl_construct -#undef perl_destruct -#define perl_destruct pPerl->perl_destruct -#undef perl_free -#define perl_free pPerl->perl_free -#undef perl_run -#define perl_run pPerl->perl_run -#undef perl_parse -#define perl_parse pPerl->perl_parse +#undef Perl_construct +#define Perl_construct pPerl->Perl_construct +#undef Perl_destruct +#define Perl_destruct pPerl->Perl_destruct +#undef Perl_free +#define Perl_free pPerl->Perl_free +#undef Perl_run +#define Perl_run pPerl->Perl_run +#undef Perl_parse +#define Perl_parse pPerl->Perl_parse +#endif #if defined(USE_THREADS) #undef Perl_new_struct_thread #define Perl_new_struct_thread pPerl->Perl_new_struct_thread #undef new_struct_thread #define new_struct_thread Perl_new_struct_thread #endif -#endif #undef Perl_call_atexit #define Perl_call_atexit pPerl->Perl_call_atexit #undef call_atexit @@ -2724,6 +2737,10 @@ #define Perl_save_I32 pPerl->Perl_save_I32 #undef save_I32 #define save_I32 Perl_save_I32 +#undef Perl_save_I8 +#define Perl_save_I8 pPerl->Perl_save_I8 +#undef save_I8 +#define save_I8 Perl_save_I8 #undef Perl_save_int #define Perl_save_int pPerl->Perl_save_int #undef save_int @@ -2760,6 +2777,10 @@ #define Perl_save_pptr pPerl->Perl_save_pptr #undef save_pptr #define save_pptr Perl_save_pptr +#undef Perl_save_vptr +#define Perl_save_vptr pPerl->Perl_save_vptr +#undef save_vptr +#define save_vptr Perl_save_vptr #undef Perl_save_re_context #define Perl_save_re_context pPerl->Perl_save_re_context #undef save_re_context @@ -2882,6 +2903,14 @@ #define Perl_sv_2pv pPerl->Perl_sv_2pv #undef sv_2pv #define sv_2pv Perl_sv_2pv +#undef Perl_sv_2pvutf8 +#define Perl_sv_2pvutf8 pPerl->Perl_sv_2pvutf8 +#undef sv_2pvutf8 +#define sv_2pvutf8 Perl_sv_2pvutf8 +#undef Perl_sv_2pvbyte +#define Perl_sv_2pvbyte pPerl->Perl_sv_2pvbyte +#undef sv_2pvbyte +#define sv_2pvbyte Perl_sv_2pvbyte #undef Perl_sv_2uv #define Perl_sv_2uv pPerl->Perl_sv_2uv #undef sv_2uv @@ -2902,6 +2931,14 @@ #define Perl_sv_pvn pPerl->Perl_sv_pvn #undef sv_pvn #define sv_pvn Perl_sv_pvn +#undef Perl_sv_pvutf8n +#define Perl_sv_pvutf8n pPerl->Perl_sv_pvutf8n +#undef sv_pvutf8n +#define sv_pvutf8n Perl_sv_pvutf8n +#undef Perl_sv_pvbyten +#define Perl_sv_pvbyten pPerl->Perl_sv_pvbyten +#undef sv_pvbyten +#define sv_pvbyten Perl_sv_pvbyten #undef Perl_sv_true #define Perl_sv_true pPerl->Perl_sv_true #undef sv_true @@ -3060,6 +3097,14 @@ #define Perl_sv_pvn_force pPerl->Perl_sv_pvn_force #undef sv_pvn_force #define sv_pvn_force Perl_sv_pvn_force +#undef Perl_sv_pvutf8n_force +#define Perl_sv_pvutf8n_force pPerl->Perl_sv_pvutf8n_force +#undef sv_pvutf8n_force +#define sv_pvutf8n_force Perl_sv_pvutf8n_force +#undef Perl_sv_pvbyten_force +#define Perl_sv_pvbyten_force pPerl->Perl_sv_pvbyten_force +#undef sv_pvbyten_force +#define sv_pvbyten_force Perl_sv_pvbyten_force #undef Perl_sv_reftype #define Perl_sv_reftype pPerl->Perl_sv_reftype #undef sv_reftype @@ -3252,6 +3297,10 @@ #define Perl_wait4pid pPerl->Perl_wait4pid #undef wait4pid #define wait4pid Perl_wait4pid +#undef Perl_report_uninit +#define Perl_report_uninit pPerl->Perl_report_uninit +#undef report_uninit +#define report_uninit Perl_report_uninit #undef Perl_warn #define Perl_warn pPerl->Perl_warn #undef warn @@ -3304,22 +3353,6 @@ #define Perl_dump_mstats pPerl->Perl_dump_mstats #undef dump_mstats #define dump_mstats Perl_dump_mstats -#undef Perl_malloc -#define Perl_malloc pPerl->Perl_malloc -#undef malloc -#define malloc Perl_malloc -#undef Perl_calloc -#define Perl_calloc pPerl->Perl_calloc -#undef calloc -#define calloc Perl_calloc -#undef Perl_realloc -#define Perl_realloc pPerl->Perl_realloc -#undef realloc -#define realloc Perl_realloc -#undef Perl_mfree -#define Perl_mfree pPerl->Perl_mfree -#undef mfree -#define mfree Perl_mfree #endif #undef Perl_safesysmalloc #define Perl_safesysmalloc pPerl->Perl_safesysmalloc @@ -3493,10 +3526,26 @@ #define Perl_sv_2pv_nolen pPerl->Perl_sv_2pv_nolen #undef sv_2pv_nolen #define sv_2pv_nolen Perl_sv_2pv_nolen +#undef Perl_sv_2pvutf8_nolen +#define Perl_sv_2pvutf8_nolen pPerl->Perl_sv_2pvutf8_nolen +#undef sv_2pvutf8_nolen +#define sv_2pvutf8_nolen Perl_sv_2pvutf8_nolen +#undef Perl_sv_2pvbyte_nolen +#define Perl_sv_2pvbyte_nolen pPerl->Perl_sv_2pvbyte_nolen +#undef sv_2pvbyte_nolen +#define sv_2pvbyte_nolen Perl_sv_2pvbyte_nolen #undef Perl_sv_pv #define Perl_sv_pv pPerl->Perl_sv_pv #undef sv_pv #define sv_pv Perl_sv_pv +#undef Perl_sv_pvutf8 +#define Perl_sv_pvutf8 pPerl->Perl_sv_pvutf8 +#undef sv_pvutf8 +#define sv_pvutf8 Perl_sv_pvutf8 +#undef Perl_sv_pvbyte +#define Perl_sv_pvbyte pPerl->Perl_sv_pvbyte +#undef sv_pvbyte +#define sv_pvbyte Perl_sv_pvbyte #undef Perl_sv_force_normal #define Perl_sv_force_normal pPerl->Perl_sv_force_normal #undef sv_force_normal @@ -3546,6 +3595,10 @@ #define Perl_ss_dup pPerl->Perl_ss_dup #undef ss_dup #define ss_dup Perl_ss_dup +#undef Perl_any_dup +#define Perl_any_dup pPerl->Perl_any_dup +#undef any_dup +#define any_dup Perl_any_dup #undef Perl_he_dup #define Perl_he_dup pPerl->Perl_he_dup #undef he_dup @@ -3596,12 +3649,9 @@ #define Perl_ptr_table_split pPerl->Perl_ptr_table_split #undef ptr_table_split #define ptr_table_split Perl_ptr_table_split -#undef perl_clone -#define perl_clone pPerl->perl_clone -#undef perl_clone_using -#define perl_clone_using pPerl->perl_clone_using #endif #if defined(PERL_OBJECT) +#else #endif #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) #endif @@ -3651,7 +3701,7 @@ #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) # if defined(CRIPPLED_CC) # endif -# if defined(WIN32) +# if defined(PERL_CR_FILTER) # endif #endif #if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT) @@ -3660,6 +3710,8 @@ # if defined(LEAKTEST) # endif #endif +#if defined(PERL_OBJECT) +#endif #undef Perl_ck_anoncode #define Perl_ck_anoncode pPerl->Perl_ck_anoncode #undef ck_anoncode @@ -23,10 +23,17 @@ /* #define PL_OP_SLAB_ALLOC */ /* XXXXXX testing */ -#define OP_REFCNT_LOCK NOOP -#define OP_REFCNT_UNLOCK NOOP -#define OpREFCNT_set(o,n) NOOP -#define OpREFCNT_dec(o) ((o)->op_targ--) +#ifdef USE_ITHREADS +# define OP_REFCNT_LOCK NOOP +# define OP_REFCNT_UNLOCK NOOP +# define OpREFCNT_set(o,n) ((o)->op_targ = (n)) +# define OpREFCNT_dec(o) (--(o)->op_targ) +#else +# define OP_REFCNT_LOCK NOOP +# define OP_REFCNT_UNLOCK NOOP +# define OpREFCNT_set(o,n) NOOP +# define OpREFCNT_dec(o) 0 +#endif #ifdef PL_OP_SLAB_ALLOC #define SLAB_SIZE 8192 @@ -105,7 +112,7 @@ S_no_bareword_allowed(pTHX_ OP *o) { qerror(Perl_mess(aTHX_ "Bareword \"%s\" not allowed while \"strict subs\" in use", - SvPV_nolen(cSVOPo->op_sv))); + SvPV_nolen(cSVOPo_sv))); } /* "register" allocation */ @@ -319,6 +326,7 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, return 0; } break; + case CXt_FORMAT: case CXt_SUB: if (!saweval) return 0; @@ -498,14 +506,18 @@ Perl_pad_free(pTHX_ PADOFFSET po) Perl_croak(aTHX_ "panic: pad_free po"); #ifdef USE_THREADS DEBUG_X(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" Pad 0x%"UVxf" free %"IVd"\n", + "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n", PTR2UV(thr), PTR2UV(PL_curpad), (IV)po)); #else DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n", PTR2UV(PL_curpad), (IV)po)); #endif /* USE_THREADS */ - if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) + if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) { SvPADTMP_off(PL_curpad[po]); +#ifdef USE_ITHREADS + SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */ +#endif + } if ((I32)po < PL_padix) PL_padix = po - 1; } @@ -659,7 +671,6 @@ Perl_op_free(pTHX_ OP *o) OP_REFCNT_UNLOCK; return; } - o->op_targ = 0; /* XXXXXX */ OP_REFCNT_UNLOCK; break; default: @@ -721,7 +732,7 @@ S_op_clear(pTHX_ OP *o) #ifdef USE_ITHREADS if (cPADOPo->op_padix > 0) { if (PL_curpad) { - GV *gv = cGVOPo; + GV *gv = cGVOPo_gv; pad_swipe(cPADOPo->op_padix); /* No GvIN_PAD_off(gv) here, because other references may still * exist on the pad */ @@ -1069,7 +1080,7 @@ Perl_scalarvoid(pTHX_ OP *o) break; case OP_CONST: - sv = cSVOPo->op_sv; + sv = cSVOPo_sv; if (cSVOPo->op_private & OPpCONST_STRICT) no_bareword_allowed(o); else { @@ -1299,7 +1310,7 @@ Perl_mod(pTHX_ OP *o, I32 type) if (!(o->op_private & (OPpCONST_ARYBASE))) goto nomod; if (PL_eval_start && PL_eval_start->op_type == OP_CONST) { - PL_compiling.cop_arybase = (I32)SvIV(((SVOP*)PL_eval_start)->op_sv); + PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv); PL_eval_start = 0; } else if (!type) { @@ -1402,7 +1413,7 @@ Perl_mod(pTHX_ OP *o, I32 type) break; } - cv = GvCV(kGVOP); + cv = GvCV(kGVOP_gv); if (!cv) goto restore_2cv; if (CvLVALUE(cv)) @@ -1979,7 +1990,7 @@ Perl_block_start(pTHX_ int full) PL_pad_reset_pending = FALSE; SAVEHINTS(); PL_hints &= ~HINT_BLOCK_SCOPE; - SAVEPPTR(PL_compiling.cop_warnings); + SAVESPTR(PL_compiling.cop_warnings); if (! specialWARN(PL_compiling.cop_warnings)) { PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; SAVEFREESV(PL_compiling.cop_warnings) ; @@ -2229,6 +2240,7 @@ Perl_gen_constant_list(pTHX_ register OP *o) PL_op = curop = LINKLIST(o); o->op_next = 0; + peep(curop); pp_pushmark(); CALLRUNOPS(aTHX); PL_op = curop; @@ -2860,7 +2872,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) } #else if (curop->op_type == OP_GV) { - GV *gv = cGVOPx(curop); + GV *gv = cGVOPx_gv(curop); repl_has_vars = 1; if (strchr("&`'123456789+", *GvENAME(gv))) break; @@ -2948,7 +2960,9 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) padop->op_type = type; padop->op_ppaddr = PL_ppaddr[type]; padop->op_padix = pad_alloc(type, SVs_PADTMP); + SvREFCNT_dec(PL_curpad[padop->op_padix]); PL_curpad[padop->op_padix] = sv; + SvPADTMP_on(sv); padop->op_next = (OP*)padop; padop->op_flags = flags; if (PL_opargs[type] & OA_RETSCALAR) @@ -3206,7 +3220,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { if (PL_opargs[curop->op_type] & OA_DANGEROUS) { if (curop->op_type == OP_GV) { - GV *gv = cGVOPx(curop); + GV *gv = cGVOPx_gv(curop); if (gv == PL_defgv || SvCUR(gv) == PL_generation) break; SvCUR(gv) = PL_generation; @@ -3362,13 +3376,7 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE); if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) { (void)SvIOK_on(*svp); - SvIVX(*svp) = 1; -#ifndef USE_ITHREADS - /* XXX This nameless kludge interferes with cloning SVs. :-( - * What's more, it seems entirely redundant when considering - * PL_DBsingle exists to do the same thing */ - SvSTASH(*svp) = (HV*)cop; -#endif + SvIVX(*svp) = PTR2IV(cop); } } @@ -3907,7 +3915,7 @@ Perl_cv_undef(pTHX_ CV *cv) #endif /* USE_THREADS */ ENTER; - SAVESPTR(PL_curpad); + SAVEVPTR(PL_curpad); PL_curpad = 0; if (!CvCLONED(cv)) @@ -4010,7 +4018,7 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside) assert(!CvUNIQUE(proto)); ENTER; - SAVESPTR(PL_curpad); + SAVEVPTR(PL_curpad); SAVESPTR(PL_comppad); SAVESPTR(PL_comppad_name); SAVESPTR(PL_compcv); @@ -4085,7 +4093,7 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside) PL_curpad[ix] = sv; } } - else if (IS_PADGV(ppad[ix])) { + else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) { PL_curpad[ix] = SvREFCNT_inc(ppad[ix]); } else { @@ -4130,9 +4138,9 @@ CV * Perl_cv_clone(pTHX_ CV *proto) { CV *cv; - MUTEX_LOCK(&PL_cred_mutex); /* XXX create separate mutex */ + LOCK_CRED_MUTEX; /* XXX create separate mutex */ cv = cv_clone2(proto, CvOUTSIDE(proto)); - MUTEX_UNLOCK(&PL_cred_mutex); /* XXX create separate mutex */ + UNLOCK_CRED_MUTEX; /* XXX create separate mutex */ return cv; } @@ -4191,9 +4199,9 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv) break; if (sv) return Nullsv; - if (type == OP_CONST) + if (type == OP_CONST && cSVOPo->op_sv) sv = cSVOPo->op_sv; - else if (type == OP_PADSV && cv) { + else if ((type == OP_PADSV || type == OP_CONST) && cv) { AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]); sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv; if (!sv || (!SvREADONLY(sv) && SvREFCNT(sv) > 1)) @@ -4397,12 +4405,25 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad)) av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv); + if (CvLVALUE(cv)) { + CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, scalarseq(block)); + } + else { + CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); + } + CvROOT(cv)->op_private |= OPpREFCOUNTED; + OpREFCNT_set(CvROOT(cv), 1); + CvSTART(cv) = LINKLIST(CvROOT(cv)); + CvROOT(cv)->op_next = 0; + peep(CvSTART(cv)); + + /* now that optimizer has done its work, adjust pad values */ if (CvCLONE(cv)) { SV **namep = AvARRAY(PL_comppad_name); for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { SV *namesv; - if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix])) + if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix])) continue; /* * The only things that a clonable function needs in its @@ -4426,25 +4447,13 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) AvFLAGS(av) = AVf_REIFY; for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { - if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix])) + if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix])) continue; if (!SvPADMY(PL_curpad[ix])) SvPADTMP_on(PL_curpad[ix]); } } - if (CvLVALUE(cv)) { - CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, scalarseq(block)); - } - else { - CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); - } - CvROOT(cv)->op_private |= OPpREFCOUNTED; - OpREFCNT_set(CvROOT(cv), 1); - CvSTART(cv) = LINKLIST(CvROOT(cv)); - CvROOT(cv)->op_next = 0; - peep(CvSTART(cv)); - if (name) { char *s; @@ -4912,11 +4921,22 @@ Perl_ck_delete(pTHX_ OP *o) o->op_private = 0; if (o->op_flags & OPf_KIDS) { OP *kid = cUNOPo->op_first; - if (kid->op_type == OP_HSLICE) + switch (kid->op_type) { + case OP_ASLICE: + o->op_flags |= OPf_SPECIAL; + /* FALL THROUGH */ + case OP_HSLICE: o->op_private |= OPpSLICE; - else if (kid->op_type != OP_HELEM) - Perl_croak(aTHX_ "%s argument is not a HASH element or slice", + break; + case OP_AELEM: + o->op_flags |= OPf_SPECIAL; + /* FALL THROUGH */ + case OP_HELEM: + break; + default: + Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice", PL_op_desc[o->op_type]); + } null(kid); } return o; @@ -5002,8 +5022,11 @@ Perl_ck_exists(pTHX_ OP *o) o = ck_fun(o); if (o->op_flags & OPf_KIDS) { OP *kid = cUNOPo->op_first; - if (kid->op_type != OP_HELEM) - Perl_croak(aTHX_ "%s argument is not a HASH element", PL_op_desc[o->op_type]); + if (kid->op_type == OP_AELEM) + o->op_flags |= OPf_SPECIAL; + else if (kid->op_type != OP_HELEM) + Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element", + PL_op_desc[o->op_type]); null(kid); } return o; @@ -5116,7 +5139,7 @@ Perl_ck_rvconst(pTHX_ register OP *o) kid->op_type = OP_GV; SvREFCNT_dec(kid->op_sv); #ifdef USE_ITHREADS - /* XXXXXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ + /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP); GvIN_PAD_on(gv); PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv); @@ -5288,26 +5311,46 @@ Perl_ck_fun(pTHX_ OP *o) else { I32 flags = OPf_SPECIAL; I32 priv = 0; + PADOFFSET targ = 0; + /* is this op a FH constructor? */ if (is_handle_constructor(o,numargs)) { - flags = 0; - /* Set a flag to tell rv2gv to vivify + char *name = Nullch; + STRLEN len; + + flags = 0; + /* Set a flag to tell rv2gv to vivify * need to "prove" flag does not mean something * else already - NI-S 1999/05/07 - */ - priv = OPpDEREF; -#if 0 - /* Helps with open($array[$n],...) - but is too simplistic - need to do selectively - */ - mod(kid,type); -#endif + */ + priv = OPpDEREF; + if (kid->op_type == OP_PADSV) { + SV **namep = av_fetch(PL_comppad_name, + kid->op_targ, 4); + if (namep && *namep) + name = SvPV(*namep, len); + } + else if (kid->op_type == OP_RV2SV + && kUNOP->op_first->op_type == OP_GV) + { + GV *gv = cGVOPx_gv(kUNOP->op_first); + name = GvNAME(gv); + len = GvNAMELEN(gv); + } + if (name) { + SV *namesv; + targ = pad_alloc(OP_RV2GV, SVs_PADTMP); + namesv = PL_curpad[targ]; + SvUPGRADE(namesv, SVt_PV); + if (*name != '$') + sv_setpvn(namesv, "$", 1); + sv_catpvn(namesv, name, len); + } } kid->op_sibling = 0; kid = newUNOP(OP_RV2GV, flags, scalar(kid)); - if (priv) { - kid->op_private |= priv; - } + kid->op_targ = targ; + kid->op_private |= priv; } kid->op_sibling = sibl; *tokid = kid; @@ -5352,18 +5395,18 @@ Perl_ck_glob(pTHX_ OP *o) if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv))) gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); -#if defined(PERL_INTERNAL_GLOB) && !defined(MINIPERL_BUILD) +#if !defined(PERL_EXTERNAL_GLOB) /* XXX this can be tightened up and made more failsafe. */ if (!gv) { OP *modname = newSVOP(OP_CONST, 0, newSVpvn("File::Glob", 10)); modname->op_private |= OPpCONST_BARE; ENTER; utilize(1, start_subparse(FALSE, 0), Nullop, modname, - newSVOP(OP_CONST, 0, newSVpvn("globally", 8))); + newSVOP(OP_CONST, 0, newSVpvn(":globally", 9))); gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); LEAVE; } -#endif /* PERL_INTERNAL_GLOB && !MINIPERL_BUILD */ +#endif /* PERL_EXTERNAL_GLOB */ if (gv && GvIMPORTED_CV(gv)) { append_elem(OP_GLOB, o, @@ -5569,31 +5612,6 @@ Perl_ck_sassign(pTHX_ OP *o) if (kkid && kkid->op_type == OP_PADSV && !(kkid->op_private & OPpLVAL_INTRO)) { - /* Concat has problems if target is equal to right arg. */ - if (kid->op_type == OP_CONCAT) { - if (kLISTOP->op_first->op_sibling->op_type == OP_PADSV - && kLISTOP->op_first->op_sibling->op_targ == kkid->op_targ) - return o; - } - else if (kid->op_type == OP_JOIN) { - /* do_join has problems if the arguments coincide with target. - In fact the second argument *can* safely coincide, - but ignore=pessimize this rare occasion. */ - OP *arg = kLISTOP->op_first->op_sibling; /* Skip PUSHMARK */ - - while (arg) { - if (arg->op_type == OP_PADSV - && arg->op_targ == kkid->op_targ) - return o; - arg = arg->op_sibling; - } - } - else if (kid->op_type == OP_QUOTEMETA) { - /* quotemeta has problems if the argument coincides with target. */ - if (kLISTOP->op_first->op_type == OP_PADSV - && kLISTOP->op_first->op_targ == kkid->op_targ) - return o; - } kid->op_targ = kkid->op_targ; kkid->op_targ = 0; /* Now we do not need PADSV and SASSIGN. */ @@ -5828,7 +5846,7 @@ S_simplify_sort(pTHX_ OP *o) if (kUNOP->op_first->op_type != OP_GV) return; kid = kUNOP->op_first; /* get past rv2sv */ - gv = kGVOP; + gv = kGVOP_gv; if (GvSTASH(gv) != PL_curstash) return; if (strEQ(GvNAME(gv), "a")) @@ -5844,7 +5862,7 @@ S_simplify_sort(pTHX_ OP *o) if (kUNOP->op_first->op_type != OP_GV) return; kid = kUNOP->op_first; /* get past rv2sv */ - gv = kGVOP; + gv = kGVOP_gv; if (GvSTASH(gv) != PL_curstash || ( reversed ? strNE(GvNAME(gv), "a") @@ -5954,7 +5972,7 @@ Perl_ck_subr(pTHX_ OP *o) null(cvop); /* disable rv2cv */ tmpop = (SVOP*)((UNOP*)cvop)->op_first; if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) { - GV *gv = cGVOPx(tmpop); + GV *gv = cGVOPx_gv(tmpop); cv = GvCVu(gv); if (!cv) tmpop->op_private |= OPpEARLY_CV; @@ -6022,7 +6040,7 @@ Perl_ck_subr(pTHX_ OP *o) (gvop = ((UNOP*)gvop)->op_first) && gvop->op_type == OP_GV) { - GV *gv = cGVOPx(gvop); + GV *gv = cGVOPx_gv(gvop); OP *sibling = o2->op_sibling; SV *n = newSVpvn("",0); op_free(o2); @@ -6140,7 +6158,7 @@ Perl_peep(pTHX_ register OP *o) return; ENTER; SAVEOP(); - SAVESPTR(PL_curcop); + SAVEVPTR(PL_curcop); for (; o; o = o->op_next) { if (o->op_seq) break; @@ -6159,31 +6177,31 @@ Perl_peep(pTHX_ register OP *o) case OP_CONST: if (cSVOPo->op_private & OPpCONST_STRICT) no_bareword_allowed(o); +#ifdef USE_ITHREADS + /* Relocate sv to the pad for thread safety. + * Despite being a "constant", the SV is written to, + * for reference counts, sv_upgrade() etc. */ + if (cSVOP->op_sv) { + PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP); + SvREFCNT_dec(PL_curpad[ix]); + SvPADTMP_on(cSVOPo->op_sv); + PL_curpad[ix] = cSVOPo->op_sv; + cSVOPo->op_sv = Nullsv; + o->op_targ = ix; + } +#endif /* FALL THROUGH */ case OP_UC: case OP_UCFIRST: case OP_LC: case OP_LCFIRST: - if ( o->op_next && o->op_next->op_type == OP_STRINGIFY - && !(o->op_next->op_private & OPpTARGET_MY) ) - null(o->op_next); - o->op_seq = PL_op_seqmax++; - break; case OP_CONCAT: case OP_JOIN: case OP_QUOTEMETA: if (o->op_next && o->op_next->op_type == OP_STRINGIFY) { if (o->op_next->op_private & OPpTARGET_MY) { - if ((o->op_flags & OPf_STACKED) /* chained concats */ - || (o->op_type == OP_CONCAT - /* Concat has problems if target is equal to right arg. */ - && (((LISTOP*)o)->op_first->op_sibling->op_type - == OP_PADSV) - && (((LISTOP*)o)->op_first->op_sibling->op_targ - == o->op_next->op_targ))) - { + if (o->op_flags & OPf_STACKED) /* chained concats */ goto ignore_optimization; - } else { o->op_targ = o->op_next->op_targ; o->op_next->op_targ = 0; @@ -6251,12 +6269,12 @@ Perl_peep(pTHX_ register OP *o) o->op_type = OP_AELEMFAST; o->op_ppaddr = PL_ppaddr[OP_AELEMFAST]; o->op_private = (U8)i; - gv = cGVOPo; + gv = cGVOPo_gv; GvAVn(gv); } } else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_UNSAFE)) { - GV *gv = cGVOPo; + GV *gv = cGVOPo_gv; if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) { /* XXX could check prototype here instead of just carping */ SV *sv = sv_newmortal(); @@ -6337,7 +6355,7 @@ Perl_peep(pTHX_ register OP *o) fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); if (!fields || !GvHV(*fields)) break; - svp = &((SVOP*)((BINOP*)o)->op_last)->op_sv; + svp = cSVOPx_svp(((BINOP*)o)->op_last); key = SvPV(*svp, keylen); indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE); if (!indsvp) { @@ -305,25 +305,28 @@ struct loop { #ifdef USE_ITHREADS -# define cGVOPx(o) ((GV*)PAD_SV(cPADOPx(o)->op_padix)) -# define cGVOP ((GV*)PAD_SV(cPADOP->op_padix)) -# define cGVOPo ((GV*)PAD_SV(cPADOPo->op_padix)) -# define kGVOP ((GV*)PAD_SV(kPADOP->op_padix)) -# define cGVOP_set(v) (PL_curpad[cPADOP->op_padix] = (SV*)(v)) -# define cGVOPo_set(v) (PL_curpad[cPADOPo->op_padix] = (SV*)(v)) -# define kGVOP_set(v) (PL_curpad[kPADOP->op_padix] = (SV*)(v)) +# define cGVOPx_gv(o) ((GV*)PL_curpad[cPADOPx(o)->op_padix]) # define IS_PADGV(v) (v && SvTYPE(v) == SVt_PVGV && GvIN_PAD(v)) +# define IS_PADCONST(v) (v && SvREADONLY(v)) +# define cSVOPx_sv(v) (cSVOPx(v)->op_sv \ + ? cSVOPx(v)->op_sv : PL_curpad[(v)->op_targ]) +# define cSVOPx_svp(v) (cSVOPx(v)->op_sv \ + ? &cSVOPx(v)->op_sv : &PL_curpad[(v)->op_targ]) #else -# define cGVOPx(o) ((GV*)cSVOPx(o)->op_sv) -# define cGVOP ((GV*)cSVOP->op_sv) -# define cGVOPo ((GV*)cSVOPo->op_sv) -# define kGVOP ((GV*)kSVOP->op_sv) -# define cGVOP_set(v) (cPADOP->op_sv = (SV*)(v)) -# define cGVOPo_set(v) (cPADOPo->op_sv = (SV*)(v)) -# define kGVOP_set(v) (kPADOP->op_sv = (SV*)(v)) +# define cGVOPx_gv(o) ((GV*)cSVOPx(o)->op_sv) # define IS_PADGV(v) FALSE +# define IS_PADCONST(v) FALSE +# define cSVOPx_sv(v) (cSVOPx(v)->op_sv) +# define cSVOPx_svp(v) (&cSVOPx(v)->op_sv) #endif +#define cGVOP_gv cGVOPx_gv(PL_op) +#define cGVOPo_gv cGVOPx_gv(o) +#define kGVOP_gv cGVOPx_gv(kid) +#define cSVOP_sv cSVOPx_sv(PL_op) +#define cSVOPo_sv cSVOPx_sv(o) +#define kSVOP_sv cSVOPx_sv(kid) + #define Nullop Null(OP*) /* Lowest byte of PL_opargs */ @@ -388,9 +388,9 @@ EXT char *PL_op_desc[] = { "private value", "push regexp", "ref-to-glob cast", - "scalar deref", + "scalar dereference", "array length", - "subroutine deref", + "subroutine dereference", "anonymous subroutine", "subroutine prototype", "reference constructor", @@ -1576,7 +1576,7 @@ EXT U32 PL_opargs[] = { 0x0001368e, /* lcfirst */ 0x0001368e, /* uc */ 0x0001368e, /* lc */ - 0x0001378e, /* quotemeta */ + 0x0001368e, /* quotemeta */ 0x00000248, /* rv2av */ 0x00026c04, /* aelemfast */ 0x00026404, /* aelem */ @@ -1592,7 +1592,7 @@ EXT U32 PL_opargs[] = { 0x00022800, /* unpack */ 0x0004280d, /* pack */ 0x00222808, /* split */ - 0x0004290d, /* join */ + 0x0004280d, /* join */ 0x00004801, /* list */ 0x00448400, /* lslice */ 0x00004805, /* anonlist */ @@ -298,6 +298,7 @@ sub tab { # ref not OK (RETPUSHNO) # trans not OK (dTARG; TARG = sv_newmortal();) # ucfirst etc not OK: TMP arg processed inplace +# quotemeta not OK (unsafe when TARG == arg) # each repeat not OK too due to array context # pack split - unknown whether they are safe # sprintf: is calling do_sprintf(TARG,...) which can act on TARG @@ -314,6 +315,7 @@ sub tab { # readline - unknown whether it is safe # match subst not OK (dTARG) # grepwhile not OK (not always setting) +# join not OK (unsafe when TARG == arg) # Suspicious wrt "additional mode of failure": concat (dealt with # in ck_sassign()), join (same). @@ -363,9 +365,9 @@ pushre push regexp ck_null d/ # References and stuff. rv2gv ref-to-glob cast ck_rvconst ds1 -rv2sv scalar deref ck_rvconst ds1 +rv2sv scalar dereference ck_rvconst ds1 av2arylen array length ck_null is1 -rv2cv subroutine deref ck_rvconst d1 +rv2cv subroutine dereference ck_rvconst d1 anoncode anonymous subroutine ck_anoncode $ prototype subroutine prototype ck_null s% S refgen reference constructor ck_spair m1 L @@ -506,7 +508,7 @@ ucfirst ucfirst ck_fun_locale fstu% S? lcfirst lcfirst ck_fun_locale fstu% S? uc uc ck_fun_locale fstu% S? lc lc ck_fun_locale fstu% S? -quotemeta quotemeta ck_fun fsTu% S? +quotemeta quotemeta ck_fun fstu% S? # Arrays. @@ -531,7 +533,7 @@ hslice hash slice ck_null m@ H L unpack unpack ck_fun @ S S pack pack ck_fun mst@ S L split split ck_split t@ S S S -join join ck_join msT@ S L +join join ck_join mst@ S L # List operators. diff --git a/os2/Makefile.SHs b/os2/Makefile.SHs index ba503ffbb3..005d7a92b6 100644 --- a/os2/Makefile.SHs +++ b/os2/Makefile.SHs @@ -96,9 +96,12 @@ perl.linkexp: perl.exports perl.map os2/os2.sym # We link miniperl statically, since .DLL depends on $(DYNALOADER) -miniperl.map miniperl: $(obj) perl$(OBJ_EXT) miniperlmain$(OBJ_EXT) - $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) perl$(OBJ_EXT) $(obj) $(libs) -Zmap -Zlinker /map - @./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest +opmini$(OBJ_EXT) : op.c + $(CCCMD) $(PLDLFLAGS) -DPERL_EXTERNAL_GLOB -o opmini$(OBJ_EXT) op.c + +miniperl.map miniperl: $(obj) perl$(OBJ_EXT) miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) + $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) perl$(OBJ_EXT) `echo $(obj)|sed -e 's/\bop\./opmini./g'` $(libs) -Zmap -Zlinker /map/PM:VIO + @./miniperl -w -Ilib -MExporter -e '<?>' || $(MAKE) minitest depend: os2ish.h dlfcn.h os2thread.h os2.c @@ -162,6 +165,9 @@ $(AOUT_LIBPERL) : $(aout_obj) perl$(AOUT_OBJ_EXT) .c$(AOUT_OBJ_EXT): $(AOUT_CCCMD) $(PLDLFLAGS) -c $*.c +opmini$(AOUT_OBJ_EXT): op.c + $(AOUT_CCCMD) $(PLDLFLAGS) -DPERL_EXTERNAL_GLOB -o opmini$(AOUT_OBJ_EXT) -c op.c + perlmain(AOUT_OBJ_EXT): perlmain.c $(AOUT_CCCMD_DLL) $(PLDLFLAGS) -c perlmain.c @@ -169,8 +175,8 @@ aout_perlmain.c: miniperlmain.c config.sh makefile $(static_ext_autoinit) sh writemain $(DYNALOADER) $(aout_static_lib) > tmp sh mv-if-diff tmp aout_perlmain.c -miniperl_: $& miniperlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) - $(CC) $(LARGE) $(AOUT_CLDFLAGS) $(CCDLFLAGS) -o miniperl_ miniperlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) $(libs) +miniperl_: $& miniperlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) opmini$(AOUT_OBJ_EXT) + $(CC) $(LARGE) $(AOUT_CLDFLAGS) $(CCDLFLAGS) -o miniperl_ miniperlmain$(AOUT_OBJ_EXT) opmini$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) $(libs) perl_: $& aout_perlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) $(AOUT_DYNALOADER) $(aout_static_ext) ext.libs $(CC) $(LARGE) $(AOUT_CLDFLAGS) $(CCDLFLAGS) -o perl_ aout_perlmain$(AOUT_OBJ_EXT) $(AOUT_DYNALOADER) $(aout_static_ext) $(AOUT_LIBPERL) `cat ext.libs` $(libs) diff --git a/os2/OS2/REXX/REXX.pm b/os2/OS2/REXX/REXX.pm index 5c6dfd226f..144dd379cb 100644 --- a/os2/OS2/REXX/REXX.pm +++ b/os2/OS2/REXX/REXX.pm @@ -335,6 +335,11 @@ which access REXX queues or REXX variables in signal handlers. See C<t/rx*.t> for examples. +=head1 ENVIRONMENT + +If C<PERL_REXX_DEBUG> is set, prints trace info on calls to REXX runtime +environment. + =head1 AUTHOR Andreas Kaiser ak@ananke.s.bawue.de, with additions by Ilya Zakharevich diff --git a/os2/POSIX.mkfifo b/os2/POSIX.mkfifo deleted file mode 100644 index f460bc679e..0000000000 --- a/os2/POSIX.mkfifo +++ /dev/null @@ -1,16 +0,0 @@ -diff -cr ..\perl5os2.patch\perl5.001m.andy/ext/POSIX/POSIX.xs ./ext/POSIX/POSIX.xs -*** ../perl5os2.patch/perl5.001m.andy/ext/POSIX/POSIX.xs Tue May 23 11:54:26 1995 ---- ./ext/POSIX/POSIX.xs Thu Sep 28 00:00:16 1995 -*************** -*** 81,86 **** ---- 81,90 ---- - /* Possibly needed prototypes */ - char *cuserid (char *); - -+ #ifndef HAS_MKFIFO -+ #define mkfifo(a,b) not_here("mkfifo") -+ #endif -+ - #ifndef HAS_CUSERID - #define cuserid(a) (char *) not_here("cuserid") - #endif diff --git a/os2/os2ish.h b/os2/os2ish.h index 3d7a6fd403..f254b5cacb 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -64,7 +64,7 @@ #ifndef SIGILL # define SIGILL 6 /* blech */ #endif -#define ABORT() kill(getpid(),SIGABRT); +#define ABORT() kill(PerlProc_getpid(),SIGABRT); #define BIT_BUCKET "/dev/nul" /* Will this work? */ diff --git a/patchlevel.h b/patchlevel.h index 51222176a0..e25b1308bf 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -5,20 +5,19 @@ #define PERL_REVISION 5 /* age */ #define PERL_VERSION 5 /* epoch */ -#define PERL_SUBVERSION 63 /* generation */ +#define PERL_SUBVERSION 640 /* generation */ -/* Compatibility across versions: MakeMaker will install add-on - modules in a directory with the PERL_APIVERSION version number. +/* The following numbers describe the earliest compatible version of + Perl ("compatibility" here being defined as sufficient binary/API + compatibility to run XS code built with the older version). Normally this should not change across maintenance releases. - perl.c:incpush() and lib/lib.pm will automatically search older - directories across major versions back to to PERL_XS_APIVERSION - for XS modules and back to PERL_PM_APIVERSION for pure PERL modules. - (Since the versioned directory layout didn't start until 5.005, - that's the earliest these can go back. - See INSTALL for how this works. + This is used by Configure et al to figure out which version libraries + are legal to include in @INC. See INSTALL for how this works. */ -#define PERL_APIVERSION 5.00563 /* Adjust manually as needed. */ +#define PERL_API_REVISION 5 /* Adjust manually as needed. */ +#define PERL_API_VERSION 5 /* Adjust manually as needed. */ +#define PERL_API_SUBVERSION 640 /* Adjust manually as needed. */ #define __PATCHLEVEL_H_INCLUDED__ #endif @@ -47,40 +47,42 @@ static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen); #endif #ifdef PERL_OBJECT -CPerlObj* -perl_alloc(struct IPerlMem* ipM, struct IPerlEnv* ipE, - struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, - struct IPerlDir* ipD, struct IPerlSock* ipS, - struct IPerlProc* ipP) -{ - CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP); - if (pPerl != NULL) - pPerl->Init(); - - return pPerl; -} -#else +#define perl_construct Perl_construct +#define perl_parse Perl_parse +#define perl_run Perl_run +#define perl_destruct Perl_destruct +#define perl_free Perl_free +#endif #ifdef PERL_IMPLICIT_SYS PerlInterpreter * -perl_alloc_using(struct IPerlMem* ipM, struct IPerlEnv* ipE, +perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, + struct IPerlMem* ipMP, struct IPerlEnv* ipE, struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, struct IPerlDir* ipD, struct IPerlSock* ipS, struct IPerlProc* ipP) { PerlInterpreter *my_perl; - +#ifdef PERL_OBJECT + my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, + ipLIO, ipD, ipS, ipP); + PERL_SET_INTERP(my_perl); +#else /* New() needs interpreter, so call malloc() instead */ my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); PERL_SET_INTERP(my_perl); Zero(my_perl, 1, PerlInterpreter); PL_Mem = ipM; + PL_MemShared = ipMS; + PL_MemParse = ipMP; PL_Env = ipE; PL_StdIO = ipStd; PL_LIO = ipLIO; PL_Dir = ipD; PL_Sock = ipS; PL_Proc = ipP; +#endif + return my_perl; } #else @@ -92,10 +94,10 @@ perl_alloc(void) /* New() needs interpreter, so call malloc() instead */ my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); PERL_SET_INTERP(my_perl); + Zero(my_perl, 1, PerlInterpreter); return my_perl; } #endif /* PERL_IMPLICIT_SYS */ -#endif /* PERL_OBJECT */ void perl_construct(pTHXx) @@ -117,9 +119,8 @@ perl_construct(pTHXx) /* Init the real globals (and main thread)? */ if (!PL_linestr) { -#ifdef USE_THREADS - INIT_THREADS; +#ifdef USE_THREADS #ifdef ALLOC_THREAD_KEY ALLOC_THREAD_KEY; #else @@ -202,14 +203,29 @@ perl_construct(pTHXx) init_i18nl10n(1); SET_NUMERIC_STANDARD(); + { + U8 *s; + PL_patchlevel = NEWSV(0,4); + SvUPGRADE(PL_patchlevel, SVt_PVNV); + if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127) + SvGROW(PL_patchlevel,24); + s = (U8*)SvPVX(PL_patchlevel); + s = uv_to_utf8(s, (UV)PERL_REVISION); + s = uv_to_utf8(s, (UV)PERL_VERSION); + s = uv_to_utf8(s, (UV)PERL_SUBVERSION); + *s = '\0'; + SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel)); + SvPOK_on(PL_patchlevel); + SvNVX(PL_patchlevel) = (NV)PERL_REVISION + + ((NV)PERL_VERSION / (NV)1000) #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0 - sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION - + ((double) PERL_VERSION / (double) 1000) - + ((double) PERL_SUBVERSION / (double) 100000)); -#else - sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION + - ((double) PERL_VERSION / (double) 1000)); + + ((NV)PERL_SUBVERSION / (NV)1000000) #endif + ; + SvNOK_on(PL_patchlevel); /* dual valued */ + SvUTF8_on(PL_patchlevel); + SvREADONLY_on(PL_patchlevel); + } #if defined(LOCAL_PATCH_COUNT) PL_localpatches = local_patches; /* For possible -v */ @@ -235,6 +251,9 @@ perl_destruct(pTHXx) dTHX; #endif /* USE_THREADS */ + /* wait for all pseudo-forked children to finish */ + PERL_WAIT_FOR_CHILDREN; + #ifdef USE_THREADS #ifndef FAKE_THREADS /* Pass 1 on any remaining threads: detach joinables, join zombies */ @@ -389,6 +408,7 @@ perl_destruct(pTHXx) Safefree(PL_inplace); PL_inplace = Nullch; + SvREFCNT_dec(PL_patchlevel); if (PL_e_script) { SvREFCNT_dec(PL_e_script); @@ -594,7 +614,6 @@ perl_destruct(pTHXx) /* No SVs have survived, need to clean out */ Safefree(PL_origfilename); - Safefree(PL_archpat_auto); Safefree(PL_reg_start_tmp); if (PL_reg_curpm) Safefree(PL_reg_curpm); @@ -836,18 +855,18 @@ S_parse_body(pTHX_ va_list args) if (!*++s && (s=argv[1]) != Nullch) { argc--,argv++; } - while (s && isSPACE(*s)) - ++s; if (s && *s) { - char *e, *p; - for (e = s; *e && !isSPACE(*e); e++) ; - p = savepvn(s, e-s); + char *p; + STRLEN len = strlen(s); + p = savepvn(s, len); incpush(p, TRUE); - sv_catpv(sv,"-I"); - sv_catpv(sv,p); - sv_catpv(sv," "); + sv_catpvn(sv, "-I", 2); + sv_catpvn(sv, p, len); + sv_catpvn(sv, " ", 1); Safefree(p); - } /* XXX else croak? */ + } + else + Perl_croak(aTHX_ "No directory specified for -I"); break; case 'P': forbid_setid("-P"); @@ -958,7 +977,8 @@ print \" \\@INC:\\n @INC\\n\";"); #ifndef SECURE_INTERNAL_GETENV !PL_tainting && #endif - (s = PerlEnv_getenv("PERL5OPT"))) { + (s = PerlEnv_getenv("PERL5OPT"))) + { while (isSPACE(*s)) s++; if (*s == '-' && *(s+1) == 'T') @@ -1402,7 +1422,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) /* my_exit() was called */ PL_curstash = PL_defstash; FREETMPS; - if (PL_statusvalue) + if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) Perl_croak(aTHX_ "Callback called exit"); my_exit_jump(); /* NOTREACHED */ @@ -1526,7 +1546,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) /* my_exit() was called */ PL_curstash = PL_defstash; FREETMPS; - if (PL_statusvalue) + if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) Perl_croak(aTHX_ "Callback called exit"); my_exit_jump(); /* NOTREACHED */ @@ -1742,14 +1762,23 @@ Perl_moreswitches(pTHX_ char *s) ++s; if (*s) { char *e, *p; - for (e = s; *e && !isSPACE(*e); e++) ; - p = savepvn(s, e-s); - incpush(p, TRUE); - Safefree(p); - s = e; + p = s; + /* ignore trailing spaces (possibly followed by other switches) */ + do { + for (e = p; *e && !isSPACE(*e); e++) ; + p = e; + while (isSPACE(*p)) + p++; + } while (*p && *p != '-'); + e = savepvn(s, e-s); + incpush(e, TRUE); + Safefree(e); + s = p; + if (*s == '-') + s++; } else - Perl_croak(aTHX_ "No space allowed after -I"); + Perl_croak(aTHX_ "No directory specified for -I"); return s; case 'l': PL_minus_l = TRUE; @@ -1836,13 +1865,8 @@ Perl_moreswitches(pTHX_ char *s) s++; return s; case 'v': -#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0 - printf("\nThis is perl, version %d.%03d_%02d built for %s", - PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME); -#else - printf("\nThis is perl, version %s built for %s", - PL_patchlevel, ARCHNAME); -#endif + printf("\nThis is perl, v%"UVuf".%"UVuf".%"UVuf" built for %s", + (UV)PERL_REVISION, (UV)PERL_VERSION, (UV)PERL_SUBVERSION, ARCHNAME); #if defined(LOCAL_PATCH_COUNT) if (LOCAL_PATCH_COUNT > 0) printf("\n(with %d registered patch%s, see perl -V for more detail)", @@ -2139,7 +2163,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP); sv_catpv(cpp, cpp_cfg); - sv_catpv(sv,"-I"); + sv_catpvn(sv, "-I", 2); sv_catpv(sv,PRIVLIB_EXP); #ifdef MSDOS @@ -2238,7 +2262,9 @@ sed %s -e \"/^[^#]/b\" \ PL_statbuf.st_mode & (S_ISUID|S_ISGID)) { /* try again */ - PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv); + PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP, + (int)PERL_REVISION, (int)PERL_VERSION, + (int)PERL_SUBVERSION), PL_origargv); Perl_croak(aTHX_ "Can't do setuid\n"); } #endif @@ -2286,7 +2312,7 @@ S_fd_on_nosuid_fs(pTHX_ int fd) # if defined(HAS_FSTAT) && \ defined(HAS_USTAT) && \ defined(HAS_GETMNT) && \ - defined(HAS_STRUCT_FS_DATA) && + defined(HAS_STRUCT_FS_DATA) && \ defined(NOSTAT_ONE) struct stat fdst; if (fstat(fd, &fdst) == 0) { @@ -2485,7 +2511,9 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); (void)PerlIO_close(PL_rsfp); #ifndef IAMSUID /* try again */ - PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv); + PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP, + (int)PERL_REVISION, (int)PERL_VERSION, + (int)PERL_SUBVERSION), PL_origargv); #endif Perl_croak(aTHX_ "Can't do setuid\n"); } @@ -2567,7 +2595,9 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #if defined(HAS_FCNTL) && defined(F_SETFD) fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */ #endif - PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */ + PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP, + (int)PERL_REVISION, (int)PERL_VERSION, + (int)PERL_SUBVERSION), PL_origargv);/* try again */ Perl_croak(aTHX_ "Can't do setuid\n"); #endif /* IAMSUID */ #else /* !DOSUID */ @@ -2797,7 +2827,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register for (; argc > 0 && **argv == '-'; argc--,argv++) { if (!argv[0][1]) break; - if (argv[0][1] == '-') { + if (argv[0][1] == '-' && !argv[0][2]) { argc--,argv++; break; } @@ -2873,7 +2903,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register } TAINT_NOT; if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) - sv_setiv(GvSV(tmpgv), (IV)getpid()); + sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid()); } STATIC void @@ -2964,17 +2994,6 @@ S_incpush(pTHX_ char *p, int addsubdirs) if (addsubdirs) { subdir = sv_newmortal(); - if (!PL_archpat_auto) { - STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel) - + sizeof("//auto")); - New(55, PL_archpat_auto, len, char); - sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel); -#ifdef VMS - for (len = sizeof(ARCHNAME) + 2; - PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++) - if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_'; -#endif - } } /* Break at all separators */ @@ -3020,16 +3039,16 @@ S_incpush(pTHX_ char *p, int addsubdirs) SvPV(libdir,len)); #endif /* .../archname/version if -d .../archname/version/auto */ - sv_setsv(subdir, libdir); - sv_catpv(subdir, PL_archpat_auto); + Perl_sv_setpvf(aTHX_ subdir, "%_/%s/"PERL_FS_VER_FMT"/auto", libdir, + ARCHNAME, (int)PERL_REVISION, + (int)PERL_VERSION, (int)PERL_SUBVERSION); if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) av_push(GvAVn(PL_incgv), newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); /* .../archname if -d .../archname/auto */ - sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME), - strlen(PL_patchlevel) + 1, "", 0); + Perl_sv_setpvf(aTHX_ subdir, "%_/%s/auto", libdir, ARCHNAME); if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) av_push(GvAVn(PL_incgv), @@ -3165,7 +3184,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) PL_curstash = PL_defstash; PL_curcop = &PL_compiling; CopLINE_set(PL_curcop, oldline); - if (PL_statusvalue) { + if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) { if (paramList == PL_beginav) Perl_croak(aTHX_ "BEGIN failed--compilation aborted"); else @@ -23,6 +23,17 @@ #define VOIDUSED 1 #include "config.h" +#if defined(USE_ITHREADS) && defined(USE_5005THREADS) +# include "error: USE_ITHREADS and USE_5005THREADS are incompatible" +#endif + +/* XXX This next guard can disappear if the sources are revised + to use USE_5005THREADS throughout. -- A.D 1/6/2000 +*/ +#if defined(USE_ITHREADS) && defined(USE_THREADS) +# include "error: USE_ITHREADS and USE_THREADS are incompatible" +#endif + /* See L<perlguts/"The Perl API"> for detailed notes on * PERL_IMPLICIT_CONTEXT and PERL_IMPLICIT_SYS */ @@ -30,26 +41,19 @@ # ifndef PERL_IMPLICIT_CONTEXT # define PERL_IMPLICIT_CONTEXT # endif -# ifndef PERL_IMPLICIT_SYS -# if defined(WIN32) && !defined(__MINGW32__) -# define PERL_IMPLICIT_SYS /* XXX not implemented everywhere yet */ -# endif -# endif #endif #if defined(MULTIPLICITY) # ifndef PERL_IMPLICIT_CONTEXT # define PERL_IMPLICIT_CONTEXT # endif -# ifndef PERL_IMPLICIT_SYS -# if defined(WIN32) && !defined(__MINGW32__) -# define PERL_IMPLICIT_SYS /* XXX not implemented everywhere yet */ -# endif -# endif #endif #ifdef PERL_CAPI # undef PERL_OBJECT +# ifndef MULTIPLICITY +# define MULTIPLICITY +# endif # ifndef PERL_IMPLICIT_CONTEXT # define PERL_IMPLICIT_CONTEXT # endif @@ -67,6 +71,10 @@ # endif #endif +#if defined(USE_ITHREADS) && !defined(MULTIPLICITY) && !defined(PERL_OBJECT) +# include "error: USE_ITHREADS must be built with MULTIPLICITY" +#endif + #ifdef PERL_OBJECT /* PERL_OBJECT explained - DickH and DougL @ ActiveState.com @@ -146,7 +154,7 @@ class CPerlObj; #define STATIC #define CPERLscope(x) CPerlObj::x -#define CALL_FPTR(fptr) (this->*fptr) +#define CALL_FPTR(fptr) (aTHXo->*fptr) #define pTHXo CPerlObj *pPerl #define pTHXo_ pTHXo, @@ -393,7 +401,8 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); /* HP-UX 10.X CMA (Common Multithreaded Architecure) insists that pthread.h must be included before all other header files. */ -#if defined(USE_THREADS) && defined(PTHREAD_H_FIRST) && defined(I_PTHREAD) +#if (defined(USE_THREADS) || defined(USE_ITHREADS)) \ + && defined(PTHREAD_H_FIRST) && defined(I_PTHREAD) # include <pthread.h> #endif @@ -1479,10 +1488,6 @@ typedef struct ptr_tbl PTR_TBL_t; # define PERL_SYS_INIT3(argvp,argcp,envp) PERL_SYS_INIT(argvp,argcp) #endif -#ifndef PERL_SYS_INIT3 -# define PERL_SYS_INIT3(argvp,argcp,envp) PERL_SYS_INIT(argvp,argcp) -#endif - #ifndef MAXPATHLEN # ifdef PATH_MAX # ifdef _POSIX_PATH_MAX @@ -1512,11 +1517,12 @@ typedef struct ptr_tbl PTR_TBL_t; * May make sense to have threads after "*ish.h" anyway */ -#ifdef USE_THREADS +#if defined(USE_THREADS) || defined(USE_ITHREADS) +# if defined(USE_THREADS) /* pending resolution of licensing issues, we avoid the erstwhile * atomic.h everywhere */ # define EMULATE_ATOMIC_REFCOUNTS - +# endif # ifdef FAKE_THREADS # include "fakethr.h" # else @@ -1547,10 +1553,10 @@ typedef pthread_key_t perl_key; # endif /* OS2 */ # endif /* WIN32 */ # endif /* FAKE_THREADS */ -#endif /* USE_THREADS */ +#endif /* USE_THREADS || USE_ITHREADS */ #ifdef WIN32 -#include "win32.h" +# include "win32.h" #endif #ifdef VMS @@ -1602,8 +1608,17 @@ typedef pthread_key_t perl_key; # define STATUS_ALL_FAILURE (PL_statusvalue = 1) #endif +/* flags in PL_exit_flags for nature of exit() */ +#define PERL_EXIT_EXPECTED 0x01 + #ifndef MEMBER_TO_FPTR -#define MEMBER_TO_FPTR(name) name +# define MEMBER_TO_FPTR(name) name +#endif + +/* format to use for version numbers in file/directory names */ +/* XXX move to Configure? */ +#ifndef PERL_FS_VER_FMT +# define PERL_FS_VER_FMT "%d.%d.%d" #endif /* This defines a way to flush all output buffers. This may be a @@ -1621,6 +1636,10 @@ typedef pthread_key_t perl_key; # endif #endif +#ifndef PERL_WAIT_FOR_CHILDREN +# define PERL_WAIT_FOR_CHILDREN NOOP +#endif + /* the traditional thread-unsafe notion of "current interpreter". * XXX todo: a thread-safe version that fetches it from TLS (akin to THR) * needs to be defined elsewhere (conditional on pthread_getspecific() @@ -1751,6 +1770,7 @@ struct _sublex_info { typedef struct magic_state MGS; /* struct magic_state defined in mg.c */ struct scan_data_t; /* Used in S_* functions in regcomp.c */ +struct regnode_charclass_class; /* Used in S_* functions in regcomp.c */ typedef I32 CHECKPOINT; @@ -1870,6 +1890,7 @@ Gid_t getegid (void); #ifndef Perl_error_log # define Perl_error_log (PL_stderrgv \ + && IoOFP(GvIOp(PL_stderrgv)) \ ? IoOFP(GvIOp(PL_stderrgv)) \ : PerlIO_stderr()) #endif @@ -1989,9 +2010,9 @@ END_EXTERN_C # if defined(NeXT) || defined(__NeXT__) /* or whatever catches all NeXTs */ char *crypt (); /* Maybe more hosts will need the unprototyped version */ # else -# if !defined(WIN32) || !defined(HAVE_DES_FCRYPT) +# if !defined(WIN32) char *crypt (const char*, const char*); -# endif /* !WIN32 && !HAVE_CRYPT_SOURCE */ +# endif /* !WIN32 */ # endif /* !NeXT && !__NeXT__ */ # ifndef DONT_DECLARE_STD # ifndef getenv @@ -2105,7 +2126,7 @@ START_EXTERN_C /* handy constants */ EXTCONST char PL_warn_uninit[] - INIT("Use of uninitialized value"); + INIT("Use of uninitialized value%s%s"); EXTCONST char PL_warn_nosemi[] INIT("Semicolon seems to be missing"); EXTCONST char PL_warn_reserved[] @@ -2144,13 +2165,9 @@ EXTCONST char PL_uuemap[65] #ifdef DOINIT EXT char *PL_sig_name[] = { SIG_NAME }; EXT int PL_sig_num[] = { SIG_NUM }; -EXT SV * PL_psig_ptr[sizeof(PL_sig_num)/sizeof(*PL_sig_num)]; -EXT SV * PL_psig_name[sizeof(PL_sig_num)/sizeof(*PL_sig_num)]; #else EXT char *PL_sig_name[]; EXT int PL_sig_num[]; -EXT SV * PL_psig_ptr[]; -EXT SV * PL_psig_name[]; #endif /* fast case folding tables */ @@ -2425,7 +2442,7 @@ enum { /* pass one of these to get_vtbl */ #define HINT_STRICT_REFS 0x00000002 /* #define HINT_notused4 0x00000004 */ #define HINT_UTF8 0x00000008 -/* #define HINT_notused10 0x00000010 */ +#define HINT_BYTE 0x00000010 /* Note: 20,40,80 used for NATIVE_HINTS */ #define HINT_BLOCK_SCOPE 0x00000100 @@ -2487,44 +2504,25 @@ typedef struct exitlistentry { void *ptr; } PerlExitListEntry; -#ifdef PERL_OBJECT -#undef perl_alloc -#define perl_alloc Perl_alloc -CPerlObj* Perl_alloc (IPerlMem*, IPerlEnv*, IPerlStdIO*, IPerlLIO*, IPerlDir*, IPerlSock*, IPerlProc*); - -#undef EXT -#define EXT -#undef EXTCONST -#define EXTCONST -#undef INIT -#define INIT(x) - -class CPerlObj { -public: - CPerlObj(IPerlMem*, IPerlEnv*, IPerlStdIO*, IPerlLIO*, IPerlDir*, IPerlSock*, IPerlProc*); - void Init(void); - void* operator new(size_t nSize, IPerlMem *pvtbl); - static void operator delete(void* pPerl, IPerlMem *pvtbl); -#endif /* PERL_OBJECT */ - #ifdef PERL_GLOBAL_STRUCT struct perl_vars { -#include "perlvars.h" +# include "perlvars.h" }; -#ifdef PERL_CORE +# ifdef PERL_CORE EXT struct perl_vars PL_Vars; EXT struct perl_vars *PL_VarsPtr INIT(&PL_Vars); -#else /* PERL_CORE */ -#if !defined(__GNUC__) || !defined(WIN32) +# else /* PERL_CORE */ +# if !defined(__GNUC__) || !defined(WIN32) EXT -#endif /* WIN32 */ +# endif /* WIN32 */ struct perl_vars *PL_VarsPtr; -#define PL_Vars (*((PL_VarsPtr) ? PL_VarsPtr : (PL_VarsPtr = Perl_GetVars(aTHX)))) -#endif /* PERL_CORE */ +# define PL_Vars (*((PL_VarsPtr) \ + ? PL_VarsPtr : (PL_VarsPtr = Perl_GetVars(aTHX)))) +# endif /* PERL_CORE */ #endif /* PERL_GLOBAL_STRUCT */ -#ifdef MULTIPLICITY +#if defined(MULTIPLICITY) || defined(PERL_OBJECT) /* If we have multiple interpreters define a struct holding variables which must be per-interpreter If we don't have threads anything that would have @@ -2532,17 +2530,22 @@ struct perl_vars *PL_VarsPtr; */ struct interpreter { -#ifndef USE_THREADS -# include "thrdvar.h" -#endif -#include "intrpvar.h" +# ifndef USE_THREADS +# include "thrdvar.h" +# endif +# include "intrpvar.h" +/* + * The following is a buffer where new variables must + * be defined to maintain binary compatibility with PERL_OBJECT + */ +PERLVARA(object_compatibility,30, char) }; #else struct interpreter { char broiled; }; -#endif +#endif /* MULTIPLICITY || PERL_OBJECT */ #ifdef USE_THREADS /* If we have threads define a struct with all the variables @@ -2583,25 +2586,18 @@ typedef void *Thread; #endif #ifdef PERL_OBJECT -#define PERL_DECL_PROT -#define perl_alloc Perl_alloc +# define PERL_DECL_PROT #endif -#include "proto.h" - #undef PERL_CKDEF #undef PERL_PPDEF #define PERL_CKDEF(s) OP *s (pTHX_ OP *o); #define PERL_PPDEF(s) OP *s (pTHX); -#ifdef PERL_OBJECT -public: -#endif -#include "pp_proto.h" +#include "proto.h" #ifdef PERL_OBJECT -int CPerlObj::do_aspawn (void *vreally, void **vmark, void **vsp); -#undef PERL_DECL_PROT +# undef PERL_DECL_PROT #endif #ifndef PERL_OBJECT @@ -2625,29 +2621,17 @@ int CPerlObj::do_aspawn (void *vreally, void **vmark, void **vsp); #define PERLVARI(var,type,init) EXT type PL_##var INIT(init); #define PERLVARIC(var,type,init) EXTCONST type PL_##var INIT(init); -#ifndef MULTIPLICITY - +#if !defined(MULTIPLICITY) && !defined(PERL_OBJECT) +START_EXTERN_C # include "intrpvar.h" # ifndef USE_THREADS # include "thrdvar.h" # endif - +END_EXTERN_C #endif #ifdef PERL_OBJECT -/* - * The following is a buffer where new variables must - * be defined to maintain binary compatibility with PERL_OBJECT - * for 5.005 - */ -PERLVARA(object_compatibility,30, char) -}; - - # include "embed.h" -# if defined(WIN32) && !defined(WIN32IO_IS_STDIO) -# define errno CPerlObj::ErrorNo() -# endif # ifdef DOINIT # include "INTERN.h" @@ -3012,6 +2996,7 @@ typedef struct am_table_short AMTS; * Now we have __attribute__ out of the way * Remap printf */ +#undef printf #define printf PerlIO_stdoutf #endif @@ -3106,7 +3091,13 @@ typedef struct am_table_short AMTS; # include <sys/statfs.h> /* for some statfs() */ #endif #ifdef I_SYS_VFS -# include <sys/vfs.h> /* for some statfs() */ +# ifdef __sgi +# define sv IRIX_sv /* kludge: IRIX has an sv of its own */ +# endif +# include <sys/vfs.h> /* for some statfs() */ +# ifdef __sgi +# undef IRIX_sv +# endif #endif #ifdef I_USTAT # include <ustat.h> /* for ustat() */ @@ -17,9 +17,9 @@ START_EXTERN_C #undef PERLVARI #undef PERLVARIC #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHXo) \ - { return &(aTHXo->PL_##v); } + { return &(aTHXo->interp.v); } #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHXo) \ - { return &(aTHXo->PL_##v); } + { return &(aTHXo->interp.v); } #define PERLVARI(v,t,i) PERLVAR(v,t) #define PERLVARIC(v,t,i) PERLVAR(v, const t) @@ -39,7 +39,21 @@ START_EXTERN_C #undef PERLVARI #undef PERLVARIC +#if defined(PERL_IMPLICIT_SYS) +#else +#endif +#if defined(USE_ITHREADS) +# if defined(PERL_IMPLICIT_SYS) +# endif +#endif +#if defined(MYMALLOC) +#endif +#if defined(PERL_OBJECT) +#ifndef __BORLANDC__ +#endif +#endif #if defined(PERL_OBJECT) +#else #endif #undef Perl_amagic_call @@ -77,6 +91,13 @@ Perl_apply(pTHXo_ I32 type, SV** mark, SV** sp) return ((CPerlObj*)pPerl)->Perl_apply(type, mark, sp); } +#undef Perl_avhv_delete_ent +SV* +Perl_avhv_delete_ent(pTHXo_ AV *ar, SV* keysv, I32 flags, U32 hash) +{ + return ((CPerlObj*)pPerl)->Perl_avhv_delete_ent(ar, keysv, flags, hash); +} + #undef Perl_avhv_exists_ent bool Perl_avhv_exists_ent(pTHXo_ AV *ar, SV* keysv, U32 hash) @@ -119,6 +140,20 @@ Perl_av_clear(pTHXo_ AV* ar) ((CPerlObj*)pPerl)->Perl_av_clear(ar); } +#undef Perl_av_delete +SV* +Perl_av_delete(pTHXo_ AV* ar, I32 key, I32 flags) +{ + return ((CPerlObj*)pPerl)->Perl_av_delete(ar, key, flags); +} + +#undef Perl_av_exists +bool +Perl_av_exists(pTHXo_ AV* ar, I32 key) +{ + return ((CPerlObj*)pPerl)->Perl_av_exists(ar, key); +} + #undef Perl_av_extend void Perl_av_extend(pTHXo_ AV* ar, I32 key) @@ -2150,16 +2185,6 @@ Perl_magicname(pTHXo_ char* sym, char* name, I32 namlen) { ((CPerlObj*)pPerl)->Perl_magicname(sym, name, namlen); } -#if defined(MYMALLOC) - -#undef Perl_malloced_size -MEM_SIZE -Perl_malloced_size(void *p) -{ - dTHXo; - return ((CPerlObj*)pPerl)->Perl_malloced_size(p); -} -#endif #undef Perl_markstack_grow void @@ -2298,8 +2323,9 @@ Perl_my_atof(pTHXo_ const char *s) #undef Perl_my_bcopy char* -Perl_my_bcopy(pTHXo_ const char* from, char* to, I32 len) +Perl_my_bcopy(const char* from, char* to, I32 len) { + dTHXo; return ((CPerlObj*)pPerl)->Perl_my_bcopy(from, to, len); } #endif @@ -2307,8 +2333,9 @@ Perl_my_bcopy(pTHXo_ const char* from, char* to, I32 len) #undef Perl_my_bzero char* -Perl_my_bzero(pTHXo_ char* loc, I32 len) +Perl_my_bzero(char* loc, I32 len) { + dTHXo; return ((CPerlObj*)pPerl)->Perl_my_bzero(loc, len); } #endif @@ -2344,8 +2371,9 @@ Perl_my_lstat(pTHXo) #undef Perl_my_memcmp I32 -Perl_my_memcmp(pTHXo_ const char* s1, const char* s2, I32 len) +Perl_my_memcmp(const char* s1, const char* s2, I32 len) { + dTHXo; return ((CPerlObj*)pPerl)->Perl_my_memcmp(s1, s2, len); } #endif @@ -2353,8 +2381,9 @@ Perl_my_memcmp(pTHXo_ const char* s1, const char* s2, I32 len) #undef Perl_my_memset void* -Perl_my_memset(pTHXo_ char* loc, I32 ch, I32 len) +Perl_my_memset(char* loc, I32 ch, I32 len) { + dTHXo; return ((CPerlObj*)pPerl)->Perl_my_memset(loc, ch, len); } #endif @@ -2887,15 +2916,42 @@ Perl_peep(pTHXo_ OP* o) ((CPerlObj*)pPerl)->Perl_peep(o); } #if defined(PERL_OBJECT) -#else -#undef perl_alloc -PerlInterpreter* -perl_alloc() +#undef Perl_construct +void +Perl_construct(pTHXo) { - dTHXo; - return ((CPerlObj*)pPerl)->perl_alloc(); + ((CPerlObj*)pPerl)->Perl_construct(); } + +#undef Perl_destruct +void +Perl_destruct(pTHXo) +{ + ((CPerlObj*)pPerl)->Perl_destruct(); +} + +#undef Perl_free +void +Perl_free(pTHXo) +{ + ((CPerlObj*)pPerl)->Perl_free(); +} + +#undef Perl_run +int +Perl_run(pTHXo) +{ + return ((CPerlObj*)pPerl)->Perl_run(); +} + +#undef Perl_parse +int +Perl_parse(pTHXo_ XSINIT_t xsinit, int argc, char** argv, char** env) +{ + return ((CPerlObj*)pPerl)->Perl_parse(xsinit, argc, argv, env); +} +#endif #if defined(USE_THREADS) #undef Perl_new_struct_thread @@ -2905,7 +2961,6 @@ Perl_new_struct_thread(pTHXo_ struct perl_thread *t) return ((CPerlObj*)pPerl)->Perl_new_struct_thread(t); } #endif -#endif #undef Perl_call_atexit void @@ -3413,6 +3468,13 @@ Perl_save_I32(pTHXo_ I32* intp) ((CPerlObj*)pPerl)->Perl_save_I32(intp); } +#undef Perl_save_I8 +void +Perl_save_I8(pTHXo_ I8* bytep) +{ + ((CPerlObj*)pPerl)->Perl_save_I8(bytep); +} + #undef Perl_save_int void Perl_save_int(pTHXo_ int* intp) @@ -3476,6 +3538,13 @@ Perl_save_pptr(pTHXo_ char** pptr) ((CPerlObj*)pPerl)->Perl_save_pptr(pptr); } +#undef Perl_save_vptr +void +Perl_save_vptr(pTHXo_ void* pptr) +{ + ((CPerlObj*)pPerl)->Perl_save_vptr(pptr); +} + #undef Perl_save_re_context void Perl_save_re_context(pTHXo) @@ -3689,6 +3758,20 @@ Perl_sv_2pv(pTHXo_ SV* sv, STRLEN* lp) return ((CPerlObj*)pPerl)->Perl_sv_2pv(sv, lp); } +#undef Perl_sv_2pvutf8 +char* +Perl_sv_2pvutf8(pTHXo_ SV* sv, STRLEN* lp) +{ + return ((CPerlObj*)pPerl)->Perl_sv_2pvutf8(sv, lp); +} + +#undef Perl_sv_2pvbyte +char* +Perl_sv_2pvbyte(pTHXo_ SV* sv, STRLEN* lp) +{ + return ((CPerlObj*)pPerl)->Perl_sv_2pvbyte(sv, lp); +} + #undef Perl_sv_2uv UV Perl_sv_2uv(pTHXo_ SV* sv) @@ -3724,6 +3807,20 @@ Perl_sv_pvn(pTHXo_ SV *sv, STRLEN *len) return ((CPerlObj*)pPerl)->Perl_sv_pvn(sv, len); } +#undef Perl_sv_pvutf8n +char* +Perl_sv_pvutf8n(pTHXo_ SV *sv, STRLEN *len) +{ + return ((CPerlObj*)pPerl)->Perl_sv_pvutf8n(sv, len); +} + +#undef Perl_sv_pvbyten +char* +Perl_sv_pvbyten(pTHXo_ SV *sv, STRLEN *len) +{ + return ((CPerlObj*)pPerl)->Perl_sv_pvbyten(sv, len); +} + #undef Perl_sv_true I32 Perl_sv_true(pTHXo_ SV *sv) @@ -4002,6 +4099,20 @@ Perl_sv_pvn_force(pTHXo_ SV* sv, STRLEN* lp) return ((CPerlObj*)pPerl)->Perl_sv_pvn_force(sv, lp); } +#undef Perl_sv_pvutf8n_force +char* +Perl_sv_pvutf8n_force(pTHXo_ SV* sv, STRLEN* lp) +{ + return ((CPerlObj*)pPerl)->Perl_sv_pvutf8n_force(sv, lp); +} + +#undef Perl_sv_pvbyten_force +char* +Perl_sv_pvbyten_force(pTHXo_ SV* sv, STRLEN* lp) +{ + return ((CPerlObj*)pPerl)->Perl_sv_pvbyten_force(sv, lp); +} + #undef Perl_sv_reftype char* Perl_sv_reftype(pTHXo_ SV* sv, int ob) @@ -4338,6 +4449,13 @@ Perl_wait4pid(pTHXo_ Pid_t pid, int* statusp, int flags) return ((CPerlObj*)pPerl)->Perl_wait4pid(pid, statusp, flags); } +#undef Perl_report_uninit +void +Perl_report_uninit(pTHXo) +{ + ((CPerlObj*)pPerl)->Perl_report_uninit(); +} + #undef Perl_warn void Perl_warn(pTHXo_ const char* pat, ...) @@ -4431,38 +4549,6 @@ Perl_dump_mstats(pTHXo_ char* s) { ((CPerlObj*)pPerl)->Perl_dump_mstats(s); } - -#undef Perl_malloc -Malloc_t -Perl_malloc(MEM_SIZE nbytes) -{ - dTHXo; - return ((CPerlObj*)pPerl)->Perl_malloc(nbytes); -} - -#undef Perl_calloc -Malloc_t -Perl_calloc(MEM_SIZE elements, MEM_SIZE size) -{ - dTHXo; - return ((CPerlObj*)pPerl)->Perl_calloc(elements, size); -} - -#undef Perl_realloc -Malloc_t -Perl_realloc(Malloc_t where, MEM_SIZE nbytes) -{ - dTHXo; - return ((CPerlObj*)pPerl)->Perl_realloc(where, nbytes); -} - -#undef Perl_mfree -Free_t -Perl_mfree(Malloc_t where) -{ - dTHXo; - ((CPerlObj*)pPerl)->Perl_mfree(where); -} #endif #undef Perl_safesysmalloc @@ -4786,6 +4872,20 @@ Perl_sv_2pv_nolen(pTHXo_ SV* sv) return ((CPerlObj*)pPerl)->Perl_sv_2pv_nolen(sv); } +#undef Perl_sv_2pvutf8_nolen +char* +Perl_sv_2pvutf8_nolen(pTHXo_ SV* sv) +{ + return ((CPerlObj*)pPerl)->Perl_sv_2pvutf8_nolen(sv); +} + +#undef Perl_sv_2pvbyte_nolen +char* +Perl_sv_2pvbyte_nolen(pTHXo_ SV* sv) +{ + return ((CPerlObj*)pPerl)->Perl_sv_2pvbyte_nolen(sv); +} + #undef Perl_sv_pv char* Perl_sv_pv(pTHXo_ SV *sv) @@ -4793,6 +4893,20 @@ Perl_sv_pv(pTHXo_ SV *sv) return ((CPerlObj*)pPerl)->Perl_sv_pv(sv); } +#undef Perl_sv_pvutf8 +char* +Perl_sv_pvutf8(pTHXo_ SV *sv) +{ + return ((CPerlObj*)pPerl)->Perl_sv_pvutf8(sv); +} + +#undef Perl_sv_pvbyte +char* +Perl_sv_pvbyte(pTHXo_ SV *sv) +{ + return ((CPerlObj*)pPerl)->Perl_sv_pvbyte(sv); +} + #undef Perl_sv_force_normal void Perl_sv_force_normal(pTHXo_ SV *sv) @@ -4873,9 +4987,16 @@ Perl_si_dup(pTHXo_ PERL_SI* si) #undef Perl_ss_dup ANY* -Perl_ss_dup(pTHXo_ ANY* ss, I32 ix, I32 max) +Perl_ss_dup(pTHXo_ PerlInterpreter* proto_perl) { - return ((CPerlObj*)pPerl)->Perl_ss_dup(ss, ix, max); + return ((CPerlObj*)pPerl)->Perl_ss_dup(proto_perl); +} + +#undef Perl_any_dup +void* +Perl_any_dup(pTHXo_ void* v, PerlInterpreter* proto_perl) +{ + return ((CPerlObj*)pPerl)->Perl_any_dup(v, proto_perl); } #undef Perl_he_dup @@ -4963,24 +5084,9 @@ Perl_ptr_table_split(pTHXo_ PTR_TBL_t *tbl) { ((CPerlObj*)pPerl)->Perl_ptr_table_split(tbl); } - -#undef perl_clone -PerlInterpreter* -perl_clone(PerlInterpreter* interp, UV flags) -{ - dTHXo; - return ((CPerlObj*)pPerl)->perl_clone(flags); -} - -#undef perl_clone_using -PerlInterpreter* -perl_clone_using(PerlInterpreter *interp, UV flags, struct IPerlMem* m, struct IPerlEnv* e, struct IPerlStdIO* io, struct IPerlLIO* lio, struct IPerlDir* d, struct IPerlSock* s, struct IPerlProc* p) -{ - dTHXo; - return ((CPerlObj*)pPerl)->perl_clone_using(interp, flags, m, e, io, lio, d, s, p); -} #endif #if defined(PERL_OBJECT) +#else #endif #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) #endif @@ -5030,7 +5136,7 @@ perl_clone_using(PerlInterpreter *interp, UV flags, struct IPerlMem* m, struct I #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) # if defined(CRIPPLED_CC) # endif -# if defined(WIN32) +# if defined(PERL_CR_FILTER) # endif #endif #if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT) @@ -5039,6 +5145,8 @@ perl_clone_using(PerlInterpreter *interp, UV flags, struct IPerlMem* m, struct I # if defined(LEAKTEST) # endif #endif +#if defined(PERL_OBJECT) +#endif #undef Perl_ck_anoncode OP * @@ -7728,7 +7836,7 @@ Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...) dTHXo; va_list(arglist); va_start(arglist, format); - return (*pPerl->PL_StdIO->pVprintf)(pPerl->PL_StdIO, stream, format, arglist); + return (*PL_StdIO->pVprintf)(PL_StdIO, stream, format, arglist); } END_EXTERN_C diff --git a/perlsdio.h b/perlsdio.h index 71a9e752cd..7afda68191 100644 --- a/perlsdio.h +++ b/perlsdio.h @@ -85,11 +85,7 @@ #ifdef HAS_SETLINEBUF #define PerlIO_setlinebuf(f) setlinebuf(f); #else -# ifdef CYGWIN -# define PerlIO_setlinebuf(f) -# else -# define PerlIO_setlinebuf(f) setvbuf(f, Nullch, _IOLBF, 0); -# endif +#define PerlIO_setlinebuf(f) setvbuf(f, Nullch, _IOLBF, 0); #endif /* Now our interface to Configure's FILE_xxx macros */ diff --git a/perlvars.h b/perlvars.h index 85ff7515bd..55769d55ca 100644 --- a/perlvars.h +++ b/perlvars.h @@ -31,6 +31,6 @@ PERLVARIC(Gpatleave, char *, "\\.^$@dDwWsSbB+*?|()-nrtfeaxc0123456789[{]}") /* XXX does anyone even use this? */ PERLVARI(Gdo_undump, bool, FALSE) /* -u or dump seen? */ -#if defined(MYMALLOC) && defined(USE_THREADS) +#if defined(MYMALLOC) && (defined(USE_THREADS) || defined(USE_ITHREADS)) PERLVAR(Gmalloc_mutex, perl_mutex) /* Mutex for malloc */ #endif diff --git a/plan9/plan9ish.h b/plan9/plan9ish.h index 06a30fee3a..bac6a92d8f 100644 --- a/plan9/plan9ish.h +++ b/plan9/plan9ish.h @@ -103,7 +103,7 @@ #ifndef SIGILL # define SIGILL 6 /* blech */ #endif -#define ABORT() kill(getpid(),SIGABRT); +#define ABORT() kill(PerlProc_getpid(),SIGABRT); #define BIT_BUCKET "/dev/null" #define PERL_SYS_INIT(c,v) MALLOC_INIT diff --git a/pod/Makefile b/pod/Makefile index a4b405c320..3aadd9efc6 100644 --- a/pod/Makefile +++ b/pod/Makefile @@ -31,6 +31,7 @@ POD = \ perlmod.pod \ perlmodlib.pod \ perlmodinstall.pod \ + perlfork.pod \ perlform.pod \ perllocale.pod \ perlref.pod \ @@ -92,6 +93,7 @@ MAN = \ perlmod.man \ perlmodlib.man \ perlmodinstall.man \ + perlfork.man \ perlform.man \ perllocale.man \ perlref.man \ @@ -153,6 +155,7 @@ HTML = \ perlmod.html \ perlmodlib.html \ perlmodinstall.html \ + perlfork.html \ perlform.html \ perllocale.html \ perlref.html \ @@ -214,6 +217,7 @@ TEX = \ perlmod.tex \ perlmodlib.tex \ perlmodinstall.tex \ + perlfork.tex \ perlform.tex \ perllocale.tex \ perlref.tex \ diff --git a/pod/buildtoc b/pod/buildtoc index 1a9a24bb2d..41cb76dcb5 100644 --- a/pod/buildtoc +++ b/pod/buildtoc @@ -8,7 +8,7 @@ sub output ($); perl perlfaq perlfaq1 perlfaq2 perlfaq3 perlfaq4 perlfaq5 perlfaq6 perlfaq7 perlfaq8 perlfaq9 perldelta perldata perlsyn perlop perlre perlrun perlfunc perlvar perlsub - perlmod perlmodlib perlmodinstall perlform perllocale + perlmod perlmodlib perlmodinstall perlfork perlform perllocale perlref perlreftut perldsc perllol perltoot perltootc perlobj perltie perlbot perlipc perldbmfilter perldebug diff --git a/pod/perl.pod b/pod/perl.pod index 6e3921e307..9b5db8250c 100644 --- a/pod/perl.pod +++ b/pod/perl.pod @@ -47,6 +47,7 @@ sections: perltie Perl objects hidden behind simple variables perlbot Perl OO tricks and examples perlipc Perl interprocess communication + perlfork Perl fork() information perlthrtut Perl threads tutorial perldbmfilter Perl DBM Filters @@ -296,7 +297,7 @@ Perl developers, please write to perl-thanks@perl.org . s2p sed to perl translator http://www.perl.com/ the Perl Home Page - http://www.perl.com/CPAN the Comphrehensive Perl Archive + http://www.perl.com/CPAN the Comprehensive Perl Archive =head1 DIAGNOSTICS diff --git a/pod/perl5005delta.pod b/pod/perl5005delta.pod index 3766681ddd..335382181d 100644 --- a/pod/perl5005delta.pod +++ b/pod/perl5005delta.pod @@ -978,7 +978,7 @@ The F<Artistic> and F<Copying> files for copyright information. =head1 HISTORY -Written by Gurusamy Sarathy <F<gsar@umich.edu>>, with many contributions +Written by Gurusamy Sarathy <F<gsar@activestate.com>>, with many contributions from The Perl Porters. Send omissions or corrections to <F<perlbug@perl.com>>. diff --git a/pod/perlcall.pod b/pod/perlcall.pod index 35c0f051d5..e691e759a1 100644 --- a/pod/perlcall.pod +++ b/pod/perlcall.pod @@ -1948,7 +1948,7 @@ L<perlxs>, L<perlguts>, L<perlembed> =head1 AUTHOR -Paul Marquess <F<pmarquess@bfsec.bt.co.uk>> +Paul Marquess Special thanks to the following people who assisted in the creation of the document. diff --git a/pod/perldelta.pod b/pod/perldelta.pod index e46df77f83..9c040ed835 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -1,6 +1,6 @@ =head1 NAME -perldelta - what's new for perl v5.6 (as of v5.005_62) +perldelta - what's new for perl v5.6 (as of v5.005_64) =head1 DESCRIPTION @@ -15,8 +15,8 @@ This document describes differences between the 5.005 release and this one. =head2 Perl Source Incompatibilities -Beware that any new warnings that have been added or enhanced old -warnings are B<not> considered incompatible changes. +Beware that any new warnings that have been added or old ones +that have been enhanced are B<not> considered incompatible changes. Since all new warnings must be explicitly requested via the C<-w> switch or the C<warnings> pragma, it is ultimately the programmer's @@ -26,9 +26,11 @@ responsibility to ensure that warnings are enabled judiciously. =item STOP is a new keyword -In addition to C<BEGIN>, C<INIT> and C<END>, subroutines named -C<STOP> are now special. They are queued up for execution at the -end of compilation, and cannot be called directly. +In addition to C<BEGIN>, C<INIT>, C<END>, C<DESTROY> and C<AUTOLOAD>, +subroutines named C<STOP> are now special. These are queued up during +compilation and behave similar to END blocks, except they are called at +the end of compilation rather than at the end of execution. They cannot +be called directly. =item Treatment of list slices of undef has changed @@ -95,9 +97,9 @@ but still allowed it. In Perl 5.6 and later, C<"$$1"> always means C<"${$1}">. -=item values(%h) and C<\(%h)> operate on aliases to values, not copies +=item delete(), values() and C<\(%h)> operate on aliases to values, not copies -each(), values() and hashes in a list context return the actual +delete(), each(), values() and hashes in a list context return the actual values in the hash, instead of copies (as they used to in earlier versions). Typical idioms for using these constructs copy the returned values, but this can make a significant difference when @@ -125,6 +127,28 @@ The undocumented special variable C<%@> that used to accumulate has been removed, because it could potentially result in memory leaks. +=item Parenthesized not() behaves like a list operator + +The C<not> operator now falls under the "if it looks like a function, +it behaves like a function" rule. + +As a result, the parenthesized form can be used with C<grep> and C<map>. +The following construct used to be a syntax error before, but it works +as expected now: + + grep not($_), @things; + +On the other hand, using C<not> with a literal list slice may not +work. The following previously allowed construct: + + print not (1,2,3)[0]; + +needs to be written with additional parentheses now: + + print not((1,2,3)[0]); + +The behavior remains unaffected when C<not> is not followed by parentheses. + =back =head2 C Source Incompatibilities @@ -144,6 +168,10 @@ specified via MakeMaker: =item C<PERL_IMPLICIT_CONTEXT> +PERL_IMPLICIT_CONTEXT is automatically enabled whenever Perl is built +with one of -Dusethreads, -Dusemultiplicity, or both. It is not +intended to be enabled by users at this time. + This new build option provides a set of macros for all API functions such that an implicit interpreter/thread context argument is passed to every API function. As a result of this, something like C<sv_setsv(foo,bar)> @@ -160,9 +188,6 @@ Note that the above issue is not relevant to the default build of Perl, whose interfaces continue to match those of prior versions (but subject to the other options described here). -PERL_IMPLICIT_CONTEXT is automatically enabled whenever Perl is built -with one of -Dusethreads, -Dusemultiplicity, or both. - See L<perlguts/"The Perl API"> for detailed information on the ramifications of building Perl using this option. @@ -298,6 +323,52 @@ Perl can optionally use UTF-8 as its internal representation for character strings. The C<utf8> pragma enables this support in the current lexical scope. See L<utf8> for more information. +=head2 Interpreter threads + +WARNING: This is an experimental feature in a pre-alpha state. Use +at your own risk. + +Perl 5.005_63 introduces the beginnings of support for running multiple +interpreters concurrently in different threads. In conjunction with +the perl_clone() API call, which can be used to selectively duplicate +the state of any given interpreter, it is possible to compile a +piece of code once in an interpreter, clone that interpreter +one or more times, and run all the resulting interpreters in distinct +threads. + +On Windows, this feature is used to emulate fork() at the interpreter +level. See L<perlfork>. + +This feature is still in evolution. It is eventually meant to be used +to selectively clone a subroutine and data reachable from that +subroutine in a separate interpreter and run the cloned subroutine +in a separate thread. Since there is no shared data between the +interpreters, little or no locking will be needed (unless parts of +the symbol table are explicitly shared). This is obviously intended +to be an easy-to-use replacement for the existing threads support. + +Support for cloning interpreters must currently be manually enabled +by defining the cpp macro USE_ITHREADS on non-Windows platforms. +(See win32/Makefile for how to enable it on Windows.) The resulting +perl executable will be functionally identical to one that was built +without USE_ITHREADS, but the perl_clone() API call will only be +available in the former. + +USE_ITHREADS enables Perl source code changes that provide a clear +separation between the op tree and the data it operates with. The +former is considered immutable, and can therefore be shared between +an interpreter and all of its clones, while the latter is considered +local to each interpreter, and is therefore copied for each clone. + +Note that building Perl with the -Dusemultiplicity Configure option +is adequate if you wish to run multiple B<independent> interpreters +concurrently in different threads. USE_ITHREADS only needs to be +enabled if you wish to obtain access to perl_clone() and cloned +interpreters. + +[XXX TODO - the Compiler backends may be broken when USE_ITHREADS is +enabled.] + =head2 Lexically scoped warning categories You can now control the granularity of warnings emitted by perl at a finer @@ -333,9 +404,9 @@ change#3385, also need perlguts documentation WARNING: This is currently an experimental feature. Interfaces and implementation are likely to change. -Perl can be compiled with -DPERL_INTERNAL_GLOB to use the File::Glob -implementation of the glob() operator. This avoids using an external -csh process and the problems associated with it. +Perl now uses the File::Glob implementation of the glob() operator +automatically. This avoids using an external csh process and the +problems associated with it. =head2 Binary numbers supported @@ -354,17 +425,38 @@ This is rather similar to how the arrow may be omitted from C<$foo[10]->{'foo'}>. Note however, that the arrow is still required for C<foo(10)->('bar')>. +=head2 exists() and delete() are supported on array elements + +The exists() and delete() builtins now work on simple arrays as well. +The behavior is similar to that on hash elements. + +exists() can be used to check whether an array element has been +initialized without autovivifying it. If the array is tied, the +EXISTS() method in the corresponding tied package will be invoked. + +delete() may be used to remove an element from the array and return +it. The array element at that position returns to its unintialized +state, so that testing for the same element with exists() will return +false. If the element happens to be the one at the end, the size of +the array also shrinks by one. If the array is tied, the DELETE() method +in the corresponding tied package will be invoked. + +See L<perlfunc/exists> and L<perlfunc/delete> for examples. + =head2 syswrite() ease-of-use The length argument of C<syswrite()> has become optional. =head2 Filehandles can be autovivified -The construct C<open(my $fh, ...)> can be used to create filehandles -more easily. The filehandle will be automatically closed at the end -of the scope of $fh, provided there are no other references to it. This -largely eliminates the need for typeglobs when opening filehandles -that must be passed around, as in the following example: +Similar to how constructs such as C<$x->[0]> autovivify a reference, +open() now autovivifies a filehandle if the first argument is an +uninitialized variable. This allows the constructs C<open(my $fh, ...)> and +C<open(local $fh,...)> to be used to create filehandles that will +conveniently be closed automatically when the scope ends, provided there +are no other references to them. This largely eliminates the need for +typeglobs when opening filehandles that must be passed around, as in the +following example: sub myopen { open my $fh, "@_" @@ -469,6 +561,16 @@ this support (if it is available). You can Configure -Dusemorebits to turn on both the 64-bit support and the long double support. +=head2 Enhanced support for sort() subroutines + +Perl subroutines with a prototype of C<($$)> and XSUBs in general can +now be used as sort subroutines. In either case, the two elements to +be compared are passed as normal parameters in @_. See L<perlfunc/sort>. + +For unprototyped sort subroutines, the historical behavior of passing +the elements to be compared as the global variables $a and $b remains +unchanged. + =head2 Better syntax checks on parenthesized unary operators Expressions such as: @@ -609,13 +711,6 @@ BEGIN blocks are executed under such conditions, this variable enables perl code to determine whether actions that make sense only during normal running are warranted. See L<perlvar>. -=head2 STOP blocks - -Arbitrary code can be queued for execution when Perl has finished -parsing the program (i.e. when the compile phase ends) using STOP -blocks. These behave similar to END blocks, except for being -called at the end of compilation rather than at the end of execution. - =head2 Optional Y2K warnings If Perl is built with the cpp macro C<PERL_Y2KWARN> defined, @@ -698,6 +793,12 @@ on C<NEW> will return the same data as the corresponding operation on C<OLD>. Formerly, it would have returned the data from the start of the following disk block instead. +=head2 eof() has the same old magic as <> + +C<eof()> would return true if no attempt to read from C<E<lt>E<gt>> had +yet been made. C<eof()> has been changed to have a little magic of its +own, it now opens the C<E<lt>E<gt>> files. + =head2 system(), backticks and pipe open now reflect exec() failure On Unix and similar platforms, system(), qx() and open(FOO, "cmd |") @@ -729,6 +830,10 @@ been corrected. When applied to a pseudo-hash element, exists() now reports whether the specified value exists, not merely if the key is valid. +delete() now works on pseudo-hashes. When given a pseudo-hash element +or slice it deletes the values corresponding to the keys (but not the keys +themselves). See L<perlref/"Pseudo-hashes: Using an array as a hash">. + =head2 C<goto &sub> and AUTOLOAD The C<goto &sub> construct works correctly when C<&sub> happens @@ -960,6 +1065,13 @@ The C<Shell> module is supported. Rudimentary support for building under command.com in Windows 95 has been added. +Scripts are read in binary mode by default to allow ByteLoader (and +the filter mechanism in general) to work properly. For compatibility, +the DATA filehandle will be set to text mode if a carriage return is +detected at the end of the line containing the __END__ or __DATA__ +token; if not, the DATA filehandle will be left open in binary mode. +Earlier versions always opened the DATA filehandle in text mode. + [TODO - GSAR] =head1 New tests @@ -1031,7 +1143,17 @@ Perl bytecode. See L<ByteLoader>. =item constant -References can now be used. See L<constant>. +References can now be used. + +The new version also allows a leading underscore in constant names, but +disallows a double leading underscore (as in "__LINE__"). Some other names +are disallowed or warned against, including BEGIN, END, etc. Some names +which were forced into main:: used to fail silently in some cases; now they're +fatal (outside of main::) and an optional warning (inside of main::). +The ability to detect whether a constant had been set with a given name has +been added. + +See L<constant>. =item charnames @@ -1052,7 +1174,8 @@ to Perl's debugging API. =item DB_File -[TODO - Paul Marquess <paul.marquess@bt.com>] +DB_File can now be built with Berkeley DB versions 1, 2 or 3. +See C<ext/DB_File/Changes>. =item Devel::DProf @@ -1134,11 +1257,19 @@ autoloaded or is a symbolic reference. A bug that caused File::Find to lose track of the working directory when pruning top-level directories has been fixed. +File::Find now also supports several other options to control its +behavior. It can follow symbolic links if the C<follow> option is +specified. Enabling the C<no_chdir> option will make File::Find skip +changing the current directory when walking directories. The C<untaint> +flag can be useful when running with taint checks enabled. + +See L<File::Find>. + =item File::Glob -This extension implements BSD-style file globbing. It will also be -used for the internal implementation of the glob() operator if -Perl was compiled with -DPERL_INTERNAL_GLOB. See L<File::Glob>. +This extension implements BSD-style file globbing. By default, +it will also be used for the internal implementation of the glob() +operator. See L<File::Glob>. =item File::Spec diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 277e6342bc..f82cd25409 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -140,23 +140,23 @@ definition ahead of the call to get proper prototype checking. Alternatively, if you are certain that you're calling the function correctly, you may put an ampersand before the name to avoid the warning. See L<perlsub>. -=item %s argument is not a HASH element +=item %s argument is not a HASH or ARRAY element -(F) The argument to exists() must be a hash element, such as +(F) The argument to exists() must be a hash or array element, such as: $foo{$bar} - $ref->[12]->{"susie"} + $ref->[12]->["susie"] -=item %s argument is not a HASH element or slice +=item %s argument is not a HASH or ARRAY element or slice -(F) The argument to delete() must be either a hash element, such as +(F) The argument to delete() must be either a hash or array element, such as: $foo{$bar} - $ref->[12]->{"susie"} + $ref->[12]->["susie"] -or a hash slice, such as +or a hash or array slice, such as: - @foo{$bar, $baz, $xyzzy} + @foo[$bar, $baz, $xyzzy] @{$ref->[12]}{"susie", "queue"} =item %s did not return a true value @@ -280,7 +280,7 @@ the string being unpacked. See L<perlfunc/pack>. (F) You wrote C<require E<lt>fileE<gt>> when you should have written C<require 'file'>. -=item accept() on closed fd +=item accept() on closed socket (W) You tried to do an accept on a closed socket. Did you forget to check the return value of your socket() call? See L<perlfunc/accept>. @@ -518,7 +518,7 @@ likely depends on its correct operation, Perl just gave up. (4294967295) and therefore non-portable between systems. See L<perlport> for more on portability concerns. -=item bind() on closed fd +=item bind() on closed socket (W) You tried to do a bind on a closed socket. Did you forget to check the return value of your socket() call? See L<perlfunc/bind>. @@ -542,7 +542,7 @@ so it was truncated to the string shown. (F) A subroutine invoked from an external package via perl_call_sv() exited by calling exit. -=item Can't "goto" outside a block +=item Can't "goto" out of a pseudo block (F) A "goto" statement was executed to jump out of what might look like a block, except that it isn't a proper block. This usually @@ -554,22 +554,24 @@ is a no-no. See L<perlfunc/goto>. (F) A "goto" statement was executed to jump into the middle of a foreach loop. You can't get there from here. See L<perlfunc/goto>. -=item Can't "last" outside a block +=item Can't "last" outside a loop block (F) A "last" statement was executed to break out of the current block, except that there's this itty bitty problem called there isn't a current block. Note that an "if" or "else" block doesn't count as a -"loopish" block, as doesn't a block given to sort(). You can usually double -the curlies to get the same effect though, because the inner curlies -will be considered a block that loops once. See L<perlfunc/last>. +"loopish" block, as doesn't a block given to sort(), map() or grep(). +You can usually double the curlies to get the same effect though, +because the inner curlies will be considered a block that loops once. +See L<perlfunc/last>. -=item Can't "next" outside a block +=item Can't "next" outside a loop block (F) A "next" statement was executed to reiterate the current block, but there isn't a current block. Note that an "if" or "else" block doesn't -count as a "loopish" block, as doesn't a block given to sort(). You can -usually double the curlies to get the same effect though, because the inner -curlies will be considered a block that loops once. See L<perlfunc/next>. +count as a "loopish" block, as doesn't a block given to sort(), map() +or grep(). You can usually double the curlies to get the same effect +though, because the inner curlies will be considered a block that +loops once. See L<perlfunc/next>. =item Can't read CRTL environ @@ -578,13 +580,14 @@ from the CRTL's internal environment array and discovered the array was missing. You need to figure out where your CRTL misplaced its environ or define F<PERL_ENV_TABLES> (see L<perlvms>) so that environ is not searched. -=item Can't "redo" outside a block +=item Can't "redo" outside a loop block (F) A "redo" statement was executed to restart the current block, but there isn't a current block. Note that an "if" or "else" block doesn't -count as a "loopish" block, as doesn't a block given to sort(). You can -usually double the curlies to get the same effect though, because the inner -curlies will be considered a block that loops once. See L<perlfunc/redo>. +count as a "loopish" block, as doesn't a block given to sort(), map() +or grep(). You can usually double the curlies to get the same effect +though, because the inner curlies will be considered a block that +loops once. See L<perlfunc/redo>. =item Can't bless non-reference value @@ -1065,7 +1068,7 @@ most likely an unexpected right brace '}'. reference of the type needed. You can use the ref() function to test the type of the reference, if need be. -=item Can't use \1 to mean $1 in expression +=item Can't use \%c to mean $%c in expression (W) In an ordinary expression, backslash is a unary operator that creates a reference to its argument. The use of backslash to indicate a backreference @@ -1073,7 +1076,7 @@ to a matched substring is valid only as part of a regular expression pattern. Trying to do this in ordinary Perl code produces a value that prints out looking like SCALAR(0xdecaf). Use the $1 form instead. -=item Can't use bareword ("%s") as %s ref while \"strict refs\" in use +=item Can't use bareword ("%s") as %s ref while "strict refs" in use (F) Only hard references are allowed by "strict refs". Symbolic references are disallowed. See L<perlref>. @@ -1184,7 +1187,7 @@ than in the regular expression engine; or rewriting the regular expression so that it is simpler or backtracks less. (See L<perlbook> for information on I<Mastering Regular Expressions>.) -=item connect() on closed fd +=item connect() on closed socket (W) You tried to do a connect on a closed socket. Did you forget to check the return value of your socket() call? See L<perlfunc/connect>. @@ -1486,7 +1489,7 @@ when you meant because if it did, it'd feel morally obligated to return every hostname on the Internet. -=item get{sock,peer}name() on closed fd +=item get%sname() on closed socket (W) You tried to get a socket or peer socket name on a closed socket. Did you forget to check the return value of your socket() call? @@ -1763,7 +1766,7 @@ L<perlfunc/last>. (F) While under the C<use filetest> pragma, switching the real and effective uids or gids failed. -=item listen() on closed fd +=item listen() on closed socket (W) You tried to do a listen on a closed socket. Did you forget to check the return value of your socket() call? See L<perlfunc/listen>. @@ -1901,6 +1904,11 @@ See L<perlsec>. (F) A setuid script can't be specified by the user. +=item No %s specified for -%c + +(F) The indicated command line switch needs a mandatory argument, but +you haven't specified one. + =item No comma allowed after %s (F) A list operator that has a filehandle or "indirect object" is not @@ -1985,10 +1993,10 @@ your system. (F) Configure didn't find anything resembling the setreuid() call for your system. -=item No space allowed after B<-I> +=item No space allowed after -%c -(F) The argument to B<-I> must follow the B<-I> immediately with no -intervening space. +(F) The argument to the indicated command line switch must follow immediately +after the switch, without intervening spaces. =item No such pseudo-hash field "%s" @@ -2475,12 +2483,12 @@ instead of "||". See Server error. -=item print on closed filehandle %s +=item print() on closed filehandle %s (W) The filehandle you're printing on got itself closed sometime before now. Check your logic flow. -=item printf on closed filehandle %s +=item printf() on closed filehandle %s (W) The filehandle you're writing to got itself closed sometime before now. Check your logic flow. @@ -2505,7 +2513,7 @@ are outside the range which can be represented by integers internally. One possible workaround is to force Perl to use magical string increment by prepending "0" to your numbers. -=item Read on closed filehandle %s +=item readline() on closed filehandle %s (W) The filehandle you're reading from got itself closed sometime before now. Check your logic flow. @@ -2646,9 +2654,9 @@ that had previously been marked as free. (W) A nearby syntax error was probably caused by a missing semicolon, or possibly some other missing operator, such as a comma. -=item Send on closed socket +=item send() on closed socket -(W) The filehandle you're sending to got itself closed sometime before now. +(W) The socket you're sending to got itself closed sometime before now. Check your logic flow. =item Sequence (? incomplete @@ -2735,7 +2743,7 @@ because the world might have written on it already. (F) You don't have System V shared memory IPC on your system. -=item shutdown() on closed fd +=item shutdown() on closed socket (W) You tried to do a shutdown on a closed socket. Seems a bit superfluous. @@ -2873,7 +2881,7 @@ into Perl yourself. machine. In some machines the functionality can exist but be unconfigured. Consult your system support. -=item Syswrite on closed filehandle +=item syswrite() on closed filehandle (W) The filehandle you're writing to got itself closed sometime before now. Check your logic flow. @@ -3266,7 +3274,7 @@ e.g. C<&our()>, or C<Foo::our()>. because there's a better way to do it, and also because the old way has bad side effects. -=item Use of uninitialized value +=item Use of uninitialized value%s (W) An undefined value was used as if it were already defined. It was interpreted as a "" or a 0, but maybe it was a mistake. To suppress this @@ -3441,7 +3449,7 @@ but in actual fact, you got So put in parentheses to say what you really mean. -=item Write on closed filehandle %s +=item write() on closed filehandle %s (W) The filehandle you're writing to got itself closed sometime before now. Check your logic flow. @@ -3484,11 +3492,11 @@ already have a subroutine of that name declared, which means that Perl 5 will try to call the subroutine when the assignment is executed, which is probably not what you want. (If it IS what you want, put an & in front.) -=item [gs]etsockopt() on closed fd +=item %cetsockopt() on closed fd (W) You tried to get or set a socket option on a closed socket. Did you forget to check the return value of your socket() call? -See L<perlfunc/getsockopt>. +See L<perlfunc/getsockopt> and L<perlfunc/setsockopt>. =item \1 better written as $1 diff --git a/pod/perlfaq2.pod b/pod/perlfaq2.pod index 5a04da399c..80b150d89c 100644 --- a/pod/perlfaq2.pod +++ b/pod/perlfaq2.pod @@ -344,10 +344,10 @@ following list is I<not> the complete list of CPAN mirrors. Most of the major modules (Tk, CGI, libwww-perl) have their own mailing lists. Consult the documentation that came with the module for -subscription information. The Perl Institute attempts to maintain a +subscription information. Perl Mongers attempts to maintain a list of mailing lists at: - http://www.perl.org/maillist.html + http://www.perl.org/support/online_support.html#mail =head2 Archives of comp.lang.perl.misc diff --git a/pod/perlfaq3.pod b/pod/perlfaq3.pod index 26f7a693f3..18c436bdc4 100644 --- a/pod/perlfaq3.pod +++ b/pod/perlfaq3.pod @@ -483,7 +483,7 @@ The Win95/NT installation, when using the ActiveState port of Perl, will modify the Registry to associate the C<.pl> extension with the perl interpreter. If you install another port, perhaps even building your own Win95/NT Perl from the standard sources by using a Windows port -of gcc (e.g., with cygwin32 or mingw32), then you'll have to modify +of gcc (e.g., with cygwin or mingw32), then you'll have to modify the Registry yourself. In addition to associating C<.pl> with the interpreter, NT people can use: C<SET PATHEXT=%PATHEXT%;.PL> to let them run the program C<install-linux.pl> merely by typing C<install-linux>. diff --git a/pod/perlfaq4.pod b/pod/perlfaq4.pod index 63e093fe0e..838f753fa6 100644 --- a/pod/perlfaq4.pod +++ b/pod/perlfaq4.pod @@ -1746,7 +1746,7 @@ if you just want to say, ``Is this a float?'' } } - sub is_numeric { defined &getnum } + sub is_numeric { defined getnum($_[0]) } Or you could check out http://www.perl.com/CPAN/modules/by-module/String/String-Scanf-1.1.tar.gz diff --git a/pod/perlfilter.pod b/pod/perlfilter.pod index f3ab788ffc..a2eb1d855b 100644 --- a/pod/perlfilter.pod +++ b/pod/perlfilter.pod @@ -57,7 +57,7 @@ Every source stream is associated with only one file. A source filter is a special kind of Perl module that intercepts and modifies a source stream before it reaches the parser. A source filter -changes the our diagram like this: +changes our diagram like this: file ----> filter ----> parser @@ -510,8 +510,7 @@ doesn't know Perl. It can be fooled quite easily: EOM Such things aside, you can see that a lot can be achieved with a modest -amount of code. I<[Note that Tuomas' toy VRML parser on p. 17 had the -same difficulty parsing VRML strings that look like comments. -Jon]> +amount of code. =head1 CONCLUSION diff --git a/pod/perlfork.pod b/pod/perlfork.pod new file mode 100644 index 0000000000..533dcfab31 --- /dev/null +++ b/pod/perlfork.pod @@ -0,0 +1,232 @@ +=head1 NAME + +perlfork - Perl's fork() emulation + +=head1 SYNOPSIS + +Perl provides a fork() keyword that corresponds to the Unix system call +of the same name. On most Unix-like platforms where the fork() system +call is available, Perl's fork() simply calls it. + +On some platforms such as Windows where the fork() system call is not +available, Perl can be built to emulate fork() at the interpreter level. +While the emulation is designed to be as compatible as possible with the +real fork() at the the level of the Perl program, there are certain +important differences that stem from the fact that all the pseudo child +"processes" created this way live in the same real process as far as the +operating system is concerned. + +This document provides a general overview of the capabilities and +limitations of the fork() emulation. Note that the issues discussed here +are not applicable to platforms where a real fork() is available and Perl +has been configured to use it. + +=head1 DESCRIPTION + +The fork() emulation is implemented at the level of the Perl interpreter. +What this means in general is that running fork() will actually clone the +running interpreter and all its state, and run the cloned interpreter in +a separate thread, beginning execution in the new thread just after the +point where the fork() was called in the parent. We will refer to the +thread that implements this child "process" as the pseudo-process. + +To the Perl program that called fork(), all this is designed to be +transparent. The parent returns from the fork() with a pseudo-process +ID that can be subsequently used in any process manipulation functions; +the child returns from the fork() with a value of C<0> to signify that +it is the child pseudo-process. + +=head2 Behavior of other Perl features in forked pseudo-processes + +Most Perl features behave in a natural way within pseudo-processes. + +=over 8 + +=item $$ or $PROCESS_ID + +This special variable is correctly set to the pseudo-process ID. +It can be used to identify pseudo-processes within a particular +session. Note that this value is subject to recycling if any +pseudo-processes are launched after others have been wait()-ed on. + +=item %ENV + +Each pseudo-process maintains its own virtual enviroment. Modifications +to %ENV affect the virtual environment, and are only visible within that +pseudo-process, and in any processes (or pseudo-processes) launched from +it. + +=item chdir() and all other builtins that accept filenames + +Each pseudo-process maintains its own virtual idea of the current directory. +Modifications to the current directory using chdir() are only visible within +that pseudo-process, and in any processes (or pseudo-processes) launched from +it. All file and directory accesses from the pseudo-process will correctly +map the virtual working directory to the real working directory appropriately. + +=item wait() and waitpid() + +wait() and waitpid() can be passed a pseudo-process ID returned by fork(). +These calls will properly wait for the termination of the pseudo-process +and return its status. + +=item kill() + +kill() can be used to terminate a pseudo-process by passing it the ID returned +by fork(). This should not be used except under dire circumstances, because +the operating system may not guarantee integrity of the process resources +when a running thread is terminated. Note that using kill() on a +pseudo-process() may typically cause memory leaks, because the thread that +implements the pseudo-process does not get a chance to clean up its resources. + +=item exec() + +Calling exec() within a pseudo-process actually spawns the requested +executable in a separate process and waits for it to complete before +exiting with the same exit status as that process. This means that the +process ID reported within the running executable will be different from +what the earlier Perl fork() might have returned. Similarly, any process +manipulation functions applied to the ID returned by fork() will affect the +waiting pseudo-process that called exec(), not the real process it is +waiting for after the exec(). + +=item exit() + +exit() always exits just the executing pseudo-process, after automatically +wait()-ing for any outstanding child pseudo-processes. Note that this means +that the process as a whole will not exit unless all running pseudo-processes +have exited. + +=item Open handles to files, directories and network sockets + +All open handles are dup()-ed in pseudo-processes, so that closing +any handles in one process does not affect the others. See below for +some limitations. + +=back + +=head2 Resource limits + +In the eyes of the operating system, pseudo-processes created via the fork() +emulation are simply threads in the same process. This means that any +process-level limits imposed by the operating system apply to all +pseudo-processes taken together. This includes any limits imposed by the +operating system on the number of open file, directory and socket handles, +limits on disk space usage, limits on memory size, limits on CPU utilization +etc. + +=head2 Killing the parent process + +If the parent process is killed (either using Perl's kill() builtin, or +using some external means) all the pseudo-processes are killed as well, +and the whole process exits. + +=head2 Lifetime of the parent process and pseudo-processes + +During the normal course of events, the parent process and every +pseudo-process started by it will wait for their respective pseudo-children +to complete before they exit. This means that the parent and every +pseudo-child created by it that is also a pseudo-parent will only exit +after their pseudo-children have exited. + +A way to mark a pseudo-processes as running detached from their parent (so +that the parent would not have to wait() for them if it doesn't want to) +will be provided in future. + +=head2 CAVEATS AND LIMITATIONS + +=over 8 + +=item BEGIN blocks + +The fork() emulation will not work entirely correctly when called from +within a BEGIN block. The forked copy will run the contents of the +BEGIN block, but will not continue parsing the source stream after the +BEGIN block. For example, consider the following code: + + BEGIN { + fork and exit; # fork child and exit the parent + print "inner\n"; + } + print "outer\n"; + +This will print: + + inner + +rather than the expected: + + inner + outer + +This limitation arises from fundamental technical difficulties in +cloning and restarting the stacks used by the Perl parser in the +middle of a parse. + +=item Open filehandles + +Any filehandles open at the time of the fork() will be dup()-ed. Thus, +the files can be closed independently in the parent and child, but beware +that the dup()-ed handles will still share the same seek pointer. Changing +the seek position in the parent will change it in the child and vice-versa. +One can avoid this by opening files that need distinct seek pointers +separately in the child. + +=item Global state maintained by XSUBs + +External subroutines (XSUBs) that maintain their own global state may +not work correctly. Such XSUBs will either need to maintain locks to +protect simultaneous access to global data from different pseudo-processes, +or maintain all their state on the Perl symbol table, which is copied +naturally when fork() is called. A callback mechanism that provides +extensions an opportunity to clone their state will be provided in the +near future. + +=item Interpreter embedded in larger application + +The fork() emulation may not behave as expected when it is executed in an +application which embeds a Perl interpreter and calls Perl APIs that can +evaluate bits of Perl code. This stems from the fact that the emulation +only has knowledge about the Perl interpreter's own data structures and +knows nothing about the containing application's state. For example, any +state carried on the application's own call stack is out of reach. + +=item Thread-safety of extensions + +Since the fork() emulation runs code in multiple threads, extensions +calling into non-thread-safe libraries may not work reliably when +calling fork(). As Perl's threading support gradually becomes more +widely adopted even on platforms with a native fork(), such extensions +are expected to be fixed for thread-safety. + +=back + +=head1 BUGS + +=over 8 + +=item * + +Having pseudo-process IDs be negative integers breaks down for the integer +C<-1> because the wait() and waitpid() functions treat this number as +being special. The tacit assumption in the current implementation is that +the system never allocates a thread ID of C<1> for user threads. A better +representation for pseudo-process IDs will be implemented in future. + +=item * + +This document may be incomplete in some respects. + +=head1 AUTHOR + +Support for concurrent interpreters and the fork() emulation was implemented +by ActiveState, with funding from Microsoft Corporation. + +This document is authored and maintained by Gurusamy Sarathy +E<lt>gsar@activestate.comE<gt>. + +=head1 SEE ALSO + +L<perlfunc/"fork">, L<perlipc> + +=cut diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 088f1dd509..90c1988fb0 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -515,12 +515,12 @@ to go back before the current one. ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints) = caller($i); -Here $subroutine may be C<"(eval)"> if the frame is not a subroutine +Here $subroutine may be C<(eval)> if the frame is not a subroutine call, but an C<eval>. In such a case additional elements $evaltext and C<$is_require> are set: C<$is_require> is true if the frame is created by a C<require> or C<use> statement, $evaltext contains the text of the C<eval EXPR> statement. In particular, for a C<eval BLOCK> statement, -$filename is C<"(eval)">, but $evaltext is undefined. (Note also that +$filename is C<(eval)>, but $evaltext is undefined. (Note also that each C<use> statement creates a C<require> frame inside an C<eval EXPR>) frame. C<$hints> contains pragmatic hints that the caller was compiled with. It currently only reflects the hint corresponding to @@ -669,7 +669,7 @@ If NUMBER is omitted, uses C<$_>. This function works like the system call by the same name: it makes the named directory the new root directory for all further pathnames that -begin with a C<"/"> by your process and all its children. (It doesn't +begin with a C</> by your process and all its children. (It doesn't change your current working directory, which is unaffected.) For security reasons, this call is restricted to the superuser. If FILENAME is omitted, does a C<chroot> to C<$_>. @@ -925,35 +925,55 @@ See also L</undef>, L</exists>, L</ref>. =item delete EXPR -Deletes the specified key(s) and their associated values from a hash. -For each key, returns the deleted value associated with that key, or -the undefined value if there was no such key. Deleting from C<$ENV{}> -modifies the environment. Deleting from a hash tied to a DBM file -deletes the entry from the DBM file. (But deleting from a C<tie>d hash -doesn't necessarily return anything.) +Given an expression that specifies a hash element, array element, hash slice, +or array slice, deletes the specified element(s) from the hash or array. +If the array elements happen to be at the end of the array, the size +of the array will shrink by that number of elements. -The following deletes all the values of a hash: +Returns each element so deleted or the undefined value if there was no such +element. Deleting from C<$ENV{}> modifies the environment. Deleting from +a hash tied to a DBM file deletes the entry from the DBM file. Deleting +from a C<tie>d hash or array may not necessarily return anything. + +Deleting an array element effectively returns that position of the array +to its initial, uninitialized state. Subsequently testing for the same +element with exists() will return false. See L</exists>. + +The following (inefficiently) deletes all the values of %HASH and @ARRAY: foreach $key (keys %HASH) { delete $HASH{$key}; } -And so does this: + foreach $index (0 .. $#ARRAY) { + delete $ARRAY[$index]; + } + +And so do these: - delete @HASH{keys %HASH} + delete @HASH{keys %HASH}; + + delete @ARRAY{0 .. $#ARRAY}; But both of these are slower than just assigning the empty list -or undefining it: +or undefining %HASH or @ARRAY: + + %HASH = (); # completely empty %HASH + undef %HASH; # forget %HASH ever existed - %hash = (); # completely empty %hash - undef %hash; # forget %hash every existed + @ARRAY = (); # completely empty @ARRAY + undef @ARRAY; # forget @ARRAY ever existed Note that the EXPR can be arbitrarily complicated as long as the final -operation is a hash element lookup or hash slice: +operation is a hash element, array element, hash slice, or array slice +lookup: delete $ref->[$x][$y]{$key}; delete @{$ref->[$x][$y]}{$key1, $key2, @morekeys}; + delete $ref->[$x][$y][$index]; + delete @{$ref->[$x][$y]}[$index1, $index2, @moreindices]; + =item die LIST Outside an C<eval>, prints the value of LIST to C<STDERR> and @@ -1172,13 +1192,17 @@ interactive context.) Do not read from a terminal file (or call C<eof(FILEHANDLE)> on it) after end-of-file is reached. File types such as terminals may lose the end-of-file condition if you do. -An C<eof> without an argument uses the last file read as argument. -Using C<eof()> with empty parentheses is very different. It indicates -the pseudo file formed of the files listed on the command line, -i.e., C<eof()> is reasonable to use inside a C<while (E<lt>E<gt>)> -loop to detect the end of only the last file. Use C<eof(ARGV)> or -C<eof> without the parentheses to test I<each> file in a while -(E<lt>E<gt>) loop. Examples: +An C<eof> without an argument uses the last file read. Using C<eof()> +with empty parentheses is very different. It refers to the pseudo file +formed from the files listed on the command line and accessed via the +C<E<lt>E<gt>> operator. Since C<E<lt>E<gt>> isn't explicitly opened, +as a normal filehandle is, an C<eof()> before C<E<lt>E<gt>> has been +used will cause C<@ARGV> to be examined to determine if input is +available. + +In a C<while (E<lt>E<gt>)> loop, C<eof> or C<eof(ARGV)> can be used to +detect the end of each file, C<eof()> will only detect the end of the +last file. Examples: # reset line numbering on each input file while (<>) { @@ -1199,8 +1223,8 @@ C<eof> without the parentheses to test I<each> file in a while } Practical hint: you almost never need to use C<eof> in Perl, because the -input operators return false values when they run out of data, or if there -was an error. +input operators typically return C<undef> when they run out of data, or if +there was an error. =item eval EXPR @@ -1382,27 +1406,36 @@ any C<DESTROY> methods in your objects. =item exists EXPR -Returns true if the specified hash key exists in its hash, even -if the corresponding value is undefined. +Given an expression that specifies a hash element or array element, +returns true if the specified element in the hash or array has ever +been initialized, even if the corresponding value is undefined. The +element is not autovivified if it doesn't exist. - print "Exists\n" if exists $array{$key}; - print "Defined\n" if defined $array{$key}; - print "True\n" if $array{$key}; + print "Exists\n" if exists $hash{$key}; + print "Defined\n" if defined $hash{$key}; + print "True\n" if $hash{$key}; -A hash element can be true only if it's defined, and defined if + print "Exists\n" if exists $array[$index]; + print "Defined\n" if defined $array[$index]; + print "True\n" if $array[$index]; + +A hash or array element can be true only if it's defined, and defined if it exists, but the reverse doesn't necessarily hold true. Note that the EXPR can be arbitrarily complicated as long as the final -operation is a hash key lookup: +operation is a hash or array key lookup: if (exists $ref->{A}->{B}->{$key}) { } if (exists $hash{A}{B}{$key}) { } -Although the last element will not spring into existence just because -its existence was tested, intervening ones will. Thus C<$ref-E<gt>{"A"}> -and C<$ref-E<gt>{"A"}-E<gt>{"B"}> will spring into existence due to the -existence test for a $key element. This happens anywhere the arrow -operator is used, including even + if (exists $ref->{A}->{B}->[$ix]) { } + if (exists $hash{A}{B}[$ix]) { } + +Although the deepest nested array or hash will not spring into existence +just because its existence was tested, any intervening ones will. +Thus C<$ref-E<gt>{"A"}> and C<$ref-E<gt>{"A"}-E<gt>{"B"}> will spring +into existence due to the existence test for the $key element above. +This happens anywhere the arrow operator is used, including even: undef $ref; if (exists $ref->{"Some key"}) { } @@ -1462,8 +1495,8 @@ For example: or die "can't fcntl F_GETFL: $!"; You don't have to check for C<defined> on the return from C<fnctl>. -Like C<ioctl>, it maps a C<0> return from the system call into C<"0 -but true"> in Perl. This string is true in boolean context and C<0> +Like C<ioctl>, it maps a C<0> return from the system call into +C<"0 but true"> in Perl. This string is true in boolean context and C<0> in numeric context. It is also exempt from the normal B<-w> warnings on improper numeric conversions. @@ -1884,6 +1917,14 @@ I<not> simply the last two digits of the year. If you assume it is, then you create non-Y2K-compliant programs--and you wouldn't want to do that, would you? +The proper way to get a complete 4-digit year is simply: + + $year += 1900; + +And to get the last two digits of the year (e.g., '01' in 2001) do: + + $year = sprintf("%02d", $year % 100); + If EXPR is omitted, does C<gmtime(time())>. In scalar context, returns the ctime(3) value: @@ -1929,13 +1970,20 @@ necessarily recommended if you're optimizing for maintainability: goto ("FOO", "BAR", "GLARCH")[$i]; -The C<goto-&NAME> form is highly magical, and substitutes a call to the -named subroutine for the currently running subroutine. This is used by -C<AUTOLOAD> subroutines that wish to load another subroutine and then -pretend that the other subroutine had been called in the first place -(except that any modifications to C<@_> in the current subroutine are -propagated to the other subroutine.) After the C<goto>, not even C<caller> -will be able to tell that this routine was called first. +The C<goto-&NAME> form is quite different from the other forms of C<goto>. +In fact, it isn't a goto in the normal sense at all, and doesn't have +the stigma associated with other gotos. Instead, it +substitutes a call to the named subroutine for the currently running +subroutine. This is used by C<AUTOLOAD> subroutines that wish to load +another subroutine and then pretend that the other subroutine had been +called in the first place (except that any modifications to C<@_> +in the current subroutine are propagated to the other subroutine.) +After the C<goto>, not even C<caller> will be able to tell that this +routine was called first. + +NAME needn't be the name of a subroutine; it can be a scalar variable +containing a code reference, or a block which evaluates to a code +reference. =item grep BLOCK LIST @@ -2232,6 +2280,14 @@ and I<not> simply the last two digits of the year. If you assume it is, then you create non-Y2K-compliant programs--and you wouldn't want to do that, would you? +The proper way to get a complete 4-digit year is simply: + + $year += 1900; + +And to get the last two digits of the year (e.g., '01' in 2001) do: + + $year = sprintf("%02d", $year % 100); + If EXPR is omitted, uses the current time (C<localtime(time)>). In scalar context, returns the ctime(3) value: @@ -2349,8 +2405,8 @@ Calls the System V IPC function msgctl(2). You'll probably have to say first to get the correct constant definitions. If CMD is C<IPC_STAT>, then ARG must be a variable which will hold the returned C<msqid_ds> -structure. Returns like C<ioctl>: the undefined value for error, C<"0 but -true"> for zero, or the actual return value otherwise. See also +structure. Returns like C<ioctl>: the undefined value for error, +C<"0 but true"> for zero, or the actual return value otherwise. See also C<IPC::SysV> and C<IPC::Semaphore> documentation. =item msgget KEY,FLAGS @@ -2602,6 +2658,12 @@ parsimonious of file descriptors. For example: open(FILEHANDLE, "<&=$fd") +Note that this feature depends on the fdopen() C library function. +On many UNIX systems, fdopen() is known to fail when file descriptors +exceed a certain value, typically 255. If you need more file +descriptors than that, consider rebuilding Perl to use the C<sfio> +library. + If you open a pipe on the command C<'-'>, i.e., either C<'|-'> or C<'-|'> with 2-arguments (or 1-argument) form of open(), then there is an implicit fork done, and the return value of open is the pid @@ -2808,75 +2870,105 @@ The following rules apply: =item * Each letter may optionally be followed by a number giving a repeat -count. With all types except C<"a">, C<"A">, C<"Z">, C<"b">, C<"B">, C<"h">, -C<"H">, and C<"P"> the pack function will gobble up that many values from +count. With all types except C<a>, C<A>, C<Z>, C<b>, C<B>, C<h>, +C<H>, and C<P> the pack function will gobble up that many values from the LIST. A C<*> for the repeat count means to use however many items are -left, except for C<"@">, C<"x">, C<"X">, where it is equivalent -to C<"0">, and C<"u">, where it is equivalent to 1 (or 45, what is the +left, except for C<@>, C<x>, C<X>, where it is equivalent +to C<0>, and C<u>, where it is equivalent to 1 (or 45, what is the same). -When used with C<"Z">, C<*> results in the addition of a trailing null +When used with C<Z>, C<*> results in the addition of a trailing null byte (so the packed result will be one longer than the byte C<length> of the item). -The repeat count for C<"u"> is interpreted as the maximal number of bytes +The repeat count for C<u> is interpreted as the maximal number of bytes to encode per line of output, with 0 and 1 replaced by 45. =item * -The C<"a">, C<"A">, and C<"Z"> types gobble just one value, but pack it as a +The C<a>, C<A>, and C<Z> types gobble just one value, but pack it as a string of length count, padding with nulls or spaces as necessary. When -unpacking, C<"A"> strips trailing spaces and nulls, C<"Z"> strips everything -after the first null, and C<"a"> returns data verbatim. When packing, -C<"a">, and C<"Z"> are equivalent. +unpacking, C<A> strips trailing spaces and nulls, C<Z> strips everything +after the first null, and C<a> returns data verbatim. When packing, +C<a>, and C<Z> are equivalent. If the value-to-pack is too long, it is truncated. If too long and an -explicit count is provided, C<"Z"> packs only C<$count-1> bytes, followed -by a null byte. Thus C<"Z"> always packs a trailing null byte under +explicit count is provided, C<Z> packs only C<$count-1> bytes, followed +by a null byte. Thus C<Z> always packs a trailing null byte under all circumstances. =item * -Likewise, the C<"b"> and C<"B"> fields pack a string that many bits long. -Each byte of the input field generates 1 bit of the result basing on -the least-signifant bit of each input byte, i.e., on C<ord($byte)%2>. -In particular, bytes C<"0"> and C<"1"> generate bits 0 and 1. +Likewise, the C<b> and C<B> fields pack a string that many bits long. +Each byte of the input field of pack() generates 1 bit of the result. +Each result bit is based on the least-significant bit of the corresponding +input byte, i.e., on C<ord($byte)%2>. In particular, bytes C<"0"> and +C<"1"> generate bits 0 and 1, as do bytes C<"\0"> and C<"\1">. -Starting from the beginning of the input string, each 8-tuple of bytes -is converted to 1 byte of output. If the length of the input string -is not divisible by 8, the remainder is packed as if padded by 0s. -Similarly, during unpack()ing the "extra" bits are ignored. +Starting from the beginning of the input string of pack(), each 8-tuple +of bytes is converted to 1 byte of output. With format C<b> +the first byte of the 8-tuple determines the least-significant bit of a +byte, and with format C<B> it determines the most-significant bit of +a byte. -If the input string is longer than needed, extra bytes are ignored. +If the length of the input string is not exactly divisible by 8, the +remainder is packed as if the input string were padded by null bytes +at the end. Similarly, during unpack()ing the "extra" bits are ignored. + +If the input string of pack() is longer than needed, extra bytes are ignored. A C<*> for the repeat count of pack() means to use all the bytes of the input field. On unpack()ing the bits are converted to a string of C<"0">s and C<"1">s. =item * -The C<"h"> and C<"H"> fields pack a string that many nybbles (4-bit groups, +The C<h> and C<H> fields pack a string that many nybbles (4-bit groups, representable as hexadecimal digits, 0-9a-f) long. +Each byte of the input field of pack() generates 4 bits of the result. +For non-alphabetical bytes the result is based on the 4 least-significant +bits of the input byte, i.e., on C<ord($byte)%16>. In particular, +bytes C<"0"> and C<"1"> generate nybbles 0 and 1, as do bytes +C<"\0"> and C<"\1">. For bytes C<"a".."f"> and C<"A".."F"> the result +is compatible with the usual hexadecimal digits, so that C<"a"> and +C<"A"> both generate the nybble C<0xa==10>. The result for bytes +C<"g".."z"> and C<"G".."Z"> is not well-defined. + +Starting from the beginning of the input string of pack(), each pair +of bytes is converted to 1 byte of output. With format C<h> the +first byte of the pair determines the least-significant nybble of the +output byte, and with format C<H> it determines the most-significant +nybble. + +If the length of the input string is not even, it behaves as if padded +by a null byte at the end. Similarly, during unpack()ing the "extra" +nybbles are ignored. + +If the input string of pack() is longer than needed, extra bytes are ignored. +A C<*> for the repeat count of pack() means to use all the bytes of +the input field. On unpack()ing the bits are converted to a string +of hexadecimal digits. + =item * -The C<"p"> type packs a pointer to a null-terminated string. You are +The C<p> type packs a pointer to a null-terminated string. You are responsible for ensuring the string is not a temporary value (which can potentially get deallocated before you get around to using the packed result). -The C<"P"> type packs a pointer to a structure of the size indicated by the -length. A NULL pointer is created if the corresponding value for C<"p"> or -C<"P"> is C<undef>, similarly for unpack(). +The C<P> type packs a pointer to a structure of the size indicated by the +length. A NULL pointer is created if the corresponding value for C<p> or +C<P> is C<undef>, similarly for unpack(). =item * -The C<"/"> character allows packing and unpacking of strings where the -packed structure contains a byte count followed by the string itself. +The C</> template character allows packing and unpacking of strings where +the packed structure contains a byte count followed by the string itself. You write I<length-item>C</>I<string-item>. The I<length-item> can be any C<pack> template letter, and describes how the length value is packed. The ones likely to be of most use are integer-packing ones like -C<"n"> (for Java strings), C<"w"> (for ASN.1 or SNMP) -and C<"N"> (for Sun XDR). +C<n> (for Java strings), C<w> (for ASN.1 or SNMP) +and C<N> (for Sun XDR). The I<string-item> must, at present, be C<"A*">, C<"a*"> or C<"Z*">. For C<unpack> the length of the string is obtained from the I<length-item>, @@ -2888,27 +2980,25 @@ but if you put in the '*' it will be ignored. The I<length-item> is not returned explicitly from C<unpack>. -Adding a count to the I<length-item> letter -is unlikely to do anything useful, -unless that letter is C<"A">, C<"a"> or C<"Z">. -Packing with a I<length-item> of C<"a"> or C<"Z"> -may introduce C<"\000"> characters, +Adding a count to the I<length-item> letter is unlikely to do anything +useful, unless that letter is C<A>, C<a> or C<Z>. Packing with a +I<length-item> of C<a> or C<Z> may introduce C<"\000"> characters, which Perl does not regard as legal in numeric strings. =item * -The integer types C<"s">, C<"S">, C<"l">, and C<"L"> may be -immediately followed by a C<"!"> suffix to signify native shorts or -longs--as you can see from above for example a bare C<"l"> does mean +The integer types C<s>, C<S>, C<l>, and C<L> may be +immediately followed by a C<!> suffix to signify native shorts or +longs--as you can see from above for example a bare C<l> does mean exactly 32 bits, the native C<long> (as seen by the local C compiler) may be larger. This is an issue mainly in 64-bit platforms. You can -see whether using C<"!"> makes any difference by +see whether using C<!> makes any difference by print length(pack("s")), " ", length(pack("s!")), "\n"; print length(pack("l")), " ", length(pack("l!")), "\n"; -C<"i!"> and C<"I!"> also work but only because of completeness; -they are identical to C<"i"> and C<"I">. +C<i!> and C<I!> also work but only because of completeness; +they are identical to C<i> and C<I>. The actual sizes (in bytes) of native shorts, ints, longs, and long longs on the platform where Perl was built are also available via @@ -2925,7 +3015,7 @@ not support long longs.) =item * -The integer formats C<"s">, C<"S">, C<"i">, C<"I">, C<"l">, and C<"L"> +The integer formats C<s>, C<S>, C<i>, C<I>, C<l>, and C<L> are inherently non-portable between processors and operating systems because they obey the native byteorder and endianness. For example a 4-byte integer 0x12345678 (305419896 decimal) be ordered natively @@ -2963,8 +3053,8 @@ via L<Config>: Byteorders C<'1234'> and C<'12345678'> are little-endian, C<'4321'> and C<'87654321'> are big-endian. -If you want portable packed integers use the formats C<"n">, C<"N">, -C<"v">, and C<"V">, their byte endianness and size is known. +If you want portable packed integers use the formats C<n>, C<N>, +C<v>, and C<V>, their byte endianness and size is known. See also L<perlport>. =item * @@ -3411,15 +3501,16 @@ subroutine: foreach $prefix (@INC) { $realfilename = "$prefix/$filename"; if (-f $realfilename) { + $INC{$filename} = $realfilename; $result = do $realfilename; last ITER; } } die "Can't find $filename in \@INC"; } + delete $INC{$filename} if $@ || !$result; die $@ if $@; die "$filename did not return true value" unless $result; - $INC{$filename} = $realfilename; return $result; } @@ -3897,12 +3988,16 @@ the name of (or a reference to) the actual subroutine to use. In place of a SUBNAME, you can provide a BLOCK as an anonymous, in-line sort subroutine. -In the interests of efficiency the normal calling code for subroutines is -bypassed, with the following effects: the subroutine may not be a -recursive subroutine, and the two elements to be compared are passed into -the subroutine not via C<@_> but as the package global variables $a and -$b (see example below). They are passed by reference, so don't -modify $a and $b. And don't try to declare them as lexicals either. +If the subroutine's prototype is C<($$)>, the elements to be compared +are passed by reference in C<@_>, as for a normal subroutine. If not, +the normal calling code for subroutines is bypassed in the interests of +efficiency, and the elements to be compared are passed into the subroutine +as the package global variables $a and $b (see example below). Note that +in the latter case, it is usually counter-productive to declare $a and +$b as lexicals. + +In either case, the subroutine may not be recursive. The values to be +compared are always passed by reference, so don't modify them. You also cannot exit out of the sort block or subroutine using any of the loop control operators described in L<perlsyn> or with C<goto>. @@ -3982,6 +4077,14 @@ Examples: || $a->[2] cmp $b->[2] } map { [$_, /=(\d+)/, uc($_)] } @old; + + # using a prototype allows you to use any comparison subroutine + # as a sort subroutine (including other package's subroutines) + package other; + sub backwards ($$) { $_[1] cmp $_[0]; } # $a and $b are not set here + + package main; + @new = sort other::backwards @old; If you're using strict, you I<must not> declare $a and $b as lexicals. They are package globals. That means @@ -4316,9 +4419,9 @@ meaning of the fields: 5 gid numeric group ID of file's owner 6 rdev the device identifier (special files only) 7 size total size of file, in bytes - 8 atime last access time since the epoch - 9 mtime last modify time since the epoch - 10 ctime inode change time (NOT creation time!) since the epoch + 8 atime last access time in seconds since the epoch + 9 mtime last modify time in seconds since the epoch + 10 ctime inode change time (NOT creation time!) in seconds since the epoch 11 blksize preferred block size for file system I/O 12 blocks actual number of blocks allocated @@ -4385,8 +4488,8 @@ before any line containing a certain pattern: print; } -In searching for C</\bfoo\b/>, only those locations in C<$_> that contain C<"f"> -will be looked at, because C<"f"> is rarer than C<"o">. In general, this is +In searching for C</\bfoo\b/>, only those locations in C<$_> that contain C<f> +will be looked at, because C<f> is rarer than C<o>. In general, this is a big win except in pathological cases. The only question is whether it saves you more time than it took to build the linked list in the first place. @@ -4528,8 +4631,7 @@ For historical reasons, some values work on almost every system supported by perl: zero means read-only, one means write-only, and two means read/write. We know that these values do I<not> work under OS/390 & VM/ESA Unix and on the Macintosh; you probably don't want to -se them in new code, use thhe constants discussed in the preceding -paragraph. +use them in new code. If the file named by FILENAME does not exist and the C<open> call creates it (typically because MODE includes the C<O_CREAT> flag), then the value of @@ -4550,6 +4652,12 @@ that takes away the user's option to have a more permissive umask. Better to omit it. See the perlfunc(1) entry on C<umask> for more on this. +Note that C<sysopen> depends on the fdopen() C library function. +On many UNIX systems, fdopen() is known to fail when file descriptors +exceed a certain value, typically 255. If you need more file +descriptors than that, consider rebuilding Perl to use the C<sfio> +library, or perhaps using the POSIX::open() function. + See L<perlopentut> for a kinder, gentler explanation of opening files. =item sysread FILEHANDLE,SCALAR,LENGTH,OFFSET @@ -4946,7 +5054,7 @@ The following efficiently counts the number of set bits in a bit vector: $setbits = unpack("%32b*", $selectmask); -The C<"p"> and C<"P"> formats should be used with care. Since Perl +The C<p> and C<P> formats should be used with care. Since Perl has no way of checking whether the value passed to C<unpack()> corresponds to a valid memory location, passing a pointer value that's not known to be valid is likely to have disastrous consequences. @@ -5090,6 +5198,20 @@ that are reserved for each element in the bit vector. This must be a power of two from 1 to 32 (or 64, if your platform supports that). +If BITS is 8, "elements" coincide with bytes of the input string. + +If BITS is 16 or more, bytes of the input string are grouped into chunks +of size BITS/8, and each group is converted to a number as with +pack()/unpack() with big-endian formats C<n>/C<N> (and analoguously +for BITS==64). See L<"pack"> for details. + +If bits is 4 or less, the string is broken into bytes, then the bits +of each byte are broken into 8/BITS groups. Bits of a byte are +numbered in a little-endian-ish way, as in C<0x01>, C<0x02>, +C<0x04>, C<0x08>, C<0x10>, C<0x20>, C<0x40>, C<0x80>. For example, +breaking the single input byte C<chr(0x36)> into two groups gives a list +C<(0x6, 0x3)>; breaking it into 4 groups gives C<(0x2, 0x1, 0x3, 0x0)>. + C<vec> may also be assigned to, in which case parentheses are needed to give the expression the correct precedence as in diff --git a/pod/perlhack.pod b/pod/perlhack.pod index 12a5f9ce8b..5ecdf2cadb 100644 --- a/pod/perlhack.pod +++ b/pod/perlhack.pod @@ -34,11 +34,12 @@ engine), while others seem to do nothing but complain. In other words, it's your usual mix of technical people. Over this group of porters presides Larry Wall. He has the final word -in what does and does not change in the Perl language. Various releases -of Perl are shepherded by a ``pumpking'', a porter responsible for -gathering patches, deciding on a patch-by-patch feature-by-feature -basis what will and will not go into the release. For instance, -Gurusamy Sarathy is the pumpking for the 5.6 release of Perl. +in what does and does not change in the Perl language. Various +releases of Perl are shepherded by a ``pumpking'', a porter +responsible for gathering patches, deciding on a patch-by-patch +feature-by-feature basis what will and will not go into the release. +For instance, Gurusamy Sarathy is the pumpking for the 5.6 release of +Perl. In addition, various people are pumpkings for different things. For instance, Andy Dougherty and Jarkko Hietaniemi share the I<Configure> @@ -177,6 +178,15 @@ another man's pointless cruft. Work for the pumpking, work for Perl programmers, work for module authors, ... Perl is supposed to be easy. +=item Patches speak louder than words + +Working code is always preferred to pie-in-the-sky ideas. A patch to +add a feature stands a much higher chance of making it to the language +than does a random feature request, no matter how fervently argued the +request might be. This ties into ``Will it be useful?'', as the fact +that someone took the time to make the patch demonstrates a strong +desire for the feature. + =back If you're on the list, you might hear the word ``core'' bandied @@ -195,16 +205,16 @@ anonymous CVS access to the latest versions. Always submit patches to I<perl5-porters@perl.org>. This lets other porters review your patch, which catches a surprising number of errors -in patches. Either use the diff program (available in source code form -from I<ftp://ftp.gnu.org/pub/gnu/>), or use Johan Vromans' I<makepatch> -(available from I<CPAN/authors/id/JV/>). Unified diffs are preferred, -but context diffs are ok too. Do not send RCS-style diffs or diffs -without context lines. More information is given in the -I<Porting/patching.pod> file in the Perl source distribution. Please -patch against the latest B<development> version (e.g., if you're fixing -a bug in the 5.005 track, patch against the latest 5.005_5x version). -Only patches that survive the heat of the development branch get -applied to maintenance versions. +in patches. Either use the diff program (available in source code +form from I<ftp://ftp.gnu.org/pub/gnu/>), or use Johan Vromans' +I<makepatch> (available from I<CPAN/authors/id/JV/>). Unified diffs +are preferred, but context diffs are accepted. Do not send RCS-style +diffs or diffs without context lines. More information is given in +the I<Porting/patching.pod> file in the Perl source distribution. +Please patch against the latest B<development> version (e.g., if +you're fixing a bug in the 5.005 track, patch against the latest +5.005_5x version). Only patches that survive the heat of the +development branch get applied to maintenance versions. Your patch should update the documentation and test suite. @@ -220,9 +230,9 @@ the searchable archives. The CPAN testers (I<http://testers.cpan.org/>) are a group of volunteers who test CPAN modules on a variety of platforms. Perl Labs -(I<http://labs.perl.org/>) automatically tests modules and Perl source -releases on platforms and gives feedback to the CPAN testers mailing -list. Both efforts welcome volunteers. +(I<http://labs.perl.org/>) automatically tests Perl source releases on +platforms and gives feedback to the CPAN testers mailing list. Both +efforts welcome volunteers. To become an active and patching Perl porter, you'll need to learn how Perl works on the inside. Chip Salzenberg, a pumpking, has written @@ -231,9 +241,9 @@ articles on Perl internals for The Perl Journal interpreter work. The C<perlguts> manpage explains the internal data structures. And, of course, the C source code (sometimes sparsely commented, sometimes commented well) is a great place to start (begin -with C<perl.c> and see where it goes from there). A lot of the -style of the Perl source is explained in the I<Porting/pumpkin.pod> -file in the source distribution. +with C<perl.c> and see where it goes from there). A lot of the style +of the Perl source is explained in the I<Porting/pumpkin.pod> file in +the source distribution. It is essential that you be comfortable using a good debugger (e.g. gdb, dbx) before you can patch perl. Stepping through perl @@ -255,14 +265,11 @@ personalities of the players, and hopefully be better prepared to make a useful contribution when do you speak up. If after all this you still think you want to join the perl5-porters -mailing list, send mail to I<perl5-porters-request@perl.org> with the -body of your message reading I<subscribe>. To unsubscribe, either -send mail to the same address with the body reading I<unsubscribe>, or -send mail to I<perl5-porters-unsubscribe@perl.org>. +mailing list, send mail to I<perl5-porters-subscribe@perl.org>. To +unsubscribe, send mail to I<perl5-porters-unsubscribe@perl.org>. =head1 AUTHOR This document was written by Nathan Torkington, and is maintained by the perl5-porters mailing list. -=cut diff --git a/pod/perlipc.pod b/pod/perlipc.pod index e687304510..3034197e14 100644 --- a/pod/perlipc.pod +++ b/pod/perlipc.pod @@ -152,6 +152,10 @@ Here's an example: }; if ($@ and $@ !~ /alarm clock restart/) { die } +If the operation being timed out is system() or qx(), this technique +is liable to generate zombies. If this matters to you, you'll +need to do your own fork() and exec(), and kill the errant child process. + For more complex signal handling, you might see the standard POSIX module. Lamentably, this is almost entirely undocumented, but the F<t/lib/posix.t> file from the Perl source distribution has some diff --git a/pod/perllexwarn.pod b/pod/perllexwarn.pod index 32fc21084e..6078aefd96 100644 --- a/pod/perllexwarn.pod +++ b/pod/perllexwarn.pod @@ -3,7 +3,7 @@ perllexwarn - Perl Lexical Warnings =head1 DESCRIPTION - + The C<use warnings> pragma is a replacement for both the command line flag B<-w> and the equivalent Perl variable, C<$^W>. @@ -160,7 +160,7 @@ introduction of lexically scoped warnings, or have code that uses both lexical warnings and C<$^W>, this section will describe how they interact. How Lexical Warnings interact with B<-w>/C<$^W>: - + =over 5 =item 1. diff --git a/pod/perlop.pod b/pod/perlop.pod index c430dbc48d..547ee5328e 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -963,7 +963,7 @@ notably if the result of qr() is used standalone: my @compiled = map qr/$_/i, @$patterns; grep { my $success = 0; - foreach my $pat @compiled { + foreach my $pat (@compiled) { $success = 1, last if /$pat/; } $success; diff --git a/pod/perlopentut.pod b/pod/perlopentut.pod index dbb3a0bd83..5d2be3039e 100644 --- a/pod/perlopentut.pod +++ b/pod/perlopentut.pod @@ -123,9 +123,9 @@ special way. If you open minus for reading, it really means to access the standard input. If you open minus for writing, it really means to access the standard output. -If minus can be used as the default input or default output? What happens +If minus can be used as the default input or default output, what happens if you open a pipe into or out of minus? What's the default command it -would run? The same script as you're current running! This is actually +would run? The same script as you're currently running! This is actually a stealth C<fork> hidden inside an C<open> call. See L<perlipc/"Safe Pipe Opens"> for details. diff --git a/pod/perlport.pod b/pod/perlport.pod index 3fd4352932..21f144c237 100644 --- a/pod/perlport.pod +++ b/pod/perlport.pod @@ -925,10 +925,10 @@ the message body to majordomo@list.stratagy.com. Recent versions of Perl have been ported to platforms such as OS/400 on AS/400 minicomputers as well as OS/390, VM/ESA, and BS2000 for S/390 Mainframes. Such computers use EBCDIC character sets internally (usually -Character Code Set ID 00819 for OS/400 and 1047 for S/390 systems). -On the mainframe perl currently works under the "Unix system services -for OS/390" (formerly known as OpenEdition), VM/ESA OpenEdition, or -the BS200 POSIX system (BS2000 is supported in perl 5.006 and greater). +Character Code Set ID 0037 for OS/400 and either 1047 or POSIX-BC for S/390 +systems). On the mainframe perl currently works under the "Unix system +services for OS/390" (formerly known as OpenEdition), VM/ESA OpenEdition, or +the BS200 POSIX-BC system (BS2000 is supported in perl 5.6 and greater). As of R2.5 of USS for OS/390 and Version 2.3 of VM/ESA these Unix sub-systems do not support the C<#!> shebang trick for script invocation. @@ -1663,6 +1663,10 @@ Not useful. (S<RISC OS>) =over 4 +=item v1.45, 20 December 1999 + +Small changes from 5.005_63 distribution, more changes to EBCDIC info. + =item v1.44, 19 July 1999 A bunch of updates from Peter Prymmer for C<$^O> values, @@ -1756,9 +1760,10 @@ Chris Nandor E<lt>pudge@pobox.comE<gt>, Matthias Neeracher E<lt>neeri@iis.ee.ethz.chE<gt>, Gary Ng E<lt>71564.1743@CompuServe.COME<gt>, Tom Phoenix E<lt>rootbeer@teleport.comE<gt>, +AndrE<eacute> Pirard E<lt>A.Pirard@ulg.ac.beE<gt>, Peter Prymmer E<lt>pvhp@forte.comE<gt>, Hugo van der Sanden E<lt>hv@crypt0.demon.co.ukE<gt>, -Gurusamy Sarathy E<lt>gsar@umich.eduE<gt>, +Gurusamy Sarathy E<lt>gsar@activestate.comE<gt>, Paul J. Schinder E<lt>schinder@pobox.comE<gt>, Michael G Schwern E<lt>schwern@pobox.comE<gt>, Dan Sugalski E<lt>sugalskd@ous.eduE<gt>, @@ -1769,4 +1774,4 @@ E<lt>pudge@pobox.comE<gt>. =head1 VERSION -Version 1.44, last modified 22 July 1999 +Version 1.45, last modified 20 December 1999 diff --git a/pod/perlre.pod b/pod/perlre.pod index 1610254da5..70ec00c6cb 100644 --- a/pod/perlre.pod +++ b/pod/perlre.pod @@ -121,7 +121,7 @@ to integral values less than a preset limit defined when perl is built. This is usually 32766 on the most common platforms. The actual limit can be seen in the error message generated by code such as this: - $_ **= $_ , / {$_} / for 2 .. 42; + $_ **= $_ , / {$_} / for 2 .. 42; By default, a quantified subpattern is "greedy", that is, it will match as many times as possible (given a particular starting location) while still @@ -191,7 +191,7 @@ See L<utf8> for details about C<\pP>, C<\PP>, and C<\X>. The POSIX character class syntax - [:class:] + [:class:] is also available. The available classes and their backslash equivalents (if available) are as follows: @@ -214,7 +214,7 @@ For example use C<[:upper:]> to match all the uppercase characters. Note that the C<[]> are part of the C<[::]> construct, not part of the whole character class. For example: - [01[:alpha:]%] + [01[:alpha:]%] matches one, zero, any alphabetic character, and the percentage sign. @@ -247,29 +247,27 @@ The assumedly non-obviously named classes are: =item cntrl - Any control character. Usually characters that don't produce - output as such but instead control the terminal somehow: - for example newline and backspace are control characters. - All characters with ord() less than 32 are most often control - classified as characters. +Any control character. Usually characters that don't produce output as +such but instead control the terminal somehow: for example newline and +backspace are control characters. All characters with ord() less than +32 are most often control classified as characters. =item graph - Any alphanumeric or punctuation character. +Any alphanumeric or punctuation character. =item print - Any alphanumeric or punctuation character or space. +Any alphanumeric or punctuation character or space. =item punct - Any punctuation character. +Any punctuation character. =item xdigit - Any hexadecimal digit. Though this may feel silly - (/0-9a-f/i would work just fine) it is included - for completeness. +Any hexadecimal digit. Though this may feel silly (/0-9a-f/i would +work just fine) it is included for completeness. =item @@ -936,8 +934,10 @@ in C<[]>, which will match any one character from the list. If the first character after the "[" is "^", the class matches any character not in the list. Within a list, the "-" character specifies a range, so that C<a-z> represents all characters between "a" and "z", -inclusive. If you want "-" itself to be a member of a class, put it -at the start or end of the list, or escape it with a backslash. (The +inclusive. If you want either "-" or "]" itself to be a member of a +class, put it at the start of the list (possibly after a "^"), or +escape it with a backslash. "-" is also taken literally when it is +at the end of the list, just before the closing "]". (The following all specify the same class of three characters: C<[-az]>, C<[az-]>, and C<[a\-z]>. All are different from C<[a-z]>, which specifies a class containing twenty-six characters.) diff --git a/pod/perlref.pod b/pod/perlref.pod index 12bc581a6d..f738399c9a 100644 --- a/pod/perlref.pod +++ b/pod/perlref.pod @@ -558,29 +558,39 @@ to array indices. Here is an example: print "$k => $v\n"; } -Perl will raise an exception if you try to delete keys from a pseudo-hash -or try to access nonexistent fields. For better performance, Perl can also +Perl will raise an exception if you try to access nonexistent fields. +For better performance, Perl can also do the translation from field names to array indices at compile time for typed object references. See L<fields>. -There are two ways to check for the existance of a key in a +There are two ways to check for the existence of a key in a pseudo-hash. The first is to use exists(). This checks to see if the -given field has been used yet. It acts this way to match the behavior +given field has ever been set. It acts this way to match the behavior of a regular hash. For instance: $phash = [{foo =>1, bar => 2, pants => 3}, 'FOO']; $phash->{pants} = undef; - exists $phash->{foo}; # true, 'foo' was set in the declaration - exists $phash->{bar}; # false, 'bar' has not been used. - exists $phash->{pants}; # true, your 'pants' have been touched + print exists $phash->{foo}; # true, 'foo' was set in the declaration + print exists $phash->{bar}; # false, 'bar' has not been used. + print exists $phash->{pants}; # true, your 'pants' have been touched The second is to use exists() on the hash reference sitting in the first array element. This checks to see if the given key is a valid field in the pseudo-hash. - exists $phash->[0]{bar}; # true, 'bar' is a valid field - exists $phash->[0]{shoes}; # false, 'shoes' can't be used + print exists $phash->[0]{bar}; # true, 'bar' is a valid field + print exists $phash->[0]{shoes};# false, 'shoes' can't be used + +delete() on a pseudo-hash element only deletes the value corresponding +to the key, not the key itself. To delete the key, you'll have to +explicitly delete it from the first hash element. + + print delete $phash->{foo}; # prints $phash->[1], "FOO" + print exists $phash->{foo}; # false + print exists $phash->[0]{foo}; # true, key still exists + print delete $phash->[0]{foo}; # now key is gone + print $phash->{foo}; # runtime exception =head2 Function Templates diff --git a/pod/perlrun.pod b/pod/perlrun.pod index 8fec7c397a..5eb3b829f0 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -742,10 +742,13 @@ used. A colon-separated list of directories in which to look for Perl library files before looking in the standard library and the current -directory. If PERL5LIB is not defined, PERLLIB is used. When running -taint checks (because the program was running setuid or setgid, or the -B<-T> switch was used), neither variable is used. The program should -instead say +directory. Any architecture-specific directories under the specified +locations are automatically included if they exist. If PERL5LIB is not +defined, PERLLIB is used. + +When running taint checks (either because the program was running setuid +or setgid, or the B<-T> switch was used), neither variable is used. +The program should instead say: use lib "/my/directory"; diff --git a/pod/perlsyn.pod b/pod/perlsyn.pod index 0dd842d2a2..1f3ae50f2d 100644 --- a/pod/perlsyn.pod +++ b/pod/perlsyn.pod @@ -163,6 +163,8 @@ If the LABEL is omitted, the loop control statement refers to the innermost enclosing loop. This may include dynamically looking back your call-stack at run time to find the LABEL. Such desperate behavior triggers a warning if you use the B<-w> flag. +Unlike a C<foreach> statement, a C<while> statement never implicitly +localises any variables. If there is a C<continue> BLOCK, it is always executed just before the conditional is about to be evaluated again, just like the third part of a diff --git a/pod/perltie.pod b/pod/perltie.pod index 5611174669..58e9c4375b 100644 --- a/pod/perltie.pod +++ b/pod/perltie.pod @@ -185,10 +185,12 @@ methods: TIEARRAY, FETCH, STORE, FETCHSIZE, STORESIZE and perhaps DESTROY. FETCHSIZE and STORESIZE are used to provide C<$#array> and equivalent C<scalar(@array)> access. -The methods POP, PUSH, SHIFT, UNSHIFT, SPLICE are required if the perl -operator with the corresponding (but lowercase) name is to operate on the -tied array. The B<Tie::Array> class can be used as a base class to implement -these in terms of the basic five methods above. +The methods POP, PUSH, SHIFT, UNSHIFT, SPLICE, DELETE, and EXISTS are +required if the perl operator with the corresponding (but lowercase) name +is to operate on the tied array. The B<Tie::Array> class can be used as a +base class to implement the first five of these in terms of the basic +methods above. The default implementations of DELETE and EXISTS in +B<Tie::Array> simply C<croak>. In addition EXTEND will be called when perl would have pre-extended allocation in a real array. diff --git a/pod/perltrap.pod b/pod/perltrap.pod index 50987cb102..f278fa0929 100644 --- a/pod/perltrap.pod +++ b/pod/perltrap.pod @@ -585,24 +585,6 @@ number of elements in the resulting list. # perl4 prints: second new # perl5 prints: 3 -=item * Discontinuance - -In Perl 4 (and versions of Perl 5 before 5.004), C<'\r'> characters in -Perl code were silently allowed, although they could cause (mysterious!) -failures in certain constructs, particularly here documents. Now, -C<'\r'> characters cause an immediate fatal error. (Note: In this -example, the notation B<\015> represents the incorrect line -ending. Depending upon your text viewer, it will look different.) - - print "foo";\015 - print "bar"; - - # perl4 prints: foobar - # perl5.003 prints: foobar - # perl5.004 dies: Illegal character \015 (carriage return) - -See L<perldiag> for full details. - =item * Deprecation Some error messages will be different. @@ -715,6 +697,30 @@ Logical tests now return an null, instead of 0 Also see L<"General Regular Expression Traps using s///, etc."> for another example of this new feature... +=item * Bitwise string ops + +When bitwise operators which can operate upon either numbers or +strings (C<& | ^ ~>) are given only strings as arguments, perl4 would +treat the operands as bitstrings so long as the program contained a call +to the C<vec()> function. perl5 treats the string operands as bitstrings. +(See L<perlop/Bitwise String Operators> for more details.) + + $fred = "10"; + $barney = "12"; + $betty = $fred & $barney; + print "$betty\n"; + # Uncomment the next line to change perl4's behavior + # ($dummy) = vec("dummy", 0, 0); + + # Perl4 prints: + 8 + + # Perl5 prints: + 10 + + # If vec() is used anywhere in the program, both print: + 10 + =back =head2 General data type traps diff --git a/pod/perlvar.pod b/pod/perlvar.pod index d38bc4937d..5e705313d5 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -270,7 +270,7 @@ set, you'll get the record back in pieces. On VMS, record reads are done with the equivalent of C<sysread>, so it's best not to mix record and non-record reads on the same file. (This is unlikely to be a problem, because any file you'd -want to read in record mode is probably usable in line mode.) +want to read in record mode is probably unusable in line mode.) Non-VMS systems do normal I/O, so it's safe to mix record and non-record reads of a file. diff --git a/pod/perlxs.pod b/pod/perlxs.pod index ee582e0a55..a2755b8f2d 100644 --- a/pod/perlxs.pod +++ b/pod/perlxs.pod @@ -6,27 +6,72 @@ perlxs - XS language reference manual =head2 Introduction -XS is a language used to create an extension interface -between Perl and some C library which one wishes to use with -Perl. The XS interface is combined with the library to -create a new library which can be linked to Perl. An B<XSUB> -is a function in the XS language and is the core component -of the Perl application interface. - -The XS compiler is called B<xsubpp>. This compiler will embed -the constructs necessary to let an XSUB, which is really a C -function in disguise, manipulate Perl values and creates the -glue necessary to let Perl access the XSUB. The compiler +XS is an interface description file format used to create an extension +interface between Perl and C code (or a C library) which one wishes +to use with Perl. The XS interface is combined with the library to +create a new library which can then be either dynamically loaded +or statically linked into perl. The XS interface description is +written in the XS language and is the core component of the Perl +extension interface. + +An B<XSUB> forms the basic unit of the XS interface. After compilation +by the B<xsubpp> compiler, each XSUB amounts to a C function definition +which will provide the glue between Perl calling conventions and C +calling conventions. + +The glue code pulls the arguments from the Perl stack, converts these +Perl values to the formats expected by a C function, call this C function, +transfers the return values of the C function back to Perl. +Return values here may be a conventional C return value or any C +function arguments that may serve as output parameters. These return +values may be passed back to Perl either by putting them on the +Perl stack, or by modifying the arguments supplied from the Perl side. + +The above is a somewhat simplified view of what really happens. Since +Perl allows more flexible calling conventions than C, XSUBs may do much +more in practice, such as checking input parameters for validity, +throwing exceptions (or returning undef/empty list) if the return value +from the C function indicates failure, calling different C functions +based on numbers and types of the arguments, providing an object-oriented +interface, etc. + +Of course, one could write such glue code directly in C. However, this +would be a tedious task, especially if one needs to write glue for +multiple C functions, and/or one is not familiar enough with the Perl +stack discipline and other such arcana. XS comes to the rescue here: +instead of writing this glue C code in long-hand, one can write +a more concise short-hand I<description> of what should be done by +the glue, and let the XS compiler B<xsubpp> handle the rest. + +The XS language allows one to describe the mapping between how the C +routine is used, and how the corresponding Perl routine is used. It +also allows creation of Perl routines which are directly translated to +C code and which are not related to a pre-existing C function. In cases +when the C interface coincides with the Perl interface, the XSUB +declaration is almost identical to a declaration of a C function (in K&R +style). In such circumstances, there is another tool called C<h2xs> +that is able to translate an entire C header file into a corresponding +XS file that will provide glue to the functions/macros described in +the header file. + +The XS compiler is called B<xsubpp>. This compiler creates +the constructs necessary to let an XSUB manipulate Perl values, and +creates the glue necessary to let Perl call the XSUB. The compiler uses B<typemaps> to determine how to map C function parameters -and variables to Perl values. The default typemap handles -many common C types. A supplement typemap must be created -to handle special structures and types for the library being -linked. +and output values to Perl values and back. The default typemap +(which comes with Perl) handles many common C types. A supplementary +typemap may also be needed to handle any special structures and types +for the library being linked. + +A file in XS format starts with a C language section which goes until the +first C<MODULE =Z<>> directive. Other XS directives and XSUB definitions +may follow this line. The "language" used in this part of the file +is usually referred to as the XS language. See L<perlxstut> for a tutorial on the whole extension creation process. -Note: For many extensions, Dave Beazley's SWIG system provides a -significantly more convenient mechanism for creating the XS glue +Note: For some extensions, Dave Beazley's SWIG system may provide a +significantly more convenient mechanism for creating the extension glue code. See L<http://www.cs.utah.edu/~beazley/SWIG> for more information. @@ -76,7 +121,7 @@ expanded later in this document. rpcb_gettime(host,timep) char *host time_t &timep - OUTPUT: + OUTPUT: timep Any extension to Perl, including those containing XSUBs, @@ -110,6 +155,10 @@ function. =head2 The Anatomy of an XSUB +The simplest XSUBs consist of 3 parts: a description of the return +value, the name of the XSUB routine and the names of its arguments, +and a description of types or formats of the arguments. + The following XSUB allows a Perl program to access a C library function called sin(). The XSUB will imitate the C function which takes a single argument and returns a single value. @@ -118,14 +167,24 @@ argument and returns a single value. sin(x) double x -When using C pointers the indirection operator C<*> should be considered -part of the type and the address operator C<&> should be considered part of -the variable, as is demonstrated in the rpcb_gettime() function above. See -the section on typemaps for more about handling qualifiers and unary +When using parameters with C pointer types, as in + + double string_to_double(char *s); + +there may be two ways to describe this argument to B<xsubpp>: + + char * s + char &s + +Both these XS declarations correspond to the C<char*> C type, but they have +different semantics. It is convenient to think that the indirection operator +C<*> should be considered as a part of the type and the address operator C<&> +should be considered part of the variable. See L<"The Typemap"> and +L<"The & Unary Operator"> for more info about handling qualifiers and unary operators in C types. The function name and the return type must be placed on -separate lines. +separate lines and should be flush left-adjusted. INCORRECT CORRECT @@ -135,7 +194,7 @@ separate lines. The function body may be indented or left-adjusted. The following example shows a function with its body left-adjusted. Most examples in this -document will indent the body. +document will indent the body for better readability. CORRECT @@ -143,13 +202,23 @@ document will indent the body. sin(x) double x +More complicated XSUBs may contain many other sections. Each section of +an XSUB starts with the corresponding keyword, such as INIT: or CLEANUP:. +However, the first two lines of an XSUB always contain the same data: +descriptions of the return type and the names of the function and its +parameters. Whatever immediately follows these is considered to be +an INPUT: section unless explicitly marked with another keyword. +(See L<The INPUT: Keyword>.) + +An XSUB section continues until another section-start keyword is found. + =head2 The Argument Stack -The argument stack is used to store the values which are +The Perl argument stack is used to store the values which are sent as parameters to the XSUB and to store the XSUB's -return value. In reality all Perl functions keep their -values on this stack at the same time, each limited to its -own range of positions on the stack. In this document the +return value(s). In reality all Perl functions (including non-XSUB +ones) keep their values on this stack all the same time, each limited +to its own range of positions on the stack. In this document the first position on that stack which belongs to the active function will be referred to as position 0 for that function. @@ -163,17 +232,19 @@ typemaps. In more complex cases the programmer must supply the code. =head2 The RETVAL Variable -The RETVAL variable is a magic variable which always matches -the return type of the C library function. The B<xsubpp> compiler will -supply this variable in each XSUB and by default will use it to hold the -return value of the C library function being called. In simple cases the -value of RETVAL will be placed in ST(0) of the argument stack where it can -be received by Perl as the return value of the XSUB. +The RETVAL variable is a special C variable that is declared automatically +for you. The C type of RETVAL matches the return type of the C library +function. The B<xsubpp> compiler will declare this variable in each XSUB +with non-C<void> return type. By default the generated C function +will use RETVAL to hold the return value of the C library function being +called. In simple cases the value of RETVAL will be placed in ST(0) of +the argument stack where it can be received by Perl as the return value +of the XSUB. If the XSUB has a return type of C<void> then the compiler will -not supply a RETVAL variable for that function. When using -the PPCODE: directive the RETVAL variable is not needed, unless used -explicitly. +not declare a RETVAL variable for that function. When using +a PPCODE: section no manipulation of the RETVAL variable is required, the +section may use direct stack manipulation to place output values on the stack. If PPCODE: directive is not used, C<void> return value should be used only for subroutines which do not return a value, I<even if> CODE: @@ -248,8 +319,9 @@ keyword. The OUTPUT: keyword indicates that certain function parameters should be updated (new values made visible to Perl) when the XSUB terminates or that certain values should be returned to the calling Perl function. For -simple functions, such as the sin() function above, the RETVAL variable is -automatically designated as an output value. In more complex functions +simple functions which have no CODE: or PPCODE: section, +such as the sin() function above, the RETVAL variable is +automatically designated as an output value. For more complex functions the B<xsubpp> compiler will need help to determine which variables are output variables. @@ -268,7 +340,7 @@ be seen by Perl. rpcb_gettime(host,timep) char *host time_t &timep - OUTPUT: + OUTPUT: timep The OUTPUT: keyword will also allow an output parameter to @@ -279,7 +351,7 @@ typemap. rpcb_gettime(host,timep) char *host time_t &timep - OUTPUT: + OUTPUT: timep sv_setnv(ST(1), (double)timep); B<xsubpp> emits an automatic C<SvSETMAGIC()> for all parameters in the @@ -297,8 +369,8 @@ about 'set' magic. This keyword is used in more complicated XSUBs which require special handling for the C function. The RETVAL variable is -available but will not be returned unless it is specified -under the OUTPUT: keyword. +still declared, but it will not be returned unless it is specified +in the OUTPUT: section. The following XSUB is for a C function which requires special handling of its parameters. The Perl usage is given first. @@ -311,9 +383,9 @@ The XSUB follows. rpcb_gettime(host,timep) char *host time_t timep - CODE: + CODE: RETVAL = rpcb_gettime( host, &timep ); - OUTPUT: + OUTPUT: timep RETVAL @@ -327,11 +399,24 @@ above, this keyword does not affect the way the compiler handles RETVAL. rpcb_gettime(host,timep) char *host time_t &timep - INIT: + INIT: printf("# Host is %s\n", host ); - OUTPUT: + OUTPUT: timep +Another use for the INIT: section is to check for preconditions before +making a call to the C function: + + long long + lldiv(a,b) + long long a + long long b + INIT: + if (a == 0 && b == 0) + XSRETURN_UNDEF; + if (b == 0) + croak("lldiv: cannot divide by 0"); + =head2 The NO_INIT Keyword The NO_INIT keyword is used to indicate that a function @@ -351,17 +436,21 @@ not care about its initial contents. rpcb_gettime(host,timep) char *host time_t &timep = NO_INIT - OUTPUT: + OUTPUT: timep =head2 Initializing Function Parameters -Function parameters are normally initialized with their -values from the argument stack. The typemaps contain the -code segments which are used to transfer the Perl values to +C function parameters are normally initialized with their values from +the argument stack (which in turn contains the parameters that were +passed to the XSUB from Perl). The typemaps contain the +code segments which are used to translate the Perl values to the C parameters. The programmer, however, is allowed to override the typemaps and supply alternate (or additional) -initialization code. +initialization code. Initialization code starts with the first +C<=>, C<;> or C<+> on a line in the INPUT: section. The only +exception happens if this C<;> terminates the line, then this C<;> +is quietly ignored. The following code demonstrates how to supply initialization code for function parameters. The initialization code is eval'd within double @@ -374,7 +463,7 @@ and $type can be used as in typemaps. rpcb_gettime(host,timep) char *host = (char *)SvPV($arg,PL_na); time_t &timep = 0; - OUTPUT: + OUTPUT: timep This should not be used to supply default values for parameters. One @@ -382,27 +471,38 @@ would normally use this when a function parameter must be processed by another library function before it can be used. Default parameters are covered in the next section. -If the initialization begins with C<=>, then it is output on -the same line where the input variable is declared. If the -initialization begins with C<;> or C<+>, then it is output after -all of the input variables have been declared. The C<=> and C<;> -cases replace the initialization normally supplied from the typemap. -For the C<+> case, the initialization from the typemap will precede -the initialization code included after the C<+>. A global +If the initialization begins with C<=>, then it is output in +the declaration for the input variable, replacing the initialization +supplied by the typemap. If the initialization +begins with C<;> or C<+>, then it is performed after +all of the input variables have been declared. In the C<;> +case the initialization normally supplied by the typemap is not performed. +For the C<+> case, the declaration for the variable will include the +initialization from the typemap. A global variable, C<%v>, is available for the truly rare case where information from one initialization is needed in another initialization. +Here's a truly obscure example: + bool_t rpcb_gettime(host,timep) - time_t &timep ; /*\$v{time}=@{[$v{time}=$arg]}*/ - char *host + SvOK($v{time}) ? SvPV($arg,PL_na) : NULL; - OUTPUT: + time_t &timep ; /* \$v{timep}=@{[$v{timep}=$arg]} */ + char *host + SvOK($v{timep}) ? SvPV($arg,PL_na) : NULL; + OUTPUT: timep +The construct C<\$v{timep}=@{[$v{timep}=$arg]}> used in the above +example has a two-fold purpose: first, when this line is processed by +B<xsubpp>, the Perl snippet C<$v{timep}=$arg> is evaluated. Second, +the text of the evaluated snippet is output into the generated C file +(inside a C comment)! During the processing of C<char *host> line, +$arg will evaluate to C<ST(0)>, and C<$v{timep}> will evaluate to +C<ST(1)>. + =head2 Default Parameter Values -Default values can be specified for function parameters by +Default values for XSUB arguments can be specified by placing an assignment statement in the parameter list. The default value may be a number or a string. Defaults should always be used on the right-most parameters only. @@ -410,8 +510,8 @@ always be used on the right-most parameters only. To allow the XSUB for rpcb_gettime() to have a default host value the parameters to the XSUB could be rearranged. The XSUB will then call the real rpcb_gettime() function with -the parameters in the correct order. Perl will call this -XSUB with either of the following statements. +the parameters in the correct order. This XSUB can be called +from Perl with either of the following statements: $status = rpcb_gettime( $timep, $host ); @@ -425,20 +525,29 @@ the parameters in the correct order for that function. rpcb_gettime(timep,host="localhost") char *host time_t timep = NO_INIT - CODE: + CODE: RETVAL = rpcb_gettime( host, &timep ); - OUTPUT: + OUTPUT: timep RETVAL =head2 The PREINIT: Keyword -The PREINIT: keyword allows extra variables to be declared before the -typemaps are expanded. If a variable is declared in a CODE: block then that -variable will follow any typemap code. This may result in a C syntax -error. To force the variable to be declared before the typemap code, place -it into a PREINIT: block. The PREINIT: keyword may be used one or more -times within an XSUB. +The PREINIT: keyword allows extra variables to be declared immediately +before or after the declartions of the parameters from the INPUT: section +are emitted. + +If a variable is declared inside a CODE: section it will follow any typemap +code that is emitted for the input parameters. This may result in the +declaration ending up after C code, which is C syntax error. Similar +errors may happen with an explicit C<;>-type or C<+>-type initialization of +parameters is used (see L<"Initializing Function Parameters">). Declaring +these variables in an INIT: section will not help. + +In such cases, to force an additional variable to be declared together +with declarations of other variables, place the declaration into a +PREINIT: section. The PREINIT: keyword may be used one or more times +within an XSUB. The following examples are equivalent, but if the code is using complex typemaps then the first example is safer. @@ -446,23 +555,79 @@ typemaps then the first example is safer. bool_t rpcb_gettime(timep) time_t timep = NO_INIT - PREINIT: + PREINIT: char *host = "localhost"; - CODE: + CODE: RETVAL = rpcb_gettime( host, &timep ); - OUTPUT: + OUTPUT: timep RETVAL -A correct, but error-prone example. +For this particular case an INIT: keyword would generate the +same C code as the PREINIT: keyword. Another correct, but error-prone example: bool_t rpcb_gettime(timep) time_t timep = NO_INIT - CODE: + CODE: char *host = "localhost"; RETVAL = rpcb_gettime( host, &timep ); - OUTPUT: + OUTPUT: + timep + RETVAL + +Another way to declare C<host> is to use a C block in the CODE: section: + + bool_t + rpcb_gettime(timep) + time_t timep = NO_INIT + CODE: + { + char *host = "localhost"; + RETVAL = rpcb_gettime( host, &timep ); + } + OUTPUT: + timep + RETVAL + +The ability to put additional declarations before the typemap entries are +processed is very handy in the cases when typemap conversions manipulate +some global state: + + MyObject + mutate(o) + PREINIT: + MyState st = global_state; + INPUT: + MyObject o; + CLEANUP: + reset_to(global_state, st); + +Here we suppose that conversion to C<MyObject> in the INPUT: section and from +MyObject when processing RETVAL will modify a global variable C<global_state>. +After these conversions are performed, we restore the old value of +C<global_state> (to avoid memory leaks, for example). + +There is another way to trade clarity for compactness: INPUT sections allow +declaration of C variables which do not appear in the parameter list of +a subroutine. Thus the above code for mutate() can be rewritten as + + MyObject + mutate(o) + MyState st = global_state; + MyObject o; + CLEANUP: + reset_to(global_state, st); + +and the code for rpcb_gettime() can be rewritten as + + bool_t + rpcb_gettime(timep) + time_t timep = NO_INIT + char *host = "localhost"; + C_ARGS: + host, &timep + OUTPUT: timep RETVAL @@ -472,8 +637,8 @@ The SCOPE: keyword allows scoping to be enabled for a particular XSUB. If enabled, the XSUB will invoke ENTER and LEAVE automatically. To support potentially complex type mappings, if a typemap entry used -by this XSUB contains a comment like C</*scope*/> then scoping will -automatically be enabled for that XSUB. +by an XSUB contains a comment like C</*scope*/> then scoping will +be automatically enabled for that XSUB. To enable scoping: @@ -497,14 +662,14 @@ evaluated late, after a PREINIT. bool_t rpcb_gettime(host,timep) char *host - PREINIT: + PREINIT: time_t tt; - INPUT: + INPUT: time_t timep - CODE: + CODE: RETVAL = rpcb_gettime( host, &tt ); timep = tt; - OUTPUT: + OUTPUT: timep RETVAL @@ -512,22 +677,43 @@ The next example shows each input parameter evaluated late. bool_t rpcb_gettime(host,timep) - PREINIT: + PREINIT: time_t tt; - INPUT: + INPUT: char *host - PREINIT: + PREINIT: char *h; - INPUT: + INPUT: time_t timep - CODE: + CODE: h = host; RETVAL = rpcb_gettime( h, &tt ); timep = tt; - OUTPUT: + OUTPUT: + timep + RETVAL + +Since INPUT sections allow declaration of C variables which do not appear +in the parameter list of a subroutine, this may be shortened to: + + bool_t + rpcb_gettime(host,timep) + time_t tt; + char *host; + char *h = host; + time_t timep; + CODE: + RETVAL = rpcb_gettime( h, &tt ); + timep = tt; + OUTPUT: timep RETVAL +(We used our knowledge that input conversion for C<char *> is a "simple" one, +thus C<host> is initialized on the declaration line, and our assignment +C<h = host> is not performed too early. Otherwise one would need to have the +assignment C<h = host> in a CODE: or INIT: section.) + =head2 Variable-length Parameter Lists XSUBs can have variable-length parameter lists by specifying an ellipsis @@ -551,14 +737,14 @@ The XS code, with ellipsis, follows. bool_t rpcb_gettime(timep, ...) time_t timep = NO_INIT - PREINIT: + PREINIT: char *host = "localhost"; STRLEN n_a; - CODE: - if( items > 1 ) - host = (char *)SvPV(ST(1), n_a); - RETVAL = rpcb_gettime( host, &timep ); - OUTPUT: + CODE: + if( items > 1 ) + host = (char *)SvPV(ST(1), n_a); + RETVAL = rpcb_gettime( host, &timep ); + OUTPUT: timep RETVAL @@ -566,10 +752,10 @@ The XS code, with ellipsis, follows. The C_ARGS: keyword allows creating of XSUBS which have different calling sequence from Perl than from C, without a need to write -CODE: or CPPCODE: section. The contents of the C_ARGS: paragraph is +CODE: or PPCODE: section. The contents of the C_ARGS: paragraph is put as the argument to the called C function without any change. -For example, suppose that C function is declared as +For example, suppose that a C function is declared as symbolic nth_derivative(int n, symbolic function, int flags); @@ -585,7 +771,7 @@ To do this, declare the XSUB as nth_derivative(function, n) symbolic function int n - C_ARGS: + C_ARGS: n, function, default_flags =head2 The PPCODE: Keyword @@ -595,9 +781,29 @@ to tell the B<xsubpp> compiler that the programmer is supplying the code to control the argument stack for the XSUBs return values. Occasionally one will want an XSUB to return a list of values rather than a single value. In these cases one must use PPCODE: and then explicitly push the list of -values on the stack. The PPCODE: and CODE: keywords are not used +values on the stack. The PPCODE: and CODE: keywords should not be used together within the same XSUB. +The actual difference between PPCODE: and CODE: sections is in the +initialization of C<SP> macro (which stands for the I<current> Perl +stack pointer), and in the handling of data on the stack when returning +from an XSUB. In CODE: sections SP preserves the value which was on +entry to the XSUB: SP is on the function pointer (which follows the +last parameter). In PPCODE: sections SP is moved backward to the +beginning of the parameter list, which allows C<PUSH*()> macros +to place output values in the place Perl expects them to be when +the XSUB returns back to Perl. + +The generated trailer for a CODE: section ensures that the number of return +values Perl will see is either 0 or 1 (depending on the C<void>ness of the +return value of the C function, and heuristics mentioned in +L<"The RETVAL Variable">). The trailer generated for a PPCODE: section +is based on the number of return values and on the number of times +C<SP> was updated by C<[X]PUSH*()> macros. + +Note that macros C<ST(i)>, C<XST_m*()> and C<XSRETURN*()> work equally +well in CODE: sections and PPCODE: sections. + The following XSUB will call the C rpcb_gettime() function and will return its two output values, timep and status, to Perl as a single list. @@ -605,10 +811,10 @@ Perl as a single list. void rpcb_gettime(host) char *host - PREINIT: + PREINIT: time_t timep; bool_t status; - PPCODE: + PPCODE: status = rpcb_gettime( host, &timep ); EXTEND(SP, 2); PUSHs(sv_2mortal(newSViv(status))); @@ -659,10 +865,10 @@ the default return value. SV * rpcb_gettime(host) char * host - PREINIT: + PREINIT: time_t timep; bool_t x; - CODE: + CODE: ST(0) = sv_newmortal(); if( rpcb_gettime( host, &timep ) ) sv_setnv( ST(0), (double)timep); @@ -673,10 +879,10 @@ return value, should the need arise. SV * rpcb_gettime(host) char * host - PREINIT: + PREINIT: time_t timep; bool_t x; - CODE: + CODE: ST(0) = sv_newmortal(); if( rpcb_gettime( host, &timep ) ){ sv_setnv( ST(0), (double)timep); @@ -691,14 +897,14 @@ then not push return values on the stack. void rpcb_gettime(host) char *host - PREINIT: + PREINIT: time_t timep; - PPCODE: + PPCODE: if( rpcb_gettime( host, &timep ) ) PUSHs(sv_2mortal(newSViv(timep))); else{ - /* Nothing pushed on stack, so an empty */ - /* list is implicitly returned. */ + /* Nothing pushed on stack, so an empty + * list is implicitly returned. */ } Some people may be inclined to include an explicit C<return> in the above @@ -707,6 +913,32 @@ situations C<XSRETURN_EMPTY> should be used, instead. This will ensure that the XSUB stack is properly adjusted. Consult L<perlguts/"API LISTING"> for other C<XSRETURN> macros. +Since C<XSRETURN_*> macros can be used with CODE blocks as well, one can +rewrite this example as: + + int + rpcb_gettime(host) + char *host + PREINIT: + time_t timep; + CODE: + RETVAL = rpcb_gettime( host, &timep ); + if (RETVAL == 0) + XSRETURN_UNDEF; + OUTPUT: + RETVAL + +In fact, one can put this check into a CLEANUP: section as well. Together +with PREINIT: simplifications, this leads to: + + int + rpcb_gettime(host) + char *host + time_t timep; + CLEANUP: + if (RETVAL == 0) + XSRETURN_UNDEF; + =head2 The REQUIRE: Keyword The REQUIRE: keyword is used to indicate the minimum version of the @@ -784,15 +1016,15 @@ prototypes. bool_t rpcb_gettime(timep, ...) time_t timep = NO_INIT - PROTOTYPE: $;$ - PREINIT: + PROTOTYPE: $;$ + PREINIT: char *host = "localhost"; STRLEN n_a; - CODE: + CODE: if( items > 1 ) host = (char *)SvPV(ST(1), n_a); RETVAL = rpcb_gettime( host, &timep ); - OUTPUT: + OUTPUT: timep RETVAL @@ -812,12 +1044,12 @@ C<BAR::getit()> for this function. rpcb_gettime(host,timep) char *host time_t &timep - ALIAS: + ALIAS: FOO::gettime = 1 BAR::getit = 2 - INIT: + INIT: printf("# ix = %d\n", ix ); - OUTPUT: + OUTPUT: timep =head2 The INTERFACE: Keyword @@ -825,14 +1057,14 @@ C<BAR::getit()> for this function. This keyword declares the current XSUB as a keeper of the given calling signature. If some text follows this keyword, it is considered as a list of functions which have this signature, and -should be attached to XSUBs. +should be attached to the current XSUB. -Say, if you have 4 functions multiply(), divide(), add(), subtract() all -having the signature +For example, if you have 4 C functions multiply(), divide(), add(), +subtract() all having the signature: symbolic f(symbolic, symbolic); -you code them all by using XSUB +you can make them all to use the same XSUB using this: symbolic interface_s_ss(arg1, arg2) @@ -842,16 +1074,21 @@ you code them all by using XSUB multiply divide add subtract -The advantage of this approach comparing to ALIAS: keyword is that one +(This is the complete XSUB code for 4 Perl functions!) Four generated +Perl function share names with corresponding C functions. + +The advantage of this approach comparing to ALIAS: keyword is that there +is no need to code a switch statement, each Perl function (which shares +the same XSUB) knows which C function it should call. Additionally, one can attach an extra function remainder() at runtime by using - + CV *mycv = newXSproto("Symbolic::remainder", XS_Symbolic_interface_s_ss, __FILE__, "$$"); XSINTERFACE_FUNC_SET(mycv, remainder); -(This example supposes that there was no INTERFACE_MACRO: section, -otherwise one needs to use something else instead of -C<XSINTERFACE_FUNC_SET>.) +say, from another XSUB. (This example supposes that there was no +INTERFACE_MACRO: section, otherwise one needs to use something else instead of +C<XSINTERFACE_FUNC_SET>, see the next section.) =head2 The INTERFACE_MACRO: Keyword @@ -882,10 +1119,10 @@ in C section, interface_s_ss(arg1, arg2) symbolic arg1 symbolic arg2 - INTERFACE_MACRO: + INTERFACE_MACRO: XSINTERFACE_FUNC_BYOFFSET XSINTERFACE_FUNC_BYOFFSET_set - INTERFACE: + INTERFACE: multiply divide add subtract @@ -903,7 +1140,7 @@ The file F<Rpcb1.xsh> contains our C<rpcb_gettime()> function: rpcb_gettime(host,timep) char *host time_t &timep - OUTPUT: + OUTPUT: timep The XS module can use INCLUDE: to pull that file into it. @@ -936,22 +1173,22 @@ reversed, C<(time_t *timep, char *host)>. long rpcb_gettime(a,b) CASE: ix == 1 - ALIAS: + ALIAS: x_gettime = 1 - INPUT: + INPUT: # 'a' is timep, 'b' is host char *b time_t a = NO_INIT - CODE: + CODE: RETVAL = rpcb_gettime( b, &a ); - OUTPUT: + OUTPUT: a RETVAL CASE: # 'a' is host, 'b' is timep char *a time_t &b = NO_INIT - OUTPUT: + OUTPUT: b RETVAL @@ -964,12 +1201,15 @@ the different argument lists. =head2 The & Unary Operator -The & unary operator is used to tell the compiler that it should dereference -the object when it calls the C function. This is used when a CODE: block is -not used and the object is a not a pointer type (the object is an C<int> or -C<long> but not a C<int*> or C<long*>). +The C<&> unary operator in the INPUT: section is used to tell B<xsubpp> +that it should convert a Perl value to/from C using the C type to the left +of C<&>, but provide a pointer to this value when the C function is called. + +This is useful to avoid a CODE: block for a C function which takes a parameter +by reference. Typically, the parameter should be not a pointer type (an +C<int> or C<long> but not a C<int*> or C<long*>). -The following XSUB will generate incorrect C code. The xsubpp compiler will +The following XSUB will generate incorrect C code. The B<xsubpp> compiler will turn this into code which calls C<rpcb_gettime()> with parameters C<(char *host, time_t timep)>, but the real C<rpcb_gettime()> wants the C<timep> parameter to be of type C<time_t*> rather than C<time_t>. @@ -978,10 +1218,10 @@ parameter to be of type C<time_t*> rather than C<time_t>. rpcb_gettime(host,timep) char *host time_t timep - OUTPUT: + OUTPUT: timep -That problem is corrected by using the C<&> operator. The xsubpp compiler +That problem is corrected by using the C<&> operator. The B<xsubpp> compiler will now turn this into code which calls C<rpcb_gettime()> correctly with parameters C<(char *host, time_t *timep)>. It does this by carrying the C<&> through, so the function call looks like C<rpcb_gettime(host, &timep)>. @@ -990,7 +1230,7 @@ C<&> through, so the function call looks like C<rpcb_gettime(host, &timep)>. rpcb_gettime(host,timep) char *host time_t &timep - OUTPUT: + OUTPUT: timep =head2 Inserting Comments and C Preprocessor Directives @@ -1021,13 +1261,14 @@ and not #if ... version2 #endif -because otherwise xsubpp will believe that you made a duplicate +because otherwise B<xsubpp> will believe that you made a duplicate definition of the function. Also, put a blank line before the #else/#endif so it will not be seen as part of the function body. =head2 Using XS With C++ -If a function is defined as a C++ method then it will assume +If an XSUB name contains C<::>, it is considered to be a C++ method. +The generated Perl function will assume that its first argument is an object pointer. The object pointer will be stored in a variable called THIS. The object should have been created by C++ with the new() function and should @@ -1035,7 +1276,8 @@ be blessed by Perl with the sv_setref_pv() macro. The blessing of the object by Perl can be handled by a typemap. An example typemap is shown at the end of this section. -If the method is defined as static it will call the C++ +If the return type of the XSUB includes C<static>, the method is considered +to be a static method. It will call the C++ function using the class::method() syntax. If the method is not static the function will be called using the THIS-E<gt>method() syntax. @@ -1063,22 +1305,24 @@ not listed. color::set_blue( val ) int val -Both functions will expect an object as the first parameter. The xsubpp -compiler will call that object C<THIS> and will use it to call the specified -method. So in the C++ code the blue() and set_blue() methods will be called -in the following manner. +Both Perl functions will expect an object as the first parameter. In the +generated C++ code the object is called C<THIS>, and the method call will +be performed on this object. So in the C++ code the blue() and set_blue() +methods will be called as this: RETVAL = THIS->blue(); THIS->set_blue( val ); If the function's name is B<DESTROY> then the C++ C<delete> function will be -called and C<THIS> will be given as its parameter. +called and C<THIS> will be given as its parameter. The generated C++ code for void color::DESTROY() -The C++ code will call C<delete>. +will look like this: + + color *THIS = ...; // Initialized as in typemap delete THIS; @@ -1090,9 +1334,9 @@ argument. color * color::new() -The C++ code will call C<new>. +The generated C++ code will call C<new>. - RETVAL = new color(); + RETVAL = new color(); The following is an example of a typemap that could be used for this C++ example. @@ -1118,30 +1362,59 @@ example. =head2 Interface Strategy When designing an interface between Perl and a C library a straight -translation from C to XS is often sufficient. The interface will often be +translation from C to XS (such as created by C<h2xs -x>) is often sufficient. +However, sometimes the interface will look very C-like and occasionally nonintuitive, especially when the C function -modifies one of its parameters. In cases where the programmer wishes to +modifies one of its parameters, or returns failure inband (as in "negative +return values mean failure"). In cases where the programmer wishes to create a more Perl-like interface the following strategy may help to identify the more critical parts of the interface. -Identify the C functions which modify their parameters. The XSUBs for -these functions may be able to return lists to Perl, or may be -candidates to return undef or an empty list in case of failure. +Identify the C functions with input/output or output parameters. The XSUBs for +these functions may be able to return lists to Perl. + +Identify the C functions which use some inband info as an indication +of failure. They may be +candidates to return undef or an empty list in case of failure. If the +failure may be detected without a call to the C function, you may want to use +an INIT: section to report the failure. For failures detectable after the C +function returns one may want to use a CLEANUP: section to process the +failure. In more complicated cases use CODE: or PPCODE: sections. + +If many functions use the same failure indication based on the return value, +you may want to create a special typedef to handle this situation. Put + + typedef int negative_is_failure; + +near the beginning of XS file, and create an OUTPUT typemap entry +for C<negative_is_failure> which converts negative values to C<undef>, or +maybe croak()s. After this the return value of type C<negative_is_failure> +will create more Perl-like interface. Identify which values are used by only the C and XSUB functions -themselves. If Perl does not need to access the contents of the value +themselves, say, when a parameter to a function should be a contents of a +global variable. If Perl does not need to access the contents of the value then it may not be necessary to provide a translation for that value from C to Perl. Identify the pointers in the C function parameter lists and return -values. Some pointers can be handled in XS with the & unary operator on -the variable name while others will require the use of the * operator on -the type name. In general it is easier to work with the & operator. +values. Some pointers may be used to implement input/output or +output parameters, they can be handled in XS with the C<&> unary operator, +and, possibly, using the NO_INIT keyword. +Some others will require handling of types like C<int *>, and one needs +to decide what a useful Perl translation will do in such a case. When +the semantic is clear, it is advisable to put the translation into a typemap +file. Identify the structures used by the C functions. In many cases it may be helpful to use the T_PTROBJ typemap for these structures so they can be manipulated by Perl as -blessed objects. +blessed objects. (This is handled automatically by C<h2xs -x>.) + +If the same C type is used in several different contexts which require +different translations, C<typedef> several new types mapped to this C type, +and create separate F<typemap> entries for these new types. Use these +types in declarations of return type and parameters to XSUBs. =head2 Perl Objects And C Structures @@ -1188,7 +1461,7 @@ trim the name to the word DESTROY as Perl will expect. void rpcb_DESTROY(netconf) Netconfig *netconf - CODE: + CODE: printf("Now in NetconfigPtr::DESTROY\n"); free( netconf ); @@ -1214,8 +1487,8 @@ getnetconfigent() XSUB and an object created by a normal Perl subroutine. The typemap is a collection of code fragments which are used by the B<xsubpp> compiler to map C function parameters and values to Perl values. The typemap file may consist of three sections labeled C<TYPEMAP>, C<INPUT>, and -C<OUTPUT>. Any unlabelled initial section is assumed to be a C<TYPEMAP> -section if a name is not explicitly specified. The INPUT section tells +C<OUTPUT>. An unlabelled initial section is assumed to be a C<TYPEMAP> +section. The INPUT section tells the compiler how to translate Perl values into variables of certain C types. The OUTPUT section tells the compiler how to translate the values from certain C types into values Perl can @@ -1239,8 +1512,8 @@ with the T_PTROBJ typemap. The typemap used by getnetconfigent() is shown here. Note that the C type is separated from the XS type with a tab and that the C unary operator C<*> is considered to be a part of the C type name. - TYPEMAP - Netconfig *<tab>T_PTROBJ + TYPEMAP + Netconfig *<tab>T_PTROBJ Here's a more complicated example: suppose that you wanted C<struct netconfig> to be blessed into the class C<Net::Config>. One way to do @@ -1290,9 +1563,9 @@ File C<RPC.xs>: Interface to some ONC+ RPC bind library functions. SV * rpcb_gettime(host="localhost") char *host - PREINIT: + PREINIT: time_t timep; - CODE: + CODE: ST(0) = sv_newmortal(); if( rpcb_gettime( host, &timep ) ) sv_setnv( ST(0), (double)timep ); @@ -1306,7 +1579,7 @@ File C<RPC.xs>: Interface to some ONC+ RPC bind library functions. void rpcb_DESTROY(netconf) Netconfig *netconf - CODE: + CODE: printf("NetconfigPtr::DESTROY\n"); free( netconf ); @@ -1348,5 +1621,6 @@ This document covers features supported by C<xsubpp> 1.935. =head1 AUTHOR -Dean Roehrich <F<roehrich@cray.com>> -Jul 8, 1996 +Originally written by Dean Roehrich <F<roehrich@cray.com>>. + +Maintained since 1996 by The Perl Porters <F<perlbug@perl.com>>. diff --git a/pod/perlxstut.pod b/pod/perlxstut.pod index 632f417496..35edd05ac0 100644 --- a/pod/perlxstut.pod +++ b/pod/perlxstut.pod @@ -24,15 +24,37 @@ them. If you find something that was missed, please let me know. This tutorial assumes that the make program that Perl is configured to use is called C<make>. Instead of running "make" in the examples that follow, you may have to substitute whatever make program Perl has been -configured to use. Running "perl -V:make" should tell you what it is. +configured to use. Running B<perl -V:make> should tell you what it is. =head2 Version caveat -This tutorial tries hard to keep up with the latest development versions -of Perl. This often means that it is sometimes in advance of the latest -released version of Perl, and that certain features described here might -not work on earlier versions. See the section on "Troubleshooting -these Examples" for more information. +When writing a Perl extension for general consumption, one should expect that +the extension will be used with versions of Perl different from the +version available on your machine. Since you are reading this document, +the version of Perl on your machine is probably 5.005 or later, but the users +of your extension may have more ancient versions. + +To understand what kinds of incompatibilities one may expect, and in the rare +case that the version of Perl on your machine is older than this document, +see the section on "Troubleshooting these Examples" for more information. + +If your extension uses some features of Perl which are not available on older +releases of Perl, your users would appreciate an early meaningful warning. +You would probably put this information into the F<README> file, but nowadays +installation of extensions may be performed automatically, guided by F<CPAN.pm> +module or other tools. + +In MakeMaker-based installations, F<Makefile.PL> provides the earliest +opportunity to perform version checks. One can put something like this +in F<Makefile.PL> for this purpose: + + eval { require 5.007 } + or die <<EOD; + ############ + ### This module uses frobnication framework which is not available before + ### version 5.007 of Perl. Upgrade your Perl before installing Kara::Mba. + ############ + EOD =head2 Dynamic Loading versus Static Loading @@ -168,7 +190,7 @@ You can safely ignore the line about "prototyping behavior". If you are on a Win32 system, and the build process fails with linker errors for functions in the C library, check if your Perl is configured -to use PerlCRT (running "perl -V:libc" should show you if this is the +to use PerlCRT (running B<perl -V:libc> should show you if this is the case). If Perl is configured to use PerlCRT, you have to make sure PerlCRT.lib is copied to the same location that msvcrt.lib lives in, so that the compiler can find it on its own. msvcrt.lib is usually @@ -400,21 +422,21 @@ which we passed in, so we listed it (and not RETVAL) in the OUTPUT: section. =head2 The XSUBPP Program -The xsubpp program takes the XS code in the .xs file and translates it into +The B<xsubpp> program takes the XS code in the .xs file and translates it into C code, placing it in a file whose suffix is .c. The C code created makes heavy use of the C functions within Perl. =head2 The TYPEMAP file -The xsubpp program uses rules to convert from Perl's data types (scalar, +The B<xsubpp> program uses rules to convert from Perl's data types (scalar, array, etc.) to C's data types (int, char, etc.). These rules are stored in the typemap file ($PERLLIB/ExtUtils/typemap). This file is split into three parts. The first section maps various C data types to a name, which corresponds somewhat with the various Perl types. The second section contains C code -which xsubpp uses to handle input parameters. The third section contains -C code which xsubpp uses to handle output parameters. +which B<xsubpp> uses to handle input parameters. The third section contains +C code which B<xsubpp> uses to handle output parameters. Let's take a look at a portion of the .c file created for our extension. The file name is Mytest.c: @@ -649,39 +671,174 @@ commands to build it. =back -=head2 More about XSUBPP +=head2 Anatomy of .xs file + +The .xs file of L<"EXAMPLE 4"> contained some new elements. To understand +the meaning of these elements, pay attention to the line which reads + + MODULE = Mytest2 PACKAGE = Mytest2 + +Anything before this line is plain C code which describes which headers +to include, and defines some convenience functions. No translations are +performed on this part, it goes into the generated output C file as is. + +Anything after this line is the description of XSUB functions. +These descriptions are translated by B<xsubpp> into C code which +implements these functions using Perl calling conventions, and which +makes these functions visible from Perl interpreter. + +Pay a special attention to the function C<constant>. This name appears +twice in the generated .xs file: once in the first part, as a static C +function, the another time in the second part, when an XSUB interface to +this static C function is defined. + +This is quite typical for .xs files: usually the .xs file provides +an interface to an existing C function. Then this C function is defined +somewhere (either in an external library, or in the first part of .xs file), +and a Perl interface to this function (i.e. "Perl glue") is described in the +second part of .xs file. The situation in L<"EXAMPLE 1">, L<"EXAMPLE 2">, +and L<"EXAMPLE 3">, when all the work is done inside the "Perl glue", is +somewhat of an exception rather than the rule. + +=head2 Getting the fat out of XSUBs + +In L<"EXAMPLE 4"> the second part of .xs file contained the following +description of an XSUB: + + double + foo(a,b,c) + int a + long b + const char * c + OUTPUT: + RETVAL + +Note that in contrast with L<"EXAMPLE 1">, L<"EXAMPLE 2"> and L<"EXAMPLE 3">, +this description does not contain the actual I<code> for what is done +is done during a call to Perl function foo(). To understand what is going +on here, one can add a CODE section to this XSUB: + + double + foo(a,b,c) + int a + long b + const char * c + CODE: + RETVAL = foo(a,b,c); + OUTPUT: + RETVAL + +However, these two XSUBs provide almost identical generated C code: B<xsubpp> +compiler is smart enough to figure out the C<CODE:> section from the first +two lines of the description of XSUB. What about C<OUTPUT:> section? In +fact, that is absolutely the same! The C<OUTPUT:> section can be removed +as well, I<as far as C<CODE:> section or C<PPCODE:> section> is not +specified: B<xsubpp> can see that it needs to generate a function call +section, and will autogenerate the OUTPUT section too. Thus one can +shortcut the XSUB to become: + + double + foo(a,b,c) + int a + long b + const char * c + +Can we do the same with an XSUB + + int + is_even(input) + int input + CODE: + RETVAL = (input % 2 == 0); + OUTPUT: + RETVAL + +of L<"EXAMPLE 2">? To do this, one needs to define a C function C<int +is_even(int input)>. As we saw in L<Anatomy of .xs file>, a proper place +for this definition is in the first part of .xs file. In fact a C function + + int + is_even(int arg) + { + return (arg % 2 == 0); + } + +is probably overkill for this. Something as simple as a C<#define> will +do too: + + #define is_even(arg) ((arg) % 2 == 0) + +After having this in the first part of .xs file, the "Perl glue" part becomes +as simple as + + int + is_even(input) + int input + +This technique of separation of the glue part from the workhorse part has +obvious tradeoffs: if you want to change a Perl interface, you need to +change two places in your code. However, it removes a lot of clutter, +and makes the workhorse part independent from idiosyncrasies of Perl calling +convention. (In fact, there is nothing Perl-specific in the above description, +a different version of B<xsubpp> might have translated this to TCL glue or +Python glue as well.) + +=head2 More about XSUB arguments With the completion of Example 4, we now have an easy way to simulate some real-life libraries whose interfaces may not be the cleanest in the world. We shall now continue with a discussion of the arguments passed to the -xsubpp compiler. +B<xsubpp> compiler. When you specify arguments to routines in the .xs file, you are really passing three pieces of information for each argument listed. The first piece is the order of that argument relative to the others (first, second, etc). The second is the type of argument, and consists of the type declaration of the argument (e.g., int, char*, etc). The third piece is -the exact way in which the argument should be used in the call to the -library function from this XSUB. This would mean whether or not to place -a "&" before the argument or not, meaning the argument expects to be -passed the address of the specified data type. +the calling convention for the argument in the call to the library function. + +While Perl passes arguments to functions by reference, +C passes arguments by value; to implement a C function which modifies data +of one of the "arguments", the actual argument of this C function would be +a pointer to the data. Thus two C functions with declarations + + int string_length(char *s); + int upper_case_char(char *cp); + +may have completely different semantics: the first one may inspect an array +of chars pointed by s, and the second one may immediately dereference C<cp> +and manipulate C<*cp> only (using the return value as, say, a success +indicator). From Perl one would use these functions in +a completely different manner. + +One conveys this info to B<xsubpp> by replacing C<*> before the +argument by C<&>. C<&> means that the argument should be passed to a library +function by its address. The above two function may be XSUB-ified as + + int + string_length(s) + char * s + + int + upper_case_char(cp) + char &cp -There is a difference between the two arguments in this hypothetical function: +For example, consider: int foo(a,b) char &a char * b -The first argument to this function would be treated as a char and assigned +The first Perl argument to this function would be treated as a char and assigned to the variable a, and its address would be passed into the function foo. -The second argument would be treated as a string pointer and assigned to the +The second Perl argument would be treated as a string pointer and assigned to the variable b. The I<value> of b would be passed into the function foo. The -actual call to the function foo that xsubpp generates would look like this: +actual call to the function foo that B<xsubpp> generates would look like this: foo(&a, b); -Xsubpp will parse the following function argument lists identically: +B<xsubpp> will parse the following function argument lists identically: char &a char&a @@ -706,7 +863,7 @@ on the argument stack. ST(0) is thus the first argument on the stack and therefore the first argument passed to the XSUB, ST(1) is the second argument, and so on. -When you list the arguments to the XSUB in the .xs file, that tells xsubpp +When you list the arguments to the XSUB in the .xs file, that tells B<xsubpp> which argument corresponds to which of the argument stack (i.e., the first one listed is the first argument, and so on). You invite disaster if you do not list them in the same order as the function expects them. @@ -724,6 +881,23 @@ The code for the round() XSUB routine contains lines that look like this: The arg variable is initially set by taking the value from ST(0), then is stored back into ST(0) at the end of the routine. +XSUBs are also allowed to return lists, not just scalars. This must be +done by manipulating stack values ST(0), ST(1), etc, in a subtly +different way. See L<perlxs> for details. + +XSUBs are also allowed to avoid automatic conversion of Perl function arguments +to C function arguments. See L<perlxs> for details. Some people prefer +manual conversion by inspecting C<ST(i)> even in the cases when automatic +conversion will do, arguing that this makes the logic of an XSUB call clearer. +Compare with L<"Getting the fat out of XSUBs"> for a similar tradeoff of +a complete separation of "Perl glue" and "workhorse" parts of an XSUB. + +While experts may argue about these idioms, a novice to Perl guts may +prefer a way which is as little Perl-guts-specific as possible, meaning +automatic conversion and automatic call generation, as in +L<"Getting the fat out of XSUBs">. This approach has the additional +benefit of protecting the XSUB writer from future changes to the Perl API. + =head2 Extending your Extension Sometimes you might want to provide some extra methods or subroutines @@ -781,7 +955,7 @@ Mytest.xs: void statfs(path) char * path - PREINIT: + INIT: int i; struct statfs buf; @@ -822,10 +996,12 @@ This example added quite a few new concepts. We'll take them one at a time. =item * -The PREINIT: directive contains code that will be placed immediately after -variable declaration and before the argument stack is decoded. Some compilers -cannot handle variable declarations at arbitrary locations inside a function, +The INIT: directive contains code that will be placed immediately after +the argument stack is decoded. C does not allow variable declarations at +arbitrary locations inside a function, so this is usually the best way to declare local variables needed by the XSUB. +(Alternatively, one could put the whole C<PPCODE:> section into braces, and +put these declarations on top.) =item * @@ -837,7 +1013,7 @@ this function, we need room on the stack to hold the 9 values which may be returned. We do this by using the PPCODE: directive, rather than the CODE: directive. -This tells xsubpp that we will be managing the return values that will be +This tells B<xsubpp> that we will be managing the return values that will be put on the argument stack by ourselves. =item * @@ -846,7 +1022,8 @@ When we want to place values to be returned to the caller onto the stack, we use the series of macros that begin with "XPUSH". There are five different versions, for placing integers, unsigned integers, doubles, strings, and Perl scalars on the stack. In our example, we placed a -Perl scalar onto the stack. +Perl scalar onto the stack. (In fact this is the only macro which +can be used to return multiple values.) The XPUSH* macros will automatically extend the return stack to prevent it from being overrun. You push values onto the stack in the order you @@ -860,6 +1037,22 @@ program, the SV's that held the returned values can be deallocated. If they were not mortal, then they would continue to exist after the XSUB routine returned, but would not be accessible. This is a memory leak. +=item * + +If we were interested in performance, not in code compactness, in the success +branch we would not use C<XPUSHs> macros, but C<PUSHs> macros, and would +pre-extend the stack before pushing the return values: + + EXTEND(SP, 9); + +The tradeoff is that one needs to calculate the number of return values +in advance (though overextending the stack will not typically hurt +anything but memory consumption). + +Similarly, in the failure branch we could use C<PUSHs> I<without> extending +the stack: the Perl function reference comes to an XSUB on the stack, thus +the stack is I<always> large enough to take one return value. + =back =head2 EXAMPLE 6 (Coming Soon) @@ -930,4 +1123,4 @@ and Tim Bunce. =head2 Last Changed -1999/5/25 +1999/11/30 diff --git a/pod/roffitall b/pod/roffitall index 9c9daeb4d9..7ddffe76c5 100644 --- a/pod/roffitall +++ b/pod/roffitall @@ -42,6 +42,7 @@ toroff=` $mandir/perlmod.1 \ $mandir/perlmodlib.1 \ $mandir/perlmodinstall.1 \ + $mandir/perlfork.1 \ $mandir/perlform.1 \ $mandir/perllocale.1 \ $mandir/perlref.1 \ @@ -241,31 +241,30 @@ PP(pp_rv2gv) * NI-S 1999/05/07 */ if (PL_op->op_private & OPpDEREF) { - GV *gv = (GV *) newSV(0); - STRLEN len = 0; - char *name = ""; - if (cUNOP->op_first->op_type == OP_PADSV) { - SV **namep = av_fetch(PL_comppad_name, cUNOP->op_first->op_targ, 4); - if (namep && *namep) { - name = SvPV(*namep,len); - if (!name) { - name = ""; - len = 0; - } - } + char *name; + GV *gv; + if (cUNOP->op_targ) { + STRLEN len; + SV *namesv = PL_curpad[cUNOP->op_targ]; + name = SvPV(namesv, len); + gv = (GV*)NEWSV(0,0); + gv_init(gv, CopSTASH(PL_curcop), name, len, 0); + } + else { + name = CopSTASHPV(PL_curcop); + gv = newGVgen(name); } - gv_init(gv, CopSTASH(PL_curcop), name, len, 0); sv_upgrade(sv, SVt_RV); - SvRV(sv) = (SV *) gv; + SvRV(sv) = (SV*)gv; SvROK_on(sv); SvSETMAGIC(sv); goto wasref; - } + } if (PL_op->op_flags & OPf_REF || PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ PL_no_usym, "a symbol"); if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); RETSETUNDEF; } sym = SvPV(sv, n_a); @@ -321,7 +320,7 @@ PP(pp_rv2sv) PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ PL_no_usym, "a SCALAR"); if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); RETSETUNDEF; } sym = SvPV(sv, n_a); @@ -1789,7 +1788,7 @@ S_seed(pTHX) u = (U32)SEED_C1 * when; # endif #endif - u += SEED_C3 * (U32)getpid(); + u += SEED_C3 * (U32)PerlProc_getpid(); u += SEED_C4 * (U32)PTR2UV(PL_stack_sp); #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */ u += SEED_C5 * (U32)PTR2UV(&when); @@ -2022,7 +2021,9 @@ PP(pp_substr) sv_pos_u2b(sv, &pos, &rem); tmps += pos; sv_setpvn(TARG, tmps, rem); - if (lvalue) { /* it's an lvalue! */ + if (repl) + sv_insert(sv, pos, rem, repl, repl_len); + else if (lvalue) { /* it's an lvalue! */ if (!SvGMAGICAL(sv)) { if (SvROK(sv)) { STRLEN n_a; @@ -2051,8 +2052,6 @@ PP(pp_substr) LvTARGOFF(TARG) = pos; LvTARGLEN(TARG) = rem; } - else if (repl) - sv_insert(sv, pos, rem, repl, repl_len); } SPAGAIN; PUSHs(TARG); /* avoid SvSETMAGIC here */ @@ -2262,7 +2261,7 @@ PP(pp_ucfirst) tend = uv_to_utf8(tmpbuf, uv); - if (!SvPADTMP(sv) || tend - tmpbuf != ulen) { + if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) { dTARGET; sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf); sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); @@ -2274,7 +2273,7 @@ PP(pp_ucfirst) } } else { - if (!SvPADTMP(sv)) { + if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; sv_setsv(TARG, sv); sv = TARG; @@ -2319,7 +2318,7 @@ PP(pp_lcfirst) tend = uv_to_utf8(tmpbuf, uv); - if (!SvPADTMP(sv) || tend - tmpbuf != ulen) { + if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) { dTARGET; sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf); sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); @@ -2331,7 +2330,7 @@ PP(pp_lcfirst) } } else { - if (!SvPADTMP(sv)) { + if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; sv_setsv(TARG, sv); sv = TARG; @@ -2398,7 +2397,7 @@ PP(pp_uc) } } else { - if (!SvPADTMP(sv)) { + if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; sv_setsv(TARG, sv); sv = TARG; @@ -2469,7 +2468,7 @@ PP(pp_lc) } } else { - if (!SvPADTMP(sv)) { + if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; sv_setsv(TARG, sv); sv = TARG; @@ -2648,13 +2647,28 @@ PP(pp_delete) U32 hvtype; hv = (HV*)POPs; hvtype = SvTYPE(hv); - while (++MARK <= SP) { - if (hvtype == SVt_PVHV) + if (hvtype == SVt_PVHV) { /* hash element */ + while (++MARK <= SP) { sv = hv_delete_ent(hv, *MARK, discard, 0); - else - DIE(aTHX_ "Not a HASH reference"); - *MARK = sv ? sv : &PL_sv_undef; + *MARK = sv ? sv : &PL_sv_undef; + } } + else if (hvtype == SVt_PVAV) { + if (PL_op->op_flags & OPf_SPECIAL) { /* array element */ + while (++MARK <= SP) { + sv = av_delete((AV*)hv, SvIV(*MARK), discard); + *MARK = sv ? sv : &PL_sv_undef; + } + } + else { /* pseudo-hash element */ + while (++MARK <= SP) { + sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0); + *MARK = sv ? sv : &PL_sv_undef; + } + } + } + else + DIE(aTHX_ "Not a HASH reference"); if (discard) SP = ORIGMARK; else if (gimme == G_SCALAR) { @@ -2668,6 +2682,12 @@ PP(pp_delete) hv = (HV*)POPs; if (SvTYPE(hv) == SVt_PVHV) sv = hv_delete_ent(hv, keysv, discard, 0); + else if (SvTYPE(hv) == SVt_PVAV) { + if (PL_op->op_flags & OPf_SPECIAL) + sv = av_delete((AV*)hv, SvIV(keysv), discard); + else + sv = avhv_delete_ent((AV*)hv, keysv, discard, 0); + } else DIE(aTHX_ "Not a HASH reference"); if (!sv) @@ -2688,7 +2708,11 @@ PP(pp_exists) RETPUSHYES; } else if (SvTYPE(hv) == SVt_PVAV) { - if (avhv_exists_ent((AV*)hv, tmpsv, 0)) + if (PL_op->op_flags & OPf_SPECIAL) { /* array element */ + if (av_exists((AV*)hv, SvIV(tmpsv))) + RETPUSHYES; + } + else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */ RETPUSHYES; } else { @@ -3136,6 +3160,7 @@ PP(pp_reverse) *MARK++ = *SP; *SP-- = tmp; } + /* safe as long as stack cannot get extended in the above */ SP = oldsp; } else { @@ -3236,7 +3261,7 @@ PP(pp_unpack) { djSP; dPOPPOPssrl; - SV **oldsp = SP; + I32 start_sp_offset = SP - PL_stack_base; I32 gimme = GIMME_V; SV *sv; STRLEN llen; @@ -3249,6 +3274,7 @@ PP(pp_unpack) I32 datumtype; register I32 len; register I32 bits; + register char *str; /* These must not be in registers: */ I16 ashort; @@ -3364,7 +3390,7 @@ PP(pp_unpack) s += len; break; case '/': - if (oldsp >= SP) + if (start_sp_offset >= SP - PL_stack_base) DIE(aTHX_ "/ must follow a numeric type"); datumtype = *pat++; if (*pat == '*') @@ -3444,8 +3470,7 @@ PP(pp_unpack) sv = NEWSV(35, len + 1); SvCUR_set(sv, len); SvPOK_on(sv); - aptr = pat; /* borrow register */ - pat = SvPVX(sv); + str = SvPVX(sv); if (datumtype == 'b') { aint = len; for (len = 0; len < aint; len++) { @@ -3453,7 +3478,7 @@ PP(pp_unpack) bits >>= 1; else bits = *s++; - *pat++ = '0' + (bits & 1); + *str++ = '0' + (bits & 1); } } else { @@ -3463,11 +3488,10 @@ PP(pp_unpack) bits <<= 1; else bits = *s++; - *pat++ = '0' + ((bits & 128) != 0); + *str++ = '0' + ((bits & 128) != 0); } } - *pat = '\0'; - pat = aptr; /* unborrow register */ + *str = '\0'; XPUSHs(sv_2mortal(sv)); break; case 'H': @@ -3477,8 +3501,7 @@ PP(pp_unpack) sv = NEWSV(35, len + 1); SvCUR_set(sv, len); SvPOK_on(sv); - aptr = pat; /* borrow register */ - pat = SvPVX(sv); + str = SvPVX(sv); if (datumtype == 'h') { aint = len; for (len = 0; len < aint; len++) { @@ -3486,7 +3509,7 @@ PP(pp_unpack) bits >>= 4; else bits = *s++; - *pat++ = PL_hexdigit[bits & 15]; + *str++ = PL_hexdigit[bits & 15]; } } else { @@ -3496,11 +3519,10 @@ PP(pp_unpack) bits <<= 4; else bits = *s++; - *pat++ = PL_hexdigit[(bits >> 4) & 15]; + *str++ = PL_hexdigit[(bits >> 4) & 15]; } } - *pat = '\0'; - pat = aptr; /* unborrow register */ + *str = '\0'; XPUSHs(sv_2mortal(sv)); break; case 'c': @@ -4204,7 +4226,7 @@ PP(pp_unpack) checksum = 0; } } - if (SP == oldsp && gimme == G_SCALAR) + if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR) PUSHs(&PL_sv_undef); RETURN; } @@ -4468,15 +4490,14 @@ PP(pp_pack) case 'B': case 'b': { - char *savepat = pat; + register char *str; I32 saveitems; fromstr = NEXTFROM; saveitems = items; - aptr = SvPV(fromstr, fromlen); + str = SvPV(fromstr, fromlen); if (pat[-1] == '*') len = fromlen; - pat = aptr; aint = SvCUR(cat); SvCUR(cat) += (len+7)/8; SvGROW(cat, SvCUR(cat) + 1); @@ -4487,7 +4508,7 @@ PP(pp_pack) items = 0; if (datumtype == 'B') { for (len = 0; len++ < aint;) { - items |= *pat++ & 1; + items |= *str++ & 1; if (len & 7) items <<= 1; else { @@ -4498,7 +4519,7 @@ PP(pp_pack) } else { for (len = 0; len++ < aint;) { - if (*pat++ & 1) + if (*str++ & 1) items |= 128; if (len & 7) items >>= 1; @@ -4515,26 +4536,24 @@ PP(pp_pack) items >>= 7 - (aint & 7); *aptr++ = items & 0xff; } - pat = SvPVX(cat) + SvCUR(cat); - while (aptr <= pat) + str = SvPVX(cat) + SvCUR(cat); + while (aptr <= str) *aptr++ = '\0'; - pat = savepat; items = saveitems; } break; case 'H': case 'h': { - char *savepat = pat; + register char *str; I32 saveitems; fromstr = NEXTFROM; saveitems = items; - aptr = SvPV(fromstr, fromlen); + str = SvPV(fromstr, fromlen); if (pat[-1] == '*') len = fromlen; - pat = aptr; aint = SvCUR(cat); SvCUR(cat) += (len+1)/2; SvGROW(cat, SvCUR(cat) + 1); @@ -4545,10 +4564,10 @@ PP(pp_pack) items = 0; if (datumtype == 'H') { for (len = 0; len++ < aint;) { - if (isALPHA(*pat)) - items |= ((*pat++ & 15) + 9) & 15; + if (isALPHA(*str)) + items |= ((*str++ & 15) + 9) & 15; else - items |= *pat++ & 15; + items |= *str++ & 15; if (len & 1) items <<= 4; else { @@ -4559,10 +4578,10 @@ PP(pp_pack) } else { for (len = 0; len++ < aint;) { - if (isALPHA(*pat)) - items |= (((*pat++ & 15) + 9) & 15) << 4; + if (isALPHA(*str)) + items |= (((*str++ & 15) + 9) & 15) << 4; else - items |= (*pat++ & 15) << 4; + items |= (*str++ & 15) << 4; if (len & 1) items >>= 4; else { @@ -4573,11 +4592,10 @@ PP(pp_pack) } if (aint & 1) *aptr++ = items & 0xff; - pat = SvPVX(cat) + SvCUR(cat); - while (aptr <= pat) + str = SvPVX(cat) + SvCUR(cat); + while (aptr <= str) *aptr++ = '\0'; - pat = savepat; items = saveitems; } break; @@ -4859,9 +4877,13 @@ PP(pp_pack) * of pack() (and all copies of the result) are * gone. */ - if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr))) + if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) + || (SvPADTMP(fromstr) + && !SvREADONLY(fromstr)))) + { Perl_warner(aTHX_ WARN_UNSAFE, "Attempt to pack pointer to temporary value"); + } if (SvPOK(fromstr) || SvNIOK(fromstr)) aptr = SvPV(fromstr,n_a); else @@ -27,6 +27,8 @@ #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) static I32 sortcv(pTHXo_ SV *a, SV *b); +static I32 sortcv_stacked(pTHXo_ SV *a, SV *b); +static I32 sortcv_xsub(pTHXo_ SV *a, SV *b); static I32 sv_ncmp(pTHXo_ SV *a, SV *b); static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b); static I32 amagic_ncmp(pTHXo_ SV *a, SV *b); @@ -132,9 +134,13 @@ PP(pp_regcomp) else if (strEQ("\\s+", pm->op_pmregexp->precomp)) pm->op_pmflags |= PMf_WHITE; + /* XXX runtime compiled output needs to move to the pad */ if (pm->op_pmflags & PMf_KEEP) { pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ +#if !defined(USE_ITHREADS) && !defined(USE_THREADS) + /* XXX can't change the optree at runtime either */ cLOGOP->op_first->op_next = PL_op->op_next; +#endif } RETURN; } @@ -686,7 +692,7 @@ PP(pp_grepstart) /* SAVE_DEFSV does *not* suffice here for USE_THREADS */ SAVESPTR(DEFSV); ENTER; /* enter inner scope */ - SAVESPTR(PL_curpm); + SAVEVPTR(PL_curpm); src = PL_stack_base[*PL_markstack_ptr]; SvTEMP_off(src); @@ -756,7 +762,7 @@ PP(pp_mapwhile) SV *src; ENTER; /* enter inner scope */ - SAVESPTR(PL_curpm); + SAVEVPTR(PL_curpm); src = PL_stack_base[PL_markstack_ptr[-1]]; SvTEMP_off(src); @@ -778,6 +784,8 @@ PP(pp_sort) I32 gimme = GIMME; OP* nextop = PL_op->op_next; I32 overloading = 0; + bool hasargs = FALSE; + I32 is_xsub = 0; if (gimme != G_ARRAY) { SP = MARK; @@ -785,7 +793,7 @@ PP(pp_sort) } ENTER; - SAVEPPTR(PL_sortcop); + SAVEVPTR(PL_sortcop); if (PL_op->op_flags & OPf_STACKED) { if (PL_op->op_flags & OPf_SPECIAL) { OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */ @@ -796,28 +804,38 @@ PP(pp_sort) } else { cv = sv_2cv(*++MARK, &stash, &gv, 0); + if (cv && SvPOK(cv)) { + STRLEN n_a; + char *proto = SvPV((SV*)cv, n_a); + if (proto && strEQ(proto, "$$")) { + hasargs = TRUE; + } + } if (!(cv && CvROOT(cv))) { - if (gv) { + if (cv && CvXSUB(cv)) { + is_xsub = 1; + } + else if (gv) { SV *tmpstr = sv_newmortal(); gv_efullname3(tmpstr, gv, Nullch); - if (cv && CvXSUB(cv)) - DIE(aTHX_ "Xsub \"%s\" called in sort", SvPVX(tmpstr)); DIE(aTHX_ "Undefined sort subroutine \"%s\" called", SvPVX(tmpstr)); } - if (cv) { - if (CvXSUB(cv)) - DIE(aTHX_ "Xsub called in sort"); + else { DIE(aTHX_ "Undefined subroutine in sort"); } - DIE(aTHX_ "Not a CODE reference in sort"); } - PL_sortcop = CvSTART(cv); - SAVESPTR(CvROOT(cv)->op_ppaddr); - CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL]; - SAVESPTR(PL_curpad); - PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]); + if (is_xsub) + PL_sortcop = (OP*)cv; + else { + PL_sortcop = CvSTART(cv); + SAVEVPTR(CvROOT(cv)->op_ppaddr); + CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL]; + + SAVEVPTR(PL_curpad); + PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]); + } } } else { @@ -863,7 +881,6 @@ PP(pp_sort) PUSHBLOCK(cx, CXt_NULL, PL_stack_base); if (!(PL_op->op_flags & OPf_SPECIAL)) { - bool hasargs = FALSE; cx->cx_type = CXt_SUB; cx->blk_gimme = G_SCALAR; PUSHSUB(cx); @@ -871,7 +888,19 @@ PP(pp_sort) (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */ } PL_sortcxix = cxstack_ix; - qsortsv((myorigmark+1), max, sortcv); + + if (hasargs && !is_xsub) { + /* This is mostly copied from pp_entersub */ + AV *av = (AV*)PL_curpad[0]; + +#ifndef USE_THREADS + cx->blk_sub.savearray = GvAV(PL_defgv); + GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); +#endif /* USE_THREADS */ + cx->blk_sub.argarray = av; + } + qsortsv((myorigmark+1), max, + is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv); POPBLOCK(cx,PL_curpm); PL_stack_sp = newsp; @@ -968,7 +997,9 @@ PP(pp_flop) mg_get(right); if (SvNIOKp(left) || !SvPOKp(left) || - (looks_like_number(left) && *SvPVX(left) != '0') ) + SvNIOKp(right) || !SvPOKp(right) || + (looks_like_number(left) && *SvPVX(left) != '0' && + looks_like_number(right) && *SvPVX(right) != '0')) { if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX) DIE(aTHX_ "Range iterator outside integer range"); @@ -1040,6 +1071,11 @@ S_dopoptolabel(pTHX_ char *label) Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s", PL_op_name[PL_op->op_type]); break; + case CXt_FORMAT: + if (ckWARN(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s", + PL_op_name[PL_op->op_type]); + break; case CXt_EVAL: if (ckWARN(WARN_UNSAFE)) Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s", @@ -1115,6 +1151,7 @@ S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock) continue; case CXt_EVAL: case CXt_SUB: + case CXt_FORMAT: DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i)); return i; } @@ -1160,6 +1197,11 @@ S_dopoptoloop(pTHX_ I32 startingblock) Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s", PL_op_name[PL_op->op_type]); break; + case CXt_FORMAT: + if (ckWARN(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s", + PL_op_name[PL_op->op_type]); + break; case CXt_EVAL: if (ckWARN(WARN_UNSAFE)) Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s", @@ -1208,6 +1250,9 @@ Perl_dounwind(pTHX_ I32 cxix) break; case CXt_NULL: break; + case CXt_FORMAT: + POPFORMAT(cx); + break; } cxstack_ix--; } @@ -1420,7 +1465,7 @@ PP(pp_caller) } cx = &ccstack[cxix]; - if (CxTYPE(cx) == CXt_SUB) { + if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { dbcxix = dopoptosub_at(ccstack, cxix - 1); /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the field below is defined for any cx. */ @@ -1448,7 +1493,8 @@ PP(pp_caller) PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop)))); if (!MAXARG) RETURN; - if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */ + if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { + /* So is ccstack[dbcxix]. */ sv = NEWSV(49, 0); gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch); PUSHs(sv_2mortal(sv)); @@ -1563,7 +1609,7 @@ PP(pp_dbstate) PUSHSUB(cx); CvDEPTH(cv)++; (void)SvREFCNT_inc(cv); - SAVESPTR(PL_curpad); + SAVEVPTR(PL_curpad); PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE)); RETURNOP(CvSTART(cv)); } @@ -1582,6 +1628,10 @@ PP(pp_enteriter) register PERL_CONTEXT *cx; I32 gimme = GIMME_V; SV **svp; + U32 cxtype = CXt_LOOP; +#ifdef USE_ITHREADS + void *iterdata; +#endif ENTER; SAVETMPS; @@ -1598,23 +1648,39 @@ PP(pp_enteriter) if (PL_op->op_targ) { svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */ SAVESPTR(*svp); +#ifdef USE_ITHREADS + iterdata = (void*)PL_op->op_targ; + cxtype |= CXp_PADVAR; +#endif } else { - svp = &GvSV((GV*)POPs); /* symbol table variable */ + GV *gv = (GV*)POPs; + svp = &GvSV(gv); /* symbol table variable */ SAVEGENERICSV(*svp); *svp = NEWSV(0,0); +#ifdef USE_ITHREADS + iterdata = (void*)gv; +#endif } ENTER; - PUSHBLOCK(cx, CXt_LOOP, SP); + PUSHBLOCK(cx, cxtype, SP); +#ifdef USE_ITHREADS + PUSHLOOP(cx, iterdata, MARK); +#else PUSHLOOP(cx, svp, MARK); +#endif if (PL_op->op_flags & OPf_STACKED) { cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs); if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) { dPOPss; if (SvNIOKp(sv) || !SvPOKp(sv) || - (looks_like_number(sv) && *SvPVX(sv) != '0')) { + SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) || + (looks_like_number(sv) && *SvPVX(sv) != '0' && + looks_like_number((SV*)cx->blk_loop.iterary) && + *SvPVX(cx->blk_loop.iterary) != '0')) + { if (SvNV(sv) < IV_MIN || SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX) DIE(aTHX_ "Range iterator outside integer range"); @@ -1703,7 +1769,9 @@ PP(pp_return) SV *sv; if (PL_curstackinfo->si_type == PERLSI_SORT) { - if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) { + if (cxstack_ix == PL_sortcxix + || dopoptosub(cxstack_ix) <= PL_sortcxix) + { if (cxstack_ix > PL_sortcxix) dounwind(PL_sortcxix); AvARRAY(PL_curstack)[1] = *SP; @@ -1737,6 +1805,9 @@ PP(pp_return) DIE(aTHX_ "%s did not return a true value", name); } break; + case CXt_FORMAT: + POPFORMAT(cx); + break; default: DIE(aTHX_ "panic: return"); } @@ -1800,7 +1871,7 @@ PP(pp_last) if (PL_op->op_flags & OPf_SPECIAL) { cxix = dopoptoloop(cxstack_ix); if (cxix < 0) - DIE(aTHX_ "Can't \"last\" outside a block"); + DIE(aTHX_ "Can't \"last\" outside a loop block"); } else { cxix = dopoptolabel(cPVOP->op_pv); @@ -1826,6 +1897,10 @@ PP(pp_last) POPEVAL(cx); nextop = pop_return(); break; + case CXt_FORMAT: + POPFORMAT(cx); + nextop = pop_return(); + break; default: DIE(aTHX_ "panic: last"); } @@ -1874,7 +1949,7 @@ PP(pp_next) if (PL_op->op_flags & OPf_SPECIAL) { cxix = dopoptoloop(cxstack_ix); if (cxix < 0) - DIE(aTHX_ "Can't \"next\" outside a block"); + DIE(aTHX_ "Can't \"next\" outside a loop block"); } else { cxix = dopoptolabel(cPVOP->op_pv); @@ -1899,7 +1974,7 @@ PP(pp_redo) if (PL_op->op_flags & OPf_SPECIAL) { cxix = dopoptoloop(cxstack_ix); if (cxix < 0) - DIE(aTHX_ "Can't \"redo\" outside a block"); + DIE(aTHX_ "Can't \"redo\" outside a loop block"); } else { cxix = dopoptolabel(cPVOP->op_pv); @@ -2072,7 +2147,7 @@ PP(pp_goto) SP[1] = SP[0]; SP--; } - fp3 = (I32(*)(int,int,int)))CvXSUB(cv; + fp3 = (I32(*)(int,int,int))CvXSUB(cv); items = (*fp3)(CvXSUBANY(cv).any_i32, mark - PL_stack_base + 1, items); @@ -2116,9 +2191,10 @@ PP(pp_goto) AV *newpad = newAV(); SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]); I32 ix = AvFILLp((AV*)svp[1]); + I32 names_fill = AvFILLp((AV*)svp[0]); svp = AvARRAY(svp[0]); for ( ;ix > 0; ix--) { - if (svp[ix] != &PL_sv_undef) { + if (names_fill >= ix && svp[ix] != &PL_sv_undef) { char *name = SvPVX(svp[ix]); if ((SvFLAGS(svp[ix]) & SVf_FAKE) || *name == '&') @@ -2137,7 +2213,7 @@ PP(pp_goto) SvPADMY_on(sv); } } - else if (IS_PADGV(oldpad[ix])) { + else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) { av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix])); } else { @@ -2170,7 +2246,7 @@ PP(pp_goto) } } #endif /* USE_THREADS */ - SAVESPTR(PL_curpad); + SAVEVPTR(PL_curpad); PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); #ifndef USE_THREADS if (cx->blk_sub.hasargs) @@ -2275,8 +2351,9 @@ PP(pp_goto) break; } /* FALL THROUGH */ + case CXt_FORMAT: case CXt_NULL: - DIE(aTHX_ "Can't \"goto\" outside a block"); + DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); default: if (ix) DIE(aTHX_ "panic: goto"); @@ -2352,6 +2429,7 @@ PP(pp_exit) anum = 0; #endif } + PL_exit_flags |= PERL_EXIT_EXPECTED; my_exit(anum); PUSHs(&PL_sv_undef); RETURN; @@ -2506,7 +2584,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp) #ifdef OP_IN_REGISTER PL_opsave = op; #else - SAVEPPTR(PL_op); + SAVEVPTR(PL_op); #endif PL_hints = 0; @@ -2549,7 +2627,7 @@ S_doeval(pTHX_ int gimme, OP** startop) /* set up a scratch pad */ SAVEI32(PL_padix); - SAVESPTR(PL_curpad); + SAVEVPTR(PL_curpad); SAVESPTR(PL_comppad); SAVESPTR(PL_comppad_name); SAVEI32(PL_comppad_name_fill); @@ -2561,7 +2639,7 @@ S_doeval(pTHX_ int gimme, OP** startop) PERL_CONTEXT *cx = &cxstack[i]; if (CxTYPE(cx) == CXt_EVAL) break; - else if (CxTYPE(cx) == CXt_SUB) { + else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { caller = cx->blk_sub.cv; break; } @@ -2762,10 +2840,54 @@ PP(pp_require) SV *filter_sub = 0; sv = POPs; - if (SvNIOKp(sv) && !SvPOKp(sv)) { - if (Atof(PL_patchlevel) + 0.00000999 < SvNV(sv)) - DIE(aTHX_ "Perl %s required--this is only version %s, stopped", - SvPV(sv,n_a),PL_patchlevel); + if (SvNIOKp(sv)) { + UV rev, ver, sver; + if (SvPOKp(sv) && SvUTF8(sv)) { /* require v5.6.1 */ + I32 len; + U8 *s = (U8*)SvPVX(sv); + U8 *end = (U8*)SvPVX(sv) + SvCUR(sv); + if (s < end) { + rev = utf8_to_uv(s, &len); + s += len; + if (s < end) { + ver = utf8_to_uv(s, &len); + s += len; + if (s < end) + sver = utf8_to_uv(s, &len); + else + sver = 0; + } + else + ver = 0; + } + else + rev = 0; + if (PERL_REVISION < rev + || (PERL_REVISION == rev + && (PERL_VERSION < ver + || (PERL_VERSION == ver + && PERL_SUBVERSION < sver)))) + { + DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version " + "v%"UVuf".%"UVuf".%"UVuf", stopped", rev, ver, sver, PERL_REVISION, + PERL_VERSION, PERL_SUBVERSION); + } + } + else if (!SvPOKp(sv)) { /* require 5.005_03 */ + NV n = SvNV(sv); + rev = (UV)n; + ver = (UV)((n-rev)*1000); + sver = (UV)((((n-rev)*1000 - ver) + 0.0009) * 1000); + + if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000) + + ((NV)PERL_SUBVERSION/(NV)1000000) + + 0.00000099 < SvNV(sv)) + { + DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version " + "v%"UVuf".%"UVuf".%"UVuf", stopped", rev, ver, sver, PERL_REVISION, + PERL_VERSION, PERL_SUBVERSION); + } + } RETPUSHYES; } name = SvPV(sv, len); @@ -2970,11 +3092,9 @@ PP(pp_require) PL_rsfp_filters = Nullav; PL_rsfp = tryrsfp; - name = savepv(name); - SAVEFREEPV(name); SAVEHINTS(); PL_hints = 0; - SAVEPPTR(PL_compiling.cop_warnings); + SAVESPTR(PL_compiling.cop_warnings); if (PL_dowarn & G_WARN_ALL_ON) PL_compiling.cop_warnings = WARN_ALL ; else if (PL_dowarn & G_WARN_ALL_OFF) @@ -3049,7 +3169,7 @@ PP(pp_entereval) SAVEDELETE(PL_defstash, safestr, strlen(safestr)); SAVEHINTS(); PL_hints = PL_op->op_targ; - SAVEPPTR(PL_compiling.cop_warnings); + SAVESPTR(PL_compiling.cop_warnings); if (!specialWARN(PL_compiling.cop_warnings)) { PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; SAVEFREESV(PL_compiling.cop_warnings) ; @@ -4107,6 +4227,80 @@ sortcv(pTHXo_ SV *a, SV *b) return result; } +static I32 +sortcv_stacked(pTHXo_ SV *a, SV *b) +{ + dTHR; + I32 oldsaveix = PL_savestack_ix; + I32 oldscopeix = PL_scopestack_ix; + I32 result; + AV *av; + +#ifdef USE_THREADS + av = (AV*)PL_curpad[0]; +#else + av = GvAV(PL_defgv); +#endif + + if (AvMAX(av) < 1) { + SV** ary = AvALLOC(av); + if (AvARRAY(av) != ary) { + AvMAX(av) += AvARRAY(av) - AvALLOC(av); + SvPVX(av) = (char*)ary; + } + if (AvMAX(av) < 1) { + AvMAX(av) = 1; + Renew(ary,2,SV*); + SvPVX(av) = (char*)ary; + } + } + AvFILLp(av) = 1; + + AvARRAY(av)[0] = a; + AvARRAY(av)[1] = b; + PL_stack_sp = PL_stack_base; + PL_op = PL_sortcop; + CALLRUNOPS(aTHX); + if (PL_stack_sp != PL_stack_base + 1) + Perl_croak(aTHX_ "Sort subroutine didn't return single value"); + if (!SvNIOKp(*PL_stack_sp)) + Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value"); + result = SvIV(*PL_stack_sp); + while (PL_scopestack_ix > oldscopeix) { + LEAVE; + } + leave_scope(oldsaveix); + return result; +} + +static I32 +sortcv_xsub(pTHXo_ SV *a, SV *b) +{ + dSP; + I32 oldsaveix = PL_savestack_ix; + I32 oldscopeix = PL_scopestack_ix; + I32 result; + CV *cv=(CV*)PL_sortcop; + + SP = PL_stack_base; + PUSHMARK(SP); + EXTEND(SP, 2); + *++SP = a; + *++SP = b; + PUTBACK; + (void)(*CvXSUB(cv))(aTHXo_ cv); + if (PL_stack_sp != PL_stack_base + 1) + Perl_croak(aTHX_ "Sort subroutine didn't return single value"); + if (!SvNIOKp(*PL_stack_sp)) + Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value"); + result = SvIV(*PL_stack_sp); + while (PL_scopestack_ix > oldscopeix) { + LEAVE; + } + leave_scope(oldsaveix); + return result; +} + static I32 sv_ncmp(pTHXo_ SV *a, SV *b) @@ -29,7 +29,6 @@ #include <sys/file.h> #endif -#define HOP(pos,off) (IN_UTF8 ? utf8_hop(pos, off) : (pos + off)) /* Hot code. */ @@ -40,7 +39,7 @@ static void unset_cvowner(pTHXo_ void *cvarg); PP(pp_const) { djSP; - XPUSHs(cSVOP->op_sv); + XPUSHs(cSVOP_sv); RETURN; } @@ -58,9 +57,9 @@ PP(pp_gvsv) djSP; EXTEND(SP,1); if (PL_op->op_private & OPpLVAL_INTRO) - PUSHs(save_scalar(cGVOP)); + PUSHs(save_scalar(cGVOP_gv)); else - PUSHs(GvSV(cGVOP)); + PUSHs(GvSV(cGVOP_gv)); RETURN; } @@ -95,7 +94,7 @@ PP(pp_stringify) PP(pp_gv) { djSP; - XPUSHs((SV*)cGVOP); + XPUSHs((SV*)cGVOP_gv); RETURN; } @@ -153,8 +152,14 @@ PP(pp_concat) dPOPTOPssrl; STRLEN len; char *s; + if (TARG != left) { s = SvPV(left,len); + if (TARG == right) { + sv_insert(TARG, 0, 0, s, len); + SETs(TARG); + RETURN; + } sv_setpvn(TARG,s,len); } else if (SvGMAGICAL(TARG)) @@ -271,7 +276,7 @@ PP(pp_add) PP(pp_aelemfast) { djSP; - AV *av = GvAV(cGVOP); + AV *av = GvAV(cGVOP_gv); U32 lval = PL_op->op_flags & OPf_MOD; SV** svp = av_fetch(av, PL_op->op_private, lval); SV *sv = (svp ? *svp : &PL_sv_undef); @@ -368,7 +373,7 @@ PP(pp_print) SvPV(sv,n_a)); else if (ckWARN(WARN_CLOSED)) Perl_warner(aTHX_ WARN_CLOSED, - "print on closed filehandle %s", SvPV(sv,n_a)); + "print() on closed filehandle %s", SvPV(sv,n_a)); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; @@ -459,7 +464,7 @@ PP(pp_rv2av) PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ PL_no_usym, "an ARRAY"); if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); if (GIMME == G_ARRAY) { (void)POPs; RETURN; @@ -559,7 +564,7 @@ PP(pp_rv2hv) PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ PL_no_usym, "a HASH"); if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); if (GIMME == G_ARRAY) { SP--; RETURN; @@ -1255,7 +1260,7 @@ Perl_do_readline(pTHX) SV* sv = sv_newmortal(); gv_efullname3(sv, PL_last_in_gv, Nullch); Perl_warner(aTHX_ WARN_CLOSED, - "Read on closed filehandle %s", + "readline() on closed filehandle %s", SvPV_nolen(sv)); } } @@ -1284,12 +1289,11 @@ Perl_do_readline(pTHX) offset = 0; } -/* flip-flop EOF state for a snarfed empty file */ +/* delay EOF state for a snarfed empty file */ #define SNARF_EOF(gimme,rs,io,sv) \ - ((gimme != G_SCALAR || SvCUR(sv) \ - || (IoFLAGS(io) & IOf_NOLINE) || IoLINES(io) || !RsSNARF(rs)) \ - ? ((IoFLAGS(io) &= ~IOf_NOLINE), TRUE) \ - : ((IoFLAGS(io) |= IOf_NOLINE), FALSE)) + (gimme != G_SCALAR || SvCUR(sv) \ + || !RsSNARF(rs) || (IoFLAGS(io) & IOf_NOLINE) \ + || ((IoFLAGS(io) |= IOf_NOLINE), FALSE)) for (;;) { if (!sv_gets(sv, fp, offset) @@ -1509,12 +1513,14 @@ PP(pp_iter) register PERL_CONTEXT *cx; SV* sv; AV* av; + SV **itersvp; EXTEND(SP, 1); cx = &cxstack[cxstack_ix]; if (CxTYPE(cx) != CXt_LOOP) DIE(aTHX_ "panic: pp_iter"); + itersvp = CxITERVAR(cx); av = cx->blk_loop.iterary; if (SvTYPE(av) != SVt_PVAV) { /* iterate ($min .. $max) */ @@ -1525,11 +1531,9 @@ PP(pp_iter) char *max = SvPV((SV*)av, maxlen); if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) { #ifndef USE_THREADS /* don't risk potential race */ - if (SvREFCNT(*cx->blk_loop.itervar) == 1 - && !SvMAGICAL(*cx->blk_loop.itervar)) - { + if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { /* safe to reuse old SV */ - sv_setsv(*cx->blk_loop.itervar, cur); + sv_setsv(*itersvp, cur); } else #endif @@ -1537,8 +1541,8 @@ PP(pp_iter) /* we need a fresh SV every time so that loop body sees a * completely new SV for closures/references to work as * they used to */ - SvREFCNT_dec(*cx->blk_loop.itervar); - *cx->blk_loop.itervar = newSVsv(cur); + SvREFCNT_dec(*itersvp); + *itersvp = newSVsv(cur); } if (strEQ(SvPVX(cur), max)) sv_setiv(cur, 0); /* terminate next time */ @@ -1553,11 +1557,9 @@ PP(pp_iter) RETPUSHNO; #ifndef USE_THREADS /* don't risk potential race */ - if (SvREFCNT(*cx->blk_loop.itervar) == 1 - && !SvMAGICAL(*cx->blk_loop.itervar)) - { + if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { /* safe to reuse old SV */ - sv_setiv(*cx->blk_loop.itervar, cx->blk_loop.iterix++); + sv_setiv(*itersvp, cx->blk_loop.iterix++); } else #endif @@ -1565,8 +1567,8 @@ PP(pp_iter) /* we need a fresh SV every time so that loop body sees a * completely new SV for closures/references to work as they * used to */ - SvREFCNT_dec(*cx->blk_loop.itervar); - *cx->blk_loop.itervar = newSViv(cx->blk_loop.iterix++); + SvREFCNT_dec(*itersvp); + *itersvp = newSViv(cx->blk_loop.iterix++); } RETPUSHYES; } @@ -1575,7 +1577,7 @@ PP(pp_iter) if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av))) RETPUSHNO; - SvREFCNT_dec(*cx->blk_loop.itervar); + SvREFCNT_dec(*itersvp); if (sv = (SvMAGICAL(av)) ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE) @@ -1603,7 +1605,7 @@ PP(pp_iter) sv = (SV*)lv; } - *cx->blk_loop.itervar = SvREFCNT_inc(sv); + *itersvp = SvREFCNT_inc(sv); RETPUSHYES; } @@ -1900,7 +1902,7 @@ PP(pp_grepwhile) SV *src; ENTER; /* enter inner scope */ - SAVESPTR(PL_curpm); + SAVEVPTR(PL_curpm); src = PL_stack_base[*PL_markstack_ptr]; SvTEMP_off(src); @@ -2403,7 +2405,7 @@ try_autoload: SP--; } PL_stack_sp = mark + 1; - fp3 = (I32(*)(int,int,int)))CvXSUB(cv; + fp3 = (I32(*)(int,int,int))CvXSUB(cv); items = (*fp3)(CvXSUBANY(cv).any_i32, MARK - PL_stack_base + 1, items); @@ -2439,7 +2441,7 @@ try_autoload: } /* We assume first XSUB in &DB::sub is the called one. */ if (PL_curcopdb) { - SAVESPTR(PL_curcop); + SAVEVPTR(PL_curcop); PL_curcop = PL_curcopdb; PL_curcopdb = NULL; } @@ -2481,9 +2483,10 @@ try_autoload: AV *newpad = newAV(); SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]); I32 ix = AvFILLp((AV*)svp[1]); + I32 names_fill = AvFILLp((AV*)svp[0]); svp = AvARRAY(svp[0]); for ( ;ix > 0; ix--) { - if (svp[ix] != &PL_sv_undef) { + if (names_fill >= ix && svp[ix] != &PL_sv_undef) { char *name = SvPVX(svp[ix]); if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */ || *name == '&') /* anonymous code? */ @@ -2500,7 +2503,7 @@ try_autoload: SvPADMY_on(sv); } } - else if (IS_PADGV(oldpad[ix])) { + else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) { av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix])); } else { @@ -2531,7 +2534,7 @@ try_autoload: } } #endif /* USE_THREADS */ - SAVESPTR(PL_curpad); + SAVEVPTR(PL_curpad); PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); #ifndef USE_THREADS if (hasargs) @@ -247,7 +247,7 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) Gid_t egid = getegid(); int res; - MUTEX_LOCK(&PL_cred_mutex); + LOCK_CRED_MUTEX; #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID) Perl_croak(aTHX_ "switching effective uid is not implemented"); #else @@ -293,7 +293,7 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) #endif #endif Perl_croak(aTHX_ "leaving effective gid failed"); - MUTEX_UNLOCK(&PL_cred_mutex); + UNLOCK_CRED_MUTEX; return res; } @@ -411,7 +411,7 @@ PP(pp_indread) PP(pp_rcatline) { - PL_last_in_gv = cGVOP; + PL_last_in_gv = cGVOP_gv; return do_readline(); } @@ -1095,8 +1095,6 @@ PP(pp_getc) gv = PL_stdingv; else gv = (GV*)POPs; - if (!gv) - gv = PL_argvgv; if (mg = SvTIED_mg((SV*)gv, 'q')) { I32 gimme = GIMME_V; @@ -1138,9 +1136,9 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop) SAVETMPS; push_return(retop); - PUSHBLOCK(cx, CXt_SUB, PL_stack_sp); + PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp); PUSHFORMAT(cx); - SAVESPTR(PL_curpad); + SAVEVPTR(PL_curpad); PL_curpad = AvARRAY((AV*)svp[1]); setdefout(gv); /* locally select filehandle so $% et al work */ @@ -1281,7 +1279,7 @@ PP(pp_leavewrite) SvPV_nolen(sv)); else if (ckWARN(WARN_CLOSED)) Perl_warner(aTHX_ WARN_CLOSED, - "Write on closed filehandle %s", SvPV_nolen(sv)); + "write() on closed filehandle %s", SvPV_nolen(sv)); } PUSHs(&PL_sv_no); } @@ -1361,7 +1359,7 @@ PP(pp_prtf) SvPV(sv,n_a)); else if (ckWARN(WARN_CLOSED)) Perl_warner(aTHX_ WARN_CLOSED, - "printf on closed filehandle %s", SvPV(sv,n_a)); + "printf() on closed filehandle %s", SvPV(sv,n_a)); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; @@ -1631,9 +1629,9 @@ PP(pp_send) length = -1; if (ckWARN(WARN_CLOSED)) { if (PL_op->op_type == OP_SYSWRITE) - Perl_warner(aTHX_ WARN_CLOSED, "Syswrite on closed filehandle"); + Perl_warner(aTHX_ WARN_CLOSED, "syswrite() on closed filehandle"); else - Perl_warner(aTHX_ WARN_CLOSED, "Send on closed socket"); + Perl_warner(aTHX_ WARN_CLOSED, "send() on closed socket"); } } else if (PL_op->op_type == OP_SYSWRITE) { @@ -1703,10 +1701,28 @@ PP(pp_eof) GV *gv; MAGIC *mg; - if (MAXARG <= 0) - gv = PL_last_in_gv; + if (MAXARG <= 0) { + if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */ + IO *io; + gv = PL_last_in_gv = PL_argvgv; + io = GvIO(gv); + if (io && !IoIFP(io)) { + if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) { + IoLINES(io) = 0; + IoFLAGS(io) &= ~IOf_START; + do_open(gv, "-", 1, FALSE, O_RDONLY, 0, Nullfp); + sv_setpvn(GvSV(gv), "-", 1); + SvSETMAGIC(GvSV(gv)); + } + else if (!nextargv(gv)) + RETPUSHYES; + } + } + else + gv = PL_last_in_gv; /* eof */ + } else - gv = PL_last_in_gv = (GV*)POPs; + gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */ if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) { PUSHMARK(SP); @@ -2122,7 +2138,7 @@ PP(pp_bind) nuts: if (ckWARN(WARN_CLOSED)) - Perl_warner(aTHX_ WARN_CLOSED, "bind() on closed fd"); + Perl_warner(aTHX_ WARN_CLOSED, "bind() on closed socket"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else @@ -2152,7 +2168,7 @@ PP(pp_connect) nuts: if (ckWARN(WARN_CLOSED)) - Perl_warner(aTHX_ WARN_CLOSED, "connect() on closed fd"); + Perl_warner(aTHX_ WARN_CLOSED, "connect() on closed socket"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else @@ -2178,7 +2194,7 @@ PP(pp_listen) nuts: if (ckWARN(WARN_CLOSED)) - Perl_warner(aTHX_ WARN_CLOSED, "listen() on closed fd"); + Perl_warner(aTHX_ WARN_CLOSED, "listen() on closed socket"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else @@ -2232,7 +2248,7 @@ PP(pp_accept) nuts: if (ckWARN(WARN_CLOSED)) - Perl_warner(aTHX_ WARN_CLOSED, "accept() on closed fd"); + Perl_warner(aTHX_ WARN_CLOSED, "accept() on closed socket"); SETERRNO(EBADF,SS$_IVCHAN); badexit: @@ -2259,7 +2275,7 @@ PP(pp_shutdown) nuts: if (ckWARN(WARN_CLOSED)) - Perl_warner(aTHX_ WARN_CLOSED, "shutdown() on closed fd"); + Perl_warner(aTHX_ WARN_CLOSED, "shutdown() on closed socket"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else @@ -2338,7 +2354,8 @@ PP(pp_ssockopt) nuts: if (ckWARN(WARN_CLOSED)) - Perl_warner(aTHX_ WARN_CLOSED, "[gs]etsockopt() on closed fd"); + Perl_warner(aTHX_ WARN_CLOSED, "%cetsockopt() on closed socket", + optype == OP_GSOCKOPT ? 'g' : 's'); SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; @@ -2411,7 +2428,8 @@ PP(pp_getpeername) nuts: if (ckWARN(WARN_CLOSED)) - Perl_warner(aTHX_ WARN_CLOSED, "get{sock, peer}name() on closed fd"); + Perl_warner(aTHX_ WARN_CLOSED, "get%sname() on closed socket", + optype == OP_GETSOCKNAME ? "sock" : "peer"); SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; @@ -2437,7 +2455,7 @@ PP(pp_stat) STRLEN n_a; if (PL_op->op_flags & OPf_REF) { - tmpgv = cGVOP; + tmpgv = cGVOP_gv; do_fstat: if (tmpgv != PL_defgv) { PL_laststype = OP_STAT; @@ -2899,7 +2917,7 @@ PP(pp_fttty) STRLEN n_a; if (PL_op->op_flags & OPf_REF) - gv = cGVOP; + gv = cGVOP_gv; else if (isGV(TOPs)) gv = (GV*)POPs; else if (SvROK(TOPs) && isGV(SvRV(TOPs))) @@ -2941,7 +2959,7 @@ PP(pp_fttext) PerlIO *fp; if (PL_op->op_flags & OPf_REF) - gv = cGVOP; + gv = cGVOP_gv; else if (isGV(TOPs)) gv = (GV*)POPs; else if (SvROK(TOPs) && isGV(SvRV(TOPs))) @@ -2990,9 +3008,11 @@ PP(pp_fttext) len = 512; } else { - if (ckWARN(WARN_UNOPENED)) + if (ckWARN(WARN_UNOPENED)) { + gv = cGVOP_gv; Perl_warner(aTHX_ WARN_UNOPENED, "Test on unopened file <%s>", - GvENAME(cGVOP)); + GvENAME(gv)); + } SETERRNO(EBADF,RMS$_IFI); RETPUSHUNDEF; } @@ -3576,24 +3596,20 @@ PP(pp_fork) if (!childpid) { /*SUPPRESS 560*/ if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV)) - sv_setiv(GvSV(tmpgv), (IV)getpid()); + sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid()); hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */ } PUSHi(childpid); RETURN; #else -# ifdef USE_ITHREADS - /* XXXXXX testing */ +# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) djSP; dTARGET; - /* XXX this just an approximation of what will eventually be run - * in a different thread */ - PerlInterpreter *new_perl = perl_clone(my_perl, 0); - Perl_pp_enter(new_perl); - new_perl->Top = new_perl->Top->op_next; /* continue from next op */ - CALLRUNOPS(new_perl); - - /* parent returns with negative pseudo-pid */ - PUSHi(-1); + Pid_t childpid; + + EXTEND(SP, 1); + PERL_FLUSHALL_FOR_CHILD; + childpid = PerlProc_fork(); + PUSHi(childpid); RETURN; # else DIE(aTHX_ PL_no_func, "Unsupported function fork"); @@ -3783,6 +3799,12 @@ PP(pp_exec) # endif #endif } + +#if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) + if (value >= 0) + my_exit(value); +#endif + SP = ORIGMARK; PUSHi(value); RETURN; @@ -3827,7 +3849,7 @@ PP(pp_getpgrp) #ifdef BSD_GETPGRP pgrp = (I32)BSD_GETPGRP(pid); #else - if (pid != 0 && pid != getpid()) + if (pid != 0 && pid != PerlProc_getpid()) DIE(aTHX_ "POSIX getpgrp can't take an argument"); pgrp = getpgrp(); #endif @@ -3857,8 +3879,11 @@ PP(pp_setpgrp) #ifdef BSD_SETPGRP SETi( BSD_SETPGRP(pid, pgrp) >= 0 ); #else - if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid())) + if ((pgrp != 0 && pgrp != PerlProc_getpid()) + || (pid != 0 && pid != PerlProc_getpid())) + { DIE(aTHX_ "setpgrp can't take arguments"); + } SETi( setpgrp() >= 0 ); #endif /* USE_BSDPGRP */ RETURN; @@ -4,20 +4,70 @@ * and run 'make regen_headers' to effect changes. */ + + +START_EXTERN_C + +#if defined(PERL_IMPLICIT_SYS) +PERL_CALLCONV PerlInterpreter* perl_alloc_using(struct IPerlMem* m, struct IPerlMem* ms, struct IPerlMem* mp, struct IPerlEnv* e, struct IPerlStdIO* io, struct IPerlLIO* lio, struct IPerlDir* d, struct IPerlSock* s, struct IPerlProc* p); +#else +PERL_CALLCONV PerlInterpreter* perl_alloc(void); +#endif +PERL_CALLCONV void perl_construct(PerlInterpreter* interp); +PERL_CALLCONV void perl_destruct(PerlInterpreter* interp); +PERL_CALLCONV void perl_free(PerlInterpreter* interp); +PERL_CALLCONV int perl_run(PerlInterpreter* interp); +PERL_CALLCONV int perl_parse(PerlInterpreter* interp, XSINIT_t xsinit, int argc, char** argv, char** env); +#if defined(USE_ITHREADS) +PERL_CALLCONV PerlInterpreter* perl_clone(PerlInterpreter* interp, UV flags); +# if defined(PERL_IMPLICIT_SYS) +PERL_CALLCONV PerlInterpreter* perl_clone_using(PerlInterpreter *interp, UV flags, struct IPerlMem* m, struct IPerlMem* ms, struct IPerlMem* mp, struct IPerlEnv* e, struct IPerlStdIO* io, struct IPerlLIO* lio, struct IPerlDir* d, struct IPerlSock* s, struct IPerlProc* p); +# endif +#endif + +#if defined(MYMALLOC) +PERL_CALLCONV Malloc_t Perl_malloc(MEM_SIZE nbytes); +PERL_CALLCONV Malloc_t Perl_calloc(MEM_SIZE elements, MEM_SIZE size); +PERL_CALLCONV Malloc_t Perl_realloc(Malloc_t where, MEM_SIZE nbytes); +PERL_CALLCONV Free_t Perl_mfree(Malloc_t where); +PERL_CALLCONV MEM_SIZE Perl_malloced_size(void *p); +#endif + +END_EXTERN_C + +/* functions with flag 'n' should come before here */ +#if defined(PERL_OBJECT) +class CPerlObj { +public: + struct interpreter interp; + CPerlObj(IPerlMem*, IPerlMem*, IPerlMem*, IPerlEnv*, IPerlStdIO*, + IPerlLIO*, IPerlDir*, IPerlSock*, IPerlProc*); + void* operator new(size_t nSize, IPerlMem *pvtbl); +#ifndef __BORLANDC__ + static void operator delete(void* pPerl, IPerlMem *pvtbl); +#endif + int do_aspawn (void *vreally, void **vmark, void **vsp); +#endif #if defined(PERL_OBJECT) public: +#else +START_EXTERN_C #endif +# include "pp_proto.h" PERL_CALLCONV SV* Perl_amagic_call(pTHX_ SV* left, SV* right, int method, int dir); PERL_CALLCONV bool Perl_Gv_AMupdate(pTHX_ HV* stash); PERL_CALLCONV OP* Perl_append_elem(pTHX_ I32 optype, OP* head, OP* tail); PERL_CALLCONV OP* Perl_append_list(pTHX_ I32 optype, LISTOP* first, LISTOP* last); PERL_CALLCONV I32 Perl_apply(pTHX_ I32 type, SV** mark, SV** sp); +PERL_CALLCONV SV* Perl_avhv_delete_ent(pTHX_ AV *ar, SV* keysv, I32 flags, U32 hash); PERL_CALLCONV bool Perl_avhv_exists_ent(pTHX_ AV *ar, SV* keysv, U32 hash); PERL_CALLCONV SV** Perl_avhv_fetch_ent(pTHX_ AV *ar, SV* keysv, I32 lval, U32 hash); PERL_CALLCONV HE* Perl_avhv_iternext(pTHX_ AV *ar); PERL_CALLCONV SV* Perl_avhv_iterval(pTHX_ AV *ar, HE* entry); PERL_CALLCONV HV* Perl_avhv_keys(pTHX_ AV *ar); PERL_CALLCONV void Perl_av_clear(pTHX_ AV* ar); +PERL_CALLCONV SV* Perl_av_delete(pTHX_ AV* ar, I32 key, I32 flags); +PERL_CALLCONV bool Perl_av_exists(pTHX_ AV* ar, I32 key); PERL_CALLCONV void Perl_av_extend(pTHX_ AV* ar, I32 key); PERL_CALLCONV AV* Perl_av_fake(pTHX_ I32 size, SV** svp); PERL_CALLCONV SV** Perl_av_fetch(pTHX_ AV* ar, I32 key, I32 lval); @@ -315,9 +365,6 @@ PERL_CALLCONV int Perl_magic_set_all_env(pTHX_ SV* sv, MAGIC* mg); PERL_CALLCONV U32 Perl_magic_sizepack(pTHX_ SV* sv, MAGIC* mg); PERL_CALLCONV int Perl_magic_wipepack(pTHX_ SV* sv, MAGIC* mg); PERL_CALLCONV void Perl_magicname(pTHX_ char* sym, char* name, I32 namlen); -#if defined(MYMALLOC) -PERL_CALLCONV MEM_SIZE Perl_malloced_size(void *p); -#endif PERL_CALLCONV void Perl_markstack_grow(pTHX); #if defined(USE_LOCALE_COLLATE) PERL_CALLCONV char* Perl_mem_collxfrm(pTHX_ const char* s, STRLEN len, STRLEN* xlen); @@ -339,20 +386,20 @@ PERL_CALLCONV char* Perl_moreswitches(pTHX_ char* s); PERL_CALLCONV OP* Perl_my(pTHX_ OP* o); PERL_CALLCONV NV Perl_my_atof(pTHX_ const char *s); #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY) -PERL_CALLCONV char* Perl_my_bcopy(pTHX_ const char* from, char* to, I32 len); +PERL_CALLCONV char* Perl_my_bcopy(const char* from, char* to, I32 len); #endif #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) -PERL_CALLCONV char* Perl_my_bzero(pTHX_ char* loc, I32 len); +PERL_CALLCONV char* Perl_my_bzero(char* loc, I32 len); #endif PERL_CALLCONV void Perl_my_exit(pTHX_ U32 status) __attribute__((noreturn)); PERL_CALLCONV void Perl_my_failure_exit(pTHX) __attribute__((noreturn)); PERL_CALLCONV I32 Perl_my_fflush_all(pTHX); PERL_CALLCONV I32 Perl_my_lstat(pTHX); #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) -PERL_CALLCONV I32 Perl_my_memcmp(pTHX_ const char* s1, const char* s2, I32 len); +PERL_CALLCONV I32 Perl_my_memcmp(const char* s1, const char* s2, I32 len); #endif #if !defined(HAS_MEMSET) -PERL_CALLCONV void* Perl_my_memset(pTHX_ char* loc, I32 ch, I32 len); +PERL_CALLCONV void* Perl_my_memset(char* loc, I32 ch, I32 len); #endif #if !defined(PERL_OBJECT) PERL_CALLCONV I32 Perl_my_pclose(pTHX_ PerlIO* ptr); @@ -415,6 +462,7 @@ PERL_CALLCONV SV* Perl_newSVrv(pTHX_ SV* rv, const char* classname); PERL_CALLCONV SV* Perl_newSVsv(pTHX_ SV* old); PERL_CALLCONV OP* Perl_newUNOP(pTHX_ I32 type, I32 flags, OP* first); PERL_CALLCONV OP* Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP* loop, I32 whileline, OP* expr, OP* block, OP* cont); + PERL_CALLCONV PERL_SI* Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems); PERL_CALLCONV PerlIO* Perl_nextargv(pTHX_ GV* gv); PERL_CALLCONV char* Perl_ninstr(pTHX_ const char* big, const char* bigend, const char* little, const char* lend); @@ -433,22 +481,15 @@ PERL_CALLCONV void Perl_pad_reset(pTHX); PERL_CALLCONV void Perl_pad_swipe(pTHX_ PADOFFSET po); PERL_CALLCONV void Perl_peep(pTHX_ OP* o); #if defined(PERL_OBJECT) -PERL_CALLCONV void perl_construct(void); -PERL_CALLCONV void perl_destruct(void); -PERL_CALLCONV void perl_free(void); -PERL_CALLCONV int perl_run(void); -PERL_CALLCONV int perl_parse(XSINIT_t xsinit, int argc, char** argv, char** env); -#else -PERL_CALLCONV PerlInterpreter* perl_alloc(void); -PERL_CALLCONV void perl_construct(PerlInterpreter* interp); -PERL_CALLCONV void perl_destruct(PerlInterpreter* interp); -PERL_CALLCONV void perl_free(PerlInterpreter* interp); -PERL_CALLCONV int perl_run(PerlInterpreter* interp); -PERL_CALLCONV int perl_parse(PerlInterpreter* interp, XSINIT_t xsinit, int argc, char** argv, char** env); +PERL_CALLCONV void Perl_construct(pTHX); +PERL_CALLCONV void Perl_destruct(pTHX); +PERL_CALLCONV void Perl_free(pTHX); +PERL_CALLCONV int Perl_run(pTHX); +PERL_CALLCONV int Perl_parse(pTHX_ XSINIT_t xsinit, int argc, char** argv, char** env); +#endif #if defined(USE_THREADS) PERL_CALLCONV struct perl_thread* Perl_new_struct_thread(pTHX_ struct perl_thread *t); #endif -#endif PERL_CALLCONV void Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr); PERL_CALLCONV I32 Perl_call_argv(pTHX_ const char* sub_name, I32 flags, char** argv); PERL_CALLCONV I32 Perl_call_method(pTHX_ const char* methname, I32 flags); @@ -523,6 +564,7 @@ PERL_CALLCONV void Perl_save_hints(pTHX); PERL_CALLCONV void Perl_save_hptr(pTHX_ HV** hptr); PERL_CALLCONV void Perl_save_I16(pTHX_ I16* intp); PERL_CALLCONV void Perl_save_I32(pTHX_ I32* intp); +PERL_CALLCONV void Perl_save_I8(pTHX_ I8* bytep); PERL_CALLCONV void Perl_save_int(pTHX_ int* intp); PERL_CALLCONV void Perl_save_item(pTHX_ SV* item); PERL_CALLCONV void Perl_save_iv(pTHX_ IV* iv); @@ -532,6 +574,7 @@ PERL_CALLCONV void Perl_save_nogv(pTHX_ GV* gv); PERL_CALLCONV void Perl_save_op(pTHX); PERL_CALLCONV SV* Perl_save_scalar(pTHX_ GV* gv); PERL_CALLCONV void Perl_save_pptr(pTHX_ char** pptr); +PERL_CALLCONV void Perl_save_vptr(pTHX_ void* pptr); PERL_CALLCONV void Perl_save_re_context(pTHX); PERL_CALLCONV void Perl_save_sptr(pTHX_ SV** sptr); PERL_CALLCONV SV* Perl_save_svref(pTHX_ SV** sptr); @@ -564,11 +607,15 @@ PERL_CALLCONV IV Perl_sv_2iv(pTHX_ SV* sv); PERL_CALLCONV SV* Perl_sv_2mortal(pTHX_ SV* sv); PERL_CALLCONV NV Perl_sv_2nv(pTHX_ SV* sv); PERL_CALLCONV char* Perl_sv_2pv(pTHX_ SV* sv, STRLEN* lp); +PERL_CALLCONV char* Perl_sv_2pvutf8(pTHX_ SV* sv, STRLEN* lp); +PERL_CALLCONV char* Perl_sv_2pvbyte(pTHX_ SV* sv, STRLEN* lp); PERL_CALLCONV UV Perl_sv_2uv(pTHX_ SV* sv); PERL_CALLCONV IV Perl_sv_iv(pTHX_ SV* sv); PERL_CALLCONV UV Perl_sv_uv(pTHX_ SV* sv); PERL_CALLCONV NV Perl_sv_nv(pTHX_ SV* sv); PERL_CALLCONV char* Perl_sv_pvn(pTHX_ SV *sv, STRLEN *len); +PERL_CALLCONV char* Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *len); +PERL_CALLCONV char* Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *len); PERL_CALLCONV I32 Perl_sv_true(pTHX_ SV *sv); PERL_CALLCONV void Perl_sv_add_arena(pTHX_ char* ptr, U32 size, U32 flags); PERL_CALLCONV int Perl_sv_backoff(pTHX_ SV* sv); @@ -610,6 +657,8 @@ PERL_CALLCONV char* Perl_sv_peek(pTHX_ SV* sv); PERL_CALLCONV void Perl_sv_pos_u2b(pTHX_ SV* sv, I32* offsetp, I32* lenp); PERL_CALLCONV void Perl_sv_pos_b2u(pTHX_ SV* sv, I32* offsetp); PERL_CALLCONV char* Perl_sv_pvn_force(pTHX_ SV* sv, STRLEN* lp); +PERL_CALLCONV char* Perl_sv_pvutf8n_force(pTHX_ SV* sv, STRLEN* lp); +PERL_CALLCONV char* Perl_sv_pvbyten_force(pTHX_ SV* sv, STRLEN* lp); PERL_CALLCONV char* Perl_sv_reftype(pTHX_ SV* sv, int ob); PERL_CALLCONV void Perl_sv_replace(pTHX_ SV* sv, SV* nsv); PERL_CALLCONV void Perl_sv_report_used(pTHX); @@ -661,6 +710,7 @@ PERL_CALLCONV U8* Perl_uv_to_utf8(pTHX_ U8 *d, UV uv); PERL_CALLCONV void Perl_vivify_defelem(pTHX_ SV* sv); PERL_CALLCONV void Perl_vivify_ref(pTHX_ SV* sv, U32 to_what); PERL_CALLCONV I32 Perl_wait4pid(pTHX_ Pid_t pid, int* statusp, int flags); +PERL_CALLCONV void Perl_report_uninit(pTHX); PERL_CALLCONV void Perl_warn(pTHX_ const char* pat, ...); PERL_CALLCONV void Perl_vwarn(pTHX_ const char* pat, va_list* args); PERL_CALLCONV void Perl_warner(pTHX_ U32 err, const char* pat, ...); @@ -677,10 +727,6 @@ PERL_CALLCONV int Perl_yyparse(pTHX); PERL_CALLCONV int Perl_yywarn(pTHX_ char* s); #if defined(MYMALLOC) PERL_CALLCONV void Perl_dump_mstats(pTHX_ char* s); -PERL_CALLCONV Malloc_t Perl_malloc(MEM_SIZE nbytes); -PERL_CALLCONV Malloc_t Perl_calloc(MEM_SIZE elements, MEM_SIZE size); -PERL_CALLCONV Malloc_t Perl_realloc(Malloc_t where, MEM_SIZE nbytes); -PERL_CALLCONV Free_t Perl_mfree(Malloc_t where); #endif PERL_CALLCONV Malloc_t Perl_safesysmalloc(MEM_SIZE nbytes); PERL_CALLCONV Malloc_t Perl_safesyscalloc(MEM_SIZE elements, MEM_SIZE size); @@ -728,7 +774,11 @@ PERL_CALLCONV void* Perl_default_protect(pTHX_ volatile JMPENV *je, int *excpt, PERL_CALLCONV void* Perl_vdefault_protect(pTHX_ volatile JMPENV *je, int *excpt, protect_body_t body, va_list *args); PERL_CALLCONV void Perl_reginitcolors(pTHX); PERL_CALLCONV char* Perl_sv_2pv_nolen(pTHX_ SV* sv); +PERL_CALLCONV char* Perl_sv_2pvutf8_nolen(pTHX_ SV* sv); +PERL_CALLCONV char* Perl_sv_2pvbyte_nolen(pTHX_ SV* sv); PERL_CALLCONV char* Perl_sv_pv(pTHX_ SV *sv); +PERL_CALLCONV char* Perl_sv_pvutf8(pTHX_ SV *sv); +PERL_CALLCONV char* Perl_sv_pvbyte(pTHX_ SV *sv); PERL_CALLCONV void Perl_sv_force_normal(pTHX_ SV *sv); PERL_CALLCONV void Perl_tmps_grow(pTHX_ I32 n); PERL_CALLCONV SV* Perl_sv_rvweaken(pTHX_ SV *sv); @@ -741,7 +791,8 @@ PERL_CALLCONV void Perl_boot_core_xsutils(pTHX); #if defined(USE_ITHREADS) PERL_CALLCONV PERL_CONTEXT* Perl_cx_dup(pTHX_ PERL_CONTEXT* cx, I32 ix, I32 max); PERL_CALLCONV PERL_SI* Perl_si_dup(pTHX_ PERL_SI* si); -PERL_CALLCONV ANY* Perl_ss_dup(pTHX_ ANY* ss, I32 ix, I32 max); +PERL_CALLCONV ANY* Perl_ss_dup(pTHX_ PerlInterpreter* proto_perl); +PERL_CALLCONV void* Perl_any_dup(pTHX_ void* v, PerlInterpreter* proto_perl); PERL_CALLCONV HE* Perl_he_dup(pTHX_ HE* e, bool shared); PERL_CALLCONV REGEXP* Perl_re_dup(pTHX_ REGEXP* r); PERL_CALLCONV PerlIO* Perl_fp_dup(pTHX_ PerlIO* fp, char type); @@ -756,15 +807,18 @@ PERL_CALLCONV PTR_TBL_t* Perl_ptr_table_new(pTHX); PERL_CALLCONV void* Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv); PERL_CALLCONV void Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldsv, void *newsv); PERL_CALLCONV void Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl); -PERL_CALLCONV PerlInterpreter* perl_clone(PerlInterpreter* interp, UV flags); -PERL_CALLCONV PerlInterpreter* perl_clone_using(PerlInterpreter *interp, UV flags, struct IPerlMem* m, struct IPerlEnv* e, struct IPerlStdIO* io, struct IPerlLIO* lio, struct IPerlDir* d, struct IPerlSock* s, struct IPerlProc* p); #endif + #if defined(PERL_OBJECT) protected: +#else +END_EXTERN_C #endif + #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) STATIC I32 S_avhv_index_sv(pTHX_ SV* sv); #endif + #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT) STATIC I32 S_do_trans_CC_simple(pTHX_ SV *sv); STATIC I32 S_do_trans_CC_count(pTHX_ SV *sv); @@ -777,9 +831,11 @@ STATIC I32 S_do_trans_CU_simple(pTHX_ SV *sv); STATIC I32 S_do_trans_UC_trivial(pTHX_ SV *sv); STATIC I32 S_do_trans_CU_trivial(pTHX_ SV *sv); #endif + #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT) STATIC void S_gv_init_sv(pTHX_ GV *gv, I32 sv_type); #endif + #if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT) STATIC void S_hsplit(pTHX_ HV *hv); STATIC void S_hfreeentries(pTHX_ HV *hv); @@ -789,11 +845,13 @@ STATIC void S_del_he(pTHX_ HE *p); STATIC HEK* S_save_hek(pTHX_ const char *str, I32 len, U32 hash); STATIC void S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store); #endif + #if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT) STATIC void S_save_magic(pTHX_ I32 mgs_ix, SV *sv); STATIC int S_magic_methpack(pTHX_ SV *sv, MAGIC *mg, char *meth); STATIC int S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 f, int n, SV *val); #endif + #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) STATIC I32 S_list_assignment(pTHX_ OP *o); STATIC void S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid); @@ -822,6 +880,7 @@ STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs); STATIC void* S_Slab_Alloc(pTHX_ int m, size_t sz); # endif #endif + #if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT) STATIC void S_find_beginning(pTHX); STATIC void S_forbid_setid(pTHX_ char *); @@ -850,6 +909,7 @@ STATIC void* S_call_list_body(pTHX_ va_list args); STATIC struct perl_thread * S_init_main_thread(pTHX); # endif #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); @@ -858,6 +918,7 @@ 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); #endif + #if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT) STATIC OP* S_docatch(pTHX_ OP *o); STATIC void* S_docatch_body(pTHX_ va_list args); @@ -874,10 +935,12 @@ STATIC OP* S_doeval(pTHX_ int gimme, OP** startop); STATIC PerlIO * S_doopen_pmc(pTHX_ const char *name, const char *mode); STATIC void S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t f); #endif + #if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT) STATIC CV* S_get_db_sub(pTHX_ SV **svp, CV *cv); STATIC SV* S_method_common(pTHX_ SV* meth, U32* hashp); #endif + #if defined(PERL_IN_PP_SYS_C) || defined(PERL_DECL_PROT) STATIC OP* S_doform(pTHX_ CV *cv, GV *gv, OP *retop); STATIC int S_emulate_eaccess(pTHX_ const char* path, Mode_t mode); @@ -885,6 +948,7 @@ STATIC int S_emulate_eaccess(pTHX_ const char* path, Mode_t mode); STATIC int S_dooneliner(pTHX_ char *cmd, char *filename); # endif #endif + #if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT) STATIC regnode* S_reg(pTHX_ I32, I32 *); STATIC regnode* S_reganode(pTHX_ U8, U32); @@ -902,13 +966,21 @@ STATIC void S_regtail(pTHX_ regnode *, regnode *); STATIC char* S_regwhite(pTHX_ char *, char *); STATIC char* S_nextchar(pTHX); STATIC regnode* S_dumpuntil(pTHX_ regnode *start, regnode *node, regnode *last, SV* sv, I32 l); +STATIC void S_put_byte(pTHX_ SV* sv, int c); STATIC void S_scan_commit(pTHX_ struct scan_data_t *data); +STATIC void S_cl_anything(pTHX_ struct regnode_charclass_class *cl); +STATIC int S_cl_is_anything(pTHX_ struct regnode_charclass_class *cl); +STATIC void S_cl_init(pTHX_ struct regnode_charclass_class *cl); +STATIC void S_cl_init_zero(pTHX_ struct regnode_charclass_class *cl); +STATIC void S_cl_and(pTHX_ struct regnode_charclass_class *cl, struct regnode_charclass_class *and_with); +STATIC void S_cl_or(pTHX_ struct regnode_charclass_class *cl, struct regnode_charclass_class *or_with); STATIC I32 S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, struct scan_data_t *data, U32 flags); STATIC I32 S_add_data(pTHX_ I32 n, char *s); STATIC void S_re_croak2(pTHX_ const char* pat1, const char* pat2, ...) __attribute__((noreturn)); STATIC I32 S_regpposixcc(pTHX_ I32 value); STATIC void S_checkposixcc(pTHX); #endif + #if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT) STATIC I32 S_regmatch(pTHX_ regnode *prog); STATIC I32 S_regrepeat(pTHX_ regnode *p, I32 max); @@ -924,12 +996,15 @@ STATIC U8* S_reghop(pTHX_ U8 *pos, I32 off); STATIC U8* S_reghopmaybe(pTHX_ U8 *pos, I32 off); STATIC char* S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *startpos, I32 norun); #endif + #if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT) STATIC void S_debprof(pTHX_ OP *o); #endif + #if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT) STATIC SV* S_save_scalar_at(pTHX_ SV **sptr); #endif + #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) STATIC IV S_asIV(pTHX_ SV* sv); STATIC UV S_asUV(pTHX_ SV* sv); @@ -985,6 +1060,7 @@ STATIC void S_sv_del_backref(pTHX_ SV *sv); STATIC void S_del_sv(pTHX_ SV *p); # endif #endif + #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) STATIC void S_check_uni(pTHX); STATIC void S_force_next(pTHX_ I32 type); @@ -1007,7 +1083,7 @@ STATIC void S_force_ident(pTHX_ char *s, int kind); STATIC void S_incline(pTHX_ char *s); STATIC int S_intuit_method(pTHX_ char *s, GV *gv); STATIC int S_intuit_more(pTHX_ char *s); -STATIC I32 S_lop(pTHX_ I32 f, expectation x, char *s); +STATIC I32 S_lop(pTHX_ I32 f, int x, char *s); STATIC void S_missingterm(pTHX_ char *s); STATIC void S_no_op(pTHX_ char *what, char *s); STATIC void S_set_csh(pTHX); @@ -1024,16 +1100,22 @@ STATIC I32 S_utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen); # if defined(CRIPPLED_CC) STATIC int S_uni(pTHX_ I32 f, char *s); # endif -# if defined(WIN32) -STATIC I32 S_win32_textfilter(pTHX_ int idx, SV *sv, int maxlen); +# if defined(PERL_CR_FILTER) +STATIC I32 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen); # endif #endif + #if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT) STATIC SV* S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level); #endif + #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) STATIC SV* S_mess_alloc(pTHX); # if defined(LEAKTEST) STATIC void S_xstat(pTHX_ int); # endif #endif + +#if defined(PERL_OBJECT) +}; +#endif @@ -151,6 +151,7 @@ typedef struct scan_data_t { I32 offset_float_max; I32 flags; I32 whilem_c; + struct regnode_charclass_class *start_class; } scan_data_t; /* @@ -158,7 +159,7 @@ typedef struct scan_data_t { */ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0 }; + 0, 0, 0, 0, 0 }; #define SF_BEFORE_EOL (SF_BEFORE_SEOL|SF_BEFORE_MEOL) #define SF_BEFORE_SEOL 0x1 @@ -184,6 +185,9 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, #define SF_IN_PAR 0x100 #define SF_HAS_EVAL 0x200 #define SCF_DO_SUBSTR 0x400 +#define SCF_DO_STCLASS_AND 0x0800 +#define SCF_DO_STCLASS_OR 0x1000 +#define SCF_DO_STCLASS (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR) #define RF_utf8 8 #define UTF (PL_reg_flags & RF_utf8) @@ -202,6 +206,10 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, static void clear_re(pTHXo_ void *r); +/* Mark that we cannot extend a found fixed substring at this point. + Updata the longest found anchored substring and the longest found + floating substrings if needed. */ + STATIC void S_scan_commit(pTHX_ scan_data_t *data) { @@ -236,6 +244,135 @@ S_scan_commit(pTHX_ scan_data_t *data) data->flags &= ~SF_BEFORE_EOL; } +/* Can match anything (initialization) */ +STATIC void +S_cl_anything(pTHX_ struct regnode_charclass_class *cl) +{ + int value; + + ANYOF_CLASS_ZERO(cl); + for (value = 0; value < 256; ++value) + ANYOF_BITMAP_SET(cl, value); + cl->flags = ANYOF_EOS; + if (LOC) + cl->flags |= ANYOF_LOCALE; +} + +/* Can match anything (initialization) */ +STATIC int +S_cl_is_anything(pTHX_ struct regnode_charclass_class *cl) +{ + int value; + + for (value = 0; value < ANYOF_MAX; value += 2) + if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1)) + return 1; + for (value = 0; value < 256; ++value) + if (!ANYOF_BITMAP_TEST(cl, value)) + return 0; + return 1; +} + +/* Can match anything (initialization) */ +STATIC void +S_cl_init(pTHX_ struct regnode_charclass_class *cl) +{ + cl->type = ANYOF; + cl_anything(cl); +} + +STATIC void +S_cl_init_zero(pTHX_ struct regnode_charclass_class *cl) +{ + cl->type = ANYOF; + cl_anything(cl); + ANYOF_CLASS_ZERO(cl); + ANYOF_BITMAP_ZERO(cl); + if (LOC) + cl->flags |= ANYOF_LOCALE; +} + +/* 'And' a given class with another one. Can create false positives */ +/* We assume that cl is not inverted */ +STATIC void +S_cl_and(pTHX_ struct regnode_charclass_class *cl, + struct regnode_charclass_class *and_with) +{ + int value; + + if (!(and_with->flags & ANYOF_CLASS) + && !(cl->flags & ANYOF_CLASS) + && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE) + && !(and_with->flags & ANYOF_FOLD) + && !(cl->flags & ANYOF_FOLD)) { + int i; + + if (and_with->flags & ANYOF_INVERT) + for (i = 0; i < ANYOF_BITMAP_SIZE; i++) + cl->bitmap[i] &= ~and_with->bitmap[i]; + else + for (i = 0; i < ANYOF_BITMAP_SIZE; i++) + cl->bitmap[i] &= and_with->bitmap[i]; + } /* XXXX: logic is complicated otherwise, leave it along for a moment. */ + if (!(and_with->flags & ANYOF_EOS)) + cl->flags &= ~ANYOF_EOS; +} + +/* 'OR' a given class with another one. Can create false positives */ +/* We assume that cl is not inverted */ +STATIC void +S_cl_or(pTHX_ struct regnode_charclass_class *cl, struct regnode_charclass_class *or_with) +{ + int value; + + if (or_with->flags & ANYOF_INVERT) { + /* We do not use + * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2)) + * <= (B1 | !B2) | (CL1 | !CL2) + * which is wasteful if CL2 is small, but we ignore CL2: + * (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1 + * XXXX Can we handle case-fold? Unclear: + * (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) = + * (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i')) + */ + if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE) + && !(or_with->flags & ANYOF_FOLD) + && !(cl->flags & ANYOF_FOLD) ) { + int i; + + for (i = 0; i < ANYOF_BITMAP_SIZE; i++) + cl->bitmap[i] |= ~or_with->bitmap[i]; + } /* XXXX: logic is complicated otherwise */ + else { + cl_anything(cl); + } + } else { + /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */ + if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE) + && (!(or_with->flags & ANYOF_FOLD) + || (cl->flags & ANYOF_FOLD)) ) { + int i; + + /* OR char bitmap and class bitmap separately */ + for (i = 0; i < ANYOF_BITMAP_SIZE; i++) + cl->bitmap[i] |= or_with->bitmap[i]; + if (or_with->flags & ANYOF_CLASS) { + for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++) + cl->classflags[i] |= or_with->classflags[i]; + cl->flags |= ANYOF_CLASS; + } + } + else { /* XXXX: logic is complicated, leave it along for a moment. */ + cl_anything(cl); + } + } + if (or_with->flags & ANYOF_EOS) + cl->flags |= ANYOF_EOS; +} + +/* REx optimizer. Converts nodes into quickier variants "in place". + Finds fixed substrings. */ + /* Stops at toplevel WHILEM as well as at `last'. At end *scanp is set to the position after last scanned or to NULL. */ @@ -253,11 +390,13 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da int is_inf_internal = 0; /* The studied chunk is infinite */ I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0; scan_data_t data_fake; + struct regnode_charclass_class and_with; /* Valid if flags & SCF_DO_STCLASS_OR */ while (scan && OP(scan) != END && scan < last) { /* Peephole optimizer: */ if (PL_regkind[(U8)OP(scan)] == EXACT) { + /* Merge several consecutive EXACTish nodes into one. */ regnode *n = regnext(scan); U32 stringok = 1; #ifdef DEBUGGING @@ -305,19 +444,16 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da /* Allow dumping */ n = scan + NODE_SZ_STR(scan); while (n <= stop) { - /* Purify reports a benign UMR here sometimes, because we - * don't initialize the OP() slot of a node when that node - * is occupied by just the trailing null of the string in - * an EXACT node */ if (PL_regkind[(U8)OP(n)] != NOTHING || OP(n) == NOTHING) { OP(n) = OPTIMIZED; NEXT_OFF(n) = 0; } n++; } -#endif - +#endif } + /* Follow the next-chain of the current node and optimize + away all the NOTHINGs from it. */ if (OP(scan) != CURLYX) { int max = (reg_off_by_arg[OP(scan)] ? I32_MAX @@ -338,6 +474,8 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da else NEXT_OFF(scan) = off; } + /* The principal pseudo-switch. Cannot be a switch, since we + look into several different things. */ if (OP(scan) == BRANCH || OP(scan) == BRANCHJ || OP(scan) == IFTHEN || OP(scan) == SUSPEND) { next = regnext(scan); @@ -345,11 +483,15 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da if (OP(next) == code || code == IFTHEN || code == SUSPEND) { I32 max1 = 0, min1 = I32_MAX, num = 0; + struct regnode_charclass_class accum; - if (flags & SCF_DO_SUBSTR) - scan_commit(data); + if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */ + scan_commit(data); /* Cannot merge strings after this. */ + if (flags & SCF_DO_STCLASS) + cl_init_zero(&accum); while (OP(scan) == code) { - I32 deltanext, minnext; + I32 deltanext, minnext, f = 0; + struct regnode_charclass_class this_class; num++; data_fake.flags = 0; @@ -359,9 +501,14 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da scan = NEXTOPER(scan); if (code != BRANCH) scan = NEXTOPER(scan); - /* We suppose the run is continuous, last=next...*/ + if (flags & SCF_DO_STCLASS) { + cl_init(&this_class); + data_fake.start_class = &this_class; + f = SCF_DO_STCLASS_AND; + } + /* we suppose the run is continuous, last=next...*/ minnext = study_chunk(&scan, &deltanext, next, - &data_fake, 0); + &data_fake, f); if (min1 > minnext) min1 = minnext; if (max1 < minnext + deltanext) @@ -375,6 +522,8 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da data->flags |= SF_HAS_EVAL; if (data) data->whilem_c = data_fake.whilem_c; + if (flags & SCF_DO_STCLASS) + cl_or(&accum, &this_class); if (code == SUSPEND) break; } @@ -388,6 +537,30 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da } min += min1; delta += max1 - min1; + if (flags & SCF_DO_STCLASS_OR) { + cl_or(data->start_class, &accum); + if (min1) { + cl_and(data->start_class, &and_with); + flags &= ~SCF_DO_STCLASS; + } + } + else if (flags & SCF_DO_STCLASS_AND) { + if (min1) { + cl_and(data->start_class, &accum); + flags &= ~SCF_DO_STCLASS; + } + else { + /* Switch to OR mode: cache the old value of + * data->start_class */ + StructCopy(data->start_class, &and_with, + struct regnode_charclass_class); + flags &= ~SCF_DO_STCLASS_AND; + StructCopy(&accum, data->start_class, + struct regnode_charclass_class); + flags |= SCF_DO_STCLASS_OR; + data->start_class->flags |= ANYOF_EOS; + } + } } else if (code == BRANCHJ) /* single branch is optimized. */ scan = NEXTOPER(NEXTOPER(scan)); @@ -421,9 +594,34 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da data->pos_min += l; /* As in the first entry. */ data->flags &= ~SF_BEFORE_EOL; } + if (flags & SCF_DO_STCLASS_AND) { + /* Check whether it is compatible with what we know already! */ + int compat = 1; + + if (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE)) + && !ANYOF_BITMAP_TEST(data->start_class, *STRING(scan)) + && (!(data->start_class->flags & ANYOF_FOLD) + || !ANYOF_BITMAP_TEST(data->start_class, + PL_fold[*STRING(scan)]))) + compat = 0; + ANYOF_CLASS_ZERO(data->start_class); + ANYOF_BITMAP_ZERO(data->start_class); + if (compat) + ANYOF_BITMAP_SET(data->start_class, *STRING(scan)); + data->start_class->flags &= ~ANYOF_EOS; + } + else if (flags & SCF_DO_STCLASS_OR) { + /* false positive possible if the class is case-folded */ + ANYOF_BITMAP_SET(data->start_class, *STRING(scan)); + data->start_class->flags &= ~ANYOF_EOS; + cl_and(data->start_class, &and_with); + } + flags &= ~SCF_DO_STCLASS; } - else if (PL_regkind[(U8)OP(scan)] == EXACT) { + else if (PL_regkind[(U8)OP(scan)] == EXACT) { /* But OP != EXACT! */ I32 l = STR_LEN(scan); + + /* Search for fixed substrings supports EXACT only. */ if (flags & SCF_DO_SUBSTR) scan_commit(data); if (UTF) { @@ -439,19 +637,51 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da min += l; if (data && (flags & SCF_DO_SUBSTR)) data->pos_min += l; + if (flags & SCF_DO_STCLASS_AND) { + /* Check whether it is compatible with what we know already! */ + int compat = 1; + + if (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE)) + && !ANYOF_BITMAP_TEST(data->start_class, *STRING(scan)) + && !ANYOF_BITMAP_TEST(data->start_class, + PL_fold[*STRING(scan)])) + compat = 0; + ANYOF_CLASS_ZERO(data->start_class); + ANYOF_BITMAP_ZERO(data->start_class); + if (compat) { + ANYOF_BITMAP_SET(data->start_class, *STRING(scan)); + data->start_class->flags &= ~ANYOF_EOS; + data->start_class->flags |= ANYOF_FOLD; + if (OP(scan) == EXACTFL) + data->start_class->flags |= ANYOF_LOCALE; + } + } + else if (flags & SCF_DO_STCLASS_OR) { + if (data->start_class->flags & ANYOF_FOLD) { + /* false positive possible if the class is case-folded. + Assume that the locale settings are the same... */ + ANYOF_BITMAP_SET(data->start_class, *STRING(scan)); + data->start_class->flags &= ~ANYOF_EOS; + } + cl_and(data->start_class, &and_with); + } + flags &= ~SCF_DO_STCLASS; } else if (strchr((char*)PL_varies,OP(scan))) { I32 mincount, maxcount, minnext, deltanext, pos_before, fl; + I32 f = flags; regnode *oscan = scan; - + struct regnode_charclass_class this_class; + struct regnode_charclass_class *oclass = NULL; + switch (PL_regkind[(U8)OP(scan)]) { - case WHILEM: + case WHILEM: /* End of (?:...)* . */ scan = NEXTOPER(scan); goto finish; case PLUS: - if (flags & SCF_DO_SUBSTR) { + if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) { next = NEXTOPER(scan); - if (OP(next) == EXACT) { + if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) { mincount = 1; maxcount = REG_INFTY; next = regnext(scan); @@ -464,10 +694,17 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da min++; /* Fall through. */ case STAR: + if (flags & SCF_DO_STCLASS) { + mincount = 0; + maxcount = REG_INFTY; + next = regnext(scan); + scan = NEXTOPER(scan); + goto do_curly; + } is_inf = is_inf_internal = 1; scan = regnext(scan); if (flags & SCF_DO_SUBSTR) { - scan_commit(data); + scan_commit(data); /* Cannot extend fixed substrings */ data->longest = &(data->longest_float); } goto optimize_curly_tail; @@ -478,7 +715,7 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS; do_curly: if (flags & SCF_DO_SUBSTR) { - if (mincount == 0) scan_commit(data); + if (mincount == 0) scan_commit(data); /* Cannot extend fixed substrings */ pos_before = data->pos_min; } if (data) { @@ -487,10 +724,45 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da if (is_inf) data->flags |= SF_IS_INF; } + if (flags & SCF_DO_STCLASS) { + cl_init(&this_class); + oclass = data->start_class; + data->start_class = &this_class; + f |= SCF_DO_STCLASS_AND; + f &= ~SCF_DO_STCLASS_OR; + } + /* This will finish on WHILEM, setting scan, or on NULL: */ minnext = study_chunk(&scan, &deltanext, last, data, mincount == 0 - ? (flags & ~SCF_DO_SUBSTR) : flags); + ? (f & ~SCF_DO_SUBSTR) : f); + + if (flags & SCF_DO_STCLASS) + data->start_class = oclass; + if (mincount == 0 || minnext == 0) { + if (flags & SCF_DO_STCLASS_OR) { + cl_or(data->start_class, &this_class); + } + else if (flags & SCF_DO_STCLASS_AND) { + /* Switch to OR mode: cache the old value of + * data->start_class */ + StructCopy(data->start_class, &and_with, + struct regnode_charclass_class); + flags &= ~SCF_DO_STCLASS_AND; + StructCopy(&this_class, data->start_class, + struct regnode_charclass_class); + flags |= SCF_DO_STCLASS_OR; + data->start_class->flags |= ANYOF_EOS; + } + } else { /* Non-zero len */ + if (flags & SCF_DO_STCLASS_OR) { + cl_or(data->start_class, &this_class); + cl_and(data->start_class, &and_with); + } + else if (flags & SCF_DO_STCLASS_AND) + cl_and(data->start_class, &this_class); + flags &= ~SCF_DO_STCLASS; + } if (!scan) /* It was not CURLYX, but CURLY. */ scan = next; if (ckWARN(WARN_UNSAFE) && (minnext + deltanext == 0) @@ -640,6 +912,8 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da data->pos_delta += - counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount; if (mincount != maxcount) { + /* Cannot extend fixed substrings found inside + the group. */ scan_commit(data); if (mincount && last_str) { sv_setsv(data->last_found, last_str); @@ -664,39 +938,258 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da NEXT_OFF(oscan) += NEXT_OFF(next); } continue; - default: /* REF only? */ + default: /* REF and CLUMP only? */ if (flags & SCF_DO_SUBSTR) { - scan_commit(data); + scan_commit(data); /* Cannot expect anything... */ data->longest = &(data->longest_float); } is_inf = is_inf_internal = 1; + if (flags & SCF_DO_STCLASS_OR) + cl_anything(data->start_class); + flags &= ~SCF_DO_STCLASS; break; } } else if (strchr((char*)PL_simple,OP(scan)) || PL_regkind[(U8)OP(scan)] == ANYUTF8) { + int value; + if (flags & SCF_DO_SUBSTR) { scan_commit(data); data->pos_min++; } min++; + if (flags & SCF_DO_STCLASS) { + data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */ + + /* Some of the logic below assumes that switching + locale on will only add false positives. */ + switch (PL_regkind[(U8)OP(scan)]) { + case ANYUTF8: + case SANY: + case SANYUTF8: + case ALNUMUTF8: + case ANYOFUTF8: + case ALNUMLUTF8: + case NALNUMUTF8: + case NALNUMLUTF8: + case SPACEUTF8: + case NSPACEUTF8: + case SPACELUTF8: + case NSPACELUTF8: + case DIGITUTF8: + case NDIGITUTF8: + default: + do_default: + /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */ + if (flags & SCF_DO_STCLASS_OR) /* Allow everything */ + cl_anything(data->start_class); + break; + case REG_ANY: + if (OP(scan) == SANY) + goto do_default; + if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */ + value = (ANYOF_BITMAP_TEST(data->start_class,'\n') + || (data->start_class->flags & ANYOF_CLASS)); + cl_anything(data->start_class); + } + if (flags & SCF_DO_STCLASS_AND || !value) + ANYOF_BITMAP_CLEAR(data->start_class,'\n'); + break; + case ANYOF: + if (flags & SCF_DO_STCLASS_AND) + cl_and(data->start_class, + (struct regnode_charclass_class*)scan); + else + cl_or(data->start_class, + (struct regnode_charclass_class*)scan); + break; + case ALNUM: + if (flags & SCF_DO_STCLASS_AND) { + if (!(data->start_class->flags & ANYOF_LOCALE)) { + ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM); + for (value = 0; value < 256; value++) + if (!isALNUM(value)) + ANYOF_BITMAP_CLEAR(data->start_class, value); + } + } + else { + if (data->start_class->flags & ANYOF_LOCALE) + ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM); + else { + for (value = 0; value < 256; value++) + if (isALNUM(value)) + ANYOF_BITMAP_SET(data->start_class, value); + } + } + break; + case ALNUML: + if (flags & SCF_DO_STCLASS_AND) { + if (data->start_class->flags & ANYOF_LOCALE) + ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM); + } + else { + ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM); + data->start_class->flags |= ANYOF_LOCALE; + } + break; + case NALNUM: + if (flags & SCF_DO_STCLASS_AND) { + if (!(data->start_class->flags & ANYOF_LOCALE)) { + ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM); + for (value = 0; value < 256; value++) + if (isALNUM(value)) + ANYOF_BITMAP_CLEAR(data->start_class, value); + } + } + else { + if (data->start_class->flags & ANYOF_LOCALE) + ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM); + else { + for (value = 0; value < 256; value++) + if (!isALNUM(value)) + ANYOF_BITMAP_SET(data->start_class, value); + } + } + break; + case NALNUML: + if (flags & SCF_DO_STCLASS_AND) { + if (data->start_class->flags & ANYOF_LOCALE) + ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM); + } + else { + data->start_class->flags |= ANYOF_LOCALE; + ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM); + } + break; + case SPACE: + if (flags & SCF_DO_STCLASS_AND) { + if (!(data->start_class->flags & ANYOF_LOCALE)) { + ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE); + for (value = 0; value < 256; value++) + if (!isSPACE(value)) + ANYOF_BITMAP_CLEAR(data->start_class, value); + } + } + else { + if (data->start_class->flags & ANYOF_LOCALE) + ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE); + else { + for (value = 0; value < 256; value++) + if (isSPACE(value)) + ANYOF_BITMAP_SET(data->start_class, value); + } + } + break; + case SPACEL: + if (flags & SCF_DO_STCLASS_AND) { + if (data->start_class->flags & ANYOF_LOCALE) + ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE); + } + else { + data->start_class->flags |= ANYOF_LOCALE; + ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE); + } + break; + case NSPACE: + if (flags & SCF_DO_STCLASS_AND) { + if (!(data->start_class->flags & ANYOF_LOCALE)) { + ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE); + for (value = 0; value < 256; value++) + if (isSPACE(value)) + ANYOF_BITMAP_CLEAR(data->start_class, value); + } + } + else { + if (data->start_class->flags & ANYOF_LOCALE) + ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE); + else { + for (value = 0; value < 256; value++) + if (!isSPACE(value)) + ANYOF_BITMAP_SET(data->start_class, value); + } + } + break; + case NSPACEL: + if (flags & SCF_DO_STCLASS_AND) { + if (data->start_class->flags & ANYOF_LOCALE) { + ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE); + for (value = 0; value < 256; value++) + if (!isSPACE(value)) + ANYOF_BITMAP_CLEAR(data->start_class, value); + } + } + else { + data->start_class->flags |= ANYOF_LOCALE; + ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE); + } + break; + case DIGIT: + if (flags & SCF_DO_STCLASS_AND) { + ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT); + for (value = 0; value < 256; value++) + if (!isDIGIT(value)) + ANYOF_BITMAP_CLEAR(data->start_class, value); + } + else { + if (data->start_class->flags & ANYOF_LOCALE) + ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT); + else { + for (value = 0; value < 256; value++) + if (isDIGIT(value)) + ANYOF_BITMAP_SET(data->start_class, value); + } + } + break; + case NDIGIT: + if (flags & SCF_DO_STCLASS_AND) { + ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT); + for (value = 0; value < 256; value++) + if (isDIGIT(value)) + ANYOF_BITMAP_CLEAR(data->start_class, value); + } + else { + if (data->start_class->flags & ANYOF_LOCALE) + ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT); + else { + for (value = 0; value < 256; value++) + if (!isDIGIT(value)) + ANYOF_BITMAP_SET(data->start_class, value); + } + } + break; + } + if (flags & SCF_DO_STCLASS_OR) + cl_and(data->start_class, &and_with); + flags &= ~SCF_DO_STCLASS; + } } else if (PL_regkind[(U8)OP(scan)] == EOL && flags & SCF_DO_SUBSTR) { data->flags |= (OP(scan) == MEOL ? SF_BEFORE_MEOL : SF_BEFORE_SEOL); } - else if (PL_regkind[(U8)OP(scan)] == BRANCHJ - && (scan->flags || data) + else if ( PL_regkind[(U8)OP(scan)] == BRANCHJ + /* Lookbehind, or need to calculate parens/evals/stclass: */ + && (scan->flags || data || (flags & SCF_DO_STCLASS)) && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) { + /* Lookahead/lookbehind */ I32 deltanext, minnext; regnode *nscan; + struct regnode_charclass_class intrnl; + int f = 0; data_fake.flags = 0; if (data) data_fake.whilem_c = data->whilem_c; + if ( flags & SCF_DO_STCLASS && !scan->flags + && OP(scan) == IFMATCH ) { /* Lookahead */ + cl_init(&intrnl); + data_fake.start_class = &intrnl; + f = SCF_DO_STCLASS_AND; + } next = regnext(scan); nscan = NEXTOPER(NEXTOPER(scan)); - minnext = study_chunk(&nscan, &deltanext, last, &data_fake, 0); + minnext = study_chunk(&nscan, &deltanext, last, &data_fake, f); if (scan->flags) { if (deltanext) { FAIL("variable length lookbehind not implemented"); @@ -712,6 +1205,13 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da data->flags |= SF_HAS_EVAL; if (data) data->whilem_c = data_fake.whilem_c; + if (f) { + int was = (data->start_class->flags & ANYOF_EOS); + + cl_and(data->start_class, &intrnl); + if (was) + data->start_class->flags |= ANYOF_EOS; + } } else if (OP(scan) == OPEN) { pars++; @@ -732,6 +1232,8 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da data->longest = &(data->longest_float); } is_inf = is_inf_internal = 1; + if (flags & SCF_DO_STCLASS_OR) /* Allow everything */ + cl_anything(data->start_class); } /* Else: zero-length, ignore. */ scan = regnext(scan); @@ -752,6 +1254,8 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da data->flags |= SF_HAS_PAR; data->flags &= ~SF_IN_PAR; } + if (flags & SCF_DO_STCLASS_OR) + cl_and(data->start_class, &and_with); return min; } @@ -924,16 +1428,21 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) Newz(1004, r->substrs, 1, struct reg_substr_data); StructCopy(&zero_scan_data, &data, scan_data_t); + /* XXXX Should not we check for something else? Usually it is OPEN1... */ if (OP(scan) != BRANCH) { /* Only one top-level choice. */ I32 fake; STRLEN longest_float_length, longest_fixed_length; + struct regnode_charclass_class ch_class; + int stclass_flag; first = scan; /* Skip introductions and multiplicators >= 1. */ while ((OP(first) == OPEN && (sawopen = 1)) || + /* An OR of *one* alternative - should not happen now. */ (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) || (OP(first) == PLUS) || (OP(first) == MINMOD) || + /* An {n,m} with n>0 */ (PL_regkind[(U8)OP(first)] == CURLY && ARG1(first) > 0) ) { if (OP(first) == PLUS) sawplus = 1; @@ -944,13 +1453,13 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) /* Starting-point info. */ again: - if (PL_regkind[(U8)OP(first) == EXACT]) { + if (PL_regkind[(U8)OP(first)] == EXACT) { if (OP(first) == EXACT); /* Empty, get anchored substr later. */ else if ((OP(first) == EXACTF || OP(first) == EXACTFL) && !UTF) r->regstclass = first; } - else if (strchr((char*)PL_simple+4,OP(first))) + else if (strchr((char*)PL_simple,OP(first))) r->regstclass = first; else if (PL_regkind[(U8)OP(first)] == BOUND || PL_regkind[(U8)OP(first)] == NBOUND) @@ -1011,9 +1520,15 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) data.last_found = newSVpvn("",0); data.longest = &(data.longest_fixed); first = scan; - + if (!r->regstclass) { + cl_init(&ch_class); + data.start_class = &ch_class; + stclass_flag = SCF_DO_STCLASS_AND; + } else /* XXXX Check for BOUND? */ + stclass_flag = 0; + minlen = study_chunk(&first, &fake, scan + PL_regsize, /* Up to end */ - &data, SCF_DO_SUBSTR); + &data, SCF_DO_SUBSTR | stclass_flag); if ( PL_regnpar == 1 && data.longest == &(data.longest_fixed) && data.last_start_min == 0 && data.last_end > 0 && !PL_seen_zerolen @@ -1068,6 +1583,28 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) SvREFCNT_dec(data.longest_fixed); longest_fixed_length = 0; } + if (r->regstclass + && (OP(r->regstclass) == REG_ANY || OP(r->regstclass) == ANYUTF8 + || OP(r->regstclass) == SANYUTF8 || OP(r->regstclass) == SANY)) + r->regstclass = NULL; + if ((!r->anchored_substr || r->anchored_offset) && stclass_flag + && !(data.start_class->flags & ANYOF_EOS) + && !cl_is_anything(data.start_class)) { + SV *sv; + I32 n = add_data(1, "f"); + + New(1006, PL_regcomp_rx->data->data[n], 1, + struct regnode_charclass_class); + StructCopy(data.start_class, + (struct regnode_charclass_class*)PL_regcomp_rx->data->data[n], + struct regnode_charclass_class); + r->regstclass = (regnode*)PL_regcomp_rx->data->data[n]; + r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */ + DEBUG_r((sv = sv_newmortal(), + regprop(sv, (regnode*)data.start_class), + PerlIO_printf(Perl_debug_log, "synthetic stclass.\n", + SvPVX(sv)))); + } /* A temporary algorithm prefers floated substr to fixed one to dig more info. */ if (longest_fixed_length > longest_float_length) { @@ -1092,11 +1629,31 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) else { /* Several toplevels. Best we can is to set minlen. */ I32 fake; + struct regnode_charclass_class ch_class; DEBUG_r(PerlIO_printf(Perl_debug_log, "\n")); scan = r->program + 1; - minlen = study_chunk(&scan, &fake, scan + PL_regsize, &data, 0); + cl_init(&ch_class); + data.start_class = &ch_class; + minlen = study_chunk(&scan, &fake, scan + PL_regsize, &data, SCF_DO_STCLASS_AND); r->check_substr = r->anchored_substr = r->float_substr = Nullsv; + if (!(data.start_class->flags & ANYOF_EOS) + && !cl_is_anything(data.start_class)) { + SV *sv; + I32 n = add_data(1, "f"); + + New(1006, PL_regcomp_rx->data->data[n], 1, + struct regnode_charclass_class); + StructCopy(data.start_class, + (struct regnode_charclass_class*)PL_regcomp_rx->data->data[n], + struct regnode_charclass_class); + r->regstclass = (regnode*)PL_regcomp_rx->data->data[n]; + r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */ + DEBUG_r((sv = sv_newmortal(), + regprop(sv, (regnode*)data.start_class), + PerlIO_printf(Perl_debug_log, "synthetic stclass.\n", + SvPVX(sv)))); + } } r->minlen = minlen; @@ -2013,11 +2570,19 @@ tryagain: p++; break; case 'e': - ender = '\033'; +#ifdef ASCIIish + ender = '\033'; +#else + ender = '\047'; +#endif p++; break; case 'a': - ender = '\007'; +#ifdef ASCIIish + ender = '\007'; +#else + ender = '\057'; +#endif p++; break; case 'x': @@ -2353,8 +2918,13 @@ S_regclass(pTHX) case 't': value = '\t'; break; case 'f': value = '\f'; break; case 'b': value = '\b'; break; +#ifdef ASCIIish case 'e': value = '\033'; break; case 'a': value = '\007'; break; +#else + case 'e': value = '\047'; break; + case 'a': value = '\057'; break; +#endif case 'x': value = (UV)scan_hex(PL_regcomp_parse, 2, &numlen); PL_regcomp_parse += numlen; @@ -2373,7 +2943,7 @@ S_regclass(pTHX) Perl_warner(aTHX_ WARN_UNSAFE, "/%.127s/: Unrecognized escape \\%c in character class passed through", PL_regprecomp, - value); + (int)value); break; } } @@ -2491,16 +3061,28 @@ S_regclass(pTHX) if (LOC) ANYOF_CLASS_SET(ret, ANYOF_ASCII); else { +#ifdef ASCIIish for (value = 0; value < 128; value++) ANYOF_BITMAP_SET(ret, value); +#else /* EBCDIC */ + for (value = 0; value < 256; value++) + if (isASCII(value)) + ANYOF_BITMAP_SET(ret, value); +#endif /* EBCDIC */ } break; case ANYOF_NASCII: if (LOC) ANYOF_CLASS_SET(ret, ANYOF_NASCII); else { +#ifdef ASCIIish for (value = 128; value < 256; value++) ANYOF_BITMAP_SET(ret, value); +#else /* EBCDIC */ + for (value = 0; value < 256; value++) + if (!isASCII(value)) + ANYOF_BITMAP_SET(ret, value); +#endif /* EBCDIC */ } break; case ANYOF_CNTRL: @@ -2803,8 +3385,13 @@ S_regclassutf8(pTHX) case 't': value = '\t'; break; case 'f': value = '\f'; break; case 'b': value = '\b'; break; +#ifdef ASCIIish case 'e': value = '\033'; break; case 'a': value = '\007'; break; +#else + case 'e': value = '\047'; break; + case 'a': value = '\057'; break; +#endif case 'x': if (*PL_regcomp_parse == '{') { e = strchr(PL_regcomp_parse++, '}'); @@ -2834,7 +3421,7 @@ S_regclassutf8(pTHX) Perl_warner(aTHX_ WARN_UNSAFE, "/%.127s/: Unrecognized escape \\%c in character class passed through", PL_regprecomp, - value); + (int)value); break; } } @@ -3310,6 +3897,17 @@ Perl_regdump(pTHX_ regexp *r) #endif /* DEBUGGING */ } +STATIC void +S_put_byte(pTHX_ SV *sv, int c) +{ + if (c <= ' ' || c == 127 || c == 255) + Perl_sv_catpvf(aTHX_ sv, "\\%o", c); + else if (c == '-' || c == ']' || c == '\\' || c == '^') + Perl_sv_catpvf(aTHX_ sv, "\\%c", c); + else + Perl_sv_catpvf(aTHX_ sv, "%c", c); +} + /* - regprop - printable representation of opcode */ @@ -3341,6 +3939,67 @@ Perl_regprop(pTHX_ SV *sv, regnode *o) Perl_sv_catpvf(aTHX_ sv, "%d", ARG(o)); /* Parenth number */ else if (k == LOGICAL) Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* 2: embedded, otherwise 1 */ + else if (k == ANYOF) { + int i, rangestart = -1; + const char * const out[] = { /* Should be syncronized with + a table in regcomp.h */ + "\\w", + "\\W", + "\\s", + "\\S", + "\\d", + "\\D", + "[:alnum:]", + "[:^alnum:]", + "[:alpha:]", + "[:^alpha:]", + "[:ascii:]", + "[:^ascii:]", + "[:ctrl:]", + "[:^ctrl:]", + "[:graph:]", + "[:^graph:]", + "[:lower:]", + "[:^lower:]", + "[:print:]", + "[:^print:]", + "[:punct:]", + "[:^punct:]", + "[:upper:]", + "[:!upper:]", + "[:xdigit:]", + "[:^xdigit:]" + }; + + if (o->flags & ANYOF_LOCALE) + sv_catpv(sv, "{loc}"); + if (o->flags & ANYOF_FOLD) + sv_catpv(sv, "{i}"); + Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]); + if (o->flags & ANYOF_INVERT) + sv_catpv(sv, "^"); + for (i = 0; i <= 256; i++) { + if (i < 256 && ANYOF_BITMAP_TEST(o,i)) { + if (rangestart == -1) + rangestart = i; + } else if (rangestart != -1) { + if (i <= rangestart + 3) + for (; rangestart < i; rangestart++) + put_byte(sv, rangestart); + else { + put_byte(sv, rangestart); + sv_catpv(sv, "-"); + put_byte(sv, i - 1); + } + rangestart = -1; + } + } + if (o->flags & ANYOF_CLASS) + for (i = 0; i < sizeof(out)/sizeof(char*); i++) + if (ANYOF_CLASS_TEST(o,i)) + sv_catpv(sv, out[i]); + Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]); + } else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH)) Perl_sv_catpvf(aTHX_ sv, "[-%d]", o->flags); #endif /* DEBUGGING */ @@ -3402,6 +4061,9 @@ Perl_pregfree(pTHX_ struct regexp *r) case 's': SvREFCNT_dec((SV*)r->data->data[n]); break; + case 'f': + Safefree(r->data->data[n]); + break; case 'p': new_comppad = (AV*)r->data->data[n]; break; @@ -3502,39 +4164,39 @@ Perl_save_re_context(pTHX) SAVEPPTR(PL_reginput); /* String-input pointer. */ SAVEPPTR(PL_regbol); /* Beginning of input, for ^ check. */ SAVEPPTR(PL_regeol); /* End of input, for $ check. */ - SAVESPTR(PL_regstartp); /* Pointer to startp array. */ - SAVESPTR(PL_regendp); /* Ditto for endp. */ - SAVESPTR(PL_reglastparen); /* Similarly for lastparen. */ + SAVEVPTR(PL_regstartp); /* Pointer to startp array. */ + SAVEVPTR(PL_regendp); /* Ditto for endp. */ + SAVEVPTR(PL_reglastparen); /* Similarly for lastparen. */ SAVEPPTR(PL_regtill); /* How far we are required to go. */ - SAVEI32(PL_regprev); /* char before regbol, \n if none */ - SAVESPTR(PL_reg_start_tmp); /* from regexec.c */ + SAVEI8(PL_regprev); /* char before regbol, \n if none */ + SAVEVPTR(PL_reg_start_tmp); /* from regexec.c */ PL_reg_start_tmp = 0; SAVEFREEPV(PL_reg_start_tmp); SAVEI32(PL_reg_start_tmpl); /* from regexec.c */ PL_reg_start_tmpl = 0; - SAVESPTR(PL_regdata); + SAVEVPTR(PL_regdata); SAVEI32(PL_reg_flags); /* from regexec.c */ SAVEI32(PL_reg_eval_set); /* from regexec.c */ SAVEI32(PL_regnarrate); /* from regexec.c */ - SAVESPTR(PL_regprogram); /* from regexec.c */ + SAVEVPTR(PL_regprogram); /* from regexec.c */ SAVEINT(PL_regindent); /* from regexec.c */ - SAVESPTR(PL_regcc); /* from regexec.c */ - SAVESPTR(PL_curcop); - SAVESPTR(PL_regcomp_rx); /* from regcomp.c */ + SAVEVPTR(PL_regcc); /* from regexec.c */ + SAVEVPTR(PL_curcop); + SAVEVPTR(PL_regcomp_rx); /* from regcomp.c */ SAVEI32(PL_regseen); /* from regcomp.c */ SAVEI32(PL_regsawback); /* Did we see \1, ...? */ SAVEI32(PL_regnaughty); /* How bad is this pattern? */ - SAVESPTR(PL_regcode); /* Code-emit pointer; ®dummy = don't */ + SAVEVPTR(PL_regcode); /* Code-emit pointer; ®dummy = don't */ SAVEPPTR(PL_regxend); /* End of input for compile */ SAVEPPTR(PL_regcomp_parse); /* Input-scan pointer. */ - SAVESPTR(PL_reg_call_cc); /* from regexec.c */ - SAVESPTR(PL_reg_re); /* from regexec.c */ + SAVEVPTR(PL_reg_call_cc); /* from regexec.c */ + SAVEVPTR(PL_reg_re); /* from regexec.c */ SAVEPPTR(PL_reg_ganch); /* from regexec.c */ SAVESPTR(PL_reg_sv); /* from regexec.c */ - SAVESPTR(PL_reg_magic); /* from regexec.c */ + SAVEVPTR(PL_reg_magic); /* from regexec.c */ SAVEI32(PL_reg_oldpos); /* from regexec.c */ - SAVESPTR(PL_reg_oldcurpm); /* from regexec.c */ - SAVESPTR(PL_reg_curpm); /* from regexec.c */ + SAVEVPTR(PL_reg_oldcurpm); /* from regexec.c */ + SAVEVPTR(PL_reg_curpm); /* from regexec.c */ #ifdef DEBUGGING SAVEPPTR(PL_reg_starttry); /* from regexec.c */ #endif @@ -185,7 +185,12 @@ struct regnode_charclass_class { #define ANYOF_FOLD 0x02 #define ANYOF_LOCALE 0x01 +/* Used for regstclass only */ +#define ANYOF_EOS 0x10 /* Can match an empty string too */ + /* Character classes for node->classflags of ANYOF */ +/* Should be synchronized with a table in regprop() */ +/* 2n should pair with 2n+1 */ #define ANYOF_ALNUM 0 /* \w, utf8::IsWord, isALNUM() */ #define ANYOF_NALNUM 1 @@ -335,6 +335,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, DEBUG_r(PerlIO_printf(Perl_debug_log, "String too short...\n")); goto fail; } + check = prog->check_substr; if (prog->reganch & ROPT_ANCH) { /* Match at beg-of-str or after \n */ ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE) || ( (prog->reganch & ROPT_ANCH_BOL) @@ -351,8 +352,8 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, } PL_regeol = strend; /* Used in HOP() */ s = HOPc(strpos, prog->check_offset_min); - if (SvTAIL(prog->check_substr)) { - slen = SvCUR(prog->check_substr); /* >= 1 */ + if (SvTAIL(check)) { + slen = SvCUR(check); /* >= 1 */ if ( strend - s > slen || strend - s < slen - 1 || (strend - s == slen && strend[-1] != '\n')) { @@ -361,29 +362,28 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, } /* Now should match s[0..slen-2] */ slen--; - if (slen && (*SvPVX(prog->check_substr) != *s + if (slen && (*SvPVX(check) != *s || (slen > 1 - && memNE(SvPVX(prog->check_substr), s, slen)))) { + && memNE(SvPVX(check), s, slen)))) { report_neq: DEBUG_r(PerlIO_printf(Perl_debug_log, "String not equal...\n")); goto fail_finish; } } - else if (*SvPVX(prog->check_substr) != *s - || ((slen = SvCUR(prog->check_substr)) > 1 - && memNE(SvPVX(prog->check_substr), s, slen))) + else if (*SvPVX(check) != *s + || ((slen = SvCUR(check)) > 1 + && memNE(SvPVX(check), s, slen))) goto report_neq; goto success_at_start; } /* Match is anchored, but substr is not anchored wrt beg-of-str. */ s = strpos; start_shift = prog->check_offset_min; /* okay to underestimate on CC */ - /* Should be nonnegative! */ end_shift = prog->minlen - start_shift - - CHR_SVLEN(prog->check_substr) + (SvTAIL(prog->check_substr) != 0); + CHR_SVLEN(check) + (SvTAIL(check) != 0); if (!ml_anch) { - I32 end = prog->check_offset_max + CHR_SVLEN(prog->check_substr) - - (SvTAIL(prog->check_substr) != 0); + I32 end = prog->check_offset_max + CHR_SVLEN(check) + - (SvTAIL(check) != 0); I32 eshift = strend - s - end; if (end_shift < eshift) @@ -396,7 +396,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, start_shift = prog->check_offset_min; /* okay to underestimate on CC */ /* Should be nonnegative! */ end_shift = prog->minlen - start_shift - - CHR_SVLEN(prog->check_substr) + (SvTAIL(prog->check_substr) != 0); + CHR_SVLEN(check) + (SvTAIL(check) != 0); } #ifdef DEBUGGING /* 7/99: reports of failure (with the older version) */ @@ -404,7 +404,6 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, Perl_croak(aTHX_ "panic: end_shift"); #endif - check = prog->check_substr; restart: /* Find a possible match in the region s..strend by looking for the "check" substring in the region corrected by start/end_shift. */ @@ -640,7 +639,10 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, /* Even in this situation we may use MBOL flag if strpos is offset wrt the start of the string. */ if (ml_anch && sv - && (strpos + SvCUR(sv) != strend) && strpos[-1] != '\n') { + && (strpos + SvCUR(sv) != strend) && strpos[-1] != '\n' + /* May be due to an implicit anchor of m{.*foo} */ + && !(prog->reganch & ROPT_IMPLICIT)) + { t = strpos; goto find_anchor; } @@ -650,8 +652,10 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, ); success_at_start: if (!(prog->reganch & ROPT_NAUGHTY) /* XXXX If strpos moved? */ + && prog->check_substr /* Could be deleted already */ && --BmUSEFUL(prog->check_substr) < 0 - && prog->check_substr == prog->float_substr) { /* boo */ + && prog->check_substr == prog->float_substr) + { /* If flags & SOMETHING - do not do it many times on the same match */ SvREFCNT_dec(prog->check_substr); prog->check_substr = Nullsv; /* disable */ @@ -677,13 +681,20 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, regstclass does not come from lookahead... */ /* If regstclass takes bytelength more than 1: If charlength==1, OK. This leaves EXACTF only, which is dealt with in find_byclass(). */ + int cl_l = (PL_regkind[(U8)OP(prog->regstclass)] == EXACT + ? STR_LEN(prog->regstclass) + : 1); char *endpos = (prog->anchored_substr || ml_anch) - ? s + (prog->minlen? 1 : 0) - : (prog->float_substr ? check_at - start_shift + 1 + ? s + (prog->minlen? cl_l : 0) + : (prog->float_substr ? check_at - start_shift + cl_l : strend) ; char *startpos = sv ? strend - SvCUR(sv) : s; t = s; + if (prog->reganch & ROPT_UTF8) { + PL_regdata = prog->data; /* Used by REGINCLASS UTF logic */ + PL_bostr = startpos; + } s = find_byclass(prog, prog->regstclass, s, endpos, startpos, 1); if (!s) { #ifdef DEBUGGING @@ -694,30 +705,49 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, "Could not match STCLASS...\n") ); goto fail; } + DEBUG_r( PerlIO_printf(Perl_debug_log, + "This position contradicts STCLASS...\n") ); + if ((prog->reganch & ROPT_ANCH) && !ml_anch) + goto fail; /* Contradict one of substrings */ if (prog->anchored_substr) { - DEBUG_r( PerlIO_printf(Perl_debug_log, - "This position contradicts STCLASS...\n") ); if (prog->anchored_substr == check) { DEBUG_r( what = "anchored" ); hop_and_restart: PL_regeol = strend; /* Used in HOP() */ s = HOPc(t, 1); + if (s + start_shift + end_shift > strend) { + /* XXXX Should be taken into account earlier? */ + DEBUG_r( PerlIO_printf(Perl_debug_log, + "Could not match STCLASS...\n") ); + goto fail; + } DEBUG_r( PerlIO_printf(Perl_debug_log, - "trying %s substr starting at offset %ld...\n", + "Trying %s substr starting at offset %ld...\n", what, (long)(s + start_shift - i_strpos)) ); goto restart; } - /* Have both, check is floating */ + /* Have both, check_string is floating */ if (t + start_shift >= check_at) /* Contradicts floating=check */ goto retry_floating_check; /* Recheck anchored substring, but not floating... */ s = check_at; DEBUG_r( PerlIO_printf(Perl_debug_log, - "trying anchored substr starting at offset %ld...\n", + "Trying anchored substr starting at offset %ld...\n", (long)(other_last - i_strpos)) ); goto do_other_anchored; } + /* Another way we could have checked stclass at the + current position only: */ + if (ml_anch) { + s = t = t + 1; + DEBUG_r( PerlIO_printf(Perl_debug_log, + "Trying /^/m starting at offset %ld...\n", + (long)(t - i_strpos)) ); + goto try_at_offset; + } + if (!prog->float_substr) /* Could have been deleted */ + goto fail; /* Check is floating subtring. */ retry_floating_check: t = check_at - start_shift; @@ -737,7 +767,8 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, return s; fail_finish: /* Substring not found */ - BmUSEFUL(prog->check_substr) += 5; /* hooray */ + if (prog->check_substr) /* could be removed already */ + BmUSEFUL(prog->check_substr) += 5; /* hooray */ fail: DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n", PL_colors[4],PL_colors[5])); @@ -745,8 +776,8 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, } /* We know what class REx starts with. Try to find this position... */ -static char * -find_byclass(regexp * prog, regnode *c, char *s, char *strend, char *startpos, I32 norun) +STATIC char * +S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *startpos, I32 norun) { I32 doevery = (prog->reganch & ROPT_SKIP) == 0; char *m; @@ -804,9 +835,9 @@ find_byclass(regexp * prog, regnode *c, char *s, char *strend, char *startpos, I if (c1 == c2) { while (s <= e) { if ( *s == c1 - && (ln == 1 || (OP(c) == EXACTF - ? ibcmp(s, m, ln) - : ibcmp_locale(s, m, ln))) + && (ln == 1 || !(OP(c) == EXACTF + ? ibcmp(s, m, ln) + : ibcmp_locale(s, m, ln))) && (norun || regtry(prog, s)) ) goto got_it; s++; @@ -814,9 +845,9 @@ find_byclass(regexp * prog, regnode *c, char *s, char *strend, char *startpos, I } else { while (s <= e) { if ( (*s == c1 || *s == c2) - && (ln == 1 || (OP(c) == EXACTF - ? ibcmp(s, m, ln) - : ibcmp_locale(s, m, ln))) + && (ln == 1 || !(OP(c) == EXACTF + ? ibcmp(s, m, ln) + : ibcmp_locale(s, m, ln))) && (norun || regtry(prog, s)) ) goto got_it; s++; @@ -845,9 +876,9 @@ find_byclass(regexp * prog, regnode *c, char *s, char *strend, char *startpos, I /* FALL THROUGH */ case BOUNDUTF8: tmp = (I32)(s != startpos) ? utf8_to_uv(reghop((U8*)s, -1), 0) : '\n'; - tmp = ((OP(c) == BOUND ? isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0); + tmp = ((OP(c) == BOUNDUTF8 ? isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0); while (s < strend) { - if (tmp == !(OP(c) == BOUND ? + if (tmp == !(OP(c) == BOUNDUTF8 ? swash_fetch(PL_utf8_alnum, (U8*)s) : isALNUM_LC_utf8((U8*)s))) { @@ -880,12 +911,10 @@ find_byclass(regexp * prog, regnode *c, char *s, char *strend, char *startpos, I PL_reg_flags |= RF_tainted; /* FALL THROUGH */ case NBOUNDUTF8: - if (prog->minlen) - strend = reghop_c(strend, -1); tmp = (I32)(s != startpos) ? utf8_to_uv(reghop((U8*)s, -1), 0) : '\n'; - tmp = ((OP(c) == NBOUND ? isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0); + tmp = ((OP(c) == NBOUNDUTF8 ? isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0); while (s < strend) { - if (tmp == !(OP(c) == NBOUND ? + if (tmp == !(OP(c) == NBOUNDUTF8 ? swash_fetch(PL_utf8_alnum, (U8*)s) : isALNUM_LC_utf8((U8*)s))) tmp = !tmp; @@ -1221,11 +1250,8 @@ find_byclass(regexp * prog, regnode *c, char *s, char *strend, char *startpos, I } break; default: - { - dTHX; - Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c)); - break; - } + Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c)); + break; } return 0; got_it: @@ -1491,7 +1517,8 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * goto phooey; } else if (c = prog->regstclass) { - if (minlen) /* don't bother with what can't match */ + if (minlen && PL_regkind[(U8)OP(prog->regstclass)] != EXACT) + /* don't bother with what can't match */ strend = HOPc(strend, -(minlen - 1)); if (find_byclass(prog, c, s, strend, startpos, 0)) goto got_it; @@ -1615,12 +1642,12 @@ S_regtry(pTHX_ regexp *prog, char *startpos) PerlIO_printf(Perl_debug_log, " setting stack tmpbase at %"IVdf"\n", (IV)(PL_stack_sp - PL_stack_base)); )); - SAVEINT(cxstack[cxstack_ix].blk_oldsp); + SAVEI32(cxstack[cxstack_ix].blk_oldsp); cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base; /* Otherwise OP_NEXTSTATE will free whatever on stack now. */ SAVETMPS; /* Apparently this is not needed, judging by wantarray. */ - /* SAVEINT(cxstack[cxstack_ix].blk_gimme); + /* SAVEI8(cxstack[cxstack_ix].blk_gimme); cxstack[cxstack_ix].blk_gimme = G_SCALAR; */ if (PL_reg_sv) { @@ -71,13 +71,13 @@ Perl_debop(pTHX_ OP *o) Perl_deb(aTHX_ "%s", PL_op_name[o->op_type]); switch (o->op_type) { case OP_CONST: - PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo->op_sv)); + PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv)); break; case OP_GVSV: case OP_GV: - if (cGVOPo) { + if (cGVOPo_gv) { sv = NEWSV(0,0); - gv_fullname3(sv, cGVOPo, Nullch); + gv_fullname3(sv, cGVOPo_gv, Nullch); PerlIO_printf(Perl_debug_log, "(%s)", SvPV(sv, n_a)); SvREFCNT_dec(sv); } @@ -405,6 +405,16 @@ Perl_save_I16(pTHX_ I16 *intp) } void +Perl_save_I8(pTHX_ I8 *bytep) +{ + dTHR; + SSCHECK(3); + SSPUSHINT(*bytep); + SSPUSHPTR(bytep); + SSPUSHINT(SAVEt_I8); +} + +void Perl_save_iv(pTHX_ IV *ivp) { dTHR; @@ -428,6 +438,16 @@ Perl_save_pptr(pTHX_ char **pptr) } void +Perl_save_vptr(pTHX_ void *ptr) +{ + dTHR; + SSCHECK(3); + SSPUSHPTR(*(char**)ptr); + SSPUSHPTR(ptr); + SSPUSHINT(SAVEt_VPTR); +} + +void Perl_save_sptr(pTHX_ SV **sptr) { dTHR; @@ -741,6 +761,10 @@ Perl_leave_scope(pTHX_ I32 base) ptr = SSPOPPTR; *(I16*)ptr = (I16)SSPOPINT; break; + case SAVEt_I8: /* I8 reference */ + ptr = SSPOPPTR; + *(I8*)ptr = (I8)SSPOPINT; + break; case SAVEt_IV: /* IV reference */ ptr = SSPOPPTR; *(IV*)ptr = (IV)SSPOPIV; @@ -749,6 +773,7 @@ Perl_leave_scope(pTHX_ I32 base) ptr = SSPOPPTR; *(SV**)ptr = (SV*)SSPOPPTR; break; + case SAVEt_VPTR: /* random* reference */ case SAVEt_PPTR: /* char* reference */ ptr = SSPOPPTR; *(char**)ptr = (char*)SSPOPPTR; @@ -936,17 +961,25 @@ Perl_cx_dump(pTHX_ PERL_CONTEXT *cx) case CXt_NULL: case CXt_BLOCK: break; - case CXt_SUB: + case CXt_FORMAT: PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n", PTR2UV(cx->blk_sub.cv)); PerlIO_printf(Perl_debug_log, "BLK_SUB.GV = 0x%"UVxf"\n", PTR2UV(cx->blk_sub.gv)); PerlIO_printf(Perl_debug_log, "BLK_SUB.DFOUTGV = 0x%"UVxf"\n", PTR2UV(cx->blk_sub.dfoutgv)); + PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n", + (int)cx->blk_sub.hasargs); + break; + case CXt_SUB: + PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n", + PTR2UV(cx->blk_sub.cv)); PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n", (long)cx->blk_sub.olddepth); PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n", (int)cx->blk_sub.hasargs); + PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n", + (int)cx->blk_sub.lval); break; case CXt_EVAL: PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n", @@ -976,8 +1009,8 @@ Perl_cx_dump(pTHX_ PERL_CONTEXT *cx) PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%"UVxf"\n", PTR2UV(cx->blk_loop.iterary)); PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%"UVxf"\n", - PTR2UV(cx->blk_loop.itervar)); - if (cx->blk_loop.itervar) + PTR2UV(CxITERVAR(cx))); + if (CxITERVAR(cx)) PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%"UVxf"\n", PTR2UV(cx->blk_loop.itersave)); PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERLVAL = 0x%"UVxf"\n", @@ -29,6 +29,8 @@ #define SAVEt_ALLOC 28 #define SAVEt_GENERIC_SVREF 29 #define SAVEt_DESTRUCTOR_X 30 +#define SAVEt_VPTR 31 +#define SAVEt_I8 32 #define SSCHECK(need) if (PL_savestack_ix + need > PL_savestack_max) savestack_grow() #define SSPUSHINT(i) (PL_savestack[PL_savestack_ix++].any_i32 = (I32)(i)) @@ -70,6 +72,7 @@ * Not using SOFT_CAST on SAVESPTR, SAVEGENERICSV and SAVEFREESV * because these are used for several kinds of pointer values */ +#define SAVEI8(i) save_I8(SOFT_CAST(I8*)&(i)) #define SAVEI16(i) save_I16(SOFT_CAST(I16*)&(i)) #define SAVEI32(i) save_I32(SOFT_CAST(I32*)&(i)) #define SAVEINT(i) save_int(SOFT_CAST(int*)&(i)) @@ -77,6 +80,7 @@ #define SAVELONG(l) save_long(SOFT_CAST(long*)&(l)) #define SAVESPTR(s) save_sptr((SV**)&(s)) #define SAVEPPTR(s) save_pptr(SOFT_CAST(char**)&(s)) +#define SAVEVPTR(s) save_vptr((void*)&(s)) #define SAVEFREESV(s) save_freesv((SV*)(s)) #define SAVEFREEOP(o) save_freeop(SOFT_CAST(OP*)(o)) #define SAVEFREEPV(p) save_freepv(SOFT_CAST(char*)(p)) @@ -316,6 +316,16 @@ Perl_sv_free_arenas(pTHX) PL_sv_root = 0; } +void +Perl_report_uninit(pTHX) +{ + if (PL_op) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, + " in ", PL_op_desc[PL_op->op_type]); + else + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", ""); +} + STATIC XPVIV* S_new_xiv(pTHX) { @@ -1427,7 +1437,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } return 0; } @@ -1442,7 +1452,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) if (SvREADONLY(sv) && !SvOK(sv)) { dTHR; if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); return 0; } } @@ -1538,7 +1548,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) else { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); if (SvTYPE(sv) < SVt_IV) /* Typically the caller expects that sv_any is not NULL now. */ sv_upgrade(sv, SVt_IV); @@ -1566,7 +1576,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } return 0; } @@ -1581,7 +1591,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) if (SvREADONLY(sv) && !SvOK(sv)) { dTHR; if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); return 0; } } @@ -1695,7 +1705,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } if (SvTYPE(sv) < SVt_IV) /* Typically the caller expects that sv_any is not NULL now. */ @@ -1733,7 +1743,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } return 0; } @@ -1748,7 +1758,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (SvREADONLY(sv) && !SvOK(sv)) { dTHR; if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); return 0.0; } } @@ -1790,7 +1800,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) else { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); if (SvTYPE(sv) < SVt_NV) /* Typically the caller expects that sv_any is not NULL now. */ sv_upgrade(sv, SVt_NV); @@ -2035,7 +2045,7 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } *lp = 0; return ""; @@ -2129,7 +2139,7 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) if (SvREADONLY(sv) && !SvOK(sv)) { dTHR; if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); *lp = 0; return ""; } @@ -2193,7 +2203,7 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) { - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } *lp = 0; if (SvTYPE(sv) < SVt_PV) @@ -2248,6 +2258,30 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) } } +char * +Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv) +{ + return sv_2pv_nolen(sv); +} + +char * +Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp) +{ + return sv_2pv(sv,lp); +} + +char * +Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv) +{ + return sv_2pv_nolen(sv); +} + +char * +Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp) +{ + return sv_2pv(sv,lp); +} + /* This function is only called on magical items */ bool Perl_sv_2bool(pTHX_ register SV *sv) @@ -2645,6 +2679,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) *SvEND(dstr) = '\0'; (void)SvPOK_only(dstr); } + if (SvUTF8(sstr)) + SvUTF8_on(dstr); /*SUPPRESS 560*/ if (sflags & SVp_NOK) { SvNOK_on(dstr); @@ -3174,6 +3210,7 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN SvCUR_set(bigstr, offset+len); } + SvTAINT(bigstr); i = littlelen - len; if (i > 0) { /* string might grow */ big = SvGROW(bigstr, SvCUR(bigstr) + i + 1); @@ -4022,10 +4059,6 @@ screamer2: } } -#ifdef WIN32 - win32_strip_return(sv); -#endif - return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch; } @@ -4660,6 +4693,42 @@ Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) } char * +Perl_sv_pvbyte(pTHX_ SV *sv) +{ + return sv_pv(sv); +} + +char * +Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp) +{ + return sv_pvn(sv,lp); +} + +char * +Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp) +{ + return sv_pvn_force(sv,lp); +} + +char * +Perl_sv_pvutf8(pTHX_ SV *sv) +{ + return sv_pv(sv); +} + +char * +Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp) +{ + return sv_pvn(sv,lp); +} + +char * +Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp) +{ + return sv_pvn_force(sv,lp); +} + +char * Perl_sv_reftype(pTHX_ SV *sv, int ob) { if (ob && SvOBJECT(sv)) @@ -5642,11 +5711,19 @@ Perl_re_dup(pTHX_ REGEXP *r) PerlIO * Perl_fp_dup(pTHX_ PerlIO *fp, char type) { + PerlIO *ret; if (!fp) return (PerlIO*)NULL; - return fp; /* XXX */ - /* return PerlIO_fdopen(PerlIO_fileno(fp), - type == '<' ? "r" : type == '>' ? "w" : "rw"); */ + + /* look for it in the table first */ + ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp); + if (ret) + return ret; + + /* create anew and remember what it is */ + ret = PerlIO_fdupopen(fp); + ptr_table_store(PL_ptr_table, fp, ret); + return ret; } DIR * @@ -5665,7 +5742,7 @@ Perl_gp_dup(pTHX_ GP *gp) if (!gp) return (GP*)NULL; /* look for it in the table first */ - ret = ptr_table_fetch(PL_ptr_table, gp); + ret = (GP*)ptr_table_fetch(PL_ptr_table, gp); if (ret) return ret; @@ -5696,7 +5773,10 @@ Perl_mg_dup(pTHX_ MAGIC *mg) MAGIC *mgprev; if (!mg) return (MAGIC*)NULL; - /* XXX need to handle aliases here? */ + /* look for it in the table first */ + mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg); + if (mgret) + return mgret; for (; mg; mg = mg->mg_moremagic) { MAGIC *nmg; @@ -5765,27 +5845,27 @@ Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv) } void -Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *old, void *new) +Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv) { PTR_TBL_ENT_t *tblent, **otblent; /* XXX this may be pessimal on platforms where pointers aren't good * hash values e.g. if they grow faster in the most significant * bits */ - UV hash = (UV)old; + UV hash = (UV)oldv; bool i = 1; assert(tbl); otblent = &tbl->tbl_ary[hash & tbl->tbl_max]; for (tblent = *otblent; tblent; i=0, tblent = tblent->next) { - if (tblent->oldval == old) { - tblent->newval = new; + if (tblent->oldval == oldv) { + tblent->newval = newv; tbl->tbl_items++; return; } } Newz(0, tblent, 1, PTR_TBL_ENT_t); - tblent->oldval = old; - tblent->newval = new; + tblent->oldval = oldv; + tblent->newval = newv; tblent->next = *otblent; *otblent = tblent; tbl->tbl_items++; @@ -5824,7 +5904,7 @@ Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl) } #ifdef DEBUGGING -DllExport char *PL_watch_pvx; +char *PL_watch_pvx; #endif SV * @@ -5838,7 +5918,7 @@ Perl_sv_dup(pTHX_ SV *sstr) if (!sstr || SvTYPE(sstr) == SVTYPEMASK) return Nullsv; /* look for it in the table first */ - dstr = ptr_table_fetch(PL_ptr_table, sstr); + dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr); if (dstr) return dstr; @@ -5996,11 +6076,11 @@ Perl_sv_dup(pTHX_ SV *sstr) SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ - IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr)); + IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr)); if (IoOFP(sstr) == IoIFP(sstr)) IoOFP(dstr) = IoIFP(dstr); else - IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr)); + IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr)); /* PL_rsfp_filters entries have fake IoDIRP() */ if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP)) IoDIRP(dstr) = dirp_dup(IoDIRP(sstr)); @@ -6036,6 +6116,7 @@ Perl_sv_dup(pTHX_ SV *sstr) src_ary = AvARRAY((AV*)sstr); Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*); + ptr_table_store(PL_ptr_table, src_ary, dst_ary); SvPVX(dstr) = (char*)dst_ary; AvALLOC((AV*)dstr) = dst_ary; if (AvREAL((AV*)sstr)) { @@ -6073,26 +6154,11 @@ Perl_sv_dup(pTHX_ SV *sstr) Newz(0, dxhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char); while (i <= sxhv->xhv_max) { - HE *dentry, *oentry; - entry = ((HE**)sxhv->xhv_array)[i]; - dentry = he_dup(entry, !!HvSHAREKEYS(sstr)); - ((HE**)dxhv->xhv_array)[i] = dentry; - while (entry) { - entry = HeNEXT(entry); - oentry = dentry; - dentry = he_dup(entry, !!HvSHAREKEYS(sstr)); - HeNEXT(oentry) = dentry; - } + ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i], + !!HvSHAREKEYS(sstr)); ++i; } - if (sxhv->xhv_riter >= 0 && sxhv->xhv_eiter) { - entry = ((HE**)sxhv->xhv_array)[sxhv->xhv_riter]; - while (entry && entry != sxhv->xhv_eiter) - entry = HeNEXT(entry); - dxhv->xhv_eiter = entry; - } - else - dxhv->xhv_eiter = (HE*)NULL; + dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr)); } else { SvPVX(dstr) = Nullch; @@ -6150,26 +6216,86 @@ dup_pvcv: } PERL_CONTEXT * -Perl_cx_dup(pTHX_ PERL_CONTEXT *cx, I32 ix, I32 max) +Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max) { - PERL_CONTEXT *ncx; + PERL_CONTEXT *ncxs; - if (!cx) + if (!cxs) return (PERL_CONTEXT*)NULL; /* look for it in the table first */ - ncx = ptr_table_fetch(PL_ptr_table, cx); - if (ncx) - return ncx; + ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs); + if (ncxs) + return ncxs; /* create anew and remember what it is */ - Newz(56, ncx, max + 1, PERL_CONTEXT); - ptr_table_store(PL_ptr_table, cx, ncx); + Newz(56, ncxs, max + 1, PERL_CONTEXT); + ptr_table_store(PL_ptr_table, cxs, ncxs); - /* XXX todo */ - /* ... */ - - return ncx; + while (ix >= 0) { + PERL_CONTEXT *cx = &cxs[ix]; + PERL_CONTEXT *ncx = &ncxs[ix]; + ncx->cx_type = cx->cx_type; + if (CxTYPE(cx) == CXt_SUBST) { + Perl_croak(aTHX_ "Cloning substitution context is unimplemented"); + } + else { + ncx->blk_oldsp = cx->blk_oldsp; + ncx->blk_oldcop = cx->blk_oldcop; + ncx->blk_oldretsp = cx->blk_oldretsp; + ncx->blk_oldmarksp = cx->blk_oldmarksp; + ncx->blk_oldscopesp = cx->blk_oldscopesp; + ncx->blk_oldpm = cx->blk_oldpm; + ncx->blk_gimme = cx->blk_gimme; + switch (CxTYPE(cx)) { + case CXt_SUB: + ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0 + ? cv_dup_inc(cx->blk_sub.cv) + : cv_dup(cx->blk_sub.cv)); + ncx->blk_sub.argarray = (cx->blk_sub.hasargs + ? av_dup_inc(cx->blk_sub.argarray) + : Nullav); + ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray); + ncx->blk_sub.olddepth = cx->blk_sub.olddepth; + ncx->blk_sub.hasargs = cx->blk_sub.hasargs; + ncx->blk_sub.lval = cx->blk_sub.lval; + break; + case CXt_EVAL: + ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval; + ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type; + ncx->blk_eval.old_name = SAVEPV(cx->blk_eval.old_name); + ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root; + ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text); + break; + case CXt_LOOP: + ncx->blk_loop.label = cx->blk_loop.label; + ncx->blk_loop.resetsp = cx->blk_loop.resetsp; + ncx->blk_loop.redo_op = cx->blk_loop.redo_op; + ncx->blk_loop.next_op = cx->blk_loop.next_op; + ncx->blk_loop.last_op = cx->blk_loop.last_op; + ncx->blk_loop.iterdata = (CxPADLOOP(cx) + ? cx->blk_loop.iterdata + : gv_dup((GV*)cx->blk_loop.iterdata)); + ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave); + ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval); + ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary); + ncx->blk_loop.iterix = cx->blk_loop.iterix; + ncx->blk_loop.itermax = cx->blk_loop.itermax; + break; + case CXt_FORMAT: + ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv); + ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv); + ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv); + ncx->blk_sub.hasargs = cx->blk_sub.hasargs; + break; + case CXt_BLOCK: + case CXt_NULL: + break; + } + } + --ix; + } + return ncxs; } PERL_SI * @@ -6181,7 +6307,7 @@ Perl_si_dup(pTHX_ PERL_SI *si) return (PERL_SI*)NULL; /* look for it in the table first */ - nsi = ptr_table_fetch(PL_ptr_table, si); + nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si); if (nsi) return nsi; @@ -6201,51 +6327,357 @@ Perl_si_dup(pTHX_ PERL_SI *si) return nsi; } +#define POPINT(ss,ix) ((ss)[--(ix)].any_i32) +#define TOPINT(ss,ix) ((ss)[ix].any_i32) +#define POPLONG(ss,ix) ((ss)[--(ix)].any_long) +#define TOPLONG(ss,ix) ((ss)[ix].any_long) +#define POPIV(ss,ix) ((ss)[--(ix)].any_iv) +#define TOPIV(ss,ix) ((ss)[ix].any_iv) +#define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr) +#define TOPPTR(ss,ix) ((ss)[ix].any_ptr) +#define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr) +#define TOPDPTR(ss,ix) ((ss)[ix].any_dptr) +#define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr) +#define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr) + +/* XXXXX todo */ +#define pv_dup_inc(p) SAVEPV(p) +#define pv_dup(p) SAVEPV(p) +#define svp_dup_inc(p,pp) any_dup(p,pp) + +void * +Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl) +{ + void *ret; + + if (!v) + return (void*)NULL; + + /* look for it in the table first */ + ret = ptr_table_fetch(PL_ptr_table, v); + if (ret) + return ret; + + /* see if it is part of the interpreter structure */ + if (v >= (void*)proto_perl && v < (void*)(proto_perl+1)) + ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl)); + else + ret = v; + + return ret; +} + ANY * -Perl_ss_dup(pTHX_ ANY *ss, I32 ix, I32 max) +Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) { - /* XXX todo */ - return NULL; + ANY *ss = proto_perl->Tsavestack; + I32 ix = proto_perl->Tsavestack_ix; + I32 max = proto_perl->Tsavestack_max; + ANY *nss; + SV *sv; + GV *gv; + AV *av; + HV *hv; + void* ptr; + int intval; + long longval; + GP *gp; + IV iv; + I32 i; + char *c; + void (*dptr) (void*); + void (*dxptr) (pTHXo_ void*); + + Newz(54, nss, max, ANY); + + while (ix > 0) { + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + switch (i) { + case SAVEt_ITEM: /* normal string */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + break; + case SAVEt_SV: /* scalar reference */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + gv = (GV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup_inc(gv); + break; + case SAVEt_GENERIC_SVREF: /* generic sv */ + case SAVEt_SVREF: /* scalar reference */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */ + break; + case SAVEt_AV: /* array reference */ + av = (AV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = av_dup_inc(av); + gv = (GV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup(gv); + break; + case SAVEt_HV: /* hash reference */ + hv = (HV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = hv_dup_inc(hv); + gv = (GV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup(gv); + break; + case SAVEt_INT: /* int reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + intval = (int)POPINT(ss,ix); + TOPINT(nss,ix) = intval; + break; + case SAVEt_LONG: /* long reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + longval = (long)POPLONG(ss,ix); + TOPLONG(nss,ix) = longval; + break; + case SAVEt_I32: /* I32 reference */ + case SAVEt_I16: /* I16 reference */ + case SAVEt_I8: /* I8 reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + case SAVEt_IV: /* IV reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + iv = POPIV(ss,ix); + TOPIV(nss,ix) = iv; + break; + case SAVEt_SPTR: /* SV* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup(sv); + break; + case SAVEt_VPTR: /* random* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + break; + case SAVEt_PPTR: /* char* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup(c); + break; + case SAVEt_HPTR: /* HV* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + hv = (HV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = hv_dup(hv); + break; + case SAVEt_APTR: /* AV* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + av = (AV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = av_dup(av); + break; + case SAVEt_NSTAB: + gv = (GV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup(gv); + break; + case SAVEt_GP: /* scalar reference */ + gp = (GP*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gp = gp_dup(gp); + (void)GpREFCNT_inc(gp); + gv = (GV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup_inc(c); + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup(c); + iv = POPIV(ss,ix); + TOPIV(nss,ix) = iv; + iv = POPIV(ss,ix); + TOPIV(nss,ix) = iv; + break; + case SAVEt_FREESV: + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + break; + case SAVEt_FREEOP: + ptr = POPPTR(ss,ix); + if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) { + /* these are assumed to be refcounted properly */ + switch (((OP*)ptr)->op_type) { + case OP_LEAVESUB: + case OP_LEAVESUBLV: + case OP_LEAVEEVAL: + case OP_LEAVE: + case OP_SCOPE: + case OP_LEAVEWRITE: + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + break; + default: + TOPPTR(nss,ix) = Nullop; + break; + } + } + else + TOPPTR(nss,ix) = Nullop; + break; + case SAVEt_FREEPV: + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup_inc(c); + break; + case SAVEt_CLEARSV: + longval = POPLONG(ss,ix); + TOPLONG(nss,ix) = longval; + break; + case SAVEt_DELETE: + hv = (HV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = hv_dup_inc(hv); + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup_inc(c); + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + case SAVEt_DESTRUCTOR: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ + dptr = POPDPTR(ss,ix); + TOPDPTR(nss,ix) = (void (*)(void*))any_dup(dptr, proto_perl); + break; + case SAVEt_DESTRUCTOR_X: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ + dxptr = POPDXPTR(ss,ix); + TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup(dxptr, proto_perl); + break; + case SAVEt_REGCONTEXT: + case SAVEt_ALLOC: + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + ix -= i; + break; + case SAVEt_STACK_POS: /* Position on Perl stack */ + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + case SAVEt_AELEM: /* array element */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + av = (AV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = av_dup_inc(av); + break; + case SAVEt_HELEM: /* hash element */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + hv = (HV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = hv_dup_inc(hv); + break; + case SAVEt_OP: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = ptr; + break; + case SAVEt_HINTS: + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + default: + Perl_croak(aTHX_ "panic: ss_dup inconsistency"); + } + } + + return nss; +} + +#ifdef PERL_OBJECT +#include "XSUB.h" +#endif + +PerlInterpreter * +perl_clone(PerlInterpreter *proto_perl, UV flags) +{ +#ifdef PERL_OBJECT + CPerlObj *pPerl = (CPerlObj*)proto_perl; +#endif + +#ifdef PERL_IMPLICIT_SYS + return perl_clone_using(proto_perl, flags, + proto_perl->IMem, + proto_perl->IMemShared, + proto_perl->IMemParse, + proto_perl->IEnv, + proto_perl->IStdIO, + proto_perl->ILIO, + proto_perl->IDir, + proto_perl->ISock, + proto_perl->IProc); } PerlInterpreter * perl_clone_using(PerlInterpreter *proto_perl, UV flags, - struct IPerlMem* ipM, struct IPerlEnv* ipE, + struct IPerlMem* ipM, struct IPerlMem* ipMS, + struct IPerlMem* ipMP, struct IPerlEnv* ipE, struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, struct IPerlDir* ipD, struct IPerlSock* ipS, struct IPerlProc* ipP) { + /* XXX many of the string copies here can be optimized if they're + * constants; they need to be allocated as common memory and just + * their pointers copied. */ + IV i; SV *sv; SV **svp; +# ifdef PERL_OBJECT + CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO, + ipD, ipS, ipP); + PERL_SET_INTERP(pPerl); +# else /* !PERL_OBJECT */ PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); PERL_SET_INTERP(my_perl); -#ifdef DEBUGGING +# ifdef DEBUGGING memset(my_perl, 0xab, sizeof(PerlInterpreter)); PL_markstack = 0; PL_scopestack = 0; PL_savestack = 0; PL_retstack = 0; -#else +# else /* !DEBUGGING */ Zero(my_perl, 1, PerlInterpreter); -# if 0 - Copy(proto_perl, my_perl, 1, PerlInterpreter); -# endif -#endif - - /* XXX many of the string copies here can be optimized if they're - * constants; they need to be allocated as common memory and just - * their pointers copied. */ +# endif /* DEBUGGING */ /* host pointers */ PL_Mem = ipM; + PL_MemShared = ipMS; + PL_MemParse = ipMP; PL_Env = ipE; PL_StdIO = ipStd; PL_LIO = ipLIO; PL_Dir = ipD; PL_Sock = ipS; PL_Proc = ipP; +# endif /* PERL_OBJECT */ +#else /* !PERL_IMPLICIT_SYS */ + IV i; + SV *sv; + SV **svp; + PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); + PERL_SET_INTERP(my_perl); + +# ifdef DEBUGGING + memset(my_perl, 0xab, sizeof(PerlInterpreter)); + PL_markstack = 0; + PL_scopestack = 0; + PL_savestack = 0; + PL_retstack = 0; +# else /* !DEBUGGING */ + Zero(my_perl, 1, PerlInterpreter); +# endif /* DEBUGGING */ +#endif /* PERL_IMPLICIT_SYS */ /* arena roots */ PL_xiv_arenaroot = NULL; @@ -6280,7 +6712,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL; ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef); +#ifdef PERL_OBJECT + SvUPGRADE(&PL_sv_no, SVt_PVNV); +#else SvANY(&PL_sv_no) = new_XPVNV(); +#endif SvREFCNT(&PL_sv_no) = (~(U32)0)/2; SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0); @@ -6289,7 +6725,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, SvNVX(&PL_sv_no) = 0; ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no); +#ifdef PERL_OBJECT + SvUPGRADE(&PL_sv_yes, SVt_PVNV); +#else SvANY(&PL_sv_yes) = new_XPVNV(); +#endif SvREFCNT(&PL_sv_yes) = (~(U32)0)/2; SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1); @@ -6307,12 +6747,10 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_compiling = proto_perl->Icompiling; PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv); PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file); + ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling); if (!specialWARN(PL_compiling.cop_warnings)) PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings); - if (proto_perl->Tcurcop == &proto_perl->Icompiling) - PL_curcop = &PL_compiling; - else - PL_curcop = proto_perl->Tcurcop; + PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl); /* pseudo environmental stuff */ PL_origargc = proto_perl->Iorigargc; @@ -6331,7 +6769,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* switches */ PL_minus_c = proto_perl->Iminus_c; - Copy(proto_perl->Ipatchlevel, PL_patchlevel, 10, char); + PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel); PL_localpatches = proto_perl->Ilocalpatches; PL_splitstr = proto_perl->Isplitstr; PL_preprocess = proto_perl->Ipreprocess; @@ -6418,14 +6856,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_main_cv = cv_dup_inc(proto_perl->Imain_cv); PL_main_root = OpREFCNT_inc(proto_perl->Imain_root); PL_main_start = proto_perl->Imain_start; - PL_eval_root = proto_perl->Ieval_root; + PL_eval_root = OpREFCNT_inc(proto_perl->Ieval_root); PL_eval_start = proto_perl->Ieval_start; /* runtime control stuff */ - if (proto_perl->Icurcopdb == &proto_perl->Icompiling) - PL_curcopdb = &PL_compiling; - else - PL_curcopdb = proto_perl->Icurcopdb; + PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl); PL_copline = proto_perl->Icopline; PL_filemode = proto_perl->Ifilemode; @@ -6464,7 +6899,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_comppad_name = av_dup(proto_perl->Icomppad_name); PL_comppad_name_fill = proto_perl->Icomppad_name_fill; PL_comppad_name_floor = proto_perl->Icomppad_name_floor; - PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : (SV**)NULL; + PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table, + proto_perl->Tcurpad); #ifdef HAVE_INTERP_INTERN sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern); @@ -6473,7 +6909,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* more statics moved here */ PL_generation = proto_perl->Igeneration; PL_DBcv = cv_dup(proto_perl->IDBcv); - PL_archpat_auto = SAVEPV(proto_perl->Iarchpat_auto); PL_in_clean_objs = proto_perl->Iin_clean_objs; PL_in_clean_all = proto_perl->Iin_clean_all; @@ -6508,7 +6943,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_lex_defer = proto_perl->Ilex_defer; PL_lex_expect = proto_perl->Ilex_expect; PL_lex_formbrack = proto_perl->Ilex_formbrack; - PL_lex_fakebrack = proto_perl->Ilex_fakebrack; PL_lex_dojoin = proto_perl->Ilex_dojoin; PL_lex_starts = proto_perl->Ilex_starts; PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff); @@ -6610,7 +7044,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_last_swash_hv = Nullhv; /* reinits on demand */ PL_last_swash_klen = 0; PL_last_swash_key[0]= '\0'; - PL_last_swash_tmps = Nullch; + PL_last_swash_tmps = (U8*)NULL; PL_last_swash_slen = 0; /* perly.c globals */ @@ -6626,6 +7060,19 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_uudmap['M'] = 0; /* reinits on demand */ PL_bitcount = Nullch; /* reinits on demand */ + if (proto_perl->Ipsig_ptr) { + int sig_num[] = { SIG_NUM }; + Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*); + Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*); + for (i = 1; PL_sig_name[i]; i++) { + PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]); + PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]); + } + } + else { + PL_psig_ptr = (SV**)NULL; + PL_psig_name = (SV**)NULL; + } /* thrdvar.h stuff */ @@ -6658,15 +7105,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, Newz(54, PL_scopestack, PL_scopestack_max, I32); Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32); - /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix] - * NOTE: unlike the others! */ - PL_savestack_ix = proto_perl->Tsavestack_ix; - PL_savestack_max = proto_perl->Tsavestack_max; - /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/ - PL_savestack = ss_dup(proto_perl->Tsavestack, - PL_savestack_ix, - PL_savestack_max); - /* next push_return() sets PL_retstack[PL_retstack_ix] * NOTE: unlike the others! */ PL_retstack_ix = proto_perl->Tretstack_ix; @@ -6686,6 +7124,13 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp - proto_perl->Tstack_base); PL_stack_max = PL_stack_base + AvMAX(PL_curstack); + + /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix] + * NOTE: unlike the others! */ + PL_savestack_ix = proto_perl->Tsavestack_ix; + PL_savestack_max = proto_perl->Tsavestack_max; + /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/ + PL_savestack = ss_dup(proto_perl); } else { init_stacks(); @@ -6736,10 +7181,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_lastgotoprobe = Nullop; PL_dumpindent = proto_perl->Tdumpindent; - if (proto_perl->Tsortcop == (OP*)&proto_perl->Icompiling) - PL_sortcop = (OP*)&PL_compiling; - else - PL_sortcop = proto_perl->Tsortcop; + PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl); PL_sortstash = hv_dup(proto_perl->Tsortstash); PL_firstgv = gv_dup(proto_perl->Tfirstgv); PL_secondgv = gv_dup(proto_perl->Tsecondgv); @@ -6818,22 +7260,21 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_reginterp_cnt = 0; PL_reg_starttry = 0; +#ifdef PERL_OBJECT + return (PerlInterpreter*)pPerl; +#else return my_perl; +#endif } -PerlInterpreter * -perl_clone(pTHXx_ UV flags) -{ - return perl_clone_using(aTHXx_ flags, PL_Mem, PL_Env, PL_StdIO, PL_LIO, - PL_Dir, PL_Sock, PL_Proc); -} - -#endif /* USE_ITHREADS */ +#else /* !USE_ITHREADS */ #ifdef PERL_OBJECT #include "XSUB.h" #endif +#endif /* USE_ITHREADS */ + static void do_report_used(pTHXo_ SV *sv) { @@ -137,13 +137,16 @@ struct io { #define SVf_BREAK 0x00400000 /* refcnt is artificially low */ #define SVf_READONLY 0x00800000 /* may not be modified */ -#define SVf_THINKFIRST (SVf_READONLY|SVf_ROK|SVf_FAKE) #define SVp_IOK 0x01000000 /* has valid non-public integer value */ #define SVp_NOK 0x02000000 /* has valid non-public numeric value */ #define SVp_POK 0x04000000 /* has valid non-public pointer value */ #define SVp_SCREAM 0x08000000 /* has been studied? */ +#define SVf_UTF8 0x20000000 /* SvPVX is UTF-8 encoded */ + +#define SVf_THINKFIRST (SVf_READONLY|SVf_ROK|SVf_FAKE|SVf_UTF8) + #define SVf_OK (SVf_IOK|SVf_NOK|SVf_POK|SVf_ROK| \ SVp_IOK|SVp_NOK|SVp_POK) @@ -155,6 +158,8 @@ struct io { #define SVpad_OUR 0x80000000 /* pad name is "our" instead of "my" */ +#define SVpad_OUR 0x80000000 /* pad name is "our" instead of "my" */ + #define SVf_IVisUV 0x80000000 /* use XPVUV instead of XPVIV */ #define SVpfm_COMPILED 0x80000000 /* FORMLINE is compiled */ @@ -354,7 +359,7 @@ struct xpvio { SvFLAGS(sv) |= (SVf_IOK|SVp_IOK)) #define SvIOK_only_UV(sv) (SvOK_off_exc_UV(sv), \ SvFLAGS(sv) |= (SVf_IOK|SVp_IOK)) - + #define SvIOK_UV(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) \ == (SVf_IOK|SVf_IVisUV)) #define SvIOK_notUV(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) \ @@ -370,6 +375,10 @@ struct xpvio { #define SvNOK_only(sv) (SvOK_off(sv), \ SvFLAGS(sv) |= (SVf_NOK|SVp_NOK)) +#define SvUTF8(sv) (SvFLAGS(sv) & SVf_UTF8) +#define SvUTF8_on(sv) (SvFLAGS(sv) |= (SVf_UTF8)) +#define SvUTF8_off(sv) (SvFLAGS(sv) &= ~(SVf_UTF8)) + #define SvPOK(sv) (SvFLAGS(sv) & SVf_POK) #define SvPOK_on(sv) (SvFLAGS(sv) |= (SVf_POK|SVp_POK)) #define SvPOK_off(sv) (SvFLAGS(sv) &= ~(SVf_POK|SVp_POK)) @@ -545,11 +554,26 @@ struct xpvio { #define SvPV_force(sv, lp) sv_pvn_force(sv, &lp) #define SvPV(sv, lp) sv_pvn(sv, &lp) #define SvPV_nolen(sv) sv_pv(sv) + +#define SvPVutf8_force(sv, lp) sv_pvutf8n_force(sv, &lp) +#define SvPVutf8(sv, lp) sv_pvutf8n(sv, &lp) +#define SvPVutf8_nolen(sv) sv_pvutf8(sv) + +#define SvPVbyte_force(sv, lp) sv_pvbyte_force(sv, &lp) +#define SvPVbyte(sv, lp) sv_pvbyten(sv, &lp) +#define SvPVbyte_nolen(sv) sv_pvbyte(sv) + +#define SvPVx(sv, lp) sv_pvn(sv, &lp) +#define SvPVx_force(sv, lp) sv_pvn_force(sv, &lp) +#define SvPVutf8x(sv, lp) sv_pvutf8n(sv, &lp) +#define SvPVutf8x_force(sv, lp) sv_pvutf8n_force(sv, &lp) +#define SvPVbytex(sv, lp) sv_pvbyten(sv, &lp) +#define SvPVbytex_force(sv, lp) sv_pvbyten_force(sv, &lp) + #define SvIVx(sv) sv_iv(sv) #define SvUVx(sv) sv_uv(sv) #define SvNVx(sv) sv_nv(sv) -#define SvPVx(sv, lp) sv_pvn(sv, &lp) -#define SvPVx_force(sv, lp) sv_pvn_force(sv, &lp) + #define SvTRUEx(sv) sv_true(sv) #define SvIV(sv) SvIVx(sv) @@ -572,7 +596,9 @@ struct xpvio { #undef SvPV #define SvPV(sv, lp) \ - (SvPOK(sv) ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv(sv, &lp)) + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv(sv, &lp)) + #undef SvPV_force #define SvPV_force(sv, lp) \ @@ -581,19 +607,70 @@ struct xpvio { #undef SvPV_nolen #define SvPV_nolen(sv) \ - (SvPOK(sv) ? SvPVX(sv) : sv_2pv_nolen(sv)) + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_nolen(sv)) + +#undef SvPVutf8 +#define SvPVutf8(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK|SVf_UTF8) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvutf8(sv, &lp)) + +#undef SvPVutf8_force +#define SvPVutf8_force(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == (SVf_POK|SVf_UTF8) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvutf8n_force(sv, &lp)) + +#undef SvPVutf8_nolen +#define SvPVutf8_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK|SVf_UTF8)\ + ? SvPVX(sv) : sv_2pvutf8_nolen(sv)) + +#undef SvPVutf8 +#define SvPVutf8(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK|SVf_UTF8) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvutf8(sv, &lp)) + +#undef SvPVutf8_force +#define SvPVutf8_force(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == (SVf_POK|SVf_UTF8) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvutf8n_force(sv, &lp)) + +#undef SvPVutf8_nolen +#define SvPVutf8_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK|SVf_UTF8)\ + ? SvPVX(sv) : sv_2pvutf8_nolen(sv)) + +#undef SvPVbyte +#define SvPVbyte(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) + +#undef SvPVbyte_force +#define SvPVbyte_force(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8|SVf_THINKFIRST)) == (SVf_POK) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvbyte_force(sv, &lp)) + +#undef SvPVbyte_nolen +#define SvPVbyte_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK)\ + ? SvPVX(sv) : sv_2pvbyte_nolen(sv)) + #ifdef __GNUC__ # undef SvIVx # undef SvUVx # undef SvNVx # undef SvPVx +# undef SvPVutf8x +# undef SvPVbytex # undef SvTRUE # undef SvTRUEx # define SvIVx(sv) ({SV *nsv = (SV*)(sv); SvIV(nsv); }) # define SvUVx(sv) ({SV *nsv = (SV*)(sv); SvUV(nsv); }) # define SvNVx(sv) ({SV *nsv = (SV*)(sv); SvNV(nsv); }) # define SvPVx(sv, lp) ({SV *nsv = (sv); SvPV(nsv, lp); }) +# define SvPVutf8x(sv, lp) ({SV *nsv = (sv); SvPVutf8(nsv, lp); }) +# define SvPVbytex(sv, lp) ({SV *nsv = (sv); SvPVbyte(nsv, lp); }) # define SvTRUE(sv) ( \ !sv \ ? 0 \ @@ -621,12 +698,16 @@ struct xpvio { # undef SvUVx # undef SvNVx # undef SvPVx +# undef SvPVutf8x +# undef SvPVbytex # undef SvTRUE # undef SvTRUEx # define SvIVx(sv) ((PL_Sv = (sv)), SvIV(PL_Sv)) # define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) # define SvNVx(sv) ((PL_Sv = (sv)), SvNV(PL_Sv)) # define SvPVx(sv, lp) ((PL_Sv = (sv)), SvPV(PL_Sv, lp)) +# define SvPVutf8x(sv, lp) ((PL_Sv = (sv)), SvPVutf8(PL_Sv, lp)) +# define SvPVbytex(sv, lp) ((PL_Sv = (sv)), SvPVbyte(PL_Sv, lp)) # define SvTRUE(sv) ( \ !sv \ ? 0 \ @@ -153,7 +153,7 @@ EOT } } else { - $pct = sprintf("%.2f", ($files - $bad) / $files * 100); + $pct = $files ? sprintf("%.2f", ($files - $bad) / $files * 100) : "0.00"; if ($bad == 1) { warn "Failed 1 test script out of $files, $pct% okay.\n"; } diff --git a/t/comp/require.t b/t/comp/require.t index 581dcba75c..d4c9d8ca61 100755 --- a/t/comp/require.t +++ b/t/comp/require.t @@ -7,7 +7,7 @@ BEGIN { # don't make this lexical $i = 1; -print "1..4\n"; +print "1..16\n"; sub do_require { %INC = (); @@ -23,6 +23,56 @@ sub write_file { close REQ; } +# new style version numbers + +eval { require v5.5.630; }; +print "# $@\nnot " if $@; +print "ok ",$i++,"\n"; + +eval { require v10.0.2; }; +print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/; +print "ok ",$i++,"\n"; + +eval q{ use v5.5.630; }; +print "# $@\nnot " if $@; +print "ok ",$i++,"\n"; + +eval q{ use v10.0.2; }; +print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/; +print "ok ",$i++,"\n"; + +my $ver = v5.5.630; +eval { require $ver; }; +print "# $@\nnot " if $@; +print "ok ",$i++,"\n"; + +$ver = v10.0.2; +eval { require $ver; }; +print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/; +print "ok ",$i++,"\n"; + +print "not " unless v5.5.1 gt v5.5; +print "ok ",$i++,"\n"; + +print "not " unless 5.005_01 > v5.5; +print "ok ",$i++,"\n"; + +print "not " unless 5.005_64 - v5.5.640 < 0.0000001; +print "ok ",$i++,"\n"; + +{ + use utf8; + print "not " unless v5.5.640 eq "\x{5}\x{5}\x{280}"; + print "ok ",$i++,"\n"; + + print "not " unless v7.15 eq "\x{7}\x{f}"; + print "ok ",$i++,"\n"; + + print "not " + unless v1.20.300.4000.50000.600000 eq "\x{1}\x{14}\x{12c}\x{fa0}\x{c350}\x{927c0}"; + print "ok ",$i++,"\n"; +} + # interaction with pod (see the eof) write_file('bleah.pm', "print 'ok $i\n'; 1;\n"); require "bleah.pm"; diff --git a/t/comp/term.t b/t/comp/term.t index eb9968003e..f079eef58b 100755 --- a/t/comp/term.t +++ b/t/comp/term.t @@ -1,10 +1,8 @@ #!./perl -# $RCSfile: term.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:24 $ - # tests that aren't important enough for base.term -print "1..22\n"; +print "1..23\n"; $x = "\\n"; print "#1\t:$x: eq " . ':\n:' . "\n"; @@ -68,3 +66,7 @@ if (ref($a) eq 'HASH') {print "ok 21\n";} else {print "not ok 21\n";} $a = "+{ \$a=>'foo'}"; $a = eval $a; if (ref($a) eq 'HASH') {print "ok 22\n";} else {print "not ok 22\n";} + +$a = "{ 0x01 => 'foo'}->{0x01}"; +$a = eval $a; +if ($a eq 'foo') {print "ok 23\n";} else {print "not ok 23\n";} diff --git a/t/io/argv.t b/t/io/argv.t index c6565dc9c7..d6093f90ef 100755 --- a/t/io/argv.t +++ b/t/io/argv.t @@ -1,24 +1,33 @@ #!./perl -print "1..6\n"; +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +print "1..20\n"; + +use File::Spec; + +my $devnull = File::Spec->devnull; -open(try, '>Io.argv.tmp') || (die "Can't open temp file: $!"); +open(try, '>Io_argv1.tmp') || (die "Can't open temp file: $!"); print try "a line\n"; close try; if ($^O eq 'MSWin32') { - $x = `.\\perl -e "while (<>) {print \$.,\$_;}" Io.argv.tmp Io.argv.tmp`; + $x = `.\\perl -e "while (<>) {print \$.,\$_;}" Io_argv1.tmp Io_argv1.tmp`; } else { - $x = `./perl -e 'while (<>) {print \$.,\$_;}' Io.argv.tmp Io.argv.tmp`; + $x = `./perl -e 'while (<>) {print \$.,\$_;}' Io_argv1.tmp Io_argv1.tmp`; } if ($x eq "1a line\n2a line\n") {print "ok 1\n";} else {print "not ok 1\n";} if ($^O eq 'MSWin32') { - $x = `.\\perl -le "print 'foo'" | .\\perl -e "while (<>) {print \$_;}" Io.argv.tmp -`; + $x = `.\\perl -le "print 'foo'" | .\\perl -e "while (<>) {print \$_;}" Io_argv1.tmp -`; } else { - $x = `echo foo|./perl -e 'while (<>) {print $_;}' Io.argv.tmp -`; + $x = `echo foo|./perl -e 'while (<>) {print $_;}' Io_argv1.tmp -`; } if ($x eq "a line\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";} @@ -30,7 +39,7 @@ else { } if ($x eq "foo\n") {print "ok 3\n";} else {print "not ok 3 :$x:\n";} -@ARGV = ('Io.argv.tmp', 'Io.argv.tmp', '/dev/null', 'Io.argv.tmp'); +@ARGV = ('Io_argv1.tmp', 'Io_argv1.tmp', $devnull, 'Io_argv1.tmp'); while (<>) { $y .= $. . $_; if (eof()) { @@ -43,17 +52,74 @@ if ($y eq "1a line\n2a line\n3a line\n") else {print "not ok 5\n";} -open(try, '>Io.argv.tmp') or die "Can't open temp file: $!"; +open(try, '>Io_argv1.tmp') or die "Can't open temp file: $!"; close try; -@ARGV = 'Io.argv.tmp'; +open(try, '>Io_argv2.tmp') or die "Can't open temp file: $!"; +close try; +@ARGV = ('Io_argv1.tmp', 'Io_argv2.tmp'); $^I = '.bak'; $/ = undef; +my $i = 6; while (<>) { - s/^/ok 6\n/; + s/^/ok $i\n/; + ++$i; print; } -open(try, '<Io.argv.tmp') or die "Can't open temp file: $!"; +open(try, '<Io_argv1.tmp') or die "Can't open temp file: $!"; +print while <try>; +open(try, '<Io_argv2.tmp') or die "Can't open temp file: $!"; print while <try>; close try; +undef $^I; + +eof try or print 'not '; +print "ok 8\n"; + +eof NEVEROPENED or print 'not '; +print "ok 9\n"; + +open STDIN, 'Io_argv1.tmp' or die $!; +@ARGV = (); +!eof() or print 'not '; +print "ok 10\n"; + +<> eq "ok 6\n" or print 'not '; +print "ok 11\n"; + +open STDIN, $devnull or die $!; +@ARGV = (); +eof() or print 'not '; +print "ok 12\n"; + +@ARGV = ('Io_argv1.tmp'); +!eof() or print 'not '; +print "ok 13\n"; + +@ARGV = ($devnull, $devnull); +!eof() or print 'not '; +print "ok 14\n"; + +close ARGV or die $!; +eof() or print 'not '; +print "ok 15\n"; + +{ + local $/; + open F, 'Io_argv1.tmp' or die; + <F>; # set $. = 1 + open F, $devnull or die; + print "not " unless defined(<F>); + print "ok 16\n"; + print "not " if defined(<F>); + print "ok 17\n"; + print "not " if defined(<F>); + print "ok 18\n"; + open F, $devnull or die; # restart cycle again + print "not " unless defined(<F>); + print "ok 19\n"; + print "not " if defined(<F>); + print "ok 20\n"; + close F; +} -END { unlink 'Io.argv.tmp', 'Io.argv.tmp.bak' } +END { unlink 'Io_argv1.tmp', 'Io_argv1.tmp.bak', 'Io_argv2.tmp', 'Io_argv2.tmp.bak' } diff --git a/t/io/nargv.t b/t/io/nargv.t index f32e40d6ee..fb13857618 100755 --- a/t/io/nargv.t +++ b/t/io/nargv.t @@ -56,7 +56,7 @@ sub other { } sub mkfiles { - my @files = map { "scratch.$_" } @_; + my @files = map { "scratch$_" } @_; return wantarray ? @files : $files[-1]; } diff --git a/t/io/open.t b/t/io/open.t index 905aee50af..1e9409171c 100755 --- a/t/io/open.t +++ b/t/io/open.t @@ -5,110 +5,273 @@ $| = 1; $^W = 1; $Is_VMS = $^O eq 'VMS'; -print "1..32\n"; +print "1..66\n"; + +my $test = 1; + +sub ok { print "ok $test\n"; $test++ } # my $file tests +# 1..9 { -unlink("afile") if -f "afile"; -print "$!\nnot " unless open(my $f,"+>afile"); -print "ok 1\n"; -binmode $f; -print "not " unless -f "afile"; -print "ok 2\n"; -print "not " unless print $f "SomeData\n"; -print "ok 3\n"; -print "not " unless tell($f) == 9; -print "ok 4\n"; -print "not " unless seek($f,0,0); -print "ok 5\n"; -$b = <$f>; -print "not " unless $b eq "SomeData\n"; -print "ok 6\n"; -print "not " unless -f $f; -print "ok 7\n"; -eval { die "Message" }; -# warn $@; -print "not " unless $@ =~ /<\$f> line 1/; -print "ok 8\n"; -print "not " unless close($f); -print "ok 9\n"; -unlink("afile"); + unlink("afile") if -f "afile"; + print "$!\nnot " unless open(my $f,"+>afile"); + ok; + binmode $f; + print "not " unless -f "afile"; + ok; + print "not " unless print $f "SomeData\n"; + ok; + print "not " unless tell($f) == 9; + ok; + print "not " unless seek($f,0,0); + ok; + $b = <$f>; + print "not " unless $b eq "SomeData\n"; + ok; + print "not " unless -f $f; + ok; + eval { die "Message" }; + # warn $@; + print "not " unless $@ =~ /<\$f> line 1/; + ok; + print "not " unless close($f); + ok; + unlink("afile"); } + +# 10..12 { -print "# \$!='$!'\nnot " unless open(my $f,'>', 'afile'); -print "ok 10\n"; -print $f "a row\n"; -print "not " unless close($f); -print "ok 11\n"; -print "not " unless -s 'afile' < 10; -print "ok 12\n"; + print "# \$!='$!'\nnot " unless open(my $f,'>', 'afile'); + ok; + print $f "a row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' < 10; + ok; } + +# 13..15 { -print "# \$!='$!'\nnot " unless open(my $f,'>>', 'afile'); -print "ok 13\n"; -print $f "a row\n"; -print "not " unless close($f); -print "ok 14\n"; -print "not " unless -s 'afile' > 10; -print "ok 15\n"; + print "# \$!='$!'\nnot " unless open(my $f,'>>', 'afile'); + ok; + print $f "a row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' > 10; + ok; } + +# 16..18 { -print "# \$!='$!'\nnot " unless open(my $f, '<', 'afile'); -print "ok 16\n"; -@rows = <$f>; -print "not " unless @rows == 2; -print "ok 17\n"; -print "not " unless close($f); -print "ok 18\n"; + print "# \$!='$!'\nnot " unless open(my $f, '<', 'afile'); + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + print "not " unless close($f); + ok; } + +# 19..23 { -print "not " unless -s 'afile' < 20; -print "ok 19\n"; -print "# \$!='$!'\nnot " unless open(my $f, '+<', 'afile'); -print "ok 20\n"; -@rows = <$f>; -print "not " unless @rows == 2; -print "ok 21\n"; -seek $f, 0, 1; -print $f "yet another row\n"; -print "not " unless close($f); -print "ok 22\n"; -print "not " unless -s 'afile' > 20; -print "ok 23\n"; - -unlink("afile"); -} -if ($Is_VMS) { for (24..26) { print "ok $_ # skipped: not Unix fork\n"; } } + print "not " unless -s 'afile' < 20; + ok; + print "# \$!='$!'\nnot " unless open(my $f, '+<', 'afile'); + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + seek $f, 0, 1; + print $f "yet another row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' > 20; + ok; + + unlink("afile"); +} + +# 24..26 +if ($Is_VMS) { + for (24..26) { print "ok $_ # skipped: not Unix fork\n"; } +} else { -print "# \$!='$!'\nnot " unless open(my $f, '-|', <<'EOC'); -./perl -e "print qq(a row\n); print qq(another row\n)" + print "# \$!='$!'\nnot " unless open(my $f, '-|', <<'EOC'); + ./perl -e "print qq(a row\n); print qq(another row\n)" EOC -print "ok 24\n"; -@rows = <$f>; -print "not " unless @rows == 2; -print "ok 25\n"; -print "not " unless close($f); -print "ok 26\n"; -} -if ($Is_VMS) { for (27..30) { print "ok $_ # skipped: not Unix fork\n"; } } + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + print "not " unless close($f); + ok; +} + +# 27..30 +if ($Is_VMS) { + for (27..30) { print "ok $_ # skipped: not Unix fork\n"; } +} else { -print "# \$!='$!'\nnot " unless open(my $f, '|-', <<'EOC'); -./perl -pe "s/^not //" + print "# \$!='$!'\nnot " unless open(my $f, '|-', <<'EOC'); + ./perl -pe "s/^not //" EOC -print "ok 27\n"; -@rows = <$f>; -print $f "not ok 28\n"; -print $f "not ok 29\n"; -print "#\nnot " unless close($f); -sleep 1; -print "ok 30\n"; + ok; + @rows = <$f>; + print $f "not ok $test\n"; $test++; + print $f "not ok $test\n"; $test++; + print "#\nnot " unless close($f); + sleep 1; + ok; } +# 31..32 eval <<'EOE' and print "not "; open my $f, '<&', 'afile'; 1; EOE -print "ok 31\n"; +ok; +$@ =~ /Unknown open\(\) mode \'<&\'/ or print "not "; +ok; + +# local $file tests + +# 33..41 +{ + unlink("afile") if -f "afile"; + print "$!\nnot " unless open(local $f,"+>afile"); + ok; + binmode $f; + print "not " unless -f "afile"; + ok; + print "not " unless print $f "SomeData\n"; + ok; + print "not " unless tell($f) == 9; + ok; + print "not " unless seek($f,0,0); + ok; + $b = <$f>; + print "not " unless $b eq "SomeData\n"; + ok; + print "not " unless -f $f; + ok; + eval { die "Message" }; + # warn $@; + print "not " unless $@ =~ /<\$f> line 1/; + ok; + print "not " unless close($f); + ok; + unlink("afile"); +} + +# 42..44 +{ + print "# \$!='$!'\nnot " unless open(local $f,'>', 'afile'); + ok; + print $f "a row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' < 10; + ok; +} + +# 45..47 +{ + print "# \$!='$!'\nnot " unless open(local $f,'>>', 'afile'); + ok; + print $f "a row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' > 10; + ok; +} + +# 48..50 +{ + print "# \$!='$!'\nnot " unless open(local $f, '<', 'afile'); + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + print "not " unless close($f); + ok; +} + +# 51..55 +{ + print "not " unless -s 'afile' < 20; + ok; + print "# \$!='$!'\nnot " unless open(local $f, '+<', 'afile'); + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + seek $f, 0, 1; + print $f "yet another row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' > 20; + ok; + + unlink("afile"); +} + +# 56..58 +if ($Is_VMS) { + for (56..58) { print "ok $_ # skipped: not Unix fork\n"; } +} +else { + print "# \$!='$!'\nnot " unless open(local $f, '-|', <<'EOC'); + ./perl -e "print qq(a row\n); print qq(another row\n)" +EOC + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + print "not " unless close($f); + ok; +} + +# 59..62 +if ($Is_VMS) { + for (59..62) { print "ok $_ # skipped: not Unix fork\n"; } +} +else { + print "# \$!='$!'\nnot " unless open(local $f, '|-', <<'EOC'); + ./perl -pe "s/^not //" +EOC + ok; + @rows = <$f>; + print $f "not ok $test\n"; $test++; + print $f "not ok $test\n"; $test++; + print "#\nnot " unless close($f); + sleep 1; + ok; +} + +# 63..64 +eval <<'EOE' and print "not "; +open local $f, '<&', 'afile'; +1; +EOE +ok; $@ =~ /Unknown open\(\) mode \'<&\'/ or print "not "; -print "ok 32\n"; +ok; + +# 65..66 +{ + local *F; + for (1..2) { + open(F, "echo #foo|") or print "not "; + print <F>; + close F; + } + ok; + for (1..2) { + open(F, "-|", "echo #foo") or print "not "; + print <F>; + close F; + } + ok; +} diff --git a/t/lib/bigfltpm.t b/t/lib/bigfltpm.t index 42cd9583d1..4cfd36e02d 100755 --- a/t/lib/bigfltpm.t +++ b/t/lib/bigfltpm.t @@ -9,7 +9,7 @@ use Math::BigFloat; $test = 0; $| = 1; -print "1..358\n"; +print "1..362\n"; while (<DATA>) { chop; if (s/^&//) { @@ -41,15 +41,15 @@ while (<DATA>) { $try .= "0+\$x->fsqrt;"; } else { $try .= "\$y = new Math::BigFloat \"$args[1]\";"; - if ($f eq fcmp){ + if ($f eq "fcmp") { $try .= "\$x <=> \$y;"; - }elsif ($f eq fadd){ + } elsif ($f eq "fadd") { $try .= "\$x + \$y;"; - }elsif ($f eq fsub){ + } elsif ($f eq "fsub") { $try .= "\$x - \$y;"; - }elsif ($f eq fmul){ + } elsif ($f eq "fmul") { $try .= "\$x * \$y;"; - }elsif ($f eq fdiv){ + } elsif ($f eq "fdiv") { $try .= "\$x / \$y;"; } else { warn "Unknown op"; } } @@ -271,6 +271,10 @@ abc:+0: +1:-1:1 -1:-1:0 +1:+1:0 +-1.1:0:-1 ++0:-1.1:1 ++1.1:+0:1 ++0:+1.1:-1 +123:+123:0 +123:+12:1 +12:+123:-1 diff --git a/t/lib/charnames.t b/t/lib/charnames.t index b03083e6d1..9775b141b2 100644 --- a/t/lib/charnames.t +++ b/t/lib/charnames.t @@ -12,7 +12,7 @@ print "1..5\n"; use charnames ':full'; -print "not " unless "Here\N{EXCLAMATION MARK}?" eq 'Here!?'; +print "not " unless "Here\N{EXCLAMATION MARK}?" eq "Here\041?"; print "ok 1\n"; { diff --git a/t/lib/dumper.t b/t/lib/dumper.t index 9130d1c690..0ac269620d 100755 --- a/t/lib/dumper.t +++ b/t/lib/dumper.t @@ -9,6 +9,8 @@ BEGIN { } use Data::Dumper; +use Config; +my $Is_ebcdic = defined($Config{'ebcdic'}) && $Config{'ebcdic'} eq 'define'; $Data::Dumper::Pad = "#"; my $TMAX; @@ -22,6 +24,14 @@ sub TEST { ++$TNUM; $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g if ($WANT =~ /deadbeef/); + if ($Is_ebcdic) { + # these data need massaging with non ascii character sets + # because of hashing order differences + $WANT = join("\n",sort(split(/\n/,$WANT))); + $WANT =~ s/\,$//mg; + $t = join("\n",sort(split(/\n/,$t))); + $t =~ s/\,$//mg; + } print( ($t eq $WANT and not $@) ? "ok $TNUM\n" : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n"); @@ -33,6 +43,13 @@ sub TEST { ++$TNUM; $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g if ($WANT =~ /deadbeef/); + if ($Is_ebcdic) { + # here too there are hashing order differences + $WANT = join("\n",sort(split(/\n/,$WANT))); + $WANT =~ s/\,$//mg; + $t = join("\n",sort(split(/\n/,$t))); + $t =~ s/\,$//mg; + } print( ($t eq $WANT and not $@) ? "ok $TNUM\n" : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n"); } diff --git a/t/lib/english.t b/t/lib/english.t index 2ee613352b..dba68dbf94 100755 --- a/t/lib/english.t +++ b/t/lib/english.t @@ -5,7 +5,7 @@ print "1..16\n"; BEGIN { unshift @INC, '../lib' } use English; use Config; -my $threads = $Config{'usethreads'} || 0; +my $threads = $Config{'use5005threads'} || 0; print $PID == $$ ? "ok 1\n" : "not ok 1\n"; diff --git a/t/lib/filecopy.t b/t/lib/filecopy.t index 7ef68eb02b..b6fcbeafa6 100755 --- a/t/lib/filecopy.t +++ b/t/lib/filecopy.t @@ -5,88 +5,103 @@ BEGIN { unshift @INC, '../lib'; } -print "1..11\n"; - $| = 1; +my @pass = (0,1); +my $tests = 11; +printf "1..%d\n", $tests * scalar(@pass); + use File::Copy; -# First we create a file -open(F, ">file-$$") or die; -binmode F; # for DOSISH platforms, because test 3 copies to stdout -print F "ok 3\n"; -close F; - -copy "file-$$", "copy-$$"; - -open(F, "copy-$$") or die; -$foo = <F>; -close(F); - -print "not " if -s "file-$$" != -s "copy-$$"; -print "ok 1\n"; - -print "not " unless $foo eq "ok 3\n"; -print "ok 2\n"; - -binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode -copy "copy-$$", \*STDOUT; -unlink "copy-$$" or die "unlink: $!"; - -open(F,"file-$$"); -copy(*F, "copy-$$"); -open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R); -print "not " unless $foo eq "ok 3\n"; -print "ok 4\n"; -unlink "copy-$$" or die "unlink: $!"; -open(F,"file-$$"); -copy(\*F, "copy-$$"); -close(F) or die "close: $!"; -open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!"; -print "not " unless $foo eq "ok 3\n"; -print "ok 5\n"; -unlink "copy-$$" or die "unlink: $!"; - -require IO::File; -$fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!"; -binmode $fh or die; -copy("file-$$",$fh); -$fh->close or die "close: $!"; -open(R, "copy-$$") or die; $foo = <R>; close(R); -print "# foo=`$foo'\nnot " unless $foo eq "ok 3\n"; -print "ok 6\n"; -unlink "copy-$$" or die "unlink: $!"; -require FileHandle; -my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!"; -binmode $fh or die; -copy("file-$$",$fh); -$fh->close; -open(R, "copy-$$") or die; $foo = <R>; close(R); -print "not " unless $foo eq "ok 3\n"; -print "ok 7\n"; -unlink "file-$$" or die "unlink: $!"; - -print "# moved missing file.\nnot " if move("file-$$", "copy-$$"); -print "# target disappeared.\nnot " if not -e "copy-$$"; -print "ok 8\n"; - -move "copy-$$", "file-$$" or print "# move did not succeed.\n"; -print "# not moved: $!\nnot " unless -e "file-$$" and not -e "copy-$$"; -open(R, "file-$$") or die; $foo = <R>; close(R); -print "# foo=`$foo'\nnot " unless $foo eq "ok 3\n"; -print "ok 9\n"; - -copy "file-$$", "lib"; -open(R, "lib/file-$$") or die; $foo = <R>; close(R); -print "not " unless $foo eq "ok 3\n"; -print "ok 10\n"; -unlink "lib/file-$$" or die "unlink: $!"; - -move "file-$$", "lib"; -open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); -print "not " unless $foo eq "ok 3\n" and not -e "file-$$";; -print "ok 11\n"; -unlink "lib/file-$$" or die "unlink: $!"; +for my $pass (@pass) { + + require File::Copy; + + my $loopconst = $pass*$tests; + + # First we create a file + open(F, ">file-$$") or die; + binmode F; # for DOSISH platforms, because test 3 copies to stdout + printf F "ok %d\n", 3 + $loopconst; + close F; + + copy "file-$$", "copy-$$"; + + open(F, "copy-$$") or die; + $foo = <F>; + close(F); + + print "not " if -s "file-$$" != -s "copy-$$"; + printf "ok %d\n", 1 + $loopconst; + + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 2+$loopconst; + + binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode + copy "copy-$$", \*STDOUT; + unlink "copy-$$" or die "unlink: $!"; + + open(F,"file-$$"); + copy(*F, "copy-$$"); + open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R); + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 4+$loopconst; + unlink "copy-$$" or die "unlink: $!"; + open(F,"file-$$"); + copy(\*F, "copy-$$"); + close(F) or die "close: $!"; + open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!"; + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 5+$loopconst; + unlink "copy-$$" or die "unlink: $!"; + + require IO::File; + $fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!"; + binmode $fh or die; + copy("file-$$",$fh); + $fh->close or die "close: $!"; + open(R, "copy-$$") or die; $foo = <R>; close(R); + print "# foo=`$foo'\nnot " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 6+$loopconst; + unlink "copy-$$" or die "unlink: $!"; + require FileHandle; + my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!"; + binmode $fh or die; + copy("file-$$",$fh); + $fh->close; + open(R, "copy-$$") or die; $foo = <R>; close(R); + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 7+$loopconst; + unlink "file-$$" or die "unlink: $!"; + + print "# moved missing file.\nnot " if move("file-$$", "copy-$$"); + print "# target disappeared.\nnot " if not -e "copy-$$"; + printf "ok %d\n", 8+$loopconst; + + move "copy-$$", "file-$$" or print "# move did not succeed.\n"; + print "# not moved: $!\nnot " unless -e "file-$$" and not -e "copy-$$"; + open(R, "file-$$") or die; $foo = <R>; close(R); + print "# foo=`$foo'\nnot " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 9+$loopconst; + + copy "file-$$", "lib"; + open(R, "lib/file-$$") or die; $foo = <R>; close(R); + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 10+$loopconst; + unlink "lib/file-$$" or die "unlink: $!"; + + move "file-$$", "lib"; + open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); + print "not " unless $foo eq sprintf("ok %d\n", 3+$loopconst) + and not -e "file-$$";; + printf "ok %d\n", 11+$loopconst; + unlink "lib/file-$$" or die "unlink: $!"; + + # warn sprintf "INC->".$INC{"File/Copy.pm"}; + delete $INC{"File/Copy.pm"}; + +} + END { 1 while unlink "file-$$"; diff --git a/t/lib/filefind.t b/t/lib/filefind.t index 5d1492f040..f958b19cad 100755 --- a/t/lib/filefind.t +++ b/t/lib/filefind.t @@ -1,14 +1,105 @@ -#!./perl +####!./perl + + +my %Expect; +my $symlink_exists = eval { symlink("",""); 1 }; BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib'; } -print "1..2\n"; +if ( $symlink_exists ) { print "1..59\n"; } +else { print "1..31\n"; } use File::Find; -# hope we will eventually find ourself find(sub { print "ok 1\n" if $_ eq 'filefind.t'; }, "."); finddepth(sub { print "ok 2\n" if $_ eq 'filefind.t'; }, "."); + + +my $case = 2; + +END { + unlink 'FA/FA_ord','FA/FSL','FA/FAA/FAA_ord', + 'FA/FAB/FAB_ord','FA/FAB/FABA/FABA_ord','FB/FB_ord','FB/FBA/FBA_ord'; + rmdir 'FA/FAA'; + rmdir 'FA/FAB/FABA'; + rmdir 'FA/FAB'; + rmdir 'FA'; + rmdir 'FB/FBA'; + rmdir 'FB'; +} + +sub Check($) { + $case++; + if ($_[0]) { print "ok $case\n"; } + else { print "not ok $case\n"; } +} + +sub CheckDie($) { + $case++; + if ($_[0]) { print "ok $case\n"; } + else { print "not ok $case\n $!\n"; exit 0; } +} + +sub touch { + CheckDie( open(my $T,'>',$_[0]) ); +} + +sub MkDir($$) { + CheckDie( mkdir($_[0],$_[1]) ); +} + +sub wanted { + print "# '$_' => 1\n"; + Check( $Expect{$_} ); + delete $Expect{$_}; + $File::Find::prune=1 if $_ eq 'FABA'; +} + +MkDir( 'FA',0770 ); +MkDir( 'FB',0770 ); +touch('FB/FB_ord'); +MkDir( 'FB/FBA',0770 ); +touch('FB/FBA/FBA_ord'); +CheckDie( symlink('../FB','FA/FSL') ) if $symlink_exists; +touch('FA/FA_ord'); + +MkDir( 'FA/FAA',0770 ); +touch('FA/FAA/FAA_ord'); +MkDir( 'FA/FAB',0770 ); +touch('FA/FAB/FAB_ord'); +MkDir( 'FA/FAB/FABA',0770 ); +touch('FA/FAB/FABA/FABA_ord'); + +%Expect = ('.' => 1, 'FSL' => 1, 'FA_ord' => 1, 'FAB' => 1, 'FAB_ord' => 1, + 'FABA' => 1, 'FAA' => 1, 'FAA_ord' => 1); +delete $Expect{'FSL'} unless $symlink_exists; +File::Find::find( {wanted => \&wanted, },'FA' ); +Check( scalar(keys %Expect) == 0 ); + +%Expect=('FA' => 1, 'FA/FSL' => 1, 'FA/FA_ord' => 1, 'FA/FAB' => 1, + 'FA/FAB/FAB_ord' => 1, 'FA/FAB/FABA' => 1, + 'FA/FAB/FABA/FABA_ord' => 1, 'FA/FAA' => 1, 'FA/FAA/FAA_ord' => 1); +delete $Expect{'FA/FSL'} unless $symlink_exists; +File::Find::find( {wanted => \&wanted, no_chdir => 1},'FA' ); + +Check( scalar(keys %Expect) == 0 ); + +if ( $symlink_exists ) { + %Expect=('.' => 1, 'FA_ord' => 1, 'FSL' => 1, 'FB_ord' => 1, 'FBA' => 1, + 'FBA_ord' => 1, 'FAB' => 1, 'FAB_ord' => 1, 'FABA' => 1, 'FAA' => 1, + 'FAA_ord' => 1); + + File::Find::find( {wanted => \&wanted, follow_fast => 1},'FA' ); + Check( scalar(keys %Expect) == 0 ); + %Expect=('FA' => 1, 'FA/FA_ord' => 1, 'FA/FSL' => 1, 'FA/FSL/FB_ord' => 1, + 'FA/FSL/FBA' => 1, 'FA/FSL/FBA/FBA_ord' => 1, 'FA/FAB' => 1, + 'FA/FAB/FAB_ord' => 1, 'FA/FAB/FABA' => 1, 'FA/FAB/FABA/FABA_ord' => 1, + 'FA/FAA' => 1, 'FA/FAA/FAA_ord' => 1); + File::Find::find( {wanted => \&wanted, follow_fast => 1, no_chdir => 1},'FA' ); + Check( scalar(keys %Expect) == 0 ); +} + +print "# of cases: $case\n"; diff --git a/t/lib/glob-case.t b/t/lib/glob-case.t new file mode 100755 index 0000000000..2e65a0fc8b --- /dev/null +++ b/t/lib/glob-case.t @@ -0,0 +1,48 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + print "1..7\n"; +} +END { + print "not ok 1\n" unless $loaded; +} +use File::Glob qw(:glob csh_glob); +$loaded = 1; +print "ok 1\n"; + +# Test the actual use of the case sensitivity tags, via csh_glob() +import File::Glob ':nocase'; +@a = csh_glob("lib/G*.t"); # At least glob-basic.t glob-case.t glob-global.t +print "not " unless @a >= 3; +print "ok 2\n"; + +# This may fail on systems which are not case-PRESERVING +import File::Glob ':case'; +@a = csh_glob("lib/G*.t"); # None should be uppercase +print "not " unless @a == 0; +print "ok 3\n"; + +# Test the explicit use of the GLOB_NOCASE flag +@a = File::Glob::glob("lib/G*.t", GLOB_NOCASE); +print "not " unless @a >= 3; +print "ok 4\n"; + +# Test Win32 backslash nastiness... +if ($^O ne 'MSWin32') { + print "ok 5\nok 6\nok 7\n"; +} +else { + @a = File::Glob::glob("lib\\g*.t"); + print "not " unless @a >= 3; + print "ok 5\n"; + mkdir "[]", 0; + @a = File::Glob::glob("\\[\\]", GLOB_QUOTE); + rmdir "[]"; + print "# returned @a\nnot " unless @a == 1; + print "ok 6\n"; + @a = File::Glob::glob("lib\\*", GLOB_QUOTE); + print "not " if @a == 0; + print "ok 7\n"; +} diff --git a/t/lib/glob-global.t b/t/lib/glob-global.t index 7da741ee16..44d7e8b5c3 100755 --- a/t/lib/glob-global.t +++ b/t/lib/glob-global.t @@ -23,7 +23,7 @@ EOMessage } } -use File::Glob 'globally'; +use File::Glob ':globally'; $loaded = 1; print "ok 1\n"; @@ -81,7 +81,7 @@ print "ok 8\n"; # how about in a different package, like? package Foo; -use File::Glob 'globally'; +use File::Glob ':globally'; @s = (); while (glob '*/*.t') { #print "# $_\n"; diff --git a/t/lib/safe2.t b/t/lib/safe2.t index 2c1c80c604..876e7a37db 100755 --- a/t/lib/safe2.t +++ b/t/lib/safe2.t @@ -66,7 +66,7 @@ $glob = "ok 11\n"; sub sayok { print "ok @_\n" } $cpt->share(qw($foo %bar @baz *glob sayok)); -$cpt->share('$"') unless $Config{archname} =~ /-thread$/; +$cpt->share('$"') unless $Config{use5005threads}; $cpt->reval(q{ package other; diff --git a/t/lib/thread.t b/t/lib/thread.t index 6c25407853..edfb443fc8 100755 --- a/t/lib/thread.t +++ b/t/lib/thread.t @@ -4,8 +4,8 @@ BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib'; require Config; import Config; - if (! $Config{'usethreads'}) { - print "1..0 # Skip: this perl is not threaded\n"; + if (! $Config{'use5005threads'}) { + print "1..0 # Skip: not use5005threads\n"; exit 0; } @@ -13,8 +13,8 @@ BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } $| = 1; -print "1..18\n"; -use Thread; +print "1..21\n"; +use Thread 'yield'; print "ok 1\n"; sub content @@ -82,3 +82,37 @@ Loch::Ness->monster(15); Loch::Ness->new->monster(16); Loch::Ness->gollum(17); Loch::Ness->new->gollum(18); + +my $short = "This is a long string that goes on and on."; +my $shorte = " a long string that goes on and on."; +my $long = "This is short."; +my $longe = " short."; +my $thr1 = new Thread \&threaded, $short, $shorte, "19"; +my $thr2 = new Thread \&threaded, $long, $longe, "20"; + +sub threaded { + my ($string, $string_end, $testno) = @_; + + # Do the match, saving the output in appropriate variables + $string =~ /(.*)(is)(.*)/; + # Yield control, allowing the other thread to fill in the match variables + yield(); + # Examine the match variable contents; on broken perls this fails + if ($3 eq $string_end) { + print "ok $testno\n"; + } + else { + warn <<EOT; + +# +# This is a KNOWN FAILURE, and one of the reasons why threading +# is still an experimental feature. It is here to stop people +# from deploying threads in production. ;-) +# +EOT + print "not ok $testno # other thread filled in match variables\n"; + } +} +$thr1->join; +$thr2->join; +print "ok 21\n"; diff --git a/t/op/avhv.t b/t/op/avhv.t index 92afa37d37..23f9c69c8c 100755 --- a/t/op/avhv.t +++ b/t/op/avhv.t @@ -17,7 +17,7 @@ sub STORESIZE { $#{$_[0]} = $_[1]+1 } package main; -print "1..15\n"; +print "1..20\n"; $sch = { 'abc' => 1, @@ -118,3 +118,24 @@ print "not " unless exists $avhv->{pants}; print "ok 14\n"; print "not " if exists $avhv->{bar}; print "ok 15\n"; + +$avhv->{bar} = 10; +print "not " unless exists $avhv->{bar} and $avhv->{bar} == 10; +print "ok 16\n"; + +$v = delete $avhv->{bar}; +print "not " unless $v == 10; +print "ok 17\n"; + +print "not " if exists $avhv->{bar}; +print "ok 18\n"; + +$avhv->{foo} = 'xxx'; +$avhv->{bar} = 'yyy'; +$avhv->{pants} = 'zzz'; +@x = delete @{$avhv}{'foo','pants'}; +print "# @x\nnot " unless "@x" eq "xxx zzz"; +print "ok 19\n"; + +print "not " unless "$avhv->{bar}" eq "yyy"; +print "ok 20\n"; diff --git a/t/op/delete.t b/t/op/delete.t index 6cc447506a..10a218b1b6 100755 --- a/t/op/delete.t +++ b/t/op/delete.t @@ -1,8 +1,8 @@ #!./perl -# $RCSfile: delete.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:44 $ +print "1..36\n"; -print "1..16\n"; +# delete() on hash elements $foo{1} = 'a'; $foo{2} = 'b'; @@ -13,7 +13,7 @@ $foo{5} = 'e'; $foo = delete $foo{2}; if ($foo eq 'b') {print "ok 1\n";} else {print "not ok 1 $foo\n";} -if ($foo{2} eq '') {print "ok 2\n";} else {print "not ok 2 $foo{2}\n";} +unless (exists $foo{2}) {print "ok 2\n";} else {print "not ok 2 $foo{2}\n";} if ($foo{1} eq 'a') {print "ok 3\n";} else {print "not ok 3\n";} if ($foo{3} eq 'c') {print "ok 4\n";} else {print "not ok 4\n";} if ($foo{4} eq 'd') {print "ok 5\n";} else {print "not ok 5\n";} @@ -24,8 +24,8 @@ if ($foo{5} eq 'e') {print "ok 6\n";} else {print "not ok 6\n";} if (@foo == 2) {print "ok 7\n";} else {print "not ok 7 ", @foo+0, "\n";} if ($foo[0] eq 'd') {print "ok 8\n";} else {print "not ok 8 ", $foo[0], "\n";} if ($foo[1] eq 'e') {print "ok 9\n";} else {print "not ok 9 ", $foo[1], "\n";} -if ($foo{4} eq '') {print "ok 10\n";} else {print "not ok 10 $foo{4}\n";} -if ($foo{5} eq '') {print "ok 11\n";} else {print "not ok 11 $foo{5}\n";} +unless (exists $foo{4}) {print "ok 10\n";} else {print "not ok 10 $foo{4}\n";} +unless (exists $foo{5}) {print "ok 11\n";} else {print "not ok 11 $foo{5}\n";} if ($foo{1} eq 'a') {print "ok 12\n";} else {print "not ok 12\n";} if ($foo{3} eq 'c') {print "ok 13\n";} else {print "not ok 13\n";} @@ -49,3 +49,75 @@ delete $refhash{"top"}->{"bar"}; @list = keys %{$refhash{"top"}}; print "@list" eq "foo" ? "ok 16\n" : "not ok 16 @list\n"; + +{ + my %a = ('bar', 33); + my($a) = \(values %a); + my $b = \$a{bar}; + my $c = \delete $a{bar}; + + print "not " unless $a == $b && $b == $c; + print "ok 17\n"; +} + +# delete() on array elements + +@foo = (); +$foo[1] = 'a'; +$foo[2] = 'b'; +$foo[3] = 'c'; +$foo[4] = 'd'; +$foo[5] = 'e'; + +$foo = delete $foo[2]; + +if ($foo eq 'b') {print "ok 18\n";} else {print "not ok 18 $foo\n";} +unless (exists $foo[2]) {print "ok 19\n";} else {print "not ok 19 $foo[2]\n";} +if ($foo[1] eq 'a') {print "ok 20\n";} else {print "not ok 20\n";} +if ($foo[3] eq 'c') {print "ok 21\n";} else {print "not ok 21\n";} +if ($foo[4] eq 'd') {print "ok 22\n";} else {print "not ok 22\n";} +if ($foo[5] eq 'e') {print "ok 23\n";} else {print "not ok 23\n";} + +@bar = delete @foo[4,5]; + +if (@bar == 2) {print "ok 24\n";} else {print "not ok 24 ", @bar+0, "\n";} +if ($bar[0] eq 'd') {print "ok 25\n";} else {print "not ok 25 ", $bar[0], "\n";} +if ($bar[1] eq 'e') {print "ok 26\n";} else {print "not ok 26 ", $bar[1], "\n";} +unless (exists $foo[4]) {print "ok 27\n";} else {print "not ok 27 $foo[4]\n";} +unless (exists $foo[5]) {print "ok 28\n";} else {print "not ok 28 $foo[5]\n";} +if ($foo[1] eq 'a') {print "ok 29\n";} else {print "not ok 29\n";} +if ($foo[3] eq 'c') {print "ok 30\n";} else {print "not ok 30\n";} + +$foo = join('',@foo); +if ($foo eq 'ac') {print "ok 31\n";} else {print "not ok 31\n";} + +if (@foo == 4) {print "ok 32\n";} else {print "not ok 32\n";} + +foreach $key (0 .. $#foo) { + delete $foo[$key]; +} + +if (@foo == 0) {print "ok 33\n";} else {print "not ok 33\n";} + +$foo[0] = 'x'; +$foo[1] = 'y'; + +$foo = "@foo"; +print +($foo eq 'x y') ? "ok 34\n" : "not ok 34\n"; + +$refary[0]->[0] = "FOO"; +$refary[0]->[3] = "BAR"; + +delete $refary[0]->[3]; + +print @{$refary[0]} == 1 ? "ok 35\n" : "not ok 35 @list\n"; + +{ + my @a = 33; + my($a) = \(@a); + my $b = \$a[0]; + my $c = \delete $a[bar]; + + print "not " unless $a == $b && $b == $c; + print "ok 36\n"; +} diff --git a/t/op/fork.t b/t/op/fork.t index 20c87472b2..b743a4589f 100755 --- a/t/op/fork.t +++ b/t/op/fork.t @@ -1,26 +1,319 @@ #!./perl -# $RCSfile: fork.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:53 $ +# tests for both real and emulated fork() BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib'; require Config; import Config; - unless ($Config{'d_fork'}) { + unless ($Config{'d_fork'} || ($^O eq 'MSWin32' && $Config{'useithreads'})) { print "1..0 # Skip: no fork\n"; exit 0; } + $ENV{PERL5LIB} = "../lib"; } -$| = 1; -print "1..2\n"; +$|=1; + +undef $/; +@prgs = split "\n########\n", <DATA>; +print "1..", scalar @prgs, "\n"; + +$tmpfile = "forktmp000"; +1 while -f ++$tmpfile; +END { unlink $tmpfile if $tmpfile; } + +$CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat'); +for (@prgs){ + my $switch; + if (s/^\s*(-\w.*)//){ + $switch = $1; + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + $expected =~ s/\n+$//; + # results can be in any order, so sort 'em + my @expected = sort split /\n/, $expected; + open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; + print TEST $prog, "\n"; + close TEST or die "Cannot close $tmpfile: $!"; + my $results; + if ($^O eq 'MSWin32') { + $results = `.\\perl -I../lib $switch $tmpfile 2>&1`; + } + else { + $results = `./perl $switch $tmpfile 2>&1`; + } + $status = $?; + $results =~ s/\n+$//; + $results =~ s/at\s+forktmp\d+\s+line/at - line/g; + $results =~ s/of\s+forktmp\d+\s+aborted/of - aborted/g; +# bison says 'parse error' instead of 'syntax error', +# various yaccs may or may not capitalize 'syntax'. + $results =~ s/^(syntax|parse) error/syntax error/mig; + my @results = sort split /\n/, $results; + if ( "@results" ne "@expected" ) { + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; +} + +__END__ +$| = 1; if ($cid = fork) { - sleep 2; - if ($result = (kill 9, $cid)) {print "ok 2\n";} else {print "not ok 2 $result\n";} + sleep 1; + if ($result = (kill 9, $cid)) { + print "ok 2\n"; + } + else { + print "not ok 2 $result\n"; + } + sleep 1 if $^O eq 'MSWin32'; # avoid WinNT race bug } else { - $| = 1; print "ok 1\n"; sleep 10; } +EXPECT +ok 1 +ok 2 +######## +$| = 1; +sub forkit { + print "iteration $i start\n"; + my $x = fork; + if (defined $x) { + if ($x) { + print "iteration $i parent\n"; + } + else { + print "iteration $i child\n"; + } + } + else { + print "pid $$ failed to fork\n"; + } +} +while ($i++ < 3) { do { forkit(); }; } +EXPECT +iteration 1 start +iteration 1 parent +iteration 1 child +iteration 2 start +iteration 2 parent +iteration 2 child +iteration 2 start +iteration 2 parent +iteration 2 child +iteration 3 start +iteration 3 parent +iteration 3 child +iteration 3 start +iteration 3 parent +iteration 3 child +iteration 3 start +iteration 3 parent +iteration 3 child +iteration 3 start +iteration 3 parent +iteration 3 child +######## +$| = 1; +fork() + ? (print("parent\n"),sleep(1)) + : (print("child\n"),exit) ; +EXPECT +parent +child +######## +$| = 1; +fork() + ? (print("parent\n"),exit) + : (print("child\n"),sleep(1)) ; +EXPECT +parent +child +######## +$| = 1; +@a = (1..3); +for (@a) { + if (fork) { + print "parent $_\n"; + $_ = "[$_]"; + } + else { + print "child $_\n"; + $_ = "-$_-"; + } +} +print "@a\n"; +EXPECT +parent 1 +child 1 +parent 2 +child 2 +parent 2 +child 2 +parent 3 +child 3 +parent 3 +child 3 +parent 3 +child 3 +parent 3 +child 3 +[1] [2] [3] +-1- [2] [3] +[1] -2- [3] +[1] [2] -3- +-1- -2- [3] +-1- [2] -3- +[1] -2- -3- +-1- -2- -3- +######## +use Config; +$| = 1; +$\ = "\n"; +fork() + ? print($Config{osname} eq $^O) + : print($Config{osname} eq $^O) ; +EXPECT +1 +1 +######## +$| = 1; +$\ = "\n"; +fork() + ? do { require Config; print($Config::Config{osname} eq $^O); } + : do { require Config; print($Config::Config{osname} eq $^O); } +EXPECT +1 +1 +######## +$| = 1; +use Cwd; +$\ = "\n"; +my $dir; +if (fork) { + $dir = "f$$.tst"; + mkdir $dir, 0755; + chdir $dir; + print cwd() =~ /\Q$dir/i ? "ok 1 parent" : "not ok 1 parent"; + chdir ".."; + rmdir $dir; +} +else { + sleep 2; + $dir = "f$$.tst"; + mkdir $dir, 0755; + chdir $dir; + print cwd() =~ /\Q$dir/i ? "ok 1 child" : "not ok 1 child"; + chdir ".."; + rmdir $dir; +} +EXPECT +ok 1 parent +ok 1 child +######## +$| = 1; +$\ = "\n"; +my $getenv; +if ($^O eq 'MSWin32') { + $getenv = qq[$^X -e "print \$ENV{TST}"]; +} +else { + $getenv = qq[$^X -e 'print \$ENV{TST}']; +} +$ENV{TST} = 'foo'; +if (fork) { + sleep 1; + print "parent before: " . `$getenv`; + $ENV{TST} = 'bar'; + print "parent after: " . `$getenv`; +} +else { + print "child before: " . `$getenv`; + $ENV{TST} = 'baz'; + print "child after: " . `$getenv`; +} +EXPECT +child before: foo +child after: baz +parent before: foo +parent after: bar +######## +$| = 1; +$\ = "\n"; +if ($pid = fork) { + waitpid($pid,0); + print "parent got $?" +} +else { + exit(42); +} +EXPECT +parent got 10752 +######## +$| = 1; +$\ = "\n"; +my $echo = 'echo'; +if ($pid = fork) { + waitpid($pid,0); + print "parent got $?" +} +else { + exec("$echo foo"); +} +EXPECT +foo +parent got 0 +######## +if (fork) { + die "parent died"; +} +else { + die "child died"; +} +EXPECT +parent died at - line 2. +child died at - line 5. +######## +if ($pid = fork) { + eval { die "parent died" }; + print $@; +} +else { + eval { die "child died" }; + print $@; +} +EXPECT +parent died at - line 2. +child died at - line 6. +######## +if (eval q{$pid = fork}) { + eval q{ die "parent died" }; + print $@; +} +else { + eval q{ die "child died" }; + print $@; +} +EXPECT +parent died at (eval 2) line 1. +child died at (eval 2) line 1. +######## +BEGIN { + $| = 1; + fork and exit; + print "inner\n"; +} +# XXX In emulated fork(), the child will not execute anything after +# the BEGIN block, due to difficulties in recreating the parse stacks +# and restarting yyparse() midstream in the child. This can potentially +# be overcome by treating what's after the BEGIN{} as a brand new parse. +#print "outer\n" +EXPECT +inner diff --git a/t/op/lex_assign.t b/t/op/lex_assign.t index 0f658694dd..56ddfff866 100755 --- a/t/op/lex_assign.t +++ b/t/op/lex_assign.t @@ -24,7 +24,7 @@ sub subb {"in s"} @INPUT = <DATA>; @simple_input = grep /^\s*\w+\s*\$\w+\s*[#\n]/, @INPUT; -print "1..", (8 + @INPUT + @simple_input), "\n"; +print "1..", (9 + @INPUT + @simple_input), "\n"; $ord = 0; sub wrn {"@_"} @@ -53,6 +53,12 @@ $ord++; print "not " unless $dc == 1; print "ok $ord\n"; +$ord++; +my $xxx = 'b'; +$xxx = 'c' . ($xxx || 'e'); +print "not " unless $xxx eq 'cb'; +print "ok $ord\n"; + { # Check calling STORE my $sc = 0; sub B::TIESCALAR {bless [11], 'B'} diff --git a/t/op/magic.t b/t/op/magic.t index fe55521814..0d5190a2bb 100755 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -23,7 +23,7 @@ $Is_MSWin32 = $^O eq 'MSWin32'; $Is_VMS = $^O eq 'VMS'; $Is_Dos = $^O eq 'dos'; $Is_os2 = $^O eq 'os2'; -$Is_Cygwin = $^O =~ /cygwin/; +$Is_Cygwin = $^O eq 'cygwin'; $PERL = ($Is_MSWin32 ? '.\perl' : './perl'); print "1..35\n"; diff --git a/t/op/misc.t b/t/op/misc.t index ab849777da..9f8c7dedab 100755 --- a/t/op/misc.t +++ b/t/op/misc.t @@ -506,4 +506,4 @@ else { if ($x == 0) { print "" } else { print $x } } EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in numeric eq (==) at - line 4. diff --git a/t/op/nothread.t b/t/op/nothread.t index a434956cb0..fd36e2e89a 100755 --- a/t/op/nothread.t +++ b/t/op/nothread.t @@ -9,7 +9,7 @@ BEGIN unshift @INC, "../lib"; require Config; import Config; - if ($Config{'usethreads'}) + if ($Config{'use5005threads'}) { print "1..0 # Skip: this perl is threaded\n"; exit 0; diff --git a/t/op/pat.t b/t/op/pat.t index 5c564aa719..9f685502f2 100755 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -4,7 +4,7 @@ # the format supported by op/regexp.t. If you want to add a test # that does fit that format, add it to op/re_tests, not here. -print "1..194\n"; +print "1..195\n"; BEGIN { chdir 't' if -d 't'; @@ -898,3 +898,10 @@ $text = "xA\n" x 500; $text =~ /^\s*A/m and print 'not '; print "ok $test\n"; $test++; + +$text = "abc dbf"; +@res = ($text =~ /.*?(b).*?\b/g); +"@res" eq 'b b' or print 'not '; +print "ok $test\n"; +$test++; + diff --git a/t/op/range.t b/t/op/range.t index 1698db4a55..e8aecf5fc9 100755 --- a/t/op/range.t +++ b/t/op/range.t @@ -1,6 +1,6 @@ #!./perl -print "1..13\n"; +print "1..15\n"; print join(':',1..5) eq '1:2:3:4:5' ? "ok 1\n" : "not ok 1\n"; @@ -64,3 +64,12 @@ print "ok 12\n"; $bad = 1 unless $x eq 'a:b:c:d:e'; print $bad ? "not ok 13\n" : "ok 13\n"; } + +# Should use magical autoinc only when both are strings +print "not " unless 0 == (() = "0"..-1); +print "ok 14\n"; + +for my $x ("0"..-1) { + print "not "; +} +print "ok 15\n"; diff --git a/t/op/re_tests b/t/op/re_tests index f866385096..d506e6e07f 100644 --- a/t/op/re_tests +++ b/t/op/re_tests @@ -744,3 +744,9 @@ tt+$ xxxtt y - - \GX.*X aaaXbX n - - (\d+\.\d+) 3.1415926 y $1 3.1415926 (\ba.{0,10}br) have a web browser y $1 a web br +'\.c(pp|xx|c)?$'i Changes n - - +'\.c(pp|xx|c)?$'i IO.c y - - +'(\.c(pp|xx|c)?$)'i IO.c y $1 .c +^([a-z]:) C:/ n - - +'^\S\s+aa$'m \nx aa y - - +(^|a)b ab y - - diff --git a/t/op/runlevel.t b/t/op/runlevel.t index 1dc2a234b2..1d923cf1b5 100755 --- a/t/op/runlevel.t +++ b/t/op/runlevel.t @@ -3,7 +3,7 @@ ## ## Many of these tests are originally from Michael Schroeder ## <Michael.Schroeder@informatik.uni-erlangen.de> -## Adapted and expanded by Gurusamy Sarathy <gsar@umich.edu> +## Adapted and expanded by Gurusamy Sarathy <gsar@activestate.com> ## chdir 't' if -d 't'; @@ -57,7 +57,7 @@ __END__ @a = sort { last ; } @a; } EXPECT -Can't "last" outside a block at - line 3. +Can't "last" outside a loop block at - line 3. ######## package TEST; @@ -174,7 +174,7 @@ exit; bar: print "bar reached\n"; EXPECT -Can't "goto" outside a block at - line 2. +Can't "goto" out of a pseudo block at - line 2. ######## sub sortfn { (split(/./, 'x'x10000))[0]; @@ -227,7 +227,7 @@ tie $bar, TEST; } print "OK\n"; EXPECT -Can't "next" outside a block at - line 8. +Can't "next" outside a loop block at - line 8. ######## package TEST; @@ -285,7 +285,7 @@ package main; tie $bar, TEST; } EXPECT -Can't "next" outside a block at - line 4. +Can't "next" outside a loop block at - line 4. ######## @a = (1, 2, 3); foo: diff --git a/t/op/sort.t b/t/op/sort.t index 9abc4105d2..6e3d2ca8e0 100755 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -4,12 +4,13 @@ BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib'; } -print "1..38\n"; +print "1..49\n"; # XXX known to leak scalars $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } +sub backwards_stacked($$) { my($a,$b) = @_; $a lt $b ? 1 : $a gt $b ? -1 : 0 } my $upperfirst = 'A' lt 'a'; @@ -40,96 +41,107 @@ $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; print "# 2: x = '$x', expected = '$expected'\n"; print ($x eq $expected ? "ok 2\n" : "not ok 2\n"); +$x = join('', sort( backwards_stacked @harry)); +$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; +print "# 3: x = '$x', expected = '$expected'\n"; +print ($x eq $expected ? "ok 3\n" : "not ok 3\n"); + $x = join('', sort @george, 'to', @harry); $expected = $upperfirst ? 'AbelAxedCaincatchaseddoggonepunishedtoxyz' : 'catchaseddoggonepunishedtoxyzAbelAxedCain' ; -print "# 3: x = '$x', expected = '$expected'\n"; -print ($x eq $expected ?"ok 3\n":"not ok 3\n"); +print "# 4: x = '$x', expected = '$expected'\n"; +print ($x eq $expected ?"ok 4\n":"not ok 4\n"); @a = (); @b = reverse @a; -print ("@b" eq "" ? "ok 4\n" : "not ok 4 (@b)\n"); +print ("@b" eq "" ? "ok 5\n" : "not ok 5 (@b)\n"); @a = (1); @b = reverse @a; -print ("@b" eq "1" ? "ok 5\n" : "not ok 5 (@b)\n"); +print ("@b" eq "1" ? "ok 6\n" : "not ok 6 (@b)\n"); @a = (1,2); @b = reverse @a; -print ("@b" eq "2 1" ? "ok 6\n" : "not ok 6 (@b)\n"); +print ("@b" eq "2 1" ? "ok 7\n" : "not ok 7 (@b)\n"); @a = (1,2,3); @b = reverse @a; -print ("@b" eq "3 2 1" ? "ok 7\n" : "not ok 7 (@b)\n"); +print ("@b" eq "3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n"); @a = (1,2,3,4); @b = reverse @a; -print ("@b" eq "4 3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n"); +print ("@b" eq "4 3 2 1" ? "ok 9\n" : "not ok 9 (@b)\n"); @a = (10,2,3,4); @b = sort {$a <=> $b;} @a; -print ("@b" eq "2 3 4 10" ? "ok 9\n" : "not ok 9 (@b)\n"); +print ("@b" eq "2 3 4 10" ? "ok 10\n" : "not ok 10 (@b)\n"); $sub = 'backwards'; $x = join('', sort $sub @harry); $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; -print "# 10: x = $x, expected = '$expected'\n"; -print ($x eq $expected ? "ok 10\n" : "not ok 10\n"); +print "# 11: x = $x, expected = '$expected'\n"; +print ($x eq $expected ? "ok 11\n" : "not ok 11\n"); + +$sub = 'backwards_stacked'; +$x = join('', sort $sub @harry); +$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; +print "# 12: x = $x, expected = '$expected'\n"; +print ($x eq $expected ? "ok 12\n" : "not ok 12\n"); # literals, combinations @b = sort (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 11\n" : "not ok 11\n"); +print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n"); print "# x = '@b'\n"; @b = sort grep { $_ } (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 12\n" : "not ok 12\n"); +print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n"); print "# x = '@b'\n"; @b = sort map { $_ } (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n"); +print ("@b" eq '1 2 3 4' ? "ok 15\n" : "not ok 15\n"); print "# x = '@b'\n"; @b = sort reverse (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n"); +print ("@b" eq '1 2 3 4' ? "ok 16\n" : "not ok 16\n"); print "# x = '@b'\n"; $^W = 0; # redefining sort sub inside the sort sub should fail sub twoface { *twoface = sub { $a <=> $b }; &twoface } eval { @b = sort twoface 4,1,3,2 }; -print ($@ =~ /redefine active sort/ ? "ok 15\n" : "not ok 15\n"); +print ($@ =~ /redefine active sort/ ? "ok 17\n" : "not ok 17\n"); # redefining sort subs outside the sort should not fail eval { *twoface = sub { &backwards } }; -print $@ ? "not ok 16\n" : "ok 16\n"; +print $@ ? "not ok 18\n" : "ok 18\n"; eval { @b = sort twoface 4,1,3,2 }; -print ("@b" eq '4 3 2 1' ? "ok 17\n" : "not ok 17 |@b|\n"); +print ("@b" eq '4 3 2 1' ? "ok 19\n" : "not ok 19 |@b|\n"); *twoface = sub { *twoface = *backwards; $a <=> $b }; eval { @b = sort twoface 4,1 }; -print ($@ =~ /redefine active sort/ ? "ok 18\n" : "not ok 18\n"); +print ($@ =~ /redefine active sort/ ? "ok 20\n" : "not ok 20\n"); *twoface = sub { eval 'sub twoface { $a <=> $b }'; - die($@ =~ /redefine active sort/ ? "ok 19\n" : "not ok 19\n"); + die($@ =~ /redefine active sort/ ? "ok 21\n" : "not ok 21\n"); $a <=> $b; }; eval { @b = sort twoface 4,1 }; -print $@ ? "$@" : "not ok 19\n"; +print $@ ? "$@" : "not ok 21\n"; eval <<'CODE'; my @result = sort main'backwards 'one', 'two'; CODE -print $@ ? "not ok 20\n# $@" : "ok 20\n"; +print $@ ? "not ok 22\n# $@" : "ok 22\n"; eval <<'CODE'; # "sort 'one', 'two'" should not try to parse "'one" as a sort sub my @result = sort 'one', 'two'; CODE -print $@ ? "not ok 21\n# $@" : "ok 21\n"; +print $@ ? "not ok 23\n# $@" : "ok 23\n"; { my $sortsub = \&backwards; @@ -137,13 +149,28 @@ print $@ ? "not ok 21\n# $@" : "ok 21\n"; my $sortglobr = \*backwards; my $sortname = 'backwards'; @b = sort $sortsub 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 22\n" : "not ok 22 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n"); @b = sort $sortglob 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 23\n" : "not ok 23 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n"); @b = sort $sortname 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n"); @b = sort $sortglobr 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n"); +} + +{ + my $sortsub = \&backwards_stacked; + my $sortglob = *backwards_stacked; + my $sortglobr = \*backwards_stacked; + my $sortname = 'backwards_stacked'; + @b = sort $sortsub 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n"); + @b = sort $sortglob 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n"); + @b = sort $sortname 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 30\n" : "not ok 30 |@b|\n"); + @b = sort $sortglobr 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 31\n" : "not ok 31 |@b|\n"); } { @@ -152,13 +179,28 @@ print $@ ? "not ok 21\n# $@" : "ok 21\n"; local $sortglobr = \*backwards; local $sortname = 'backwards'; @b = sort $sortsub 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 32\n" : "not ok 32 |@b|\n"); @b = sort $sortglob 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 33\n" : "not ok 33 |@b|\n"); @b = sort $sortname 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 34\n" : "not ok 34 |@b|\n"); @b = sort $sortglobr 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 35\n" : "not ok 35 |@b|\n"); +} + +{ + local $sortsub = \&backwards_stacked; + local $sortglob = *backwards_stacked; + local $sortglobr = \*backwards_stacked; + local $sortname = 'backwards_stacked'; + @b = sort $sortsub 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 36\n" : "not ok 36 |@b|\n"); + @b = sort $sortglob 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 37\n" : "not ok 37 |@b|\n"); + @b = sort $sortname 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 38\n" : "not ok 38 |@b|\n"); + @b = sort $sortglobr 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 39\n" : "not ok 39 |@b|\n"); } ## exercise sort builtins... ($a <=> $b already tested) @@ -167,42 +209,46 @@ print $@ ? "not ok 21\n# $@" : "ok 21\n"; my $dummy; # force blockness return $b <=> $a } @a; -print ("@b" eq '1996 255 90 19 5' ? "ok 30\n" : "not ok 30\n"); +print ("@b" eq '1996 255 90 19 5' ? "ok 40\n" : "not ok 40\n"); print "# x = '@b'\n"; $x = join('', sort { $a cmp $b } @harry); $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; -print ($x eq $expected ? "ok 31\n" : "not ok 31\n"); +print ($x eq $expected ? "ok 41\n" : "not ok 41\n"); print "# x = '$x'; expected = '$expected'\n"; $x = join('', sort { $b cmp $a } @harry); $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; -print ($x eq $expected ? "ok 32\n" : "not ok 32\n"); +print ($x eq $expected ? "ok 42\n" : "not ok 42\n"); print "# x = '$x'; expected = '$expected'\n"; { use integer; @b = sort { $a <=> $b } @a; - print ("@b" eq '5 19 90 255 1996' ? "ok 33\n" : "not ok 33\n"); + print ("@b" eq '5 19 90 255 1996' ? "ok 43\n" : "not ok 43\n"); print "# x = '@b'\n"; @b = sort { $b <=> $a } @a; - print ("@b" eq '1996 255 90 19 5' ? "ok 34\n" : "not ok 34\n"); + print ("@b" eq '1996 255 90 19 5' ? "ok 44\n" : "not ok 44\n"); print "# x = '@b'\n"; $x = join('', sort { $a cmp $b } @harry); $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; - print ($x eq $expected ? "ok 35\n" : "not ok 35\n"); + print ($x eq $expected ? "ok 45\n" : "not ok 45\n"); print "# x = '$x'; expected = '$expected'\n"; $x = join('', sort { $b cmp $a } @harry); $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; - print ($x eq $expected ? "ok 36\n" : "not ok 36\n"); + print ($x eq $expected ? "ok 46\n" : "not ok 46\n"); print "# x = '$x'; expected = '$expected'\n"; } # test that an optimized-away comparison block doesn't take any other # arguments away with it $x = join('', sort { $a <=> $b } 3, 1, 2); -print $x eq "123" ? "ok 37\n" : "not ok 37\n"; +print $x eq "123" ? "ok 47\n" : "not ok 47\n"; # test sorting in non-main package package Foo; @a = ( 5, 19, 1996, 255, 90 ); @b = sort { $b <=> $a } @a; -print ("@b" eq '1996 255 90 19 5' ? "ok 38\n" : "not ok 38\n"); +print ("@b" eq '1996 255 90 19 5' ? "ok 48\n" : "not ok 48\n"); +print "# x = '@b'\n"; + +@b = sort main::backwards_stacked @a; +print ("@b" eq '90 5 255 1996 19' ? "ok 49\n" : "not ok 49\n"); print "# x = '@b'\n"; diff --git a/t/op/stat.t b/t/op/stat.t index 0af55bbaab..37237f0bdf 100755 --- a/t/op/stat.t +++ b/t/op/stat.t @@ -14,9 +14,10 @@ print "1..58\n"; $Is_MSWin32 = $^O eq 'MSWin32'; $Is_Dos = $^O eq 'dos'; $Is_Dosish = $Is_Dos || $^O eq 'os2' || $Is_MSWin32; +$Is_Cygwin = $^O eq 'cygwin'; chop($cwd = ($Is_MSWin32 ? `cd` : `pwd`)); -$DEV = `ls -l /dev` unless $Is_Dosish; +$DEV = `ls -l /dev` unless $Is_Dosish or $Is_Cygwin; unlink "Op.stat.tmp"; if (open(FOO, ">Op.stat.tmp")) { @@ -163,7 +164,7 @@ else {print "not ok 33\n";} if (! -b '.') {print "ok 34\n";} else {print "not ok 34\n";} -if ($^O eq 'amigaos' or $Is_Dosish) { +if ($^O eq 'amigaos' or $Is_Dosish or $Is_Cygwin) { print "ok 35 # skipped: no -u\n"; goto tty_test; } diff --git a/t/op/subst.t b/t/op/subst.t index 2d15df4dc1..9757f4c595 100755 --- a/t/op/subst.t +++ b/t/op/subst.t @@ -6,7 +6,7 @@ BEGIN { require Config; import Config; } -print "1..83\n"; +print "1..84\n"; $x = 'foo'; $_ = "x"; @@ -375,4 +375,7 @@ $x = $x = 'interp'; eval q% ($_ = "x") =~ s/x(($x)*)/"$1"/e %; print +($_ eq '' and !length $@) ? "ok 83\n" : "not ok 83\n# \$_ eq $_, $@\n"; +$_ = "C:/"; +s/^([a-z]:)/\u$1/ and print "not "; +print "ok 84\n"; diff --git a/t/op/substr.t b/t/op/substr.t index 87efcb4512..8d31a9ae61 100755 --- a/t/op/substr.t +++ b/t/op/substr.t @@ -1,6 +1,6 @@ #!./perl -print "1..106\n"; +print "1..108\n"; #P = start of string Q = start of substr R = end of substr S = end of string @@ -209,3 +209,9 @@ print "ok 105\n"; eval 'substr($a,0,0,"") = "abc"'; print "not " unless $@ && $@ =~ /Can't modify substr/ && $a eq "foo"; print "ok 106\n"; + +$a = "abcdefgh"; +print "not " unless sub { shift }->(substr($a, 0, 4, "xxxx")) eq 'abcd'; +print "ok 107\n"; +print "not " unless $a eq 'xxxxefgh'; +print "ok 108\n"; diff --git a/t/pragma/constant.t b/t/pragma/constant.t index a56e081083..5904a4f2b6 100755 --- a/t/pragma/constant.t +++ b/t/pragma/constant.t @@ -14,9 +14,9 @@ END { print @warnings } ######################### We start with some black magic to print on failure. -BEGIN { $| = 1; print "1..46\n"; } +BEGIN { $| = 1; print "1..58\n"; } END {print "not ok 1\n" unless $loaded;} -use constant; +use constant 1.01; $loaded = 1; #print "# Version: $constant::VERSION\n"; print "ok 1\n"; @@ -155,3 +155,42 @@ test 44, scalar($@ =~ /^No such pseudo-hash field/); print CCODE->(45); eval q{ CCODE->{foo} }; test 46, scalar($@ =~ /^Constant is not a HASH/); + +# Allow leading underscore +use constant _PRIVATE => 47; +test 47, _PRIVATE == 47; + +# Disallow doubled leading underscore +eval q{ + use constant __DISALLOWED => "Oops"; +}; +test 48, $@ =~ /begins with '__'/; + +# Check on declared() and %declared. This sub should be EXACTLY the +# same as the one quoted in the docs! +sub declared ($) { + use constant 1.01; # don't omit this! + my $name = shift; + $name =~ s/^::/main::/; + my $pkg = caller; + my $full_name = $name =~ /::/ ? $name : "${pkg}::$name"; + $constant::declared{$full_name}; +} + +test 49, declared 'PI'; +test 50, $constant::declared{'main::PI'}; + +test 51, !declared 'PIE'; +test 52, !$constant::declared{'main::PIE'}; + +{ + package Other; + use constant IN_OTHER_PACK => 42; + ::test 53, ::declared 'IN_OTHER_PACK'; + ::test 54, $constant::declared{'Other::IN_OTHER_PACK'}; + ::test 55, ::declared 'main::PI'; + ::test 56, $constant::declared{'main::PI'}; +} + +test 57, declared 'Other::IN_OTHER_PACK'; +test 58, $constant::declared{'Other::IN_OTHER_PACK'}; diff --git a/t/pragma/overload.t b/t/pragma/overload.t index f673dce028..f9a9c59c87 100755 --- a/t/pragma/overload.t +++ b/t/pragma/overload.t @@ -759,7 +759,12 @@ else { }, 'deref'; # Hash: my @cont = sort %$deref; - test "@cont", '23 5 fake foo'; # 178 + if ("\t" eq "\011") { # ascii + test "@cont", '23 5 fake foo'; # 178 + } + else { # ebcdic alpha-numeric sort order + test "@cont", 'fake foo 23 5'; # 178 + } my @keys = sort keys %$deref; test "@keys", 'fake foo'; # 179 my @val = sort values %$deref; diff --git a/t/pragma/strict-subs b/t/pragma/strict-subs index deeb381473..ed4fe7a443 100644 --- a/t/pragma/strict-subs +++ b/t/pragma/strict-subs @@ -33,6 +33,24 @@ Execution of - aborted due to compilation errors. ######## # strict subs - error +use strict 'subs' ; +my @a = (A..Z); +EXPECT +Bareword "Z" not allowed while "strict subs" in use at - line 4. +Bareword "A" not allowed while "strict subs" in use at - line 4. +Execution of - aborted due to compilation errors. +######## + +# strict subs - error +use strict 'subs' ; +my $a = (B..Y); +EXPECT +Bareword "Y" not allowed while "strict subs" in use at - line 4. +Bareword "B" not allowed while "strict subs" in use at - line 4. +Execution of - aborted due to compilation errors. +######## + +# strict subs - error use strict ; Fred ; EXPECT diff --git a/t/pragma/utf8.t b/t/pragma/utf8.t index 01b0f0529c..2ae8d9c784 100755 --- a/t/pragma/utf8.t +++ b/t/pragma/utf8.t @@ -4,6 +4,10 @@ BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib'; $ENV{PERL5LIB} = '../lib'; + if ( ord("\t") != 9 ) { # skip on ebcdic platforms + print "1..0 # Skip utf8 tests on ebcdic platform.\n"; + exit; + } } print "1..12\n"; diff --git a/t/pragma/warn/1global b/t/pragma/warn/1global index 836b7f513f..0af80221b2 100644 --- a/t/pragma/warn/1global +++ b/t/pragma/warn/1global @@ -43,7 +43,7 @@ EXPECT $^W = 1 ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in scalar chop at - line 4. ######## # warnings enabled at compile time, disabled at run time @@ -59,7 +59,7 @@ BEGIN { $^W = 0 } $^W = 1 ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 5. +Use of uninitialized value in scalar chop at - line 5. ######## -w --FILE-- abcd @@ -68,7 +68,7 @@ my $b ; chop $b ; --FILE-- require "./abcd"; EXPECT -Use of uninitialized value at ./abcd line 1. +Use of uninitialized value in scalar chop at ./abcd line 1. ######## --FILE-- abcd @@ -78,7 +78,7 @@ my $b ; chop $b ; #! perl -w require "./abcd"; EXPECT -Use of uninitialized value at ./abcd line 1. +Use of uninitialized value in scalar chop at ./abcd line 1. ######## --FILE-- abcd @@ -88,7 +88,7 @@ my $b ; chop $b ; $^W =1 ; require "./abcd"; EXPECT -Use of uninitialized value at ./abcd line 1. +Use of uninitialized value in scalar chop at ./abcd line 1. ######## --FILE-- abcd @@ -110,28 +110,28 @@ $^W =0 ; require "./abcd"; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## $^W = 1; eval 'my $b ; chop $b ;' ; print $@ ; EXPECT -Use of uninitialized value at (eval 1) line 1. +Use of uninitialized value in scalar chop at (eval 1) line 1. ######## eval '$^W = 1;' ; print $@ ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in scalar chop at - line 4. ######## eval {$^W = 1;} ; print $@ ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in scalar chop at - line 4. ######## { @@ -149,12 +149,12 @@ my $a ; chop $a ; } my $c ; chop $c ; EXPECT -Use of uninitialized value at - line 5. +Use of uninitialized value in scalar chop at - line 5. ######## -w -e undef EXPECT -Use of uninitialized value at - line 2. +Use of uninitialized value in -e at - line 2. ######## $^W = 1 + 2 ; @@ -186,4 +186,4 @@ sub fred { my $b ; chop $b ;} fred() ; } EXPECT -Use of uninitialized value at - line 2. +Use of uninitialized value in scalar chop at - line 2. diff --git a/t/pragma/warn/2use b/t/pragma/warn/2use index 4ec4da0a77..384b3b361e 100644 --- a/t/pragma/warn/2use +++ b/t/pragma/warn/2use @@ -42,7 +42,7 @@ use warnings 'uninitialized' ; } my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 8. +Use of uninitialized value in scalar chop at - line 8. ######## # Check runtime scope of pragma @@ -53,7 +53,7 @@ no warnings ; } my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check runtime scope of pragma @@ -64,7 +64,7 @@ no warnings ; } &$a ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## use warnings 'deprecated' ; @@ -103,7 +103,7 @@ require "./abc"; my $a ; chop $a ; EXPECT Use of EQ is deprecated at ./abc line 2. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## --FILE-- abc.pm @@ -116,7 +116,7 @@ use abc; my $a ; chop $a ; EXPECT Use of EQ is deprecated at abc.pm line 2. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## # Check scope of pragma with eval @@ -137,7 +137,7 @@ eval { }; print STDERR $@ ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check scope of pragma with eval @@ -147,8 +147,8 @@ eval { }; print STDERR $@ ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 5. -Use of uninitialized value at - line 7. +Use of uninitialized value in scalar chop at - line 5. +Use of uninitialized value in scalar chop at - line 7. ######## # Check scope of pragma with eval @@ -159,7 +159,7 @@ eval { }; print STDERR $@ ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 8. +Use of uninitialized value in scalar chop at - line 8. ######## # Check scope of pragma with eval @@ -223,7 +223,7 @@ eval q[ ]; print STDERR $@; my $b ; chop $b ; EXPECT -Use of uninitialized value at (eval 1) line 3. +Use of uninitialized value in scalar chop at (eval 1) line 3. ######## # Check scope of pragma with eval @@ -233,8 +233,8 @@ eval ' '; print STDERR $@ ; my $b ; chop $b ; EXPECT -Use of uninitialized value at (eval 1) line 2. -Use of uninitialized value at - line 7. +Use of uninitialized value in scalar chop at (eval 1) line 2. +Use of uninitialized value in scalar chop at - line 7. ######## # Check scope of pragma with eval @@ -245,7 +245,7 @@ eval ' '; print STDERR $@ ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 8. +Use of uninitialized value in scalar chop at - line 8. ######## # Check scope of pragma with eval @@ -303,6 +303,6 @@ no warnings 'deprecated' ; 1 if $a EQ $b ; EXPECT Use of EQ is deprecated at - line 6. -Use of uninitialized value at - line 9. -Use of uninitialized value at - line 11. -Use of uninitialized value at - line 11. +Use of uninitialized value in scalar chop at - line 9. +Use of uninitialized value in string eq at - line 11. +Use of uninitialized value in string eq at - line 11. diff --git a/t/pragma/warn/3both b/t/pragma/warn/3both index 592724ad73..132b99b80f 100644 --- a/t/pragma/warn/3both +++ b/t/pragma/warn/3both @@ -13,7 +13,7 @@ sub fred { } EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings @@ -27,7 +27,7 @@ sub fred { } EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings @@ -64,7 +64,7 @@ $^W = 1 ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings @@ -73,7 +73,7 @@ use warnings ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings @@ -107,7 +107,7 @@ use warnings ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 5. +Use of uninitialized value in scalar chop at - line 5. ######## # Check interaction of $^W and use warnings @@ -119,7 +119,7 @@ sub fred { BEGIN { $^W = 0 } fred() ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings @@ -141,7 +141,7 @@ BEGIN { $^W = 1 } my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings @@ -150,7 +150,7 @@ use warnings ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings @@ -181,7 +181,7 @@ BEGIN { $^W = 1 } my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 10. +Use of uninitialized value in scalar chop at - line 10. ######## # Check interaction of $^W and use warnings @@ -194,4 +194,4 @@ BEGIN { $^W = 0 } my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 7. +Use of uninitialized value in scalar chop at - line 7. diff --git a/t/pragma/warn/4lint b/t/pragma/warn/4lint index 6a08409bb2..db54f31c7b 100644 --- a/t/pragma/warn/4lint +++ b/t/pragma/warn/4lint @@ -9,14 +9,14 @@ $a = 1 if $a EQ $b ; close STDIN ; print STDIN "abc" ; EXPECT Use of EQ is deprecated at - line 5. -print on closed filehandle main::STDIN at - line 6. +print() on closed filehandle main::STDIN at - line 6. ######## -W # lint: check runtime $^W is zapped $^W = 0 ; close STDIN ; print STDIN "abc" ; EXPECT -print on closed filehandle main::STDIN at - line 4. +print() on closed filehandle main::STDIN at - line 4. ######## -W # lint: check runtime $^W is zapped @@ -25,7 +25,7 @@ print on closed filehandle main::STDIN at - line 4. close STDIN ; print STDIN "abc" ; } EXPECT -print on closed filehandle main::STDIN at - line 5. +print() on closed filehandle main::STDIN at - line 5. ######## -W # lint: check "no warnings" is zapped @@ -35,7 +35,7 @@ $a = 1 if $a EQ $b ; close STDIN ; print STDIN "abc" ; EXPECT Use of EQ is deprecated at - line 5. -print on closed filehandle main::STDIN at - line 6. +print() on closed filehandle main::STDIN at - line 6. ######## -W # lint: check "no warnings" is zapped @@ -44,7 +44,7 @@ print on closed filehandle main::STDIN at - line 6. close STDIN ; print STDIN "abc" ; } EXPECT -print on closed filehandle main::STDIN at - line 5. +print() on closed filehandle main::STDIN at - line 5. ######## -Ww # lint: check combination of -w and -W @@ -53,7 +53,7 @@ print on closed filehandle main::STDIN at - line 5. close STDIN ; print STDIN "abc" ; } EXPECT -print on closed filehandle main::STDIN at - line 5. +print() on closed filehandle main::STDIN at - line 5. ######## -W --FILE-- abc.pm @@ -67,7 +67,7 @@ use abc; my $a ; chop $a ; EXPECT Use of EQ is deprecated at abc.pm line 3. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## -W --FILE-- abc @@ -81,7 +81,7 @@ require "./abc"; my $a ; chop $a ; EXPECT Use of EQ is deprecated at ./abc line 3. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## -W --FILE-- abc.pm @@ -95,7 +95,7 @@ use abc; my $a ; chop $a ; EXPECT Use of EQ is deprecated at abc.pm line 3. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## -W --FILE-- abc @@ -109,4 +109,4 @@ require "./abc"; my $a ; chop $a ; EXPECT Use of EQ is deprecated at ./abc line 3. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. diff --git a/t/pragma/warn/7fatal b/t/pragma/warn/7fatal index fe94511f3e..943bb06fb3 100644 --- a/t/pragma/warn/7fatal +++ b/t/pragma/warn/7fatal @@ -23,7 +23,7 @@ use warnings FATAL => 'uninitialized' ; my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT -Use of uninitialized value at - line 8. +Use of uninitialized value in scalar chop at - line 8. ######## # Check runtime scope of pragma @@ -35,7 +35,7 @@ no warnings ; &$a ; print STDERR "The End.\n" ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## --FILE-- abc @@ -69,7 +69,7 @@ my $a ; chop $a ; print STDERR "The End.\n" ; EXPECT Use of EQ is deprecated at ./abc line 2. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## --FILE-- abc.pm @@ -83,7 +83,7 @@ my $a ; chop $a ; print STDERR "The End.\n" ; EXPECT Use of EQ is deprecated at abc.pm line 2. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## # Check scope of pragma with eval @@ -95,7 +95,7 @@ eval { my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT --- Use of uninitialized value at - line 6. +-- Use of uninitialized value in scalar chop at - line 6. The End. ######## @@ -107,8 +107,8 @@ eval { my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT --- Use of uninitialized value at - line 5. -Use of uninitialized value at - line 7. +-- Use of uninitialized value in scalar chop at - line 5. +Use of uninitialized value in scalar chop at - line 7. ######## # Check scope of pragma with eval @@ -120,7 +120,7 @@ eval { my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT -Use of uninitialized value at - line 8. +Use of uninitialized value in scalar chop at - line 8. ######## # Check scope of pragma with eval @@ -178,7 +178,7 @@ eval q[ my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT --- Use of uninitialized value at (eval 1) line 3. +-- Use of uninitialized value in scalar chop at (eval 1) line 3. The End. ######## @@ -190,8 +190,8 @@ eval ' my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT --- Use of uninitialized value at (eval 1) line 2. -Use of uninitialized value at - line 7. +-- Use of uninitialized value in scalar chop at (eval 1) line 2. +Use of uninitialized value in scalar chop at - line 7. ######## # Check scope of pragma with eval @@ -203,7 +203,7 @@ eval ' my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT -Use of uninitialized value at - line 8. +Use of uninitialized value in scalar chop at - line 8. ######## # Check scope of pragma with eval diff --git a/t/pragma/warn/doio b/t/pragma/warn/doio index 5101bdef80..57dd993a2b 100644 --- a/t/pragma/warn/doio +++ b/t/pragma/warn/doio @@ -1,6 +1,6 @@ doio.c - Can't do bidirectional pipe [Perl_do_open9] + Can't open bidirectional pipe [Perl_do_open9] open(F, "| true |"); Missing command in piped open [Perl_do_open9] @@ -64,7 +64,7 @@ no warnings 'io' ; open(G, '|'.($^O eq 'VMS' ? 'mcr ':'')."$^X -e 1|"); close(G); EXPECT -Can't do bidirectional pipe at - line 3. +Can't open bidirectional pipe at - line 3. ######## # doio.c [Perl_do_open9] use warnings 'io' ; @@ -123,7 +123,7 @@ print $a ; no warnings 'uninitialized' ; print $b ; EXPECT -Use of uninitialized value at - line 3. +Use of uninitialized value in print at - line 3. ######## # doio.c [Perl_my_stat Perl_my_lstat] use warnings 'io' ; diff --git a/t/pragma/warn/doop b/t/pragma/warn/doop index 961d157502..cce6bdc07c 100644 --- a/t/pragma/warn/doop +++ b/t/pragma/warn/doop @@ -12,6 +12,12 @@ EXPECT Malformed UTF-8 character at - line 4. ######## # doop.c +BEGIN { + if (ord("\t") == 5) { + print "SKIPPED\n# Character codes differ on ebcdic machines."; + exit 0; + } +} use warnings 'utf8' ; use utf8 ; $_ = "\x80 \xff" ; @@ -20,6 +26,6 @@ no warnings 'utf8' ; $_ = "\x80 \xff" ; chop ; EXPECT -\x80 will produce malformed UTF-8 character; use \x{80} for that at - line 4. -\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 4. -Malformed UTF-8 character at - line 5. +\x80 will produce malformed UTF-8 character; use \x{80} for that at - line 10. +\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 10. +Malformed UTF-8 character at - line 11. diff --git a/t/pragma/warn/pp b/t/pragma/warn/pp index 48b5ec86b5..eb09e059ba 100644 --- a/t/pragma/warn/pp +++ b/t/pragma/warn/pp @@ -85,7 +85,7 @@ my $b = $$a; no warnings 'uninitialized' ; my $c = $$a; EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in scalar dereference at - line 4. ######## # pp.c use warnings 'unsafe' ; @@ -112,6 +112,12 @@ EXPECT Malformed UTF-8 character at - line 4. ######## # pp.c +BEGIN { + if (ord("\t") == 5) { + print "SKIPPED\n# Character codes differ on ebcdic machines."; + exit 0; + } +} use warnings 'utf8' ; use utf8 ; $_ = "\x80 \xff" ; @@ -120,6 +126,6 @@ no warnings 'utf8' ; $_ = "\x80 \xff" ; reverse ; EXPECT -\x80 will produce malformed UTF-8 character; use \x{80} for that at - line 4. -\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 4. -Malformed UTF-8 character at - line 5. +\x80 will produce malformed UTF-8 character; use \x{80} for that at - line 10. +\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 10. +Malformed UTF-8 character at - line 11. diff --git a/t/pragma/warn/pp_ctl b/t/pragma/warn/pp_ctl index 70e6d60e8d..f61da1a8e1 100644 --- a/t/pragma/warn/pp_ctl +++ b/t/pragma/warn/pp_ctl @@ -126,7 +126,7 @@ no warnings 'unsafe' ; @b = sort { last } @a ; EXPECT Exiting pseudo-block via last at - line 4. -Can't "last" outside a block at - line 4. +Can't "last" outside a loop block at - line 4. ######## # pp_ctl.c use warnings 'unsafe' ; diff --git a/t/pragma/warn/pp_hot b/t/pragma/warn/pp_hot index 9a4b0a0708..7e19dc5c94 100644 --- a/t/pragma/warn/pp_hot +++ b/t/pragma/warn/pp_hot @@ -9,7 +9,7 @@ Filehandle %s opened only for output [pp_print] print <STDOUT> ; - print on closed filehandle %s [pp_print] + print() on closed filehandle %s [pp_print] close STDIN ; print STDIN "abc" ; uninitialized [pp_rv2av] @@ -30,7 +30,7 @@ glob failed (can't start child: %s) [Perl_do_readline] <<TODO - Read on closed filehandle %s [Perl_do_readline] + readline() on closed filehandle %s [Perl_do_readline] close STDIN ; $a = <STDIN>; glob failed (child exited with status %d%s) [Perl_do_readline] <<TODO @@ -86,7 +86,7 @@ print STDIN "anc"; no warnings 'closed' ; print STDIN "anc"; EXPECT -print on closed filehandle main::STDIN at - line 4. +print() on closed filehandle main::STDIN at - line 4. ######## # pp_hot.c [pp_rv2av] use warnings 'uninitialized' ; @@ -95,7 +95,7 @@ my @b = @$a; no warnings 'uninitialized' ; my @c = @$a; EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in array dereference at - line 4. ######## # pp_hot.c [pp_rv2hv] use warnings 'uninitialized' ; @@ -104,7 +104,7 @@ my %b = %$a; no warnings 'uninitialized' ; my %c = %$a; EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in hash dereference at - line 4. ######## # pp_hot.c [pp_aassign] use warnings 'unsafe' ; @@ -128,7 +128,7 @@ close STDIN ; $a = <STDIN> ; no warnings 'closed' ; $a = <STDIN> ; EXPECT -Read on closed filehandle main::STDIN at - line 3. +readline() on closed filehandle main::STDIN at - line 3. ######## # pp_hot.c [Perl_do_readline] use warnings 'io' ; diff --git a/t/pragma/warn/pp_sys b/t/pragma/warn/pp_sys index 651cdf9515..ea4b536842 100644 --- a/t/pragma/warn/pp_sys +++ b/t/pragma/warn/pp_sys @@ -8,7 +8,7 @@ . write STDIN; - Write on closed filehandle %s [pp_leavewrite] + write() on closed filehandle %s [pp_leavewrite] format STDIN = . close STDIN; @@ -23,45 +23,47 @@ $a = "abc"; printf $a "fred" - printf on closed filehandle %s [pp_prtf] + printf() on closed filehandle %s [pp_prtf] close STDIN ; printf STDIN "fred" - Syswrite on closed filehandle [pp_send] + syswrite() on closed filehandle [pp_send] close STDIN; syswrite STDIN, "fred", 1; - Send on closed socket [pp_send] + send() on closed socket [pp_send] close STDIN; send STDIN, "fred", 1 - bind() on closed fd [pp_bind] + bind() on closed socket [pp_bind] close STDIN; bind STDIN, "fred" ; - connect() on closed fd [pp_connect] + connect() on closed socket [pp_connect] close STDIN; connect STDIN, "fred" ; - listen() on closed fd [pp_listen] + listen() on closed socket [pp_listen] close STDIN; listen STDIN, 2; - accept() on closed fd [pp_accept] + accept() on closed socket [pp_accept] close STDIN; accept STDIN, "fred" ; - shutdown() on closed fd [pp_shutdown] + shutdown() on closed socket [pp_shutdown] close STDIN; shutdown STDIN, 0; - [gs]etsockopt() on closed fd [pp_ssockopt] + setsockopt() on closed socket [pp_ssockopt] + getsockopt() on closed socket [pp_ssockopt] close STDIN; setsockopt STDIN, 1,2,3; getsockopt STDIN, 1,2; - get{sock, peer}name() on closed fd [pp_getpeername] + getsockname() on closed socket [pp_getpeername] + getpeername() on closed socket [pp_getpeername] close STDIN; getsockname STDIN; getpeername STDIN; @@ -112,7 +114,7 @@ write STDIN; no warnings 'closed' ; write STDIN; EXPECT -Write on closed filehandle main::STDIN at - line 6. +write() on closed filehandle main::STDIN at - line 6. ######## # pp_sys.c [pp_leavewrite] use warnings 'io' ; @@ -148,7 +150,7 @@ printf STDIN "fred"; no warnings 'closed' ; printf STDIN "fred"; EXPECT -printf on closed filehandle main::STDIN at - line 4. +printf() on closed filehandle main::STDIN at - line 4. ######## # pp_sys.c [pp_prtf] use warnings 'io' ; @@ -165,7 +167,7 @@ syswrite STDIN, "fred", 1; no warnings 'closed' ; syswrite STDIN, "fred", 1; EXPECT -Syswrite on closed filehandle at - line 4. +syswrite() on closed filehandle at - line 4. ######## # pp_sys.c [pp_prtf pp_send pp_bind pp_connect pp_listen pp_accept pp_shutdown pp_ssockopt ppp_getpeername] use warnings 'io' ; @@ -210,16 +212,16 @@ getsockopt STDIN, 1,2; getsockname STDIN; getpeername STDIN; EXPECT -Send on closed socket at - line 22. -bind() on closed fd at - line 23. -connect() on closed fd at - line 24. -listen() on closed fd at - line 25. -accept() on closed fd at - line 26. -shutdown() on closed fd at - line 27. -[gs]etsockopt() on closed fd at - line 28. -[gs]etsockopt() on closed fd at - line 29. -get{sock, peer}name() on closed fd at - line 30. -get{sock, peer}name() on closed fd at - line 31. +send() on closed socket at - line 22. +bind() on closed socket at - line 23. +connect() on closed socket at - line 24. +listen() on closed socket at - line 25. +accept() on closed socket at - line 26. +shutdown() on closed socket at - line 27. +setsockopt() on closed socket at - line 28. +getsockopt() on closed socket at - line 29. +getsockname() on closed socket at - line 30. +getpeername() on closed socket at - line 31. ######## # pp_sys.c [pp_stat] use warnings 'newline' ; diff --git a/t/pragma/warn/regcomp b/t/pragma/warn/regcomp index 92b8208a65..bb208db6bd 100644 --- a/t/pragma/warn/regcomp +++ b/t/pragma/warn/regcomp @@ -68,6 +68,7 @@ no warnings 'unsafe' ; /[[.foo.]]/; /[[=bar=]]/; /[:zog:]/; +BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3 } /[[:zog:]]/; EXPECT Character class syntax [: :] belongs inside character classes at - line 4. @@ -78,7 +79,7 @@ Character class syntax [= =] is reserved for future extensions at - line 6. Character class syntax [. .] is reserved for future extensions at - line 8. Character class syntax [= =] is reserved for future extensions at - line 9. Character class syntax [: :] belongs inside character classes at - line 10. -Character class [:zog:] unknown at - line 19. +Character class [:zog:] unknown at - line 20. ######## # regcomp.c [S_regclass] $_ = ""; @@ -113,6 +114,12 @@ EXPECT /[[:digit:]-[:alpha:]]/: false [] range "[:digit:]-" in regexp at - line 12. ######## # regcomp.c [S_regclassutf8] +BEGIN { + if (ord("\t") == 5) { + print "SKIPPED\n# ebcdic regular expression ranges differ."; + exit 0; + } +} use utf8; $_ = ""; use warnings 'unsafe' ; @@ -136,14 +143,14 @@ no warnings 'unsafe' ; /[[:alpha:]-[:digit:]]/; /[[:digit:]-[:alpha:]]/; EXPECT -/[a-\d]/: false [] range "a-\d" in regexp at - line 6. -/[\d-b]/: false [] range "\d-" in regexp at - line 7. -/[\s-\d]/: false [] range "\s-" in regexp at - line 8. -/[\d-\s]/: false [] range "\d-" in regexp at - line 9. -/[a-[:digit:]]/: false [] range "a-[:digit:]" in regexp at - line 10. -/[[:digit:]-b]/: false [] range "[:digit:]-" in regexp at - line 11. -/[[:alpha:]-[:digit:]]/: false [] range "[:alpha:]-" in regexp at - line 12. -/[[:digit:]-[:alpha:]]/: false [] range "[:digit:]-" in regexp at - line 13. +/[a-\d]/: false [] range "a-\d" in regexp at - line 12. +/[\d-b]/: false [] range "\d-" in regexp at - line 13. +/[\s-\d]/: false [] range "\s-" in regexp at - line 14. +/[\d-\s]/: false [] range "\d-" in regexp at - line 15. +/[a-[:digit:]]/: false [] range "a-[:digit:]" in regexp at - line 16. +/[[:digit:]-b]/: false [] range "[:digit:]-" in regexp at - line 17. +/[[:alpha:]-[:digit:]]/: false [] range "[:alpha:]-" in regexp at - line 18. +/[[:digit:]-[:alpha:]]/: false [] range "[:digit:]-" in regexp at - line 19. ######## # regcomp.c [S_regclass S_regclassutf8] use warnings 'unsafe' ; diff --git a/t/pragma/warn/sv b/t/pragma/warn/sv index c02ff01b82..97d61bca17 100644 --- a/t/pragma/warn/sv +++ b/t/pragma/warn/sv @@ -58,7 +58,7 @@ $x = 1 + $a[0] ; # a no warnings 'uninitialized' ; $x = 1 + $b[0] ; # a EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in integer addition (+) at - line 4. ######## # sv.c (sv_2iv) package fred ; @@ -73,7 +73,7 @@ $A *= 2 ; no warnings 'uninitialized' ; $A *= 2 ; EXPECT -Use of uninitialized value at - line 10. +Use of uninitialized value in integer multiplication (*) at - line 10. ######## # sv.c use integer ; @@ -82,7 +82,7 @@ my $x *= 2 ; #b no warnings 'uninitialized' ; my $y *= 2 ; #b EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in integer multiplication (*) at - line 4. ######## # sv.c (sv_2uv) package fred ; @@ -98,7 +98,7 @@ no warnings 'uninitialized' ; $B = 0 ; $B |= $A ; EXPECT -Use of uninitialized value at - line 10. +Use of uninitialized value in bitwise or (|) at - line 10. ######## # sv.c use warnings 'uninitialized' ; @@ -108,7 +108,7 @@ no warnings 'uninitialized' ; my $Y = 1 ; $x = 1 | $b[$Y] ; EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in bitwise or (|) at - line 4. ######## # sv.c use warnings 'uninitialized' ; @@ -116,7 +116,7 @@ my $x *= 1 ; # d no warnings 'uninitialized' ; my $y *= 1 ; # d EXPECT -Use of uninitialized value at - line 3. +Use of uninitialized value in multiplication (*) at - line 3. ######## # sv.c use warnings 'uninitialized' ; @@ -124,7 +124,7 @@ $x = 1 + $a[0] ; # e no warnings 'uninitialized' ; $x = 1 + $b[0] ; # e EXPECT -Use of uninitialized value at - line 3. +Use of uninitialized value in addition (+) at - line 3. ######## # sv.c (sv_2nv) package fred ; @@ -138,7 +138,7 @@ $A *= 2 ; no warnings 'uninitialized' ; $A *= 2 ; EXPECT -Use of uninitialized value at - line 9. +Use of uninitialized value in multiplication (*) at - line 9. ######## # sv.c use warnings 'uninitialized' ; @@ -146,7 +146,7 @@ $x = $y + 1 ; # f no warnings 'uninitialized' ; $x = $z + 1 ; # f EXPECT -Use of uninitialized value at - line 3. +Use of uninitialized value in addition (+) at - line 3. ######## # sv.c use warnings 'uninitialized' ; @@ -162,7 +162,7 @@ $x = chop $y ; # h no warnings 'uninitialized' ; $x = chop $z ; # h EXPECT -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## # sv.c (sv_2pv) package fred ; @@ -178,7 +178,7 @@ no warnings 'uninitialized' ; $C = "" ; $C .= $A ; EXPECT -Use of uninitialized value at - line 10. +Use of uninitialized value in concatenation (.) at - line 10. ######## # sv.c use warnings 'numeric' ; @@ -269,6 +269,12 @@ EXPECT Undefined value assigned to typeglob at - line 3. ######## # sv.c +BEGIN { + if (ord("\t") == 5) { + print "SKIPPED\n# ebcdic \\x characters differ."; + exit 0; + } +} use utf8 ; $^W =0 ; { @@ -279,9 +285,9 @@ $^W =0 ; } my $a = rindex "a\xff bc ", "bc" ; EXPECT -\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 6. -Malformed UTF-8 character at - line 6. -Malformed UTF-8 character at - line 10. +\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 12. +Malformed UTF-8 character at - line 12. +Malformed UTF-8 character at - line 16. ######## # sv.c use warnings 'misc'; diff --git a/t/pragma/warn/toke b/t/pragma/warn/toke index ee02efa813..515241ab4d 100644 --- a/t/pragma/warn/toke +++ b/t/pragma/warn/toke @@ -462,13 +462,19 @@ EXPECT ######## # toke.c +BEGIN { + if (ord("\t") == 5) { + print "SKIPPED\n# Ebcdic platforms have different \\x constructs."; + exit 0; + } +} use warnings 'utf8' ; use utf8 ; $_ = " \xffe " ; no warnings 'utf8' ; $_ = " \xffe " ; EXPECT -\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 4. +\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 10. ######## # toke.c my $a = rand + 4 ; diff --git a/t/pragma/warn/utf8 b/t/pragma/warn/utf8 index b11514d826..19b8d1db3a 100644 --- a/t/pragma/warn/utf8 +++ b/t/pragma/warn/utf8 @@ -22,6 +22,12 @@ EXPECT Malformed UTF-8 character at - line 3. ######## # utf8.c [utf8_to_uv] +BEGIN { + if (ord("\t") == 5) { + print "SKIPPED\n# Ebcdic platforms have different \\x constructs."; + exit 0; + } +} use utf8 ; my $a = ord "\x80" ; { @@ -31,9 +37,9 @@ my $a = ord "\x80" ; my $a = ord "\x80" ; } EXPECT -Malformed UTF-8 character at - line 3. -\x80 will produce malformed UTF-8 character; use \x{80} for that at - line 6. -Malformed UTF-8 character at - line 6. +Malformed UTF-8 character at - line 9. +\x80 will produce malformed UTF-8 character; use \x{80} for that at - line 12. +Malformed UTF-8 character at - line 12. ######## # utf8.c [utf8_to_uv] use utf8 ; @@ -42,6 +48,12 @@ EXPECT Malformed UTF-8 character at - line 3. ######## # utf8.c [utf8_to_uv] +BEGIN { + if (ord("\t") == 5) { + print "SKIPPED\n# Ebcdic platforms have different \\x constructs."; + exit 0; + } +} use utf8 ; my $a = ord "\xf080" ; { @@ -51,6 +63,6 @@ my $a = ord "\xf080" ; my $a = ord "\xf080" ; } EXPECT -Malformed UTF-8 character at - line 3. -\xf0 will produce malformed UTF-8 character; use \x{f0} for that at - line 6. -Malformed UTF-8 character at - line 6. +Malformed UTF-8 character at - line 9. +\xf0 will produce malformed UTF-8 character; use \x{f0} for that at - line 12. +Malformed UTF-8 character at - line 12. @@ -1,4 +1,4 @@ -#ifdef USE_THREADS +#if defined(USE_THREADS) || defined(USE_ITHREADS) #ifdef WIN32 # include <win32thread.h> @@ -73,7 +73,9 @@ struct perl_thread *getTHR (void); } STMT_END #define MUTEX_LOCK(m) mutex_lock(*m) +#define MUTEX_LOCK_NOCONTEXT(m) mutex_lock(*m) #define MUTEX_UNLOCK(m) mutex_unlock(*m) +#define MUTEX_UNLOCK_NOCONTEXT(m) mutex_unlock(*m) #define MUTEX_DESTROY(m) \ STMT_START { \ mutex_free(*m); \ @@ -109,7 +111,7 @@ struct perl_thread *getTHR (void); #define JOIN(t, avp) (*(avp) = (AV *)cthread_join(t->self)) #define SET_THR(thr) cthread_set_data(cthread_self(), thr) -#define THR cthread_data(cthread_self()) +#define THR ((struct perl_thread *)cthread_data(cthread_self())) #define INIT_THREADS cthread_init() #define YIELD cthread_yield() @@ -236,10 +238,19 @@ struct perl_thread *getTHR (void); } STMT_END #endif /* SET_THR */ -#ifndef THR -#define THR ((struct perl_thread *) pthread_getspecific(PL_thr_key)) +#ifndef INIT_THREADS +# ifdef NEED_PTHREAD_INIT +# define INIT_THREADS pthread_init() +# endif #endif +#ifndef THREAD_RET_TYPE +# define THREAD_RET_TYPE void * +# define THREAD_RET_CAST(p) ((void *)(p)) +#endif /* THREAD_RET */ + +#if defined(USE_THREADS) + /* * dTHR is performance-critical. Here, we only do the pthread_get_specific * if there may be more than one thread in existence, otherwise we get thr @@ -249,21 +260,18 @@ struct perl_thread *getTHR (void); * * The use of PL_threadnum should be safe here. */ -#ifndef dTHR -# define dTHR \ - struct perl_thread *thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv) -#endif /* dTHR */ +# if !defined(dTHR) +# define dTHR \ + struct perl_thread *thr = PL_threadnum ? THR : (struct perl_thread*)SvPVX(PL_thrsv) +# endif /* dTHR */ -#ifndef INIT_THREADS -# ifdef NEED_PTHREAD_INIT -# define INIT_THREADS pthread_init() -# else -# define INIT_THREADS NOOP +# if !defined(THR) +# define THR ((struct perl_thread *) pthread_getspecific(PL_thr_key)) # endif -#endif + /* Accessor for per-thread SVs */ -#define THREADSV(i) (thr->threadsvp[i]) +# define THREADSV(i) (thr->threadsvp[i]) /* * LOCK_SV_MUTEX and UNLOCK_SV_MUTEX are performance-critical. Here, we @@ -272,31 +280,12 @@ struct perl_thread *getTHR (void); * remove the "if (threadnum) ..." test. * XXX do NOT use C<if (PL_threadnum) ...> -- it sets up race conditions! */ -#define LOCK_SV_MUTEX \ - STMT_START { \ - MUTEX_LOCK(&PL_sv_mutex); \ - } STMT_END - -#define UNLOCK_SV_MUTEX \ - STMT_START { \ - MUTEX_UNLOCK(&PL_sv_mutex); \ - } STMT_END - -/* Likewise for strtab_mutex */ -#define LOCK_STRTAB_MUTEX \ - STMT_START { \ - MUTEX_LOCK(&PL_strtab_mutex); \ - } STMT_END - -#define UNLOCK_STRTAB_MUTEX \ - STMT_START { \ - MUTEX_UNLOCK(&PL_strtab_mutex); \ - } STMT_END - -#ifndef THREAD_RET_TYPE -# define THREAD_RET_TYPE void * -# define THREAD_RET_CAST(p) ((void *)(p)) -#endif /* THREAD_RET */ +# define LOCK_SV_MUTEX MUTEX_LOCK(&PL_sv_mutex) +# define UNLOCK_SV_MUTEX MUTEX_UNLOCK(&PL_sv_mutex) +# define LOCK_STRTAB_MUTEX MUTEX_LOCK(&PL_strtab_mutex) +# define UNLOCK_STRTAB_MUTEX MUTEX_UNLOCK(&PL_strtab_mutex) +# define LOCK_CRED_MUTEX MUTEX_LOCK(&PL_cred_mutex) +# define UNLOCK_CRED_MUTEX MUTEX_UNLOCK(&PL_cred_mutex) /* Values and macros for thr->flags */ @@ -330,24 +319,85 @@ typedef struct condpair { #define MgCONDP(mg) (&((condpair_t *)(mg->mg_ptr))->cond) #define MgOWNER(mg) ((condpair_t *)(mg->mg_ptr))->owner -#else -/* USE_THREADS is not defined */ -#define MUTEX_LOCK(m) -#define MUTEX_LOCK_NOCONTEXT(m) -#define MUTEX_UNLOCK(m) -#define MUTEX_UNLOCK_NOCONTEXT(m) -#define MUTEX_INIT(m) -#define MUTEX_DESTROY(m) -#define COND_INIT(c) -#define COND_SIGNAL(c) -#define COND_BROADCAST(c) -#define COND_WAIT(c, m) -#define COND_DESTROY(c) -#define LOCK_SV_MUTEX -#define UNLOCK_SV_MUTEX -#define LOCK_STRTAB_MUTEX -#define UNLOCK_STRTAB_MUTEX - -#define THR -#define dTHR dNOOP #endif /* USE_THREADS */ +#endif /* USE_THREADS || USE_ITHREADS */ + +#ifndef MUTEX_LOCK +# define MUTEX_LOCK(m) +#endif + +#ifndef MUTEX_LOCK_NOCONTEXT +# define MUTEX_LOCK_NOCONTEXT(m) +#endif + +#ifndef MUTEX_UNLOCK +# define MUTEX_UNLOCK(m) +#endif + +#ifndef MUTEX_UNLOCK_NOCONTEXT +# define MUTEX_UNLOCK_NOCONTEXT(m) +#endif + +#ifndef MUTEX_INIT +# define MUTEX_INIT(m) +#endif + +#ifndef MUTEX_DESTROY +# define MUTEX_DESTROY(m) +#endif + +#ifndef COND_INIT +# define COND_INIT(c) +#endif + +#ifndef COND_SIGNAL +# define COND_SIGNAL(c) +#endif + +#ifndef COND_BROADCAST +# define COND_BROADCAST(c) +#endif + +#ifndef COND_WAIT +# define COND_WAIT(c, m) +#endif + +#ifndef COND_DESTROY +# define COND_DESTROY(c) +#endif + +#ifndef LOCK_SV_MUTEX +# define LOCK_SV_MUTEX +#endif + +#ifndef UNLOCK_SV_MUTEX +# define UNLOCK_SV_MUTEX +#endif + +#ifndef LOCK_STRTAB_MUTEX +# define LOCK_STRTAB_MUTEX +#endif + +#ifndef UNLOCK_STRTAB_MUTEX +# define UNLOCK_STRTAB_MUTEX +#endif + +#ifndef LOCK_CRED_MUTEX +# define LOCK_CRED_MUTEX +#endif + +#ifndef UNLOCK_CRED_MUTEX +# define UNLOCK_CRED_MUTEX +#endif + +#ifndef THR +# define THR +#endif + +#ifndef dTHR +# define dTHR dNOOP +#endif + +#ifndef INIT_THREADS +# define INIT_THREADS NOOP +#endif @@ -28,8 +28,9 @@ static char ident_too_long[] = "Identifier too long"; static void restore_rsfp(pTHXo_ void *f); -static void restore_expect(pTHXo_ void *e); -static void restore_lex_expect(pTHXo_ void *e); + +#define XFAKEBRACK 128 +#define XENUMMASK 127 #define UTF (PL_hints & HINT_UTF8) /* @@ -303,15 +304,36 @@ S_depcom(pTHX) * utf16-to-utf8-reversed. */ -#ifdef WIN32 +#ifdef PERL_CR_FILTER +static void +strip_return(SV *sv) +{ + register char *s = SvPVX(sv); + register char *e = s + SvCUR(sv); + /* outer loop optimized to do nothing if there are no CR-LFs */ + while (s < e) { + if (*s++ == '\r' && *s == '\n') { + /* hit a CR-LF, need to copy the rest */ + register char *d = s - 1; + *d++ = *s++; + while (s < e) { + if (*s == '\r' && s[1] == '\n') + s++; + *d++ = *s++; + } + SvCUR(sv) -= s - d; + return; + } + } +} STATIC I32 -S_win32_textfilter(pTHX_ int idx, SV *sv, int maxlen) +S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) { - I32 count = FILTER_READ(idx+1, sv, maxlen); - if (count > 0 && !maxlen) - win32_strip_return(sv); - return count; + I32 count = FILTER_READ(idx+1, sv, maxlen); + if (count > 0 && !maxlen) + strip_return(sv); + return count; } #endif @@ -360,11 +382,10 @@ Perl_lex_start(pTHX_ SV *line) SAVEI32(PL_lex_dojoin); SAVEI32(PL_lex_brackets); - SAVEI32(PL_lex_fakebrack); SAVEI32(PL_lex_casemods); SAVEI32(PL_lex_starts); SAVEI32(PL_lex_state); - SAVESPTR(PL_lex_inpat); + SAVEVPTR(PL_lex_inpat); SAVEI32(PL_lex_inwhat); SAVECOPLINE(PL_curcop); SAVEPPTR(PL_bufptr); @@ -380,14 +401,13 @@ Perl_lex_start(pTHX_ SV *line) SAVEI32(PL_lex_defer); SAVEI32(PL_sublex_info.sub_inwhat); SAVESPTR(PL_lex_repl); - SAVEDESTRUCTOR_X(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */ - SAVEDESTRUCTOR_X(restore_lex_expect, PL_tokenbuf + PL_expect); + SAVEINT(PL_expect); + SAVEINT(PL_lex_expect); PL_lex_state = LEX_NORMAL; PL_lex_defer = 0; PL_expect = XSTATE; PL_lex_brackets = 0; - PL_lex_fakebrack = 0; New(899, PL_lex_brackstack, 120, char); New(899, PL_lex_casestack, 12, char); SAVEFREEPV(PL_lex_brackstack); @@ -673,7 +693,7 @@ S_uni(pTHX_ I32 f, char *s) */ STATIC I32 -S_lop(pTHX_ I32 f, expectation x, char *s) +S_lop(pTHX_ I32 f, int x, char *s) { dTHR; yylval.ival = f; @@ -804,13 +824,12 @@ S_force_version(pTHX_ char *s) s = skipspace(s); - /* default VERSION number -- GBARR */ - - if(isDIGIT(*s)) { - char *d; - int c; - for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++); - if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') { + if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { + char *d = s; + if (*d == 'v') + d++; + for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++); + if ((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') { s = scan_num(s); /* real VERSION number -- GBARR */ version = yylval.opval; @@ -963,11 +982,10 @@ S_sublex_push(pTHX) PL_lex_state = PL_sublex_info.super_state; SAVEI32(PL_lex_dojoin); SAVEI32(PL_lex_brackets); - SAVEI32(PL_lex_fakebrack); SAVEI32(PL_lex_casemods); SAVEI32(PL_lex_starts); SAVEI32(PL_lex_state); - SAVESPTR(PL_lex_inpat); + SAVEVPTR(PL_lex_inpat); SAVEI32(PL_lex_inwhat); SAVECOPLINE(PL_curcop); SAVEPPTR(PL_bufptr); @@ -988,7 +1006,6 @@ S_sublex_push(pTHX) PL_lex_dojoin = FALSE; PL_lex_brackets = 0; - PL_lex_fakebrack = 0; New(899, PL_lex_brackstack, 120, char); New(899, PL_lex_casestack, 12, char); SAVEFREEPV(PL_lex_brackstack); @@ -1036,7 +1053,6 @@ S_sublex_done(pTHX) SAVEFREESV(PL_linestr); PL_lex_dojoin = FALSE; PL_lex_brackets = 0; - PL_lex_fakebrack = 0; PL_lex_casemods = 0; *PL_lex_casestack = '\0'; PL_lex_starts = 0; @@ -1877,9 +1893,9 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) STATIC char * S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append) { -#ifdef WIN32FILTER +#ifdef PERL_CR_FILTER if (!PL_rsfp_filters) { - filter_add(win32_textfilter,NULL); + filter_add(S_cr_textfilter,NULL); } #endif if (PL_rsfp_filters) { @@ -2913,7 +2929,8 @@ Perl_yylex(pTHX) if (++t < PL_bufend && (!isALNUM(*t) || ((*t == 'q' || *t == 'x') && ++t < PL_bufend - && !isALNUM(*t)))) { + && !isALNUM(*t)))) + { char *tmps; char open, close, term; I32 brackets = 1; @@ -2944,8 +2961,10 @@ Perl_yylex(pTHX) } t++; } - else if (isIDFIRST_lazy(s)) { - for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ; + else if (isALNUM_lazy(t)) { + t += UTF8SKIP(t); + while (t < PL_bufend && isALNUM_lazy(t)) + t += UTF8SKIP(t); } while (t < PL_bufend && isSPACE(*t)) t++; @@ -2978,7 +2997,8 @@ Perl_yylex(pTHX) PL_lex_formbrack = 0; if (PL_lex_state == LEX_INTERPNORMAL) { if (PL_lex_brackets == 0) { - if (PL_lex_fakebrack) { + if (PL_expect & XFAKEBRACK) { + PL_expect &= XENUMMASK; PL_lex_state = LEX_INTERPEND; PL_bufptr = s; return yylex(); /* ignore fake brackets */ @@ -2989,9 +3009,9 @@ Perl_yylex(pTHX) PL_lex_state = LEX_INTERPEND; } } - if (PL_lex_brackets < PL_lex_fakebrack) { + if (PL_expect & XFAKEBRACK) { + PL_expect &= XENUMMASK; PL_bufptr = s; - PL_lex_fakebrack = 0; return yylex(); /* ignore fake brackets */ } force_next('}'); @@ -3399,6 +3419,19 @@ Perl_yylex(pTHX) no_op("Backslash",s); OPERATOR(REFGEN); + case 'v': + if (isDIGIT(s[1]) && PL_expect == XTERM) { + char *start = s; + start++; + start++; + while (isDIGIT(*start)) + start++; + if (*start == '.' && isDIGIT(start[1])) { + s = scan_num(s); + TERM(THING); + } + } + goto keylookup; case 'x': if (isDIGIT(s[1]) && PL_expect == XOPERATOR) { s++; @@ -3428,7 +3461,7 @@ Perl_yylex(pTHX) case 's': case 'S': case 't': case 'T': case 'u': case 'U': - case 'v': case 'V': + case 'V': case 'w': case 'W': case 'X': case 'y': case 'Y': @@ -3502,6 +3535,7 @@ Perl_yylex(pTHX) } else if (gv && !gvp && -tmp==KEY_lock /* XXX generalizable kludge */ + && GvCVu(gv) && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE)) { tmp = 0; /* any sub overrides "weak" keyword */ @@ -3772,6 +3806,28 @@ Perl_yylex(pTHX) IoTYPE(GvIOp(gv)) = '-'; else IoTYPE(GvIOp(gv)) = '<'; +#if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS) + /* if the script was opened in binmode, we need to revert + * it to text mode for compatibility; but only iff it has CRs + * XXX this is a questionable hack at best. */ + if (PL_bufend-PL_bufptr > 2 + && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r') + { + Off_t loc = 0; + if (IoTYPE(GvIOp(gv)) == '<') { + loc = PerlIO_tell(PL_rsfp); + (void)PerlIO_seek(PL_rsfp, 0L, 0); + } + if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) { +#if defined(__BORLANDC__) + /* XXX see note in do_binmode() */ + ((FILE*)PL_rsfp)->flags |= _F_BIN; +#endif + if (loc > 0) + PerlIO_seek(PL_rsfp, loc, 0); + } + } +#endif PL_rsfp = Nullfp; } goto fake_eof; @@ -4361,12 +4417,18 @@ Perl_yylex(pTHX) OLDLOP(OP_RETURN); case KEY_require: - *PL_tokenbuf = '\0'; - s = force_word(s,WORD,TRUE,TRUE,FALSE); - if (isIDFIRST_lazy(PL_tokenbuf)) - gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE); - else if (*s == '<') - yyerror("<> should be quotes"); + s = skipspace(s); + if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { + s = force_version(s); + } + else { + *PL_tokenbuf = '\0'; + s = force_word(s,WORD,TRUE,TRUE,FALSE); + if (isIDFIRST_lazy(PL_tokenbuf)) + gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE); + else if (*s == '<') + yyerror("<> should be quotes"); + } UNI(OP_REQUIRE); case KEY_reset: @@ -4728,9 +4790,9 @@ Perl_yylex(pTHX) if (PL_expect != XSTATE) yyerror("\"use\" not allowed in expression"); s = skipspace(s); - if(isDIGIT(*s)) { + if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { s = force_version(s); - if(*s == ';' || (s = skipspace(s), *s == ';')) { + if (*s == ';' || (s = skipspace(s), *s == ';')) { PL_nextval[PL_nexttoke].opval = Nullop; force_next(WORD); } @@ -5604,8 +5666,6 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des char *bracket = 0; char funny = *s++; - if (PL_lex_brackets == 0) - PL_lex_fakebrack = 0; if (isSPACE(*s)) s = skipspace(s); d = dest; @@ -5710,9 +5770,8 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des "Ambiguous use of %c{%s%s} resolved to %c%s%s", funny, dest, brack, funny, dest, brack); } - PL_lex_fakebrack = PL_lex_brackets+1; bracket++; - PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; + PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK); return s; } } @@ -6508,7 +6567,7 @@ Perl_scan_num(pTHX_ char *start) register char *e; /* end of temp buffer */ IV tryiv; /* used to see if it can be an IV */ NV value; /* number read, as a double */ - SV *sv; /* place to put the converted number */ + SV *sv = Nullsv; /* place to put the converted number */ bool floatit; /* boolean: int or float? */ char *lastub = 0; /* position of last underbar */ static char number_too_long[] = "Number too long"; @@ -6520,8 +6579,7 @@ Perl_scan_num(pTHX_ char *start) Perl_croak(aTHX_ "panic: scan_num"); /* if it starts with a 0, it could be an octal number, a decimal in - 0.13 disguise, or a hexadecimal number, or a binary number. - */ + 0.13 disguise, or a hexadecimal number, or a binary number. */ case '0': { /* variables: @@ -6783,11 +6841,61 @@ Perl_scan_num(pTHX_ char *start) (floatit ? "float" : "integer"), sv, Nullsv, NULL); break; + /* if it starts with a v, it could be a version number */ + case 'v': + { + char *pos = s; + pos++; + while (isDIGIT(*pos)) + pos++; + if (*pos == '.' && isDIGIT(pos[1])) { + UV rev; + U8 tmpbuf[10]; + U8 *tmpend; + NV nshift = 1.0; + s++; /* get past 'v' */ + + sv = NEWSV(92,5); + SvUPGRADE(sv, SVt_PVNV); + sv_setpvn(sv, "", 0); + + do { + rev = atoi(s); + s = ++pos; + while (isDIGIT(*pos)) + pos++; + + tmpend = uv_to_utf8(tmpbuf, rev); + *tmpend = '\0'; + sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); + if (rev > 0) + SvNVX(sv) += (NV)rev/nshift; + nshift *= 1000; + } while (*pos == '.' && isDIGIT(pos[1])); + + rev = atoi(s); + s = pos; + tmpend = uv_to_utf8(tmpbuf, rev); + *tmpend = '\0'; + sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); + if (rev > 0) + SvNVX(sv) += (NV)rev/nshift; + + SvPOK_on(sv); + SvNOK_on(sv); + SvREADONLY_on(sv); + SvUTF8_on(sv); + } + } + break; } /* make the op for the constant and return */ - yylval.opval = newSVOP(OP_CONST, 0, sv); + if (sv) + yylval.opval = newSVOP(OP_CONST, 0, sv); + else + yylval.opval = Nullop; return s; } @@ -6829,6 +6937,14 @@ S_scan_formline(pTHX_ register char *s) needargs = TRUE; } sv_catpvn(stuff, s, eol-s); +#ifndef PERL_STRICT_CR + if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') { + char *end = SvPVX(stuff) + SvCUR(stuff); + end[-2] = '\n'; + end[-1] = '\0'; + SvCUR(stuff)--; + } +#endif } s = eol; if (PL_rsfp) { @@ -6886,10 +7002,10 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) if (PL_compcv) { assert(SvTYPE(PL_compcv) == SVt_PVCV); } - save_I32(&PL_subline); + SAVEI32(PL_subline); save_item(PL_subname); SAVEI32(PL_padix); - SAVESPTR(PL_curpad); + SAVEVPTR(PL_curpad); SAVESPTR(PL_comppad); SAVESPTR(PL_comppad_name); SAVESPTR(PL_compcv); @@ -7033,29 +7149,3 @@ restore_rsfp(pTHXo_ void *f) PerlIO_close(PL_rsfp); PL_rsfp = fp; } - -/* - * restore_expect - * Restores the state of PL_expect when the lexing that begun with a - * start_lex() call has ended. - */ - -static void -restore_expect(pTHXo_ void *e) -{ - /* a safe way to store a small integer in a pointer */ - PL_expect = (expectation)((char *)e - PL_tokenbuf); -} - -/* - * restore_lex_expect - * Restores the state of PL_lex_expect when the lexing that begun with a - * start_lex() call has ended. - */ - -static void -restore_lex_expect(pTHXo_ void *e) -{ - /* a safe way to store a small integer in a pointer */ - PL_lex_expect = (expectation)((char *)e - PL_tokenbuf); -} @@ -99,7 +99,7 @@ #ifndef SIGILL # define SIGILL 6 /* blech */ #endif -#define ABORT() kill(getpid(),SIGABRT); +#define ABORT() kill(PerlProc_getpid(),SIGABRT); /* * fwrite1() should be a routine with the same calling sequence as fwrite(), @@ -69,7 +69,7 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) return d; } #ifdef HAS_QUAD - if (uv < 0x2000000000) + if (uv < 0x1000000000) #endif { *d++ = 0xfe; /* Can't match U+FEFF! */ @@ -27,5 +27,6 @@ EXTCONST unsigned char PL_utf8skip[]; END_EXTERN_C #define IN_UTF8 (PL_curcop->op_private & HINT_UTF8) +#define IN_BYTE (PL_curcop->op_private & HINT_BYTE) #define UTF8SKIP(s) PL_utf8skip[*(U8*)s] @@ -1889,7 +1889,7 @@ Perl_my_setenv_init(char ***penviron) } void -my_setenv(char *nam, char *val) +Perl_my_setenv(pTHX_ char *nam, char *val) { /* You can not directly manipulate the environ[] array because * the routines do some additional work that syncs the Cygwin @@ -1901,13 +1901,13 @@ my_setenv(char *nam, char *val) if (!oldstr) return; unsetenv(nam); - Safefree(oldstr); + safesysfree(oldstr); return; } setenv(nam, val, 1); environ = *Perl_main_environ; /* environ realloc can occur in setenv */ if(oldstr && environ[setenv_getix(nam)] != oldstr) - Safefree(oldstr); + safesysfree(oldstr); } #else /* if WIN32 */ @@ -2003,9 +2003,10 @@ Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */ } #endif +/* this is a drop-in replacement for bcopy() */ #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY) char * -Perl_my_bcopy(pTHX_ register const char *from,register char *to,register I32 len) +Perl_my_bcopy(register const char *from,register char *to,register I32 len) { char *retval = to; @@ -2023,9 +2024,10 @@ Perl_my_bcopy(pTHX_ register const char *from,register char *to,register I32 len } #endif +/* this is a drop-in replacement for memset() */ #ifndef HAS_MEMSET void * -Perl_my_memset(pTHX_ register char *loc, register I32 ch, register I32 len) +Perl_my_memset(register char *loc, register I32 ch, register I32 len) { char *retval = loc; @@ -2035,9 +2037,10 @@ Perl_my_memset(pTHX_ register char *loc, register I32 ch, register I32 len) } #endif +/* this is a drop-in replacement for bzero() */ #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) char * -Perl_my_bzero(pTHX_ register char *loc, register I32 len) +Perl_my_bzero(register char *loc, register I32 len) { char *retval = loc; @@ -2047,9 +2050,10 @@ Perl_my_bzero(pTHX_ register char *loc, register I32 len) } #endif +/* this is a drop-in replacement for memcmp() */ #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) I32 -Perl_my_memcmp(pTHX_ const char *s1, const char *s2, register I32 len) +Perl_my_memcmp(const char *s1, const char *s2, register I32 len) { register U8 *a = (U8 *)s1; register U8 *b = (U8 *)s2; @@ -2302,7 +2306,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) #endif /* defined OS2 */ /*SUPPRESS 560*/ if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) - sv_setiv(GvSV(tmpgv), getpid()); + sv_setiv(GvSV(tmpgv), PerlProc_getpid()); PL_forkprocess = 0; hv_clear(PL_pidstatus); /* we have no children */ return Nullfp; @@ -2497,7 +2501,7 @@ Perl_rsignal_state(pTHX_ int signo) oldsig = PerlProc_signal(signo, sig_trap); PerlProc_signal(signo, oldsig); if (sig_trapped) - PerlProc_kill(getpid(), signo); + PerlProc_kill(PerlProc_getpid(), signo); return oldsig; } @@ -3339,11 +3343,11 @@ Perl_condpair_magic(pTHX_ SV *sv) COND_INIT(&cp->owner_cond); COND_INIT(&cp->cond); cp->owner = 0; - MUTEX_LOCK(&PL_cred_mutex); /* XXX need separate mutex? */ + LOCK_CRED_MUTEX; /* XXX need separate mutex? */ mg = mg_find(sv, 'm'); if (mg) { /* someone else beat us to initialising it */ - MUTEX_UNLOCK(&PL_cred_mutex); /* XXX need separate mutex? */ + UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */ MUTEX_DESTROY(&cp->mutex); COND_DESTROY(&cp->owner_cond); COND_DESTROY(&cp->cond); @@ -3354,7 +3358,7 @@ Perl_condpair_magic(pTHX_ SV *sv) mg = SvMAGIC(sv); mg->mg_ptr = (char *)cp; mg->mg_len = sizeof(cp); - MUTEX_UNLOCK(&PL_cred_mutex); /* XXX need separate mutex? */ + UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */ DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log, "%p: condpair_magic %p\n", thr, sv));) } diff --git a/utils/h2xs.PL b/utils/h2xs.PL index 730a730e26..ca55c0ace2 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -630,13 +630,14 @@ warn "Writing $ext$modpname/$modfname.pm\n"; print PM <<"END"; package $module; +require 5.005_62; use strict; END if( $opt_X || $opt_c || $opt_A ){ # we won't have our own AUTOLOAD(), so won't have $AUTOLOAD print PM <<'END'; -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); +our @EXPORT_OK; END } else{ @@ -644,7 +645,7 @@ else{ # will want Carp. print PM <<'END'; use Carp; -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD); +our @EXPORT_OK; END } @@ -669,7 +670,7 @@ unless ($opt_A) { # no autoloader whatsoever. } # Determine @ISA. -my $myISA = '@ISA = qw(Exporter'; # We seem to always want this. +my $myISA = 'our @ISA = qw(Exporter'; # We seem to always want this. $myISA .= ' DynaLoader' unless $opt_X; # no XS $myISA .= ');'; print PM "\n$myISA\n\n"; @@ -684,16 +685,16 @@ print PM<<"END"; # This allows declaration use $module ':all'; # If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK # will save memory. -%EXPORT_TAGS = ( 'all' => [ qw( +our %EXPORT_TAGS = ( 'all' => [ qw( @exported_names ) ] ); -\@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } ); - -\@EXPORT = ( +our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } ); +our \@EXPORT = qw( + @const_names ); -\$VERSION = '$TEMPLATE_VERSION'; +our \$VERSION = '$TEMPLATE_VERSION'; END @@ -704,6 +705,7 @@ sub AUTOLOAD { # to the AUTOLOAD in AutoLoader. my \$constname; + our \$AUTOLOAD; (\$constname = \$AUTOLOAD) =~ s/.*:://; croak "&$module::constant not defined" if \$constname eq 'constant'; my \$val = constant(\$constname, \@_ ? \$_[0] : 0); diff --git a/utils/perlbug.PL b/utils/perlbug.PL index 3404d2b95e..c46df79ef3 100644 --- a/utils/perlbug.PL +++ b/utils/perlbug.PL @@ -1121,7 +1121,7 @@ Include verbose configuration data in the report. =head1 AUTHORS Kenneth Albanowski (E<lt>kjahds@kjahds.comE<gt>), subsequently I<doc>tored -by Gurusamy Sarathy (E<lt>gsar@umich.eduE<gt>), Tom Christiansen +by Gurusamy Sarathy (E<lt>gsar@activestate.comE<gt>), Tom Christiansen (E<lt>tchrist@perl.comE<gt>), Nathan Torkington (E<lt>gnat@frii.comE<gt>), Charles F. Randall (E<lt>cfr@pobox.comE<gt>), Mike Guy (E<lt>mjtg@cam.a.ukE<gt>), Dominic Dunlop (E<lt>domo@computer.orgE<gt>), diff --git a/utils/perlcc.PL b/utils/perlcc.PL index a585580be0..6c1fa45879 100644 --- a/utils/perlcc.PL +++ b/utils/perlcc.PL @@ -253,20 +253,22 @@ sub _createCode { my ( $backend, $generated_file, $file, $final_output ) = @_; my $return; + my $output_switch = "o"; local($") = " -I"; - open(GENFILE, "> $generated_file") || die "Can't open $generated_file: $!"; - if ($backend eq "Bytecode") { require ByteLoader; + open(GENFILE, "> $generated_file") || die "Can't open $generated_file: $!"; + binmode GENFILE; print GENFILE "#!$^X\n" if @_ == 3; print GENFILE "use ByteLoader $ByteLoader::VERSION;\n"; - } + close(GENFILE); - close(GENFILE); + $output_switch ="a"; + } if (@_ == 3) # compiling a program { @@ -278,7 +280,7 @@ sub _createCode chomp $stash; _print( "$^X -I@INC -MO=$backend,$stash $file\n", 36); - $return = _run("$^X -I@INC -MO=$backend,$stash,-o$generated_file $file", 9); + $return = _run("$^X -I@INC -MO=$backend,$stash,-$output_switch$generated_file $file", 9); $return; } else # compiling a shared object @@ -286,7 +288,7 @@ sub _createCode _print( "$^X -I@INC -MO=$backend,-m$final_output $file\n", 36); $return = - _run("$^X -I@INC -MO=$backend,-m$final_output,-o$generated_file $file ", 9); + _run("$^X -I@INC -MO=$backend,-m$final_output,-$output_switch$generated_file $file ", 9); $return; } } @@ -366,6 +368,8 @@ sub _ccharness my $lperl = $^O eq 'os2' ? '-llibperl' : $^O eq 'MSWin32' ? "$Config{archlibexp}\\CORE\\perl.lib" : '-lperl'; + ($lperl = $Config{libperl}) =~ s/lib(.*)\Q$Config{_a}\E/-l$1/ + if($^O eq 'cygwin'); $optimize = $Config{'optimize'} =~ /-O\d/ ? '' : $Config{'optimize'}; @@ -374,9 +378,11 @@ sub _ccharness } my $libs = _getSharedObjects($sourceprog); + @$libs = grep { !(/DynaLoader\.a$/ && ($dynaloader = $_)) } @$libs + if($^O eq 'cygwin'); my $ccflags = $Config{ccflags}; - $ccflags .= ' -DUSEIMPORTLIB' if $Config{osname} =~ /cygwin/i; + $ccflags .= ' -DUSEIMPORTLIB' if $^O eq 'cygwin'; my $cccmd = "$Config{cc} $ccflags $optimize $incdir " ."@args $dynaloader $linkargs @$libs"; diff --git a/utils/perldoc.PL b/utils/perldoc.PL index 760a0ce770..5dd0e1b1fb 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -721,10 +721,10 @@ and others. # Robin Barker <rmb1@cise.npl.co.uk> # -strict, -w cleanups # Version 1.13: Fri Feb 27 16:20:50 EST 1997 -# Gurusamy Sarathy <gsar@umich.edu> +# Gurusamy Sarathy <gsar@activestate.com> # -doc tweaks for -F and -X options # Version 1.12: Sat Apr 12 22:41:09 EST 1997 -# Gurusamy Sarathy <gsar@umich.edu> +# Gurusamy Sarathy <gsar@activestate.com> # -various fixes for win32 # Version 1.11: Tue Dec 26 09:54:33 EST 1995 # Kenneth Albanowski <kjahds@kjahds.com> diff --git a/vms/subconfigure.com b/vms/subconfigure.com index 93473dc8fd..1e0d003826 100644 --- a/vms/subconfigure.com +++ b/vms/subconfigure.com @@ -191,7 +191,7 @@ $ perl_d_mknod="undef" $ perl_d_union_semun="undef" $ perl_d_semctl_semun="undef" $ perl_d_semctl_semid_ds="undef" -$ IF (sharedperl.EQS."Y") +$ IF (sharedperl.EQS."Y" .AND. F$GETSYI("HW_MODEL").GE.1024) $ THEN $ perl_obj_ext=".abj" $ perl_so="axe" @@ -3727,6 +3727,7 @@ $ WRITE CONFIG "#define USE_LONG_LONG" $ WRITE CONFIG "#define USE_LONG_DOUBLE" $ ENDIF $ WRITE CONFIG "#define HAS_ENVGETENV" +$ WRITE CONFIG "#define PERL_EXTERNAL_GLOB" $ CLOSE CONFIG $! $! Now build the normal config.h @@ -3793,7 +3794,7 @@ $ echo "Extracting Build_Ext.Com" $ Create Sys$Disk:[-]Build_Ext.Com $ Deck/Dollar="$EndOfTpl$" $!++ Build_Ext.Com -$! NOTE: This files is extracted as part of the VMS configuration process. +$! NOTE: This file is extracted as part of the VMS configuration process. $! Any changes made to it directly will be lost. If you need to make any $! changes, please edit the template in [.vms]SubConfigure.Com instead. $ def = F$Environment("Default") diff --git a/vms/vmsish.h b/vms/vmsish.h index bc8b79fd27..e9b47a0a9d 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -252,6 +252,8 @@ #define HAS_KILL #define HAS_WAIT +#define PERL_FS_VER_FMT "%d_%d_%d" + /* VMS: * This symbol, if defined, indicates that the program is running under * VMS. It's a symbol automagically defined by all VMS C compilers I've seen. diff --git a/vos/vosish.h b/vos/vosish.h index fc53dc1ec7..16487023a9 100644 --- a/vos/vosish.h +++ b/vos/vosish.h @@ -99,7 +99,7 @@ #ifndef SIGILL # define SIGILL 6 /* blech */ #endif -#define ABORT() kill(getpid(),SIGABRT); +#define ABORT() kill(PerlProc_getpid(),SIGABRT); /* * fwrite1() should be a routine with the same calling sequence as fwrite(), diff --git a/win32/Makefile b/win32/Makefile index c4bb568570..c100d45777 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -29,7 +29,7 @@ INST_TOP = $(INST_DRV)\perl # versioned installation can be obtained by setting INST_TOP above to a # path that includes an arbitrary version string. # -INST_VER = \5.00563 +INST_VER = \5.5.640 # # Comment this out if you DON'T want your perl installation to have @@ -47,7 +47,7 @@ INST_ARCH = \$(ARCHNAME) # # uncomment to enable threads-capabilities # -#USE_THREADS = define +#USE_5005THREADS= define # # XXX WARNING! This option currently undergoing changes. May be broken. @@ -65,6 +65,22 @@ INST_ARCH = \$(ARCHNAME) #USE_OBJECT = define # +# XXX WARNING! This option currently undergoing changes. May be broken. +# +# Beginnings of interpreter cloning/threads: still rather rough, fails +# tests. This should be enabled to get the fork() emulation. Do not +# enable unless you know what you're doing! +# +#USE_ITHREADS = define + +# +# uncomment to enable the implicit "host" layer for all system calls +# made by perl. This is needed and auto-enabled by USE_OBJECT above. +# This is also needed to get fork(). +# +#USE_IMP_SYS = define + +# # uncomment one of the following lines if you are using either # Visual C++ 2.x or Visual C++ 6.x (aka Visual Studio 98) # @@ -78,12 +94,15 @@ INST_ARCH = \$(ARCHNAME) # # uncomment to enable use of PerlCRT.DLL when using the Visual C compiler. -# Highly recommended. It has patches that fix known bugs in MSVCRT.DLL. +# It has patches that fix known bugs in older versions of MSVCRT.DLL. # This currently requires VC 5.0 with Service Pack 3 or later. # Get it from CPAN at http://www.perl.com/CPAN/authors/id/D/DO/DOUGL/ # and follow the directions in the package to install. # +# Not recommended if you have VC 6.x and you're not running Windows 9x. +# #USE_PERLCRT = define +#BUILD_FOR_WIN95 = define # # uncomment to enable linking with setargv.obj under the Visual C @@ -130,26 +149,36 @@ CCINCDIR = $(CCHOME)\include CCLIBDIR = $(CCHOME)\lib # -# additional compiler flags can be specified here. +# Additional compiler flags can be specified here. # -# Adding -DPERL_POLLUTE enables support for old symbols, at the expense of -# extreme pollution. You most probably want this if you're compiling modules -# from CPAN, or other such serious uses of this experimental perl release. -# We don't enable this by default because we want the modules to get fixed -# instead of clinging to shortcuts like this one. + +# +# This should normally be disabled. Adding -DPERL_POLLUTE enables support +# for old symbols by default, at the expense of extreme pollution. You most +# probably just want to build modules that won't compile with +# perl Makefile.PL POLLUTE=1 +# instead of enabling this. Please report such modules to the respective +# authors. # #BUILDOPT = $(BUILDOPT) -DPERL_POLLUTE # -# enable this to test the File::Glob implementation of CORE::glob +# This should normally be disabled. Enabling it will disable the File::Glob +# implementation of CORE::glob. # -#BUILDOPT = $(BUILDOPT) -DPERL_INTERNAL_GLOB +#BUILDOPT = $(BUILDOPT) -DPERL_EXTERNAL_GLOB + +# +# This should normally be disabled. Enabling it causes perl to read scripts +# in text mode (which is the 5.005 behavior) and will break ByteLoader. +#BUILDOPT = $(BUILDOPT) -DPERL_TEXTMODE_SCRIPTS -# Beginnings of interpreter cloning/threads: still rather rough, fails -# many tests. Do not enable unless you know what you're doing! # -#BUILDOPT = $(BUILDOPT) -DUSE_ITHREADS +# This should normally be disabled. Enabling it runs a cloned toplevel +# interpreter (*EXPERIMENTAL*, fails tests) +#BUILDOPT = $(BUILDOPT) -DTOP_CLONE +# # specify semicolon-separated list of extra directories that modules will # look for libraries (spaces in path names need not be quoted) # @@ -159,7 +188,7 @@ EXTRALIBDIRS = # set this to your email address (perl will guess a value from # from your loginname and your hostname, which may not be right) # -#EMAIL = +#EMAIL = ## ## Build configuration ends. @@ -176,16 +205,21 @@ CRYPT_FLAG = -DHAVE_DES_FCRYPT !IF "$(USE_OBJECT)" == "define" PERL_MALLOC = undef -USE_THREADS = undef +USE_5005THREADS = undef USE_MULTI = undef +USE_IMP_SYS = define !ENDIF !IF "$(PERL_MALLOC)" == "" PERL_MALLOC = undef !ENDIF -!IF "$(USE_THREADS)" == "" -USE_THREADS = undef +!IF "$(USE_5005THREADS)" == "" +USE_5005THREADS = undef +!ENDIF + +!IF "$(USE_5005THREADS)" == "define" +USE_ITHREADS = undef !ENDIF !IF "$(USE_MULTI)" == "" @@ -196,10 +230,26 @@ USE_MULTI = undef USE_OBJECT = undef !ENDIF -!IF "$(USE_MULTI)$(USE_THREADS)$(USE_OBJECT)" != "undefundefundef" +!IF "$(USE_ITHREADS)" == "" +USE_ITHREADS = undef +!ENDIF + +!IF "$(USE_IMP_SYS)" == "" +USE_IMP_SYS = undef +!ENDIF + +!IF "$(USE_PERLCRT)" == "" +USE_PERLCRT = undef +!ENDIF + +!IF "$(USE_MULTI)$(USE_5005THREADS)$(USE_OBJECT)" != "undefundefundef" BUILDOPT = $(BUILDOPT) -DPERL_IMPLICIT_CONTEXT !ENDIF +!IF "$(USE_IMP_SYS)" != "undef" +BUILDOPT = $(BUILDOPT) -DPERL_IMPLICIT_SYS +!ENDIF + !IF "$(PROCESSOR_ARCHITECTURE)" == "" PROCESSOR_ARCHITECTURE = x86 !ENDIF @@ -207,7 +257,7 @@ PROCESSOR_ARCHITECTURE = x86 !IF "$(USE_OBJECT)" == "define" ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-object !ELSE -!IF "$(USE_THREADS)" == "define" +!IF "$(USE_5005THREADS)" == "define" ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-thread !ELSE !IF "$(USE_MULTI)" == "define" @@ -218,6 +268,10 @@ ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE) !ENDIF !ENDIF +!IF "$(USE_ITHREADS)" == "define" +ARCHNAME = $(ARCHNAME)-thread +!ENDIF + # Visual Studio 98 specific !IF "$(CCTYPE)" == "MSVC60" @@ -256,6 +310,7 @@ INST_HTML = $(INST_POD)\html CC = cl LINK32 = link LIB32 = $(LINK32) -lib +RSC = rc # # Options @@ -269,7 +324,7 @@ LOCDEFS = -DPERLDLL -DPERL_CORE SUBSYS = console CXX_FLAG = -TP -GX -!IF "$(USE_PERLCRT)" == "" +!IF "$(USE_PERLCRT)" != "define" ! IF "$(CFG)" == "Debug" PERLCRTLIBC = msvcrtd.lib ! ELSE @@ -283,6 +338,9 @@ PERLCRTLIBC = PerlCRT.lib ! ENDIF !ENDIF +PERLEXE_RES = +PERLDLL_RES = + !IF "$(RUNTIME)" == "-MD" LIBC = $(PERLCRTLIBC) !ELSE @@ -312,10 +370,14 @@ OPTIMIZE = $(OPTIMIZE) $(CXX_FLAG) BUILDOPT = $(BUILDOPT) -DPERL_OBJECT !ENDIF +!IF "$(USE_PERLCRT)" != "define" +BUILDOPT = $(BUILDOPT) -DPERL_MSVCRT_READFIX +!ENDIF + LIBBASEFILES = $(DELAYLOAD) $(CRYPT_LIB) \ - oldnames.lib kernel32.lib user32.lib gdi32.lib \ - winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib \ - oleaut32.lib netapi32.lib uuid.lib wsock32.lib mpr.lib winmm.lib \ + oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib \ + comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib \ + netapi32.lib uuid.lib wsock32.lib mpr.lib winmm.lib \ version.lib odbc32.lib odbccp32.lib # we add LIBC here, since we may be using PerlCRT.dll @@ -340,7 +402,7 @@ o = .obj # Rules # -.SUFFIXES : .c $(o) .dll .lib .exe +.SUFFIXES : .c $(o) .dll .lib .exe .rc .res .c$(o): $(CC) -c -I$(<D) $(CFLAGS_O) $(OBJOUT_FLAG)$@ $< @@ -352,6 +414,9 @@ $(o).dll: $(LINK32) -dll -subsystem:windows -implib:$(*B).lib -def:$(*B).def \ -out:$@ $(LINK_FLAGS) $(LIBFILES) $< $(LIBPERL) +.rc.res: + $(RSC) $< + # # various targets !IF "$(USE_OBJECT)" == "define" @@ -365,6 +430,7 @@ PERLDLL = ..\perl.dll MINIPERL = ..\miniperl.exe MINIDIR = .\mini PERLEXE = ..\perl.exe +WPERLEXE = ..\wperl.exe GLOBEXE = ..\perlglob.exe CONFIGPM = ..\lib\Config.pm MINIMOD = ..\lib\ExtUtils\Miniperl.pm @@ -382,7 +448,6 @@ UTILS = \ ..\utils\c2ph \ ..\utils\h2xs \ ..\utils\perldoc \ - ..\utils\pstruct \ ..\utils\perlcc \ ..\pod\checkpods \ ..\pod\pod2html \ @@ -404,7 +469,7 @@ MAKE = nmake -nologo CFGSH_TMPL = config.vc CFGH_TMPL = config_H.vc -!IF "$(USE_PERLCRT)" == "" +!IF "$(BUILD_FOR_WIN95)" == "define" PERL95EXE = ..\perl95.exe !ENDIF @@ -463,7 +528,7 @@ WIN32_SRC = \ .\win32.c \ .\win32sck.c -!IF "$(USE_THREADS)" == "define" +!IF "$(USE_5005THREADS)" == "define" WIN32_SRC = $(WIN32_SRC) .\win32thread.c !ENDIF @@ -527,7 +592,10 @@ CORE_NOCFG_H = \ .\include\dirent.h \ .\include\netdb.h \ .\include\sys\socket.h \ - .\win32.h + .\win32.h \ + .\perlhost.h \ + .\vdir.h \ + .\vmem.h CORE_H = $(CORE_NOCFG_H) .\config.h @@ -657,7 +725,9 @@ CFG_VARS = \ "static_ext=$(STATIC_EXT)" \ "dynamic_ext=$(DYNAMIC_EXT)" \ "nonxs_ext=$(NONXS_EXT)" \ - "usethreads=$(USE_THREADS)" \ + "use5005threads=$(USE_5005THREADS)" \ + "useithreads=$(USE_ITHREADS)" \ + "usethreads=$(USE_5005THREADS)" \ "usemultiplicity=$(USE_MULTI)" \ "LINK_FLAGS=$(LINK_FLAGS:"=\")" \ "optimize=$(OPTIMIZE:"=\")" @@ -722,11 +792,17 @@ $(MINIDIR) : if not exist "$(MINIDIR)" mkdir "$(MINIDIR)" $(MINICORE_OBJ) : $(CORE_NOCFG_H) - $(CC) -c $(CFLAGS) $(OBJOUT_FLAG)$@ ..\$(*F).c + $(CC) -c $(CFLAGS) -DPERL_EXTERNAL_GLOB $(OBJOUT_FLAG)$@ ..\$(*F).c $(MINIWIN32_OBJ) : $(CORE_NOCFG_H) $(CC) -c $(CFLAGS) $(OBJOUT_FLAG)$@ $(*F).c +# -DPERL_IMPLICIT_SYS needs C++ for perllib.c +!IF "$(USE_IMP_SYS)$(USE_OBJECT)" == "defineundef" +perllib$(o) : perllib.c + $(CC) -c -I. $(CFLAGS_O) $(CXX_FLAG) $(OBJOUT_FLAG)$@ perllib.c +!ENDIF + # 1. we don't want to rebuild miniperl.exe when config.h changes # 2. we don't want to rebuild miniperl.exe with non-default config.h $(MINI_OBJ) : $(CORE_NOCFG_H) @@ -741,9 +817,9 @@ perldll.def : $(MINIPERL) $(CONFIGPM) ..\global.sym ..\pp.sym ..\makedef.pl $(MINIPERL) -w ..\makedef.pl PLATFORM=win32 $(OPTIMIZE) $(DEFINES) $(BUILDOPT) \ CCTYPE=$(CCTYPE) > perldll.def -$(PERLDLL): perldll.def $(PERLDLL_OBJ) +$(PERLDLL): perldll.def $(PERLDLL_OBJ) $(PERLDLL_RES) $(LINK32) -dll -def:perldll.def -out:$@ @<< - $(LINK_FLAGS) $(LIBFILES) $(PERLDLL_OBJ) + $(LINK_FLAGS) $(LIBFILES) $(PERLDLL_OBJ) $(PERLDLL_RES) << $(XCOPY) $(PERLIMPLIB) $(COREDIR) @@ -778,13 +854,15 @@ perlmain.c : runperl.c perlmain$(o) : perlmain.c $(CC) $(CFLAGS_O) -UPERLDLL $(OBJOUT_FLAG)$@ -c perlmain.c -$(PERLEXE): $(PERLDLL) $(CONFIGPM) $(PERLEXE_OBJ) +$(PERLEXE): $(PERLDLL) $(CONFIGPM) $(PERLEXE_OBJ) $(PERLEXE_RES) $(LINK32) -subsystem:console -out:$@ $(LINK_FLAGS) $(LIBFILES) \ - $(PERLEXE_OBJ) $(SETARGV_OBJ) $(PERLIMPLIB) + $(PERLEXE_OBJ) $(SETARGV_OBJ) $(PERLIMPLIB) $(PERLEXE_RES) + copy $(PERLEXE) $(WPERLEXE) + editbin /subsystem:windows $(WPERLEXE) copy splittree.pl .. $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR) -!IF "$(USE_PERLCRT)" == "" +!IF "$(BUILD_FOR_WIN95)" == "define" perl95.c : runperl.c copy runperl.c perl95.c @@ -815,8 +893,10 @@ $(DYNALOADER).c: $(MINIPERL) $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM) if not exist $(AUTODIR) mkdir $(AUTODIR) cd $(EXTDIR)\$(*B) ..\$(MINIPERL) -I..\..\lib $(*B)_pm.PL + ..\$(MINIPERL) -I..\..\lib XSLoader_pm.PL cd ..\..\win32 $(XCOPY) $(EXTDIR)\$(*B)\$(*B).pm $(LIBDIR)\$(NULL) + $(XCOPY) $(EXTDIR)\$(*B)\XSLoader.pm $(LIBDIR)\$(NULL) cd $(EXTDIR)\$(*B) $(XSUBPP) dl_win32.xs > $(*B).c cd ..\..\win32 @@ -942,6 +1022,7 @@ distclean: clean -del /f $(EXTENSION_C) $(DYNALOADER).c $(ERRNO).pm -del /f $(EXTDIR)\DynaLoader\dl_win32.xs -del /f $(LIBDIR)\.exists $(LIBDIR)\attrs.pm $(LIBDIR)\DynaLoader.pm + -del /f $(LIBDIR)\XSLoader.pm -del /f $(LIBDIR)\Fcntl.pm $(LIBDIR)\IO.pm $(LIBDIR)\Opcode.pm -del /f $(LIBDIR)\ops.pm $(LIBDIR)\Safe.pm $(LIBDIR)\Thread.pm -del /f $(LIBDIR)\SDBM_File.pm $(LIBDIR)\Socket.pm $(LIBDIR)\POSIX.pm @@ -956,7 +1037,7 @@ distclean: clean -del /f $(PODDIR)\*.html -del /f $(PODDIR)\*.bat cd ..\utils - -del /f h2ph splain perlbug pl2pm c2ph h2xs perldoc pstruct dprofpp + -del /f h2ph splain perlbug pl2pm c2ph h2xs perldoc dprofpp -del /f *.bat cd ..\win32 cd ..\x2p @@ -977,9 +1058,10 @@ install : all installbare installhtml installbare : utils $(PERLEXE) ..\installperl -!IF "$(USE_PERLCRT)" == "" +!IF "$(BUILD_FOR_WIN95)" == "define" $(XCOPY) $(PERL95EXE) $(INST_BIN)\*.* !ENDIF + if exist $(WPERLEXE) $(XCOPY) $(WPERLEXE) $(INST_BIN)\*.* $(XCOPY) $(GLOBEXE) $(INST_BIN)\*.* $(XCOPY) bin\*.bat $(INST_SCRIPT)\*.* @@ -1025,6 +1107,7 @@ clean : -@erase /f config.h -@erase $(GLOBEXE) -@erase $(PERLEXE) + -@erase $(WPERLEXE) -@erase $(PERLDLL) -@erase $(CORE_OBJ) -rmdir /s /q $(MINIDIR) || rmdir /s $(MINIDIR) diff --git a/win32/bin/perlglob.pl b/win32/bin/perlglob.pl index 6467e573b5..17843c877a 100644 --- a/win32/bin/perlglob.pl +++ b/win32/bin/perlglob.pl @@ -41,7 +41,7 @@ builtins. =head1 AUTHOR -Gurusamy Sarathy <gsar@umich.edu> +Gurusamy Sarathy <gsar@activestate.com> =head1 SEE ALSO diff --git a/win32/config.bc b/win32/config.bc index 81ec602bac..8dba78c0f1 100644 --- a/win32/config.bc +++ b/win32/config.bc @@ -19,7 +19,9 @@ afs='false' alignbytes='8' ansi2knr='' aphostname='' -apiversion='~PERL_APIVERSION~' +apirevision='~PERL_API_REVISION~' +apisubversion='~PERL_API_SUBVERSION~' +apiversion='~PERL_API_VERSION~' ar='tlib /P128' archlib='~INST_TOP~~INST_VER~\lib~INST_ARCH~' archlibexp='~INST_TOP~~INST_VER~\lib~INST_ARCH~' @@ -27,7 +29,7 @@ archname64='' archname='MSWin32' archobjs='' awk='awk' -baserev='5.0' +baserev='5' bash='' bin='~INST_TOP~~INST_VER~\bin~INST_ARCH~' bincompat5005='undef' @@ -572,7 +574,6 @@ pg='' phostname='hostname' pidtype='int' plibpth='' -pm_apiversion='5.005' pmake='' pr='' prefix='~INST_TOP~' @@ -685,8 +686,10 @@ uidtype='uid_t' uname='uname' uniq='uniq' uquadtype='unsigned __int64' +use5005threads='undef' use64bits='undef' usedl='define' +useithreads='undef' uselargefiles='undef' uselongdouble='undef' uselonglong='undef' @@ -720,12 +723,13 @@ version='~VERSION~' vi='' voidflags='15' xlibpth='/usr/lib/386 /lib/386' -xs_apiversion='~PERL_APIVERSION~' zcat='' zip='zip' PERL_REVISION='~PERL_REVISION~' -PERL_VERSION='~PERL_VERSION~' PERL_SUBVERSION='~PERL_SUBVERSION~' -PERL_APIVERSION='~PERL_APIVERSION~' +PERL_VERSION='~PERL_VERSION~' +PERL_API_REVISION='~PERL_API_REVISION~' +PERL_API_SUBVERSION='~PERL_API_SUBVERSION~' +PERL_API_VERSION='~PERL_API_VERSION~' PATCHLEVEL='~PERL_VERSION~' SUBVERSION='~PERL_SUBVERSION~' diff --git a/win32/config.gc b/win32/config.gc index ac0345f262..556ba2b581 100644 --- a/win32/config.gc +++ b/win32/config.gc @@ -19,7 +19,9 @@ afs='false' alignbytes='8' ansi2knr='' aphostname='' -apiversion='~PERL_APIVERSION~' +apirevision='~PERL_API_REVISION~' +apisubversion='~PERL_API_SUBVERSION~' +apiversion='~PERL_API_VERSION~' ar='ar' archlib='~INST_TOP~~INST_VER~\lib~INST_ARCH~' archlibexp='~INST_TOP~~INST_VER~\lib~INST_ARCH~' @@ -27,7 +29,7 @@ archname64='' archname='MSWin32' archobjs='' awk='awk' -baserev='5.0' +baserev='5' bash='' bin='~INST_TOP~~INST_VER~\bin~INST_ARCH~' bincompat5005='undef' @@ -297,8 +299,8 @@ d_statvfs='undef' d_stdio_cnt_lval='define' d_stdio_ptr_lval='define' d_stdio_stream_array='undef' -d_stdiobase='undef' -d_stdstdio='undef' +d_stdiobase='define' +d_stdstdio='define' d_strchr='define' d_strcoll='define' d_strctcpy='define' @@ -323,7 +325,7 @@ d_telldirproto='define' d_time='define' d_times='define' d_truncate='undef' -d_tzname='undef' +d_tzname='define' d_umask='define' d_uname='define' d_union_semun='define' @@ -496,7 +498,7 @@ ldflags='~LINK_FLAGS~' ldlibpthname='' less='less' lib_ext='.a' -libc='libcrtdll.a' +libc='libmsvcrt.a' libperl='libperl.a' libpth='' libs='' @@ -572,7 +574,6 @@ pg='' phostname='hostname' pidtype='int' plibpth='' -pm_apiversion='5.005' pmake='' pr='' prefix='~INST_TOP~' @@ -685,13 +686,15 @@ uidtype='uid_t' uname='uname' uniq='uniq' uquadtype='unsigned long long' +use5005threads='undef' use64bits='undef' usedl='define' +useithreads='undef' uselargefiles='undef' uselongdouble='undef' uselonglong='undef' usemorebits='undef' -usemultiplicity='define' +usemultiplicity='undef' usemymalloc='n' usenm='false' useopcode='true' @@ -720,12 +723,13 @@ version='~VERSION~' vi='' voidflags='15' xlibpth='/usr/lib/386 /lib/386' -xs_apiversion='~PERL_APIVERSION~' zcat='' zip='zip' PERL_REVISION='~PERL_REVISION~' -PERL_VERSION='~PERL_VERSION~' PERL_SUBVERSION='~PERL_SUBVERSION~' -PERL_APIVERSION='~PERL_APIVERSION~' +PERL_VERSION='~PERL_VERSION~' +PERL_API_REVISION='~PERL_API_REVISION~' +PERL_API_SUBVERSION='~PERL_API_SUBVERSION~' +PERL_API_VERSION='~PERL_API_VERSION~' PATCHLEVEL='~PERL_VERSION~' SUBVERSION='~PERL_SUBVERSION~' diff --git a/win32/config.vc b/win32/config.vc index a294dbcf43..0e37b3c056 100644 --- a/win32/config.vc +++ b/win32/config.vc @@ -19,7 +19,9 @@ afs='false' alignbytes='8' ansi2knr='' aphostname='' -apiversion='~PERL_APIVERSION~' +apirevision='~PERL_API_REVISION~' +apisubversion='~PERL_API_SUBVERSION~' +apiversion='~PERL_API_VERSION~' ar='lib' archlib='~INST_TOP~~INST_VER~\lib~INST_ARCH~' archlibexp='~INST_TOP~~INST_VER~\lib~INST_ARCH~' @@ -27,7 +29,7 @@ archname64='' archname='MSWin32' archobjs='' awk='awk' -baserev='5.0' +baserev='5' bash='' bin='~INST_TOP~~INST_VER~\bin~INST_ARCH~' bincompat5005='undef' @@ -572,7 +574,6 @@ pg='' phostname='hostname' pidtype='int' plibpth='' -pm_apiversion='5.005' pmake='' pr='' prefix='~INST_TOP~' @@ -685,8 +686,10 @@ uidtype='uid_t' uname='uname' uniq='uniq' uquadtype='unsigned __int64' +use5005threads='undef' use64bits='undef' usedl='define' +useithreads='undef' uselargefiles='undef' uselongdouble='undef' uselonglong='undef' @@ -720,12 +723,13 @@ version='~VERSION~' vi='' voidflags='15' xlibpth='/usr/lib/386 /lib/386' -xs_apiversion='~PERL_APIVERSION~' zcat='' zip='zip' PERL_REVISION='~PERL_REVISION~' PERL_VERSION='~PERL_VERSION~' PERL_SUBVERSION='~PERL_SUBVERSION~' -PERL_APIVERSION='~PERL_APIVERSION~' +PERL_API_REVISION='~PERL_API_REVISION~' +PERL_API_SUBVERSION='~PERL_API_SUBVERSION~' +PERL_API_VERSION='~PERL_API_VERSION~' PATCHLEVEL='~PERL_VERSION~' SUBVERSION='~PERL_SUBVERSION~' diff --git a/win32/config_H.bc b/win32/config_H.bc index de0fb35bd6..e1e06b340b 100644 --- a/win32/config_H.bc +++ b/win32/config_H.bc @@ -13,7 +13,7 @@ /* * Package name : perl5 * Source directory : - * Configuration time: Sun Oct 31 02:10:33 1999 + * Configuration time: Sun Jan 9 15:13:13 2000 * Configured by : gsar * Target system : */ @@ -980,52 +980,6 @@ */ #define STDCHAR unsigned char /**/ -/* HAS_QUAD: - * This symbol, if defined, tells that there's a 64-bit integer type, - * Quad_t. - */ -/* Quad_t: - * This symbol holds the type used for 64-bit integers. - * It can be int, long, long long, int64_t etc... - */ -/* QUADCASE: - * This symbol, if defined, encodes the type of a quad: - * 1 = int, 2 = long, 3 = long long, 4 = int64_t. - */ -/* Uquad_t: - * This symbol holds the type used for unsigned 64-bit integers. - * It can be unsigned int, unsigned long, unsigned long long, - * uint64_t etc... - */ -/*#define HAS_QUAD /**/ -/*#define Quad_t __int64 /**/ -/*#define Uquad_t unsigned __int64 /**/ -/*#define QUADCASE 5 /**/ - -/* HAS_ACCESSX: - * This symbol, if defined, indicates that the accessx routine is - * available to do extended access checks. - */ -/*#define HAS_ACCESSX /**/ - -/* HAS_EACCESS: - * This symbol, if defined, indicates that the eaccess routine is - * available to do extended access checks. - */ -/*#define HAS_EACCESS /**/ - -/* I_SYS_ACCESS: - * This symbol, if defined, indicates to the C program that it should - * include <sys/access.h>. - */ -/*#define I_SYS_ACCESS /**/ - -/* I_SYS_SECURITY: - * This symbol, if defined, indicates to the C program that it should - * include <sys/security.h>. - */ -/*#define I_SYS_SECURITY /**/ - /* CROSSCOMPILE: * This symbol, if defined, signifies that we our * build process is a cross-compilation. @@ -1057,6 +1011,46 @@ */ /*#define MULTIARCH /**/ +/* HAS_QUAD: + * This symbol, if defined, tells that there's a 64-bit integer type, + * Quad_t, and its unsigned counterpar, Uquad_t. QUADKIND will be one + * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, or QUAD_IS_INT64_T. + */ +/*#define HAS_QUAD /**/ +#ifdef HAS_QUAD +# define Quad_t __int64 /**/ +# define Uquad_t unsigned __int64 /**/ +# define QUADKIND undef /**/ +# define QUAD_IS_INT 1 +# define QUAD_IS_LONG 2 +# define QUAD_IS_LONG_LONG 3 +# define QUAD_IS_INT64_T 4 +#endif + +/* HAS_ACCESSX: + * This symbol, if defined, indicates that the accessx routine is + * available to do extended access checks. + */ +/*#define HAS_ACCESSX /**/ + +/* HAS_EACCESS: + * This symbol, if defined, indicates that the eaccess routine is + * available to do extended access checks. + */ +/*#define HAS_EACCESS /**/ + +/* I_SYS_ACCESS: + * This symbol, if defined, indicates to the C program that it should + * include <sys/access.h>. + */ +/*#define I_SYS_ACCESS /**/ + +/* I_SYS_SECURITY: + * This symbol, if defined, indicates to the C program that it should + * include <sys/security.h>. + */ +/*#define I_SYS_SECURITY /**/ + /* MEM_ALIGNBYTES: * This symbol contains the number of bytes required to align a * double. Usual values are 2, 4 and 8. The default is eight, @@ -1429,7 +1423,7 @@ * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define ARCHLIB "c:\\perl\\5.00563\\lib\\MSWin32-x86" /**/ +#define ARCHLIB "c:\\perl\\5.5.640\\lib\\MSWin32-x86" /**/ /*#define ARCHLIB_EXP "" /**/ /* BIN: @@ -1440,8 +1434,8 @@ * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ -#define BIN "c:\\perl\\5.00563\\bin\\MSWin32-x86" /**/ -#define BIN_EXP "c:\\perl\\5.00563\\bin\\MSWin32-x86" /**/ +#define BIN "c:\\perl\\5.5.640\\bin\\MSWin32-x86" /**/ +#define BIN_EXP "c:\\perl\\5.5.640\\bin\\MSWin32-x86" /**/ /* INSTALL_USR_BIN_PERL: * This symbol, if defined, indicates that Perl is to be installed @@ -1459,8 +1453,8 @@ * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define PRIVLIB "c:\\perl\\5.00563\\lib" /**/ -#define PRIVLIB_EXP (win32_get_privlib("5.00563")) /**/ +#define PRIVLIB "c:\\perl\\5.5.640\\lib" /**/ +#define PRIVLIB_EXP (win32_get_privlib("5.5.640")) /**/ /* SITEARCH: * This symbol contains the name of the private library for this package. @@ -1477,7 +1471,7 @@ * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITEARCH "c:\\perl\\site\\5.00563\\lib\\MSWin32-x86" /**/ +#define SITEARCH "c:\\perl\\site\\5.5.640\\lib\\MSWin32-x86" /**/ /*#define SITEARCH_EXP "" /**/ /* SITELIB: @@ -1495,8 +1489,8 @@ * This symbol contains the ~name expanded version of SITELIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITELIB "c:\\perl\\site\\5.00563\\lib" /**/ -#define SITELIB_EXP (win32_get_sitelib("5.00563")) /**/ +#define SITELIB "c:\\perl\\site\\5.5.640\\lib" /**/ +#define SITELIB_EXP (win32_get_sitelib("5.5.640")) /**/ /* PERL_VENDORLIB_EXP: * This symbol contains the ~name expanded version of VENDORLIB, to be used @@ -2202,6 +2196,13 @@ */ /*#define HAS_HASMNTOPT /**/ +/* HAS_INT64_T: + * This symbol will defined if the C compiler supports int64_t. + * Usually the <inttypes.h> needs to be included, but sometimes + * <sys/types.h> is enough. + */ +/*#define HAS_INT64_T /**/ + /* HAS_LDBL_DIG: * This symbol, if defined, indicates that this system's <float.h> * or <limits.h> defines the symbol LDBL_DIG, which is the number @@ -2302,13 +2303,7 @@ * This symbol, if defined, indicates to the C program that it should * include <inttypes.h>. */ -/* HAS_INT64_T: - * This symbol will defined if the C compiler supports int64_t. - * Usually the <inttypes.h> needs to be included, but sometimes - * <sys/types.h> is enough. - */ /*#define I_INTTYPES /**/ -/*#define HAS_INT64_T /**/ /* I_MNTENT: * This symbol, if defined, indicates that <mntent.h> exists and @@ -2452,9 +2447,6 @@ /* U64SIZE: * This symbol contains the sizeof(U64). */ -/* NVSIZE: - * This symbol contains the sizeof(NV). - */ #define IVTYPE long /**/ #define UVTYPE unsigned long /**/ #define I8TYPE char /**/ @@ -2480,7 +2472,6 @@ #define I64SIZE 8 /**/ #define U64SIZE 8 /**/ #endif -#define NVSIZE 8 /**/ /* IVdf: * This symbol defines the format string used for printing a Perl IV @@ -2537,8 +2528,8 @@ /*#define HAS_STRTOULL /**/ /* USE_64_BITS: - * This symbol, if defined, indicates that 64-bit interfaces should - * be used when available. If not defined, the native default interfaces + * This symbol, if defined, indicates that 64-bit integers should + * be used when available. If not defined, the native integers * will be used (be they 32 or 64 bits). */ #ifndef USE_64_BITS @@ -2599,41 +2590,6 @@ /*#define USE_SOCKS /**/ #endif -/* PERL_XS_APIVERSION: - * This variable contains the version of the oldest perl binary - * compatible with the present perl. perl.c:incpush() and - * lib/lib.pm will automatically search in c:\\perl\\site\\5.00563\\lib\\MSWin32-x86 for older - * directories across major versions back to xs_apiversion. - * This is only useful if you have a perl library directory tree - * structured like the default one. - * See INSTALL for how this works. - * The versioned site_perl directory was introduced in 5.005, - * so that is the lowest possible value. - * Since this can depend on compile time options (such as - * bincompat) it is set by Configure. Other non-default sources - * of potential incompatibility, such as multiplicity, threads, - * debugging, 64bits, sfio, etc., are not checked for currently, - * though in principle we could go snooping around in old - * Config.pm files. - */ -/* PERL_PM_APIVERSION: - * This variable contains the version of the oldest perl - * compatible with the present perl. (That is, pure perl modules - * written for pm_apiversion will still work for the current - * version). perl.c:incpush() and lib/lib.pm will automatically - * search in c:\\perl\\site\\5.00563\\lib for older directories across major versions - * back to pm_apiversion. This is only useful if you have a perl - * library directory tree structured like the default one. The - * versioned site_perl library was introduced in 5.005, so that's - * the default setting for this variable. It's hard to imagine - * it changing before Perl6. It is included here for symmetry - * with xs_apiveprsion -- the searching algorithms will - * (presumably) be similar. - * See the INSTALL file for how this works. - */ -#define PERL_XS_APIVERSION 5.00563 /* Change to string for tuples?*/ -#define PERL_PM_APIVERSION 5.005 /* Change to string for tuples?*/ - /* HAS_DRAND48_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the drand48() function. Otherwise, it is up @@ -2752,16 +2708,22 @@ */ /*#define I_PTHREAD /**/ -/* USE_THREADS: - * This symbol, if defined, indicates that Perl should - * be built to use threads. +/* USE_ITHREADS: + * This symbol, if defined, indicates that Perl should be built to + * use the interpreter-based threading implementation. + */ +/* USE_5005THREADS: + * This symbol, if defined, indicates that Perl should be built to + * use the 5.005-based threading implementation. */ /* OLD_PTHREADS_API: * This symbol, if defined, indicates that Perl should * be built to use the old draft POSIX threads API. */ -#ifndef USE_TTHREADS -/*#define USE_THREADS /**/ +/*#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 /**/ @@ -2791,6 +2753,11 @@ */ #define Gid_t_f "d" /**/ +/* Gid_t_size: + * This symbol holds the size of a Gid_t in bytes. + */ +#define Gid_t_size 4 /* GID size */ + /* Gid_t: * This symbol holds the return type of getgid() and the type of * argument to setrgid() and related functions. Typically, @@ -2808,8 +2775,12 @@ /* LSEEKSIZE: * This symbol holds the number of bytes used by the Off_t. */ +/* Off_t_size: + * This symbol holds the number of bytes used by the Off_t. + */ #define Off_t off_t /* <offset> type */ #define LSEEKSIZE 4 /* <offset> size */ +#define Off_t_size 4 /* <offset> size */ /* Mode_t: * This symbol holds the type used to declare file modes @@ -2839,6 +2810,11 @@ */ #define Uid_t_f "d" /**/ +/* Uid_t_size: + * This symbol holds the size of a Uid_t in bytes. + */ +#define Uid_t_size 4 /* UID size */ + /* Uid_t: * This symbol holds the type used to declare user ids in the kernel. * It can be int, ushort, uid_t, etc... It may be necessary to include diff --git a/win32/config_H.gc b/win32/config_H.gc index cd4efc2a2e..fc91cb7d1d 100644 --- a/win32/config_H.gc +++ b/win32/config_H.gc @@ -13,7 +13,7 @@ /* * Package name : perl5 * Source directory : - * Configuration time: Sun Oct 31 02:10:12 1999 + * Configuration time: Sun Jan 9 15:13:25 2000 * Configured by : gsar * Target system : */ @@ -656,7 +656,7 @@ * This symbol, if defined, indicates that the tzname[] array is * available to access timezone names. */ -/*#define HAS_TZNAME /**/ +#define HAS_TZNAME /**/ /* HAS_UMASK: * This symbol, if defined, indicates that the umask routine is @@ -980,52 +980,6 @@ */ #define STDCHAR char /**/ -/* HAS_QUAD: - * This symbol, if defined, tells that there's a 64-bit integer type, - * Quad_t. - */ -/* Quad_t: - * This symbol holds the type used for 64-bit integers. - * It can be int, long, long long, int64_t etc... - */ -/* QUADCASE: - * This symbol, if defined, encodes the type of a quad: - * 1 = int, 2 = long, 3 = long long, 4 = int64_t. - */ -/* Uquad_t: - * This symbol holds the type used for unsigned 64-bit integers. - * It can be unsigned int, unsigned long, unsigned long long, - * uint64_t etc... - */ -/*#define HAS_QUAD /**/ -/*#define Quad_t long long /**/ -/*#define Uquad_t unsigned long long /**/ -/*#define QUADCASE 5 /**/ - -/* HAS_ACCESSX: - * This symbol, if defined, indicates that the accessx routine is - * available to do extended access checks. - */ -/*#define HAS_ACCESSX /**/ - -/* HAS_EACCESS: - * This symbol, if defined, indicates that the eaccess routine is - * available to do extended access checks. - */ -/*#define HAS_EACCESS /**/ - -/* I_SYS_ACCESS: - * This symbol, if defined, indicates to the C program that it should - * include <sys/access.h>. - */ -/*#define I_SYS_ACCESS /**/ - -/* I_SYS_SECURITY: - * This symbol, if defined, indicates to the C program that it should - * include <sys/security.h>. - */ -/*#define I_SYS_SECURITY /**/ - /* CROSSCOMPILE: * This symbol, if defined, signifies that we our * build process is a cross-compilation. @@ -1057,6 +1011,46 @@ */ /*#define MULTIARCH /**/ +/* HAS_QUAD: + * This symbol, if defined, tells that there's a 64-bit integer type, + * Quad_t, and its unsigned counterpar, Uquad_t. QUADKIND will be one + * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, or QUAD_IS_INT64_T. + */ +/*#define HAS_QUAD /**/ +#ifdef HAS_QUAD +# define Quad_t long long /**/ +# define Uquad_t unsigned long long /**/ +# define QUADKIND undef /**/ +# define QUAD_IS_INT 1 +# define QUAD_IS_LONG 2 +# define QUAD_IS_LONG_LONG 3 +# define QUAD_IS_INT64_T 4 +#endif + +/* HAS_ACCESSX: + * This symbol, if defined, indicates that the accessx routine is + * available to do extended access checks. + */ +/*#define HAS_ACCESSX /**/ + +/* HAS_EACCESS: + * This symbol, if defined, indicates that the eaccess routine is + * available to do extended access checks. + */ +/*#define HAS_EACCESS /**/ + +/* I_SYS_ACCESS: + * This symbol, if defined, indicates to the C program that it should + * include <sys/access.h>. + */ +/*#define I_SYS_ACCESS /**/ + +/* I_SYS_SECURITY: + * This symbol, if defined, indicates to the C program that it should + * include <sys/security.h>. + */ +/*#define I_SYS_SECURITY /**/ + /* MEM_ALIGNBYTES: * This symbol contains the number of bytes required to align a * double. Usual values are 2, 4 and 8. The default is eight, @@ -1270,7 +1264,7 @@ * This symbol is defined if the FILE_cnt macro can be used as an * lvalue. */ -/*#define USE_STDIO_PTR /**/ +#define USE_STDIO_PTR /**/ #ifdef USE_STDIO_PTR #define FILE_ptr(fp) ((fp)->_ptr) #define STDIO_PTR_LVALUE /**/ @@ -1298,7 +1292,7 @@ * structure pointed to its argument. This macro will always be defined * if USE_STDIO_BASE is defined. */ -/*#define USE_STDIO_BASE /**/ +#define USE_STDIO_BASE /**/ #ifdef USE_STDIO_BASE #define FILE_base(fp) ((fp)->_base) #define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base) @@ -1429,7 +1423,7 @@ * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define ARCHLIB "c:\\perl\\5.00563\\lib\\MSWin32-x86" /**/ +#define ARCHLIB "c:\\perl\\5.5.640\\lib\\MSWin32-x86" /**/ /*#define ARCHLIB_EXP "" /**/ /* BIN: @@ -1440,8 +1434,8 @@ * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ -#define BIN "c:\\perl\\5.00563\\bin\\MSWin32-x86" /**/ -#define BIN_EXP "c:\\perl\\5.00563\\bin\\MSWin32-x86" /**/ +#define BIN "c:\\perl\\5.5.640\\bin\\MSWin32-x86" /**/ +#define BIN_EXP "c:\\perl\\5.5.640\\bin\\MSWin32-x86" /**/ /* INSTALL_USR_BIN_PERL: * This symbol, if defined, indicates that Perl is to be installed @@ -1459,8 +1453,8 @@ * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define PRIVLIB "c:\\perl\\5.00563\\lib" /**/ -#define PRIVLIB_EXP (win32_get_privlib("5.00563")) /**/ +#define PRIVLIB "c:\\perl\\5.5.640\\lib" /**/ +#define PRIVLIB_EXP (win32_get_privlib("5.5.640")) /**/ /* SITEARCH: * This symbol contains the name of the private library for this package. @@ -1477,7 +1471,7 @@ * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITEARCH "c:\\perl\\site\\5.00563\\lib\\MSWin32-x86" /**/ +#define SITEARCH "c:\\perl\\site\\5.5.640\\lib\\MSWin32-x86" /**/ /*#define SITEARCH_EXP "" /**/ /* SITELIB: @@ -1495,8 +1489,8 @@ * This symbol contains the ~name expanded version of SITELIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITELIB "c:\\perl\\site\\5.00563\\lib" /**/ -#define SITELIB_EXP (win32_get_sitelib("5.00563")) /**/ +#define SITELIB "c:\\perl\\site\\5.5.640\\lib" /**/ +#define SITELIB_EXP (win32_get_sitelib("5.5.640")) /**/ /* PERL_VENDORLIB_EXP: * This symbol contains the ~name expanded version of VENDORLIB, to be used @@ -2202,6 +2196,13 @@ */ /*#define HAS_HASMNTOPT /**/ +/* HAS_INT64_T: + * This symbol will defined if the C compiler supports int64_t. + * Usually the <inttypes.h> needs to be included, but sometimes + * <sys/types.h> is enough. + */ +/*#define HAS_INT64_T /**/ + /* HAS_LDBL_DIG: * This symbol, if defined, indicates that this system's <float.h> * or <limits.h> defines the symbol LDBL_DIG, which is the number @@ -2302,13 +2303,7 @@ * This symbol, if defined, indicates to the C program that it should * include <inttypes.h>. */ -/* HAS_INT64_T: - * This symbol will defined if the C compiler supports int64_t. - * Usually the <inttypes.h> needs to be included, but sometimes - * <sys/types.h> is enough. - */ /*#define I_INTTYPES /**/ -/*#define HAS_INT64_T /**/ /* I_MNTENT: * This symbol, if defined, indicates that <mntent.h> exists and @@ -2452,9 +2447,6 @@ /* U64SIZE: * This symbol contains the sizeof(U64). */ -/* NVSIZE: - * This symbol contains the sizeof(NV). - */ #define IVTYPE long /**/ #define UVTYPE unsigned long /**/ #define I8TYPE char /**/ @@ -2480,7 +2472,6 @@ #define I64SIZE 8 /**/ #define U64SIZE 8 /**/ #endif -#define NVSIZE 8 /**/ /* IVdf: * This symbol defines the format string used for printing a Perl IV @@ -2537,8 +2528,8 @@ /*#define HAS_STRTOULL /**/ /* USE_64_BITS: - * This symbol, if defined, indicates that 64-bit interfaces should - * be used when available. If not defined, the native default interfaces + * This symbol, if defined, indicates that 64-bit integers should + * be used when available. If not defined, the native integers * will be used (be they 32 or 64 bits). */ #ifndef USE_64_BITS @@ -2599,41 +2590,6 @@ /*#define USE_SOCKS /**/ #endif -/* PERL_XS_APIVERSION: - * This variable contains the version of the oldest perl binary - * compatible with the present perl. perl.c:incpush() and - * lib/lib.pm will automatically search in c:\\perl\\site\\5.00563\\lib\\MSWin32-x86 for older - * directories across major versions back to xs_apiversion. - * This is only useful if you have a perl library directory tree - * structured like the default one. - * See INSTALL for how this works. - * The versioned site_perl directory was introduced in 5.005, - * so that is the lowest possible value. - * Since this can depend on compile time options (such as - * bincompat) it is set by Configure. Other non-default sources - * of potential incompatibility, such as multiplicity, threads, - * debugging, 64bits, sfio, etc., are not checked for currently, - * though in principle we could go snooping around in old - * Config.pm files. - */ -/* PERL_PM_APIVERSION: - * This variable contains the version of the oldest perl - * compatible with the present perl. (That is, pure perl modules - * written for pm_apiversion will still work for the current - * version). perl.c:incpush() and lib/lib.pm will automatically - * search in c:\\perl\\site\\5.00563\\lib for older directories across major versions - * back to pm_apiversion. This is only useful if you have a perl - * library directory tree structured like the default one. The - * versioned site_perl library was introduced in 5.005, so that's - * the default setting for this variable. It's hard to imagine - * it changing before Perl6. It is included here for symmetry - * with xs_apiveprsion -- the searching algorithms will - * (presumably) be similar. - * See the INSTALL file for how this works. - */ -#define PERL_XS_APIVERSION 5.00563 /* Change to string for tuples?*/ -#define PERL_PM_APIVERSION 5.005 /* Change to string for tuples?*/ - /* HAS_DRAND48_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the drand48() function. Otherwise, it is up @@ -2752,16 +2708,22 @@ */ /*#define I_PTHREAD /**/ -/* USE_THREADS: - * This symbol, if defined, indicates that Perl should - * be built to use threads. +/* USE_ITHREADS: + * This symbol, if defined, indicates that Perl should be built to + * use the interpreter-based threading implementation. + */ +/* USE_5005THREADS: + * This symbol, if defined, indicates that Perl should be built to + * use the 5.005-based threading implementation. */ /* OLD_PTHREADS_API: * This symbol, if defined, indicates that Perl should * be built to use the old draft POSIX threads API. */ -#ifndef USE_TTHREADS -/*#define USE_THREADS /**/ +/*#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 /**/ @@ -2791,6 +2753,11 @@ */ #define Gid_t_f "ld" /**/ +/* Gid_t_size: + * This symbol holds the size of a Gid_t in bytes. + */ +#define Gid_t_size 4 /* GID size */ + /* Gid_t: * This symbol holds the return type of getgid() and the type of * argument to setrgid() and related functions. Typically, @@ -2808,8 +2775,12 @@ /* LSEEKSIZE: * This symbol holds the number of bytes used by the Off_t. */ +/* Off_t_size: + * This symbol holds the number of bytes used by the Off_t. + */ #define Off_t off_t /* <offset> type */ #define LSEEKSIZE 4 /* <offset> size */ +#define Off_t_size 4 /* <offset> size */ /* Mode_t: * This symbol holds the type used to declare file modes @@ -2839,6 +2810,11 @@ */ #define Uid_t_f "ld" /**/ +/* Uid_t_size: + * This symbol holds the size of a Uid_t in bytes. + */ +#define Uid_t_size 4 /* UID size */ + /* Uid_t: * This symbol holds the type used to declare user ids in the kernel. * It can be int, ushort, uid_t, etc... It may be necessary to include diff --git a/win32/config_H.vc b/win32/config_H.vc index 032a9c8cbc..4e1964f323 100644 --- a/win32/config_H.vc +++ b/win32/config_H.vc @@ -13,7 +13,7 @@ /* * Package name : perl5 * Source directory : - * Configuration time: Sun Oct 31 02:10:23 1999 + * Configuration time: Sun Jan 9 15:13:19 2000 * Configured by : gsar * Target system : */ @@ -980,52 +980,6 @@ */ #define STDCHAR char /**/ -/* HAS_QUAD: - * This symbol, if defined, tells that there's a 64-bit integer type, - * Quad_t. - */ -/* Quad_t: - * This symbol holds the type used for 64-bit integers. - * It can be int, long, long long, int64_t etc... - */ -/* QUADCASE: - * This symbol, if defined, encodes the type of a quad: - * 1 = int, 2 = long, 3 = long long, 4 = int64_t. - */ -/* Uquad_t: - * This symbol holds the type used for unsigned 64-bit integers. - * It can be unsigned int, unsigned long, unsigned long long, - * uint64_t etc... - */ -/*#define HAS_QUAD /**/ -/*#define Quad_t __int64 /**/ -/*#define Uquad_t unsigned __int64 /**/ -/*#define QUADCASE 5 /**/ - -/* HAS_ACCESSX: - * This symbol, if defined, indicates that the accessx routine is - * available to do extended access checks. - */ -/*#define HAS_ACCESSX /**/ - -/* HAS_EACCESS: - * This symbol, if defined, indicates that the eaccess routine is - * available to do extended access checks. - */ -/*#define HAS_EACCESS /**/ - -/* I_SYS_ACCESS: - * This symbol, if defined, indicates to the C program that it should - * include <sys/access.h>. - */ -/*#define I_SYS_ACCESS /**/ - -/* I_SYS_SECURITY: - * This symbol, if defined, indicates to the C program that it should - * include <sys/security.h>. - */ -/*#define I_SYS_SECURITY /**/ - /* CROSSCOMPILE: * This symbol, if defined, signifies that we our * build process is a cross-compilation. @@ -1057,6 +1011,46 @@ */ /*#define MULTIARCH /**/ +/* HAS_QUAD: + * This symbol, if defined, tells that there's a 64-bit integer type, + * Quad_t, and its unsigned counterpar, Uquad_t. QUADKIND will be one + * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, or QUAD_IS_INT64_T. + */ +/*#define HAS_QUAD /**/ +#ifdef HAS_QUAD +# define Quad_t __int64 /**/ +# define Uquad_t unsigned __int64 /**/ +# define QUADKIND undef /**/ +# define QUAD_IS_INT 1 +# define QUAD_IS_LONG 2 +# define QUAD_IS_LONG_LONG 3 +# define QUAD_IS_INT64_T 4 +#endif + +/* HAS_ACCESSX: + * This symbol, if defined, indicates that the accessx routine is + * available to do extended access checks. + */ +/*#define HAS_ACCESSX /**/ + +/* HAS_EACCESS: + * This symbol, if defined, indicates that the eaccess routine is + * available to do extended access checks. + */ +/*#define HAS_EACCESS /**/ + +/* I_SYS_ACCESS: + * This symbol, if defined, indicates to the C program that it should + * include <sys/access.h>. + */ +/*#define I_SYS_ACCESS /**/ + +/* I_SYS_SECURITY: + * This symbol, if defined, indicates to the C program that it should + * include <sys/security.h>. + */ +/*#define I_SYS_SECURITY /**/ + /* MEM_ALIGNBYTES: * This symbol contains the number of bytes required to align a * double. Usual values are 2, 4 and 8. The default is eight, @@ -1429,7 +1423,7 @@ * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define ARCHLIB "c:\\perl\\5.00563\\lib\\MSWin32-x86" /**/ +#define ARCHLIB "c:\\perl\\5.5.640\\lib\\MSWin32-x86" /**/ /*#define ARCHLIB_EXP "" /**/ /* BIN: @@ -1440,8 +1434,8 @@ * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ -#define BIN "c:\\perl\\5.00563\\bin\\MSWin32-x86" /**/ -#define BIN_EXP "c:\\perl\\5.00563\\bin\\MSWin32-x86" /**/ +#define BIN "c:\\perl\\5.5.640\\bin\\MSWin32-x86" /**/ +#define BIN_EXP "c:\\perl\\5.5.640\\bin\\MSWin32-x86" /**/ /* INSTALL_USR_BIN_PERL: * This symbol, if defined, indicates that Perl is to be installed @@ -1459,8 +1453,8 @@ * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define PRIVLIB "c:\\perl\\5.00563\\lib" /**/ -#define PRIVLIB_EXP (win32_get_privlib("5.00563")) /**/ +#define PRIVLIB "c:\\perl\\5.5.640\\lib" /**/ +#define PRIVLIB_EXP (win32_get_privlib("5.5.640")) /**/ /* SITEARCH: * This symbol contains the name of the private library for this package. @@ -1477,7 +1471,7 @@ * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITEARCH "c:\\perl\\site\\5.00563\\lib\\MSWin32-x86" /**/ +#define SITEARCH "c:\\perl\\site\\5.5.640\\lib\\MSWin32-x86" /**/ /*#define SITEARCH_EXP "" /**/ /* SITELIB: @@ -1495,8 +1489,8 @@ * This symbol contains the ~name expanded version of SITELIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITELIB "c:\\perl\\site\\5.00563\\lib" /**/ -#define SITELIB_EXP (win32_get_sitelib("5.00563")) /**/ +#define SITELIB "c:\\perl\\site\\5.5.640\\lib" /**/ +#define SITELIB_EXP (win32_get_sitelib("5.5.640")) /**/ /* PERL_VENDORLIB_EXP: * This symbol contains the ~name expanded version of VENDORLIB, to be used @@ -2202,6 +2196,13 @@ */ /*#define HAS_HASMNTOPT /**/ +/* HAS_INT64_T: + * This symbol will defined if the C compiler supports int64_t. + * Usually the <inttypes.h> needs to be included, but sometimes + * <sys/types.h> is enough. + */ +/*#define HAS_INT64_T /**/ + /* HAS_LDBL_DIG: * This symbol, if defined, indicates that this system's <float.h> * or <limits.h> defines the symbol LDBL_DIG, which is the number @@ -2302,13 +2303,7 @@ * This symbol, if defined, indicates to the C program that it should * include <inttypes.h>. */ -/* HAS_INT64_T: - * This symbol will defined if the C compiler supports int64_t. - * Usually the <inttypes.h> needs to be included, but sometimes - * <sys/types.h> is enough. - */ /*#define I_INTTYPES /**/ -/*#define HAS_INT64_T /**/ /* I_MNTENT: * This symbol, if defined, indicates that <mntent.h> exists and @@ -2452,9 +2447,6 @@ /* U64SIZE: * This symbol contains the sizeof(U64). */ -/* NVSIZE: - * This symbol contains the sizeof(NV). - */ #define IVTYPE long /**/ #define UVTYPE unsigned long /**/ #define I8TYPE char /**/ @@ -2480,7 +2472,6 @@ #define I64SIZE 8 /**/ #define U64SIZE 8 /**/ #endif -#define NVSIZE 8 /**/ /* IVdf: * This symbol defines the format string used for printing a Perl IV @@ -2537,8 +2528,8 @@ /*#define HAS_STRTOULL /**/ /* USE_64_BITS: - * This symbol, if defined, indicates that 64-bit interfaces should - * be used when available. If not defined, the native default interfaces + * This symbol, if defined, indicates that 64-bit integers should + * be used when available. If not defined, the native integers * will be used (be they 32 or 64 bits). */ #ifndef USE_64_BITS @@ -2599,41 +2590,6 @@ /*#define USE_SOCKS /**/ #endif -/* PERL_XS_APIVERSION: - * This variable contains the version of the oldest perl binary - * compatible with the present perl. perl.c:incpush() and - * lib/lib.pm will automatically search in c:\\perl\\site\\5.00563\\lib\\MSWin32-x86 for older - * directories across major versions back to xs_apiversion. - * This is only useful if you have a perl library directory tree - * structured like the default one. - * See INSTALL for how this works. - * The versioned site_perl directory was introduced in 5.005, - * so that is the lowest possible value. - * Since this can depend on compile time options (such as - * bincompat) it is set by Configure. Other non-default sources - * of potential incompatibility, such as multiplicity, threads, - * debugging, 64bits, sfio, etc., are not checked for currently, - * though in principle we could go snooping around in old - * Config.pm files. - */ -/* PERL_PM_APIVERSION: - * This variable contains the version of the oldest perl - * compatible with the present perl. (That is, pure perl modules - * written for pm_apiversion will still work for the current - * version). perl.c:incpush() and lib/lib.pm will automatically - * search in c:\\perl\\site\\5.00563\\lib for older directories across major versions - * back to pm_apiversion. This is only useful if you have a perl - * library directory tree structured like the default one. The - * versioned site_perl library was introduced in 5.005, so that's - * the default setting for this variable. It's hard to imagine - * it changing before Perl6. It is included here for symmetry - * with xs_apiveprsion -- the searching algorithms will - * (presumably) be similar. - * See the INSTALL file for how this works. - */ -#define PERL_XS_APIVERSION 5.00563 /* Change to string for tuples?*/ -#define PERL_PM_APIVERSION 5.005 /* Change to string for tuples?*/ - /* HAS_DRAND48_PROTO: * This symbol, if defined, indicates that the system provides * a prototype for the drand48() function. Otherwise, it is up @@ -2752,16 +2708,22 @@ */ /*#define I_PTHREAD /**/ -/* USE_THREADS: - * This symbol, if defined, indicates that Perl should - * be built to use threads. +/* USE_ITHREADS: + * This symbol, if defined, indicates that Perl should be built to + * use the interpreter-based threading implementation. + */ +/* USE_5005THREADS: + * This symbol, if defined, indicates that Perl should be built to + * use the 5.005-based threading implementation. */ /* OLD_PTHREADS_API: * This symbol, if defined, indicates that Perl should * be built to use the old draft POSIX threads API. */ -#ifndef USE_TTHREADS -/*#define USE_THREADS /**/ +/*#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 /**/ @@ -2791,6 +2753,11 @@ */ #define Gid_t_f "ld" /**/ +/* Gid_t_size: + * This symbol holds the size of a Gid_t in bytes. + */ +#define Gid_t_size 4 /* GID size */ + /* Gid_t: * This symbol holds the return type of getgid() and the type of * argument to setrgid() and related functions. Typically, @@ -2808,8 +2775,12 @@ /* LSEEKSIZE: * This symbol holds the number of bytes used by the Off_t. */ +/* Off_t_size: + * This symbol holds the number of bytes used by the Off_t. + */ #define Off_t off_t /* <offset> type */ #define LSEEKSIZE 4 /* <offset> size */ +#define Off_t_size 4 /* <offset> size */ /* Mode_t: * This symbol holds the type used to declare file modes @@ -2839,6 +2810,11 @@ */ #define Uid_t_f "ld" /**/ +/* Uid_t_size: + * This symbol holds the size of a Uid_t in bytes. + */ +#define Uid_t_size 4 /* UID size */ + /* Uid_t: * This symbol holds the type used to declare user ids in the kernel. * It can be int, ushort, uid_t, etc... It may be necessary to include diff --git a/win32/config_h.PL b/win32/config_h.PL index 16e467e915..17f3fc2163 100644 --- a/win32/config_h.PL +++ b/win32/config_h.PL @@ -13,8 +13,8 @@ while (@ARGV && $ARGV[0] =~ /^([\w_]+)=(.*)$/) } my $patchlevel = $opt{INST_VER}; $patchlevel =~ s|^[\\/]||; -$patchlevel =~ s|~VERSION~|$]|g; -$patchlevel ||= $]; +$patchlevel =~ s|~VERSION~|$Config{version}|g; +$patchlevel ||= $Config{version}; $patchlevel = qq["$patchlevel"]; open(SH,"<$name") || die "Cannot open $name:$!"; diff --git a/win32/config_sh.PL b/win32/config_sh.PL index 9e53b54827..0e1d351c1a 100644 --- a/win32/config_sh.PL +++ b/win32/config_sh.PL @@ -10,17 +10,38 @@ sub mungepath { return join(' ', @p); } +# generate an array of option strings from command-line args +# or an option file +# -- added by BKS, 10-17-1999 to fix command-line overflow problems +sub loadopts { + if ($ARGV[0] =~ /--cfgsh-option-file/) { + shift @ARGV; + my $optfile = shift @ARGV; + local (*F); + open OPTF, $optfile or die "Can't open $optfile: $!\n"; + my @opts; + chomp(my $line = <OPTF>); + my @vars = split(/\t+~\t+/, $line); + for (@vars) { + push(@opts, $_) unless (/^\s*$/); + } + close OPTF; + return \@opts; + } + else { + return \@ARGV; + } +} + my %opt; -while (@ARGV && $ARGV[0] =~ /^([\w_]+)=(.*)$/) - { - $opt{$1}=$2; - shift(@ARGV); - } +my $optref = loadopts(); +while (@{$optref} && $optref->[0] =~ /^([\w_]+)=(.*)$/) { + $opt{$1}=$2; + shift(@{$optref}); +} my $pl_h = '../patchlevel.h'; -$opt{VERSION} = $]; -$opt{INST_VER} =~ s|~VERSION~|$]|g; if (-e $pl_h) { open PL, "<$pl_h" or die "Can't open $pl_h: $!"; while (<PL>) { @@ -30,17 +51,11 @@ if (-e $pl_h) { } close PL; } -elsif ($] =~ /^(\d+)\.(\d\d\d)?(\d\d)?$/) { # should always be true - $opt{PERL_REVISION} = $1; - $opt{PERL_VERSION} = int($2 || 0); - $opt{PERL_SUBVERSION} = $3; - $opt{PERL_APIVERSION} = $]; -} else { - die "Can't parse perl version ($])"; + die "Can't find $pl_h: $!"; } - -$opt{PERL_SUBVERSION} ||= '00'; +$opt{VERSION} = "$opt{PERL_REVISION}.$opt{PERL_VERSION}.$opt{PERL_SUBVERSION}"; +$opt{INST_VER} =~ s|~VERSION~|$opt{VERSION}|g; $opt{'cf_by'} = $ENV{USERNAME} unless $opt{'cf_by'}; $opt{'cf_email'} = $opt{'cf_by'} . '@' . (gethostbyname('localhost'))[0] @@ -50,19 +65,19 @@ $opt{'usemymalloc'} = 'y' if $opt{'d_mymalloc'} eq 'define'; $opt{libpth} = mungepath($opt{libpth}) if exists $opt{libpth}; $opt{incpath} = mungepath($opt{incpath}) if exists $opt{incpath}; -while (<>) - { - s/~([\w_]+)~/$opt{$1}/g; - if (/^([\w_]+)=(.*)$/) { - my($k,$v) = ($1,$2); - # this depends on cf_time being empty in the template (or we'll get a loop) - if ($k eq 'cf_time') { - $_ = "$k='" . localtime(time) . "'\n" if $v =~ /^\s*'\s*'/; - } - elsif (exists $opt{$k}) { - $_ = "$k='$opt{$k}'\n"; +while (<>) { + s/~([\w_]+)~/$opt{$1}/g; + if (/^([\w_]+)=(.*)$/) { + my($k,$v) = ($1,$2); + # this depends on cf_time being empty in the template (or we'll + # get a loop) + if ($k eq 'cf_time') { + $_ = "$k='" . localtime(time) . "'\n" if $v =~ /^\s*'\s*'/; + } + elsif (exists $opt{$k}) { + $_ = "$k='$opt{$k}'\n"; + } } - } - print; - } + print; +} diff --git a/win32/genmk95.pl b/win32/genmk95.pl index 74788ff3cb..8fe4f86dbf 100644 --- a/win32/genmk95.pl +++ b/win32/genmk95.pl @@ -1,28 +1,28 @@ -# genmk95.pl - uses miniperl to generate a makefile that command.com -# (and dmake) will understand given one that cmd.exe will understand +# genmk95.pl - uses miniperl to generate a makefile that command.com will +# understand given one that cmd.exe will understand # Author: Benjamin K. Stuhl -# Date: 8-18-1999 +# Date: 10-16-1999 # how it works: # dmake supports an alternative form for its recipes, called "group -# recipes", in which all elements of a recipe are run with only one -# shell. This program converts the standard dmake makefile.mk to -# one using group recipes. This is done so that lines using && or -# || (which command.com doesn't understand) may be split into two -# lines. +# recipes", in which all elements of a recipe are run with only one shell. +# This program converts the standard dmake makefile.mk to one using group +# recipes. This is done so that lines using && or || (which command.com +# doesn't understand) may be split into two lines that will still be run +# with one shell. my ($filein, $fileout) = @ARGV; -chomp (my $loc = `cd`); - -open my $in, $filein or die "Error opening input file: $!"; -open my $out, "> $fileout" or die "Error opening output file: $!"; +open my $in, $filein or die "Error opening input file: $!\n"; +open my $out, "> $fileout" or die "Error opening output file: $!\n"; print $out <<_EOH_; # *** Warning: this file is autogenerated from $filein by $0 *** # *** Do not edit this file - edit $filein instead *** +_HOME_DIR := \$(PWD) + _EOH_ my $inrec = 0; @@ -30,12 +30,12 @@ my $inrec = 0; while (<$in>) { chomp; - if (/^[^#.\t][^#=]*?:/) + if (/^[^#.\t][^#=]*?:(?:[^=]|$)/) { if (! $inrec) { print $out "$_\n"; - while (/\\$/) + while (/\\\s*$/) { chomp($_ = <$in>); print $out "$_\n"; @@ -45,9 +45,12 @@ while (<$in>) next; } else { - seek ($out, -3, 2); # no recipe, so back up and undo grouping + if (!/^\t/) { + seek ($out, -4, 2); # no recipe, so back up and undo grouping + # should be -3, but MS has its CR/LF thing... + $inrec = 0; + } print $out "$_\n"; - $inrec = 0; next; } } @@ -70,7 +73,7 @@ LINE_CONT: s/^\s*// for ($one, $two); print $out "\t$one\n\t$two\n" if ($sep eq "&&"); print $out "\t$one\n\tif errorlevel 1 $two\n" if ($sep eq "||"); - print $out "\tcd $loc\n"; + print $out "\tcd \$(_HOME_DIR)\n"; next; } # fall through - no need for special handling @@ -78,4 +81,5 @@ LINE_CONT: } print $out "]\n" if ($inrec); -close $in; close $out; +close $in or warn "Error closing \$in: $!\n"; +close $out or warn "Error closing \$out: $!\n"; diff --git a/win32/makefile.mk b/win32/makefile.mk index 2550611c88..e6ed1765a7 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -1,9 +1,9 @@ # # Makefile to build perl on Windows NT using DMAKE. # Supported compilers: -# Visual C++ 2.0 thro 5.0 +# Visual C++ 2.0 thro 6.0 # Borland C++ 5.02 -# Mingw32 with gcc-2.8.1 or egcs-1.0.2 **experimental** +# Mingw32 with gcc-2.95.2 or better **experimental** # # This is set up to build a perl.exe that runs off a shared library # (perl.dll). Also makes individual DLLs for the XS extensions. @@ -18,7 +18,7 @@ ## # -# Set these to wherever you want "nmake install" to put your +# Set these to wherever you want "dmake install" to put your # newly built perl. # INST_DRV *= c: @@ -33,7 +33,7 @@ INST_TOP *= $(INST_DRV)\perl # versioned installation can be obtained by setting INST_TOP above to a # path that includes an arbitrary version string. # -INST_VER *= \5.00563 +INST_VER *= \5.5.640 # # Comment this out if you DON'T want your perl installation to have @@ -51,7 +51,7 @@ INST_ARCH *= \$(ARCHNAME) # # uncomment to enable threads-capabilities # -#USE_THREADS *= define +#USE_5005THREADS *= define # # XXX WARNING! This option currently undergoing changes. May be broken. @@ -70,6 +70,22 @@ INST_ARCH *= \$(ARCHNAME) #USE_OBJECT *= define # +# XXX WARNING! This option currently undergoing changes. May be broken. +# +# Beginnings of interpreter cloning/threads: still rather rough, fails +# tests. This should be enabled to get the fork() emulation. Do not +# enable unless you know what you're doing! +# +#USE_ITHREADS *= define + +# +# uncomment to enable the implicit "host" layer for all system calls +# made by perl. This is needed and auto-enabled by USE_OBJECT above. +# This is also needed to get fork(). +# +#USE_IMP_SYS *= define + +# # uncomment exactly one of the following # # Visual C++ 2.x @@ -80,7 +96,7 @@ INST_ARCH *= \$(ARCHNAME) #CCTYPE *= MSVC60 # Borland 5.02 or later CCTYPE *= BORLAND -# mingw32/egcs or mingw32/gcc +# mingw32/gcc-2.95.2 or better #CCTYPE *= GCC # @@ -97,11 +113,13 @@ CCTYPE *= BORLAND # # uncomment to enable use of PerlCRT.DLL when using the Visual C compiler. -# Highly recommended. It has patches that fix known bugs in MSVCRT.DLL. +# It has patches that fix known bugs in older versions of MSVCRT.DLL. # This currently requires VC 5.0 with Service Pack 3 or later. # Get it from CPAN at http://www.perl.com/CPAN/authors/id/D/DO/DOUGL/ # and follow the directions in the package to install. # +# Not recommended if you have VC 6.x and you're not running Windows 9x. +# #USE_PERLCRT *= define # @@ -143,27 +161,41 @@ CCTYPE *= BORLAND # so you may have to set CCHOME explicitly (spaces in the path name should # not be quoted) # -CCHOME *= d:\bc5 +CCHOME *= c:\bc5 #CCHOME *= $(MSVCDIR) #CCHOME *= D:\packages\mingw32 CCINCDIR *= $(CCHOME)\include CCLIBDIR *= $(CCHOME)\lib # -# additional compiler flags can be specified here. +# Additional compiler flags can be specified here. +# + # -# Adding -DPERL_POLLUTE enables support for old symbols, at the expense of -# extreme pollution. You most probably want this if you're compiling modules -# from CPAN, or other such serious uses of this experimental perl release. -# We don't enable this by default because we want the modules to get fixed -# instead of clinging to shortcuts like this one. +# This should normally be disabled. Adding -DPERL_POLLUTE enables support +# for old symbols by default, at the expense of extreme pollution. You most +# probably just want to build modules that won't compile with +# perl Makefile.PL POLLUTE=1 +# instead of enabling this. Please report such modules to the respective +# authors. # #BUILDOPT += -DPERL_POLLUTE # -# enable this to test the File::Glob implementation of CORE::glob +# This should normally be disabled. Enabling it will disable the File::Glob +# implementation of CORE::glob. +# +#BUILDOPT += -DPERL_EXTERNAL_GLOB + +# +# This should normally be disabled. Enabling it causes perl to read scripts +# in text mode (which is the 5.005 behavior) and will break ByteLoader. +#BUILDOPT += -DPERL_TEXTMODE_SCRIPTS + # -#BUILDOPT += -DPERL_INTERNAL_GLOB +# This should normally be disabled. Enabling it runs a cloned toplevel +# interpreter (*EXPERIMENTAL*, fails tests) +#BUILDOPT += -DTOP_CLONE # # specify semicolon-separated list of extra directories that modules will @@ -198,20 +230,32 @@ CRYPT_FLAG = -DHAVE_DES_FCRYPT .IF "$(USE_OBJECT)" == "define" PERL_MALLOC != undef -USE_THREADS != undef +USE_5005THREADS != undef USE_MULTI != undef +USE_IMP_SYS != define .ENDIF PERL_MALLOC *= undef -USE_THREADS *= undef +USE_5005THREADS *= undef + +.IF "$(USE_5005THREADS)" == "define" +USE_ITHREADS != undef +.ENDIF + USE_MULTI *= undef USE_OBJECT *= undef +USE_ITHREADS *= undef +USE_IMP_SYS *= undef +USE_PERLCRT *= undef -.IF "$(USE_MULTI)$(USE_THREADS)$(USE_OBJECT)" != "undefundefundef" +.IF "$(USE_MULTI)$(USE_5005THREADS)$(USE_OBJECT)" != "undefundefundef" BUILDOPT += -DPERL_IMPLICIT_CONTEXT .ENDIF +.IF "$(USE_IMP_SYS)" != "undef" +BUILDOPT += -DPERL_IMPLICIT_SYS +.ENDIF .IMPORT .IGNORE : PROCESSOR_ARCHITECTURE @@ -219,7 +263,7 @@ PROCESSOR_ARCHITECTURE *= x86 .IF "$(USE_OBJECT)" == "define" ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-object -.ELIF "$(USE_THREADS)" == "define" +.ELIF "$(USE_5005THREADS)" == "define" ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-thread .ELIF "$(USE_MULTI)" == "define" ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-multi @@ -227,6 +271,10 @@ ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-multi ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE) .ENDIF +.IF "$(USE_OBJECT)" == "define" +ARCHNAME = $(ARCHNAME)-thread +.ENDIF + # Visual Studio 98 specific .IF "$(CCTYPE)" == "MSVC60" @@ -268,6 +316,7 @@ CC = bcc32 LINK32 = tlink32 LIB32 = tlib /P128 IMPLIB = implib -c +RSC = rc # # Options @@ -304,6 +353,7 @@ CC = gcc LINK32 = gcc LIB32 = ar rc IMPLIB = dlltool +RSC = rc o = .o a = .a @@ -311,6 +361,7 @@ a = .a # # Options # + RUNTIME = INCLUDES = -I$(COREDIR) -I.\include -I. -I.. DEFINES = -DWIN32 $(CRYPT_FLAG) @@ -318,11 +369,14 @@ LOCDEFS = -DPERLDLL -DPERL_CORE SUBSYS = console CXX_FLAG = -xc++ -# crtdll doesn't define _wopen and friends -#LIBC = -lcrtdll LIBC = -lmsvcrt -LIBFILES = $(CRYPT_LIB) -ladvapi32 -luser32 -lnetapi32 -lwsock32 \ - -lmingw32 -lgcc -lmoldname $(LIBC) -lkernel32 + +# same libs as MSVC +LIBFILES = $(CRYPT_LIB) $(LIBC) \ + -lmoldname -lkernel32 -luser32 -lgdi32 \ + -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 \ + -loleaut32 -lnetapi32 -luuid -lwsock32 -lmpr \ + -lwinmm -lversion -lodbc32 .IF "$(CFG)" == "Debug" OPTIMIZE = -g $(RUNTIME) -DDEBUGGING @@ -343,6 +397,7 @@ LIBOUT_FLAG = CC = cl LINK32 = link LIB32 = $(LINK32) -lib +RSC = rc # # Options @@ -356,7 +411,7 @@ LOCDEFS = -DPERLDLL -DPERL_CORE SUBSYS = console CXX_FLAG = -TP -GX -.IF "$(USE_PERLCRT)" == "" +.IF "$(USE_PERLCRT)" != "define" .IF "$(CFG)" == "Debug" PERLCRTLIBC = msvcrtd.lib .ELSE @@ -370,6 +425,9 @@ PERLCRTLIBC = PerlCRT.lib .ENDIF .ENDIF +PERLEXE_RES = +PERLDLL_RES = + .IF "$(RUNTIME)" == "-MD" LIBC = $(PERLCRTLIBC) .ELSE @@ -395,9 +453,9 @@ LINK_DBG = -release .ENDIF LIBBASEFILES = $(DELAYLOAD) $(CRYPT_LIB) \ - oldnames.lib kernel32.lib user32.lib gdi32.lib \ - winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib \ - oleaut32.lib netapi32.lib uuid.lib wsock32.lib mpr.lib winmm.lib \ + oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib \ + comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib \ + netapi32.lib uuid.lib wsock32.lib mpr.lib winmm.lib \ version.lib odbc32.lib odbccp32.lib # we add LIBC here, since we may be using PerlCRT.dll @@ -412,6 +470,10 @@ OBJOUT_FLAG = -Fo EXEOUT_FLAG = -Fe LIBOUT_FLAG = /out: +.IF "$(USE_PERLCRT)" != "define" +BUILDOPT += -DPERL_MSVCRT_READFIX +.ENDIF + .ENDIF .IF "$(USE_OBJECT)" == "define" @@ -421,6 +483,12 @@ BUILDOPT += -DPERL_OBJECT CFLAGS_O = $(CFLAGS) $(BUILDOPT) +# used to allow local linking flags that are not propogated into Config.pm, +# currently unused +# -- BKS, 12-12-1999 +PRIV_LINK_FLAGS *= +BLINK_FLAGS = $(PRIV_LINK_FLAGS) $(LINK_FLAGS) + #################### do not edit below this line ####################### ############# NO USER-SERVICEABLE PARTS BEYOND THIS POINT ############## @@ -434,7 +502,7 @@ LKPOST = ) # Rules # -.SUFFIXES : .c $(o) .dll $(a) .exe +.SUFFIXES : .c $(o) .dll $(a) .exe .rc .res .c$(o): $(CC) -c $(null,$(<:d) $(NULL) -I$(<:d)) $(CFLAGS_O) $(OBJOUT_FLAG)$@ $< @@ -444,21 +512,25 @@ LKPOST = ) $(o).dll: .IF "$(CCTYPE)" == "BORLAND" - $(LINK32) -Tpd -ap $(LINK_FLAGS) c0d32$(o) $<,$@,,$(LIBFILES),$(*B).def + $(LINK32) -Tpd -ap $(BLINK_FLAGS) c0d32$(o) $<,$@,,$(LIBFILES),$(*B).def $(IMPLIB) $(*B).lib $@ .ELIF "$(CCTYPE)" == "GCC" - $(LINK32) -o $@ $(LINK_FLAGS) $< $(LIBFILES) - $(IMPLIB) -def $(*B).def $(*B).a $@ + $(LINK32) -o $@ $(BLINK_FLAGS) $< $(LIBFILES) + $(IMPLIB) --input-def $(*B).def --output-lib $(*B).a $@ .ELSE $(LINK32) -dll -subsystem:windows -implib:$(*B).lib -def:$(*B).def \ - -out:$@ $(LINK_FLAGS) $(LIBFILES) $< $(LIBPERL) + -out:$@ $(BLINK_FLAGS) $(LIBFILES) $< $(LIBPERL) .ENDIF +.rc.res: + $(RSC) $< + # # various targets MINIPERL = ..\miniperl.exe MINIDIR = .\mini PERLEXE = ..\perl.exe +WPERLEXE = ..\wperl.exe GLOBEXE = ..\perlglob.exe CONFIGPM = ..\lib\Config.pm MINIMOD = ..\lib\ExtUtils\Miniperl.pm @@ -476,7 +548,6 @@ UTILS = \ ..\utils\c2ph \ ..\utils\h2xs \ ..\utils\perldoc \ - ..\utils\pstruct \ ..\utils\perlcc \ ..\pod\checkpods \ ..\pod\pod2html \ @@ -512,7 +583,7 @@ PERLIMPLIB = ..\libperl$(a) CFGSH_TMPL = config.vc CFGH_TMPL = config_H.vc -.IF "$(USE_PERLCRT)" == "" +.IF "$(USE_PERLCRT)" != "define" PERL95EXE = ..\perl95.exe .ENDIF @@ -580,7 +651,7 @@ WIN32_SRC = \ .\win32.c \ .\win32sck.c -.IF "$(USE_THREADS)" == "define" +.IF "$(USE_5005THREADS)" == "define" WIN32_SRC += .\win32thread.c .ENDIF @@ -644,7 +715,10 @@ CORE_NOCFG_H = \ .\include\dirent.h \ .\include\netdb.h \ .\include\sys\socket.h \ - .\win32.h + .\win32.h \ + .\perlhost.h \ + .\vdir.h \ + .\vmem.h CORE_H = $(CORE_NOCFG_H) .\config.h @@ -750,68 +824,119 @@ POD2MAN = $(PODDIR)\pod2man POD2LATEX = $(PODDIR)\pod2latex POD2TEXT = $(PODDIR)\pod2text +# vars must be separated by "\t+~\t+", since we're using the tempfile +# version of config_sh.pl (we were overflowing someone's buffer by +# trying to fit them all on the command line) +# -- BKS 10-17-1999 CFG_VARS = \ - "INST_DRV=$(INST_DRV)" \ - "INST_TOP=$(INST_TOP)" \ - "INST_VER=$(INST_VER)" \ - "INST_ARCH=$(INST_ARCH)" \ - "archname=$(ARCHNAME)" \ - "cc=$(CC)" \ - "ccflags=$(OPTIMIZE:s/"/\"/) $(DEFINES) $(BUILDOPT)" \ - "cf_email=$(EMAIL)" \ - "d_crypt=$(D_CRYPT)" \ - "d_mymalloc=$(PERL_MALLOC)" \ - "libs=$(LIBFILES:f)" \ - "incpath=$(CCINCDIR:s/"/\"/)" \ - "libperl=$(PERLIMPLIB:f)" \ - "libpth=$(CCLIBDIR:s/"/\"/);$(EXTRALIBDIRS:s/"/\"/)" \ - "libc=$(LIBC)" \ - "make=dmake" \ - "_o=$(o)" "obj_ext=$(o)" \ - "_a=$(a)" "lib_ext=$(a)" \ - "static_ext=$(STATIC_EXT)" \ - "dynamic_ext=$(DYNAMIC_EXT)" \ - "nonxs_ext=$(NONXS_EXT)" \ - "usethreads=$(USE_THREADS)" \ - "usemultiplicity=$(USE_MULTI)" \ - "LINK_FLAGS=$(LINK_FLAGS:s/"/\"/)" \ - "optimize=$(OPTIMIZE:s/"/\"/)" + INST_DRV=$(INST_DRV) ~ \ + INST_TOP=$(INST_TOP) ~ \ + INST_VER=$(INST_VER:s/\/\\/) ~ \ + INST_ARCH=$(INST_ARCH) ~ \ + archname=$(ARCHNAME) ~ \ + cc=$(CC) ~ \ + ccflags=$(OPTIMIZE) $(DEFINES) $(BUILDOPT) ~ \ + cf_email=$(EMAIL) ~ \ + d_crypt=$(D_CRYPT) ~ \ + d_mymalloc=$(PERL_MALLOC) ~ \ + libs=$(LIBFILES:f) ~ \ + incpath=$(CCINCDIR) ~ \ + libperl=$(PERLIMPLIB:f) ~ \ + libpth=$(CCLIBDIR);$(EXTRALIBDIRS) ~ \ + libc=$(LIBC) ~ \ + make=dmake ~ \ + _o=$(o) obj_ext=$(o) ~ \ + _a=$(a) lib_ext=$(a) ~ \ + static_ext=$(STATIC_EXT) ~ \ + dynamic_ext=$(DYNAMIC_EXT) ~ \ + nonxs_ext=$(NONXS_EXT) ~ \ + use5005threads=$(USE_5005THREADS) ~ \ + useithreads=$(USE_ITHREADS) ~ \ + usethreads=$(USE_5005THREADS) ~ \ + usemultiplicity=$(USE_MULTI) ~ \ + LINK_FLAGS=$(LINK_FLAGS:s/\/\\/) ~ \ + optimize=$(OPTIMIZE) + +# +# set up targets varying between Win95 and WinNT builds +# + +.IF "$(IS_WIN95)" == "define" +MK2 = .\makefile.95 +RIGHTMAKE = __switch_makefiles +NOOP = @rem +.ELSE +MK2 = __not_needed +RIGHTMAKE = __not_needed +.ENDIF # # Top targets # -.IF "$(IS_WIN95)" != "" -MK2 = .\makew95.mk +all : .\config.h $(GLOBEXE) $(MINIPERL) $(MK2) \ + $(RIGHTMAKE) $(MINIMOD) $(CONFIGPM) $(PERLEXE) $(PERL95EXE) \ + $(X2P) $(EXTENSION_DLL) $(EXTENSION_PM) + +$(DYNALOADER)$(o) : $(DYNALOADER).c $(CORE_H) $(EXTDIR)\DynaLoader\dlutils.c -all : .\config.h $(GLOBEXE) $(MINIMOD) $(MK2) -all2 : $(CONFIGPM) $(PERLEXE) $(PERL95EXE) $(X2P) $(EXTENSION_DLL) \ - $(EXTENSIOM_PM) +#---------------------------------------------------------------- + +#-------------------- BEGIN Win95 SPECIFIC ---------------------- + +# this target is a jump-off point for Win95 +# 1. it switches to the Win95-specific makefile if it exists +# (__do_switch_makefiles) +# 2. it prints a message when the Win95-specific one finishes (__done) +# 3. it then kills this makefile by trying to make __no_such_target + +__switch_makefiles: __do_switch_makefiles __done __no_such_target + +__do_switch_makefiles: +.IF "$(NOTFIRST)" != "true" + if exist $(MK2) $(MAKE:s/-S//) -f $(MK2) $(MAKETARGETS) NOTFIRST=true .ELSE -all : .\config.h $(GLOBEXE) $(MINIMOD) $(CONFIGPM) $(PERLEXE) $(PERL95EXE) \ - $(X2P) $(EXTENSION_DLL) $(EXTENSION_PM) + $(NOOP) .ENDIF -$(DYNALOADER)$(o) : $(DYNALOADER).c $(CORE_H) $(EXTDIR)\DynaLoader\dlutils.c +.IF "$(NOTFIRST)" != "true" +__done: + @echo Build process complete. Ignore any errors after this message. + @echo Run "dmake test" to test and "dmake install" to install -#------------------------------------------------------------ +.ELSE +# dummy targets for Win95-specific makefile + +__done: + $(NOOP) + +__no_such_target: + $(NOOP) -# This target is used to generate the makew95.mk for Win95 -.IF "$(IS_WIN95)" != "" -$(MK2): makefile.mk - $(MINIPERL) genmk95.pl makefile.mk $(MK2) - $(MAKE) -f $(MK2) all2 .ENDIF +# This target is used to generate the new makefile (.\makefile.95) for Win95 + +.\makefile.95: .\makefile.mk + $(MINIPERL) genmk95.pl makefile.mk $(MK2) + +#--------------------- END Win95 SPECIFIC --------------------- + +# a blank target for when builds don't need to do certain things +# this target added for Win95 port but used to keep the WinNT port able to +# use this file +__not_needed: + $(NOOP) + $(GLOBEXE) : perlglob$(o) .IF "$(CCTYPE)" == "BORLAND" $(CC) -c -w -v -tWM -I"$(CCINCDIR)" perlglob.c - $(LINK32) -Tpe -ap $(LINK_FLAGS) c0x32$(o) perlglob$(o) \ + $(LINK32) -Tpe -ap $(BLINK_FLAGS) c0x32$(o) perlglob$(o) \ "$(CCLIBDIR)\32BIT\wildargs$(o)",$@,,import32.lib cw32mt.lib, .ELIF "$(CCTYPE)" == "GCC" - $(LINK32) $(LINK_FLAGS) -o $@ perlglob$(o) $(LIBFILES) + $(LINK32) $(BLINK_FLAGS) -mconsole -o $@ perlglob$(o) $(LIBFILES) .ELSE - $(LINK32) $(LINK_FLAGS) $(LIBFILES) -out:$@ -subsystem:$(SUBSYS) \ + $(LINK32) $(BLINK_FLAGS) $(LIBFILES) -out:$@ -subsystem:$(SUBSYS) \ perlglob$(o) setargv$(o) .ENDIF @@ -825,13 +950,15 @@ config.w32 : $(CFGSH_TMPL) copy $(CFGH_TMPL) config.h ..\config.sh : config.w32 $(MINIPERL) config_sh.PL - $(MINIPERL) -I..\lib config_sh.PL $(CFG_VARS) config.w32 > ..\config.sh + $(MINIPERL) -I..\lib config_sh.PL --cfgsh-option-file \ + $(mktmp $(CFG_VARS)) config.w32 > ..\config.sh # this target is for when changes to the main config.sh happen # edit config.{b,v,g}c and make this target once for each supported # compiler (e.g. `dmake CCTYPE=BORLAND regen_config_h`) regen_config_h: - perl config_sh.PL $(CFG_VARS) $(CFGSH_TMPL) > ..\config.sh + perl config_sh.PL --cfgsh-option-file $(mktmp $(CFG_VARS)) \ + $(CFGSH_TMPL) > ..\config.sh -cd .. && del /f perl.exe cd .. && perl configpm -del /f $(CFGH_TMPL) @@ -849,27 +976,37 @@ $(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl $(MINIPERL) -I..\lib config_h.PL "INST_VER=$(INST_VER)" \ || $(MAKE) $(MAKEMACROS) $(CONFIGPM) $(MAKEFILE) -$(MINIPERL) : $(MINIDIR) $(MINI_OBJ) +$(MINIPERL) : $(MINIDIR) $(MINI_OBJ) $(CRTIPMLIBS) .IF "$(CCTYPE)" == "BORLAND" - $(LINK32) -Tpe -ap $(LINK_FLAGS) \ + $(LINK32) -Tpe -ap $(BLINK_FLAGS) \ @$(mktmp c0x32$(o) $(MINI_OBJ:s,\,\\),$(@:s,\,\\),,$(LIBFILES),) .ELIF "$(CCTYPE)" == "GCC" - $(LINK32) -v -o $@ $(LINK_FLAGS) \ - $(mktmp $(LKPRE) $(MINI_OBJ:s,\,\\) $(LIBFILES) $(LKPOST)) + $(LINK32) -v -mconsole -o $@ $(BLINK_FLAGS) \ + $(mktmp $(LKPRE) $(MINI_OBJ:s,\,\\) $(LIBFILES) $(LKPOST)) .ELSE $(LINK32) -subsystem:console -out:$@ \ - @$(mktmp $(LINK_FLAGS) $(LIBFILES) $(MINI_OBJ:s,\,\\)) + @$(mktmp $(BLINK_FLAGS) $(LIBFILES) $(MINI_OBJ:s,\,\\)) .ENDIF $(MINIDIR) : if not exist "$(MINIDIR)" mkdir "$(MINIDIR)" $(MINICORE_OBJ) : $(CORE_NOCFG_H) - $(CC) -c $(CFLAGS) $(OBJOUT_FLAG)$@ ..\$(*B).c + $(CC) -c $(CFLAGS) -DPERL_EXTERNAL_GLOB $(OBJOUT_FLAG)$@ ..\$(*B).c $(MINIWIN32_OBJ) : $(CORE_NOCFG_H) $(CC) -c $(CFLAGS) $(OBJOUT_FLAG)$@ $(*B).c +# -DPERL_IMPLICIT_SYS needs C++ for perllib.c +# rules wrapped in .IFs break Win9X build (we end up with unbalanced []s unless +# unless the .IF is true), so instead we use a .ELSE with the default +perllib$(o) : perllib.c +.IF "$(USE_IMP_SYS)$(USE_OBJECT)" == "defineundef" + $(CC) -c -I. $(CFLAGS_O) $(CXX_FLAG) $(OBJOUT_FLAG)$@ perllib.c +.ELSE + $(CC) -c -I. $(CFLAGS_O) $(OBJOUT_FLAG)$@ perllib.c +.ENDIF + # 1. we don't want to rebuild miniperl.exe when config.h changes # 2. we don't want to rebuild miniperl.exe with non-default config.h $(MINI_OBJ) : $(CORE_NOCFG_H) @@ -881,31 +1018,31 @@ $(PERL95_OBJ) : $(CORE_H) $(X2P_OBJ) : $(CORE_H) perldll.def : $(MINIPERL) $(CONFIGPM) ..\global.sym ..\pp.sym ..\makedef.pl - $(MINIPERL) -w ..\makedef.pl PLATFORM=win32 $(OPTIMIZE) $(DEFINES) $(BUILDOPT) \ - CCTYPE=$(CCTYPE) > perldll.def + $(MINIPERL) -w ..\makedef.pl PLATFORM=win32 $(OPTIMIZE) $(DEFINES) \ + $(BUILDOPT) CCTYPE=$(CCTYPE) > perldll.def -$(PERLDLL): perldll.def $(PERLDLL_OBJ) +$(PERLDLL): perldll.def $(PERLDLL_OBJ) $(PERLDLL_RES) .IF "$(CCTYPE)" == "BORLAND" - $(LINK32) -Tpd -ap $(LINK_FLAGS) \ + $(LINK32) -Tpd -ap $(BLINK_FLAGS) \ @$(mktmp c0d32$(o) $(PERLDLL_OBJ:s,\,\\)\n \ $@,\n \ $(LIBFILES)\n \ perldll.def\n) $(IMPLIB) $*.lib $@ .ELIF "$(CCTYPE)" == "GCC" - $(LINK32) -mdll -o $@ -Wl,--base-file -Wl,perl.base $(LINK_FLAGS) \ + $(LINK32) -mdll -o $@ -Wl,--base-file -Wl,perl.base $(BLINK_FLAGS) \ $(mktmp $(LKPRE) $(PERLDLL_OBJ:s,\,\\) $(LIBFILES) $(LKPOST)) dlltool --output-lib $(PERLIMPLIB) \ - --dllname $(PERLDLL:b).dll \ - --def perldll.def \ - --base-file perl.base \ - --output-exp perl.exp - $(LINK32) -mdll -o $@ $(LINK_FLAGS) \ + --dllname $(PERLDLL:b).dll \ + --def perldll.def \ + --base-file perl.base \ + --output-exp perl.exp + $(LINK32) -mdll -o $@ $(BLINK_FLAGS) \ $(mktmp $(LKPRE) $(PERLDLL_OBJ:s,\,\\) $(LIBFILES) \ perl.exp $(LKPOST)) .ELSE $(LINK32) -dll -def:perldll.def -out:$@ \ - @$(mktmp $(LINK_FLAGS) $(LIBFILES) $(PERLDLL_OBJ:s,\,\\)) + @$(mktmp $(BLINK_FLAGS) $(LIBFILES) $(PERLDLL_RES) $(PERLDLL_OBJ:s,\,\\)) .ENDIF $(XCOPY) $(PERLIMPLIB) $(COREDIR) @@ -931,14 +1068,14 @@ $(X2P) : $(MINIPERL) $(X2P_OBJ) $(MINIPERL) ..\x2p\find2perl.PL $(MINIPERL) ..\x2p\s2p.PL .IF "$(CCTYPE)" == "BORLAND" - $(LINK32) -Tpe -ap $(LINK_FLAGS) \ + $(LINK32) -Tpe -ap $(BLINK_FLAGS) \ @$(mktmp c0x32$(o) $(X2P_OBJ:s,\,\\),$(@:s,\,\\),,$(LIBFILES),) .ELIF "$(CCTYPE)" == "GCC" - $(LINK32) -v -o $@ $(LINK_FLAGS) \ + $(LINK32) -v -o $@ $(BLINK_FLAGS) \ $(mktmp $(LKPRE) $(X2P_OBJ:s,\,\\) $(LIBFILES) $(LKPOST)) .ELSE $(LINK32) -subsystem:console -out:$@ \ - @$(mktmp $(LINK_FLAGS) $(LIBFILES) $(X2P_OBJ:s,\,\\)) + @$(mktmp $(BLINK_FLAGS) $(LIBFILES) $(X2P_OBJ:s,\,\\)) .ENDIF perlmain.c : runperl.c @@ -947,25 +1084,27 @@ perlmain.c : runperl.c perlmain$(o) : perlmain.c $(CC) $(CFLAGS_O) -UPERLDLL $(OBJOUT_FLAG)$@ -c perlmain.c -$(PERLEXE): $(PERLDLL) $(CONFIGPM) $(PERLEXE_OBJ) +$(PERLEXE): $(PERLDLL) $(CONFIGPM) $(PERLEXE_OBJ) $(PERLEXE_RES) .IF "$(CCTYPE)" == "BORLAND" - $(LINK32) -Tpe -ap $(LINK_FLAGS) \ + $(LINK32) -Tpe -ap $(BLINK_FLAGS) \ @$(mktmp c0x32$(o) $(PERLEXE_OBJ:s,\,\\)\n \ $(@:s,\,\\),\n \ $(PERLIMPLIB) $(LIBFILES)\n) .ELIF "$(CCTYPE)" == "GCC" - $(LINK32) -o $@ $(LINK_FLAGS) \ + $(LINK32) -mconsole -o $@ $(BLINK_FLAGS) \ $(PERLEXE_OBJ) $(PERLIMPLIB) $(LIBFILES) .ELSE - $(LINK32) -subsystem:console -out:$@ $(LINK_FLAGS) $(LIBFILES) \ - $(PERLEXE_OBJ) $(SETARGV_OBJ) $(PERLIMPLIB) + $(LINK32) -subsystem:console -out:$@ $(BLINK_FLAGS) $(LIBFILES) \ + $(PERLEXE_OBJ) $(SETARGV_OBJ) $(PERLIMPLIB) $(PERLEXE_RES) + copy $(PERLEXE) $(WPERLEXE) + editbin /subsystem:windows $(WPERLEXE) .ENDIF copy splittree.pl .. $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR) .IF "$(CCTYPE)" != "BORLAND" .IF "$(CCTYPE)" != "GCC" -.IF "$(USE_PERLCRT)" == "" +.IF "$(USE_PERLCRT)" != "define" perl95.c : runperl.c copy runperl.c perl95.c @@ -986,7 +1125,7 @@ DynaLoadmt$(o) : $(DYNALOADER).c $(OBJOUT_FLAG)DynaLoadmt$(o) $(DYNALOADER).c $(PERL95EXE): $(PERLDLL) $(CONFIGPM) $(PERL95_OBJ) - $(LINK32) -subsystem:console -nodefaultlib -out:$@ $(LINK_FLAGS) \ + $(LINK32) -subsystem:console -nodefaultlib -out:$@ $(BLINK_FLAGS) \ $(LIBBASEFILES) $(PERL95_OBJ) $(SETARGV_OBJ) $(PERLIMPLIB) \ libcmt.lib @@ -997,7 +1136,9 @@ $(PERL95EXE): $(PERLDLL) $(CONFIGPM) $(PERL95_OBJ) $(DYNALOADER).c: $(MINIPERL) $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM) if not exist $(AUTODIR) mkdir $(AUTODIR) cd $(EXTDIR)\$(*B) && ..\$(MINIPERL) -I..\..\lib $(*B)_pm.PL + cd $(EXTDIR)\$(*B) && ..\$(MINIPERL) -I..\..\lib XSLoader_pm.PL $(XCOPY) $(EXTDIR)\$(*B)\$(*B).pm $(LIBDIR)\$(NULL) + $(XCOPY) $(EXTDIR)\$(*B)\XSLoader.pm $(LIBDIR)\$(NULL) cd $(EXTDIR)\$(*B) && $(XSUBPP) dl_win32.xs > $(*B).c $(XCOPY) $(EXTDIR)\$(*B)\dlutils.c . @@ -1103,6 +1244,7 @@ distclean: clean -del /f $(EXTENSION_C) $(DYNALOADER).c $(ERRNO).pm -del /f $(EXTDIR)\DynaLoader\dl_win32.xs -del /f $(LIBDIR)\.exists $(LIBDIR)\attrs.pm $(LIBDIR)\DynaLoader.pm + -del /f $(LIBDIR)\XSLoader.pm -del /f $(LIBDIR)\Fcntl.pm $(LIBDIR)\IO.pm $(LIBDIR)\Opcode.pm -del /f $(LIBDIR)\ops.pm $(LIBDIR)\Safe.pm $(LIBDIR)\Thread.pm -del /f $(LIBDIR)\SDBM_File.pm $(LIBDIR)\Socket.pm $(LIBDIR)\POSIX.pm @@ -1117,7 +1259,7 @@ distclean: clean -del /f $(PODDIR)\*.html -del /f $(PODDIR)\*.bat -cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph h2xs perldoc \ - dprofpp pstruct *.bat + dprofpp *.bat -cd ..\x2p && del /f find2perl s2p *.bat -del /f ..\config.sh ..\splittree.pl perlmain.c dlutils.c config.h.new -del /f $(CONFIGPM) @@ -1132,11 +1274,12 @@ distclean: clean install : all installbare installhtml -installbare : utils +installbare : $(RIGHTMAKE) utils $(PERLEXE) ..\installperl .IF "$(PERL95EXE)" != "" $(XCOPY) $(PERL95EXE) $(INST_BIN)\*.* .ENDIF + if exist $(WPERLEXE) $(XCOPY) $(WPERLEXE) $(INST_BIN)\*.* $(XCOPY) $(GLOBEXE) $(INST_BIN)\*.* $(XCOPY) bin\*.bat $(INST_SCRIPT)\*.* @@ -1169,7 +1312,7 @@ test-prep : all utils $(XCOPY) $(GLOBEXE) ..\t\$(NULL) .ENDIF -test : test-prep +test : $(RIGHTMAKE) test-prep cd ..\t && $(PERLEXE) -I..\lib harness test-notty : test-prep @@ -1185,6 +1328,7 @@ clean : -@erase /f config.h -@erase $(GLOBEXE) -@erase $(PERLEXE) + -@erase $(WPERLEXE) -@erase $(PERLDLL) -@erase $(CORE_OBJ) -rmdir /s /q $(MINIDIR) || rmdir /s $(MINIDIR) diff --git a/win32/perlhost.h b/win32/perlhost.h new file mode 100644 index 0000000000..93cb4580b0 --- /dev/null +++ b/win32/perlhost.h @@ -0,0 +1,2307 @@ +/* perlhost.h + * + * (c) 1999 Microsoft Corporation. All rights reserved. + * Portions (c) 1999 ActiveState Tool Corp, http://www.ActiveState.com/ + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + */ + +#ifndef ___PerlHost_H___ +#define ___PerlHost_H___ + +#include "iperlsys.h" +#include "vmem.h" +#include "vdir.h" + +#if !defined(PERL_OBJECT) +START_EXTERN_C +#endif +extern char * g_win32_get_privlib(char *pl); +extern char * g_win32_get_sitelib(char *pl); +extern char * g_getlogin(void); +extern int do_spawn2(char *cmd, int exectype); +#if !defined(PERL_OBJECT) +END_EXTERN_C +#endif + +#ifdef PERL_OBJECT +extern int g_do_aspawn(void *vreally, void **vmark, void **vsp); +#define do_aspawn g_do_aspawn +#endif + +class CPerlHost +{ +public: + CPerlHost(void); + CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, + struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, + struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, + struct IPerlDir** ppDir, struct IPerlSock** ppSock, + struct IPerlProc** ppProc); + CPerlHost(CPerlHost& host); + ~CPerlHost(void); + + static CPerlHost* IPerlMem2Host(struct IPerlMem* piPerl); + static CPerlHost* IPerlMemShared2Host(struct IPerlMem* piPerl); + static CPerlHost* IPerlMemParse2Host(struct IPerlMem* piPerl); + static CPerlHost* IPerlEnv2Host(struct IPerlEnv* piPerl); + static CPerlHost* IPerlStdIO2Host(struct IPerlStdIO* piPerl); + static CPerlHost* IPerlLIO2Host(struct IPerlLIO* piPerl); + static CPerlHost* IPerlDir2Host(struct IPerlDir* piPerl); + static CPerlHost* IPerlSock2Host(struct IPerlSock* piPerl); + static CPerlHost* IPerlProc2Host(struct IPerlProc* piPerl); + + BOOL PerlCreate(void); + int PerlParse(int argc, char** argv, char** env); + int PerlRun(void); + void PerlDestroy(void); + +/* IPerlMem */ + inline void* Malloc(size_t size) { return m_pVMem->Malloc(size); }; + inline void* Realloc(void* ptr, size_t size) { return m_pVMem->Realloc(ptr, size); }; + inline void Free(void* ptr) { m_pVMem->Free(ptr); }; + inline void* Calloc(size_t num, size_t size) + { + size_t count = num*size; + void* lpVoid = Malloc(count); + if (lpVoid) + ZeroMemory(lpVoid, count); + return lpVoid; + }; + inline void GetLock(void) { m_pVMem->GetLock(); }; + inline void FreeLock(void) { m_pVMem->FreeLock(); }; + inline int IsLocked(void) { return m_pVMem->IsLocked(); }; + +/* IPerlMemShared */ + inline void* MallocShared(size_t size) + { + return m_pVMemShared->Malloc(size); + }; + inline void* ReallocShared(void* ptr, size_t size) { return m_pVMemShared->Realloc(ptr, size); }; + inline void FreeShared(void* ptr) { m_pVMemShared->Free(ptr); }; + inline void* CallocShared(size_t num, size_t size) + { + size_t count = num*size; + void* lpVoid = MallocShared(count); + if (lpVoid) + ZeroMemory(lpVoid, count); + return lpVoid; + }; + inline void GetLockShared(void) { m_pVMem->GetLock(); }; + inline void FreeLockShared(void) { m_pVMem->FreeLock(); }; + inline int IsLockedShared(void) { return m_pVMem->IsLocked(); }; + +/* IPerlMemParse */ + inline void* MallocParse(size_t size) { return m_pVMemParse->Malloc(size); }; + inline void* ReallocParse(void* ptr, size_t size) { return m_pVMemParse->Realloc(ptr, size); }; + inline void FreeParse(void* ptr) { m_pVMemParse->Free(ptr); }; + inline void* CallocParse(size_t num, size_t size) + { + size_t count = num*size; + void* lpVoid = MallocParse(count); + if (lpVoid) + ZeroMemory(lpVoid, count); + return lpVoid; + }; + inline void GetLockParse(void) { m_pVMem->GetLock(); }; + inline void FreeLockParse(void) { m_pVMem->FreeLock(); }; + inline int IsLockedParse(void) { return m_pVMem->IsLocked(); }; + +/* IPerlEnv */ + char *Getenv(const char *varname); + int Putenv(const char *envstring); + inline char *Getenv(const char *varname, unsigned long *len) + { + *len = 0; + char *e = Getenv(varname); + if (e) + *len = strlen(e); + return e; + } + void* CreateChildEnv(void) { return CreateLocalEnvironmentStrings(*m_pvDir); }; + void FreeChildEnv(void* pStr) { FreeLocalEnvironmentStrings((char*)pStr); }; + char* GetChildDir(void); + void FreeChildDir(char* pStr); + void Reset(void); + void Clearenv(void); + + inline LPSTR GetIndex(DWORD &dwIndex) + { + if(dwIndex < m_dwEnvCount) + { + ++dwIndex; + return m_lppEnvList[dwIndex-1]; + } + return NULL; + }; + +protected: + LPSTR Find(LPCSTR lpStr); + void Add(LPCSTR lpStr); + + LPSTR CreateLocalEnvironmentStrings(VDir &vDir); + void FreeLocalEnvironmentStrings(LPSTR lpStr); + LPSTR* Lookup(LPCSTR lpStr); + DWORD CalculateEnvironmentSpace(void); + +public: + +/* IPerlDIR */ + virtual int Chdir(const char *dirname); + +/* IPerllProc */ + void Abort(void); + void Exit(int status); + void _Exit(int status); + int Execl(const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3); + int Execv(const char *cmdname, const char *const *argv); + int Execvp(const char *cmdname, const char *const *argv); + + inline VMem* GetMemShared(void) { m_pVMemShared->AddRef(); return m_pVMemShared; }; + inline VMem* GetMemParse(void) { m_pVMemParse->AddRef(); return m_pVMemParse; }; + inline VDir* GetDir(void) { return m_pvDir; }; + +public: + + struct IPerlMem m_hostperlMem; + struct IPerlMem m_hostperlMemShared; + struct IPerlMem m_hostperlMemParse; + struct IPerlEnv m_hostperlEnv; + struct IPerlStdIO m_hostperlStdIO; + struct IPerlLIO m_hostperlLIO; + struct IPerlDir m_hostperlDir; + struct IPerlSock m_hostperlSock; + struct IPerlProc m_hostperlProc; + + struct IPerlMem* m_pHostperlMem; + struct IPerlMem* m_pHostperlMemShared; + struct IPerlMem* m_pHostperlMemParse; + struct IPerlEnv* m_pHostperlEnv; + struct IPerlStdIO* m_pHostperlStdIO; + struct IPerlLIO* m_pHostperlLIO; + struct IPerlDir* m_pHostperlDir; + struct IPerlSock* m_pHostperlSock; + struct IPerlProc* m_pHostperlProc; + + inline char* MapPathA(const char *pInName) { return m_pvDir->MapPathA(pInName); }; + inline WCHAR* MapPathW(const WCHAR *pInName) { return m_pvDir->MapPathW(pInName); }; +protected: + + VDir* m_pvDir; + VMem* m_pVMem; + VMem* m_pVMemShared; + VMem* m_pVMemParse; + + DWORD m_dwEnvCount; + LPSTR* m_lppEnvList; +}; + + +#define STRUCT2PTR(x, y) (CPerlHost*)(((LPBYTE)x)-offsetof(CPerlHost, y)) + +inline CPerlHost* IPerlMem2Host(struct IPerlMem* piPerl) +{ + return STRUCT2PTR(piPerl, m_hostperlMem); +} + +inline CPerlHost* IPerlMemShared2Host(struct IPerlMem* piPerl) +{ + return STRUCT2PTR(piPerl, m_hostperlMemShared); +} + +inline CPerlHost* IPerlMemParse2Host(struct IPerlMem* piPerl) +{ + return STRUCT2PTR(piPerl, m_hostperlMemParse); +} + +inline CPerlHost* IPerlEnv2Host(struct IPerlEnv* piPerl) +{ + return STRUCT2PTR(piPerl, m_hostperlEnv); +} + +inline CPerlHost* IPerlStdIO2Host(struct IPerlStdIO* piPerl) +{ + return STRUCT2PTR(piPerl, m_hostperlStdIO); +} + +inline CPerlHost* IPerlLIO2Host(struct IPerlLIO* piPerl) +{ + return STRUCT2PTR(piPerl, m_hostperlLIO); +} + +inline CPerlHost* IPerlDir2Host(struct IPerlDir* piPerl) +{ + return STRUCT2PTR(piPerl, m_hostperlDir); +} + +inline CPerlHost* IPerlSock2Host(struct IPerlSock* piPerl) +{ + return STRUCT2PTR(piPerl, m_hostperlSock); +} + +inline CPerlHost* IPerlProc2Host(struct IPerlProc* piPerl) +{ + return STRUCT2PTR(piPerl, m_hostperlProc); +} + + + +#undef IPERL2HOST +#define IPERL2HOST(x) IPerlMem2Host(x) + +/* IPerlMem */ +void* +PerlMemMalloc(struct IPerlMem* piPerl, size_t size) +{ + return IPERL2HOST(piPerl)->Malloc(size); +} +void* +PerlMemRealloc(struct IPerlMem* piPerl, void* ptr, size_t size) +{ + return IPERL2HOST(piPerl)->Realloc(ptr, size); +} +void +PerlMemFree(struct IPerlMem* piPerl, void* ptr) +{ + IPERL2HOST(piPerl)->Free(ptr); +} +void* +PerlMemCalloc(struct IPerlMem* piPerl, size_t num, size_t size) +{ + return IPERL2HOST(piPerl)->Calloc(num, size); +} + +void +PerlMemGetLock(struct IPerlMem* piPerl) +{ + IPERL2HOST(piPerl)->GetLock(); +} + +void +PerlMemFreeLock(struct IPerlMem* piPerl) +{ + IPERL2HOST(piPerl)->FreeLock(); +} + +int +PerlMemIsLocked(struct IPerlMem* piPerl) +{ + return IPERL2HOST(piPerl)->IsLocked(); +} + +struct IPerlMem perlMem = +{ + PerlMemMalloc, + PerlMemRealloc, + PerlMemFree, + PerlMemCalloc, + PerlMemGetLock, + PerlMemFreeLock, + PerlMemIsLocked, +}; + +#undef IPERL2HOST +#define IPERL2HOST(x) IPerlMemShared2Host(x) + +/* IPerlMemShared */ +void* +PerlMemSharedMalloc(struct IPerlMem* piPerl, size_t size) +{ + return IPERL2HOST(piPerl)->MallocShared(size); +} +void* +PerlMemSharedRealloc(struct IPerlMem* piPerl, void* ptr, size_t size) +{ + return IPERL2HOST(piPerl)->ReallocShared(ptr, size); +} +void +PerlMemSharedFree(struct IPerlMem* piPerl, void* ptr) +{ + IPERL2HOST(piPerl)->FreeShared(ptr); +} +void* +PerlMemSharedCalloc(struct IPerlMem* piPerl, size_t num, size_t size) +{ + return IPERL2HOST(piPerl)->CallocShared(num, size); +} + +void +PerlMemSharedGetLock(struct IPerlMem* piPerl) +{ + IPERL2HOST(piPerl)->GetLockShared(); +} + +void +PerlMemSharedFreeLock(struct IPerlMem* piPerl) +{ + IPERL2HOST(piPerl)->FreeLockShared(); +} + +int +PerlMemSharedIsLocked(struct IPerlMem* piPerl) +{ + return IPERL2HOST(piPerl)->IsLockedShared(); +} + +struct IPerlMem perlMemShared = +{ + PerlMemSharedMalloc, + PerlMemSharedRealloc, + PerlMemSharedFree, + PerlMemSharedCalloc, + PerlMemSharedGetLock, + PerlMemSharedFreeLock, + PerlMemSharedIsLocked, +}; + +#undef IPERL2HOST +#define IPERL2HOST(x) IPerlMemParse2Host(x) + +/* IPerlMemParse */ +void* +PerlMemParseMalloc(struct IPerlMem* piPerl, size_t size) +{ + return IPERL2HOST(piPerl)->MallocParse(size); +} +void* +PerlMemParseRealloc(struct IPerlMem* piPerl, void* ptr, size_t size) +{ + return IPERL2HOST(piPerl)->ReallocParse(ptr, size); +} +void +PerlMemParseFree(struct IPerlMem* piPerl, void* ptr) +{ + IPERL2HOST(piPerl)->FreeParse(ptr); +} +void* +PerlMemParseCalloc(struct IPerlMem* piPerl, size_t num, size_t size) +{ + return IPERL2HOST(piPerl)->CallocParse(num, size); +} + +void +PerlMemParseGetLock(struct IPerlMem* piPerl) +{ + IPERL2HOST(piPerl)->GetLockParse(); +} + +void +PerlMemParseFreeLock(struct IPerlMem* piPerl) +{ + IPERL2HOST(piPerl)->FreeLockParse(); +} + +int +PerlMemParseIsLocked(struct IPerlMem* piPerl) +{ + return IPERL2HOST(piPerl)->IsLockedParse(); +} + +struct IPerlMem perlMemParse = +{ + PerlMemParseMalloc, + PerlMemParseRealloc, + PerlMemParseFree, + PerlMemParseCalloc, + PerlMemParseGetLock, + PerlMemParseFreeLock, + PerlMemParseIsLocked, +}; + + +#undef IPERL2HOST +#define IPERL2HOST(x) IPerlEnv2Host(x) + +/* IPerlEnv */ +char* +PerlEnvGetenv(struct IPerlEnv* piPerl, const char *varname) +{ + return IPERL2HOST(piPerl)->Getenv(varname); +}; + +int +PerlEnvPutenv(struct IPerlEnv* piPerl, const char *envstring) +{ + return IPERL2HOST(piPerl)->Putenv(envstring); +}; + +char* +PerlEnvGetenv_len(struct IPerlEnv* piPerl, const char* varname, unsigned long* len) +{ + return IPERL2HOST(piPerl)->Getenv(varname, len); +} + +int +PerlEnvUname(struct IPerlEnv* piPerl, struct utsname *name) +{ + return win32_uname(name); +} + +void +PerlEnvClearenv(struct IPerlEnv* piPerl) +{ + IPERL2HOST(piPerl)->Clearenv(); +} + +void* +PerlEnvGetChildenv(struct IPerlEnv* piPerl) +{ + return IPERL2HOST(piPerl)->CreateChildEnv(); +} + +void +PerlEnvFreeChildenv(struct IPerlEnv* piPerl, void* childEnv) +{ + IPERL2HOST(piPerl)->FreeChildEnv(childEnv); +} + +char* +PerlEnvGetChilddir(struct IPerlEnv* piPerl) +{ + return IPERL2HOST(piPerl)->GetChildDir(); +} + +void +PerlEnvFreeChilddir(struct IPerlEnv* piPerl, char* childDir) +{ + IPERL2HOST(piPerl)->FreeChildDir(childDir); +} + +unsigned long +PerlEnvOsId(struct IPerlEnv* piPerl) +{ + return win32_os_id(); +} + +char* +PerlEnvLibPath(struct IPerlEnv* piPerl, char *pl) +{ + return g_win32_get_privlib(pl); +} + +char* +PerlEnvSiteLibPath(struct IPerlEnv* piPerl, char *pl) +{ + return g_win32_get_sitelib(pl); +} + +struct IPerlEnv perlEnv = +{ + PerlEnvGetenv, + PerlEnvPutenv, + PerlEnvGetenv_len, + PerlEnvUname, + PerlEnvClearenv, + PerlEnvGetChildenv, + PerlEnvFreeChildenv, + PerlEnvGetChilddir, + PerlEnvFreeChilddir, + PerlEnvOsId, + PerlEnvLibPath, + PerlEnvSiteLibPath, +}; + +#undef IPERL2HOST +#define IPERL2HOST(x) IPerlStdIO2Host(x) + +/* PerlStdIO */ +PerlIO* +PerlStdIOStdin(struct IPerlStdIO* piPerl) +{ + return (PerlIO*)win32_stdin(); +} + +PerlIO* +PerlStdIOStdout(struct IPerlStdIO* piPerl) +{ + return (PerlIO*)win32_stdout(); +} + +PerlIO* +PerlStdIOStderr(struct IPerlStdIO* piPerl) +{ + return (PerlIO*)win32_stderr(); +} + +PerlIO* +PerlStdIOOpen(struct IPerlStdIO* piPerl, const char *path, const char *mode) +{ + return (PerlIO*)win32_fopen(path, mode); +} + +int +PerlStdIOClose(struct IPerlStdIO* piPerl, PerlIO* pf) +{ + return win32_fclose(((FILE*)pf)); +} + +int +PerlStdIOEof(struct IPerlStdIO* piPerl, PerlIO* pf) +{ + return win32_feof((FILE*)pf); +} + +int +PerlStdIOError(struct IPerlStdIO* piPerl, PerlIO* pf) +{ + return win32_ferror((FILE*)pf); +} + +void +PerlStdIOClearerr(struct IPerlStdIO* piPerl, PerlIO* pf) +{ + win32_clearerr((FILE*)pf); +} + +int +PerlStdIOGetc(struct IPerlStdIO* piPerl, PerlIO* pf) +{ + return win32_getc((FILE*)pf); +} + +char* +PerlStdIOGetBase(struct IPerlStdIO* piPerl, PerlIO* pf) +{ +#ifdef FILE_base + FILE *f = (FILE*)pf; + return FILE_base(f); +#else + return Nullch; +#endif +} + +int +PerlStdIOGetBufsiz(struct IPerlStdIO* piPerl, PerlIO* pf) +{ +#ifdef FILE_bufsiz + FILE *f = (FILE*)pf; + return FILE_bufsiz(f); +#else + return (-1); +#endif +} + +int +PerlStdIOGetCnt(struct IPerlStdIO* piPerl, PerlIO* pf) +{ +#ifdef USE_STDIO_PTR + FILE *f = (FILE*)pf; + return FILE_cnt(f); +#else + return (-1); +#endif +} + +char* +PerlStdIOGetPtr(struct IPerlStdIO* piPerl, PerlIO* pf) +{ +#ifdef USE_STDIO_PTR + FILE *f = (FILE*)pf; + return FILE_ptr(f); +#else + return Nullch; +#endif +} + +char* +PerlStdIOGets(struct IPerlStdIO* piPerl, PerlIO* pf, char* s, int n) +{ + return win32_fgets(s, n, (FILE*)pf); +} + +int +PerlStdIOPutc(struct IPerlStdIO* piPerl, PerlIO* pf, int c) +{ + return win32_fputc(c, (FILE*)pf); +} + +int +PerlStdIOPuts(struct IPerlStdIO* piPerl, PerlIO* pf, const char *s) +{ + return win32_fputs(s, (FILE*)pf); +} + +int +PerlStdIOFlush(struct IPerlStdIO* piPerl, PerlIO* pf) +{ + return win32_fflush((FILE*)pf); +} + +int +PerlStdIOUngetc(struct IPerlStdIO* piPerl, PerlIO* pf,int c) +{ + return win32_ungetc(c, (FILE*)pf); +} + +int +PerlStdIOFileno(struct IPerlStdIO* piPerl, PerlIO* pf) +{ + return win32_fileno((FILE*)pf); +} + +PerlIO* +PerlStdIOFdopen(struct IPerlStdIO* piPerl, int fd, const char *mode) +{ + return (PerlIO*)win32_fdopen(fd, mode); +} + +PerlIO* +PerlStdIOReopen(struct IPerlStdIO* piPerl, const char*path, const char*mode, PerlIO* pf) +{ + return (PerlIO*)win32_freopen(path, mode, (FILE*)pf); +} + +SSize_t +PerlStdIORead(struct IPerlStdIO* piPerl, PerlIO* pf, void *buffer, Size_t size) +{ + return win32_fread(buffer, 1, size, (FILE*)pf); +} + +SSize_t +PerlStdIOWrite(struct IPerlStdIO* piPerl, PerlIO* pf, const void *buffer, Size_t size) +{ + return win32_fwrite(buffer, 1, size, (FILE*)pf); +} + +void +PerlStdIOSetBuf(struct IPerlStdIO* piPerl, PerlIO* pf, char* buffer) +{ + win32_setbuf((FILE*)pf, buffer); +} + +int +PerlStdIOSetVBuf(struct IPerlStdIO* piPerl, PerlIO* pf, char* buffer, int type, Size_t size) +{ + return win32_setvbuf((FILE*)pf, buffer, type, size); +} + +void +PerlStdIOSetCnt(struct IPerlStdIO* piPerl, PerlIO* pf, int n) +{ +#ifdef STDIO_CNT_LVALUE + FILE *f = (FILE*)pf; + FILE_cnt(f) = n; +#endif +} + +void +PerlStdIOSetPtrCnt(struct IPerlStdIO* piPerl, PerlIO* pf, char * ptr, int n) +{ +#ifdef STDIO_PTR_LVALUE + FILE *f = (FILE*)pf; + FILE_ptr(f) = ptr; + FILE_cnt(f) = n; +#endif +} + +void +PerlStdIOSetlinebuf(struct IPerlStdIO* piPerl, PerlIO* pf) +{ + win32_setvbuf((FILE*)pf, NULL, _IOLBF, 0); +} + +int +PerlStdIOPrintf(struct IPerlStdIO* piPerl, PerlIO* pf, const char *format,...) +{ + va_list(arglist); + va_start(arglist, format); + return win32_vfprintf((FILE*)pf, format, arglist); +} + +int +PerlStdIOVprintf(struct IPerlStdIO* piPerl, PerlIO* pf, const char *format, va_list arglist) +{ + return win32_vfprintf((FILE*)pf, format, arglist); +} + +long +PerlStdIOTell(struct IPerlStdIO* piPerl, PerlIO* pf) +{ + return win32_ftell((FILE*)pf); +} + +int +PerlStdIOSeek(struct IPerlStdIO* piPerl, PerlIO* pf, off_t offset, int origin) +{ + return win32_fseek((FILE*)pf, offset, origin); +} + +void +PerlStdIORewind(struct IPerlStdIO* piPerl, PerlIO* pf) +{ + win32_rewind((FILE*)pf); +} + +PerlIO* +PerlStdIOTmpfile(struct IPerlStdIO* piPerl) +{ + return (PerlIO*)win32_tmpfile(); +} + +int +PerlStdIOGetpos(struct IPerlStdIO* piPerl, PerlIO* pf, Fpos_t *p) +{ + return win32_fgetpos((FILE*)pf, p); +} + +int +PerlStdIOSetpos(struct IPerlStdIO* piPerl, PerlIO* pf, const Fpos_t *p) +{ + return win32_fsetpos((FILE*)pf, p); +} +void +PerlStdIOInit(struct IPerlStdIO* piPerl) +{ +} + +void +PerlStdIOInitOSExtras(struct IPerlStdIO* piPerl) +{ + Perl_init_os_extras(); +} + +int +PerlStdIOOpenOSfhandle(struct IPerlStdIO* piPerl, long osfhandle, int flags) +{ + return win32_open_osfhandle(osfhandle, flags); +} + +int +PerlStdIOGetOSfhandle(struct IPerlStdIO* piPerl, int filenum) +{ + return win32_get_osfhandle(filenum); +} + +PerlIO* +PerlStdIOFdupopen(struct IPerlStdIO* piPerl, PerlIO* pf) +{ + PerlIO* pfdup; + fpos_t pos; + char mode[3]; + int fileno = win32_dup(win32_fileno((FILE*)pf)); + + /* open the file in the same mode */ +#ifdef __BORLANDC__ + if(((FILE*)pf)->flags & _F_READ) { + mode[0] = 'r'; + mode[1] = 0; + } + else if(((FILE*)pf)->flags & _F_WRIT) { + mode[0] = 'a'; + mode[1] = 0; + } + else if(((FILE*)pf)->flags & _F_RDWR) { + mode[0] = 'r'; + mode[1] = '+'; + mode[2] = 0; + } +#else + if(((FILE*)pf)->_flag & _IOREAD) { + mode[0] = 'r'; + mode[1] = 0; + } + else if(((FILE*)pf)->_flag & _IOWRT) { + mode[0] = 'a'; + mode[1] = 0; + } + else if(((FILE*)pf)->_flag & _IORW) { + mode[0] = 'r'; + mode[1] = '+'; + mode[2] = 0; + } +#endif + + /* it appears that the binmode is attached to the + * file descriptor so binmode files will be handled + * correctly + */ + pfdup = (PerlIO*)win32_fdopen(fileno, mode); + + /* move the file pointer to the same position */ + if (!fgetpos((FILE*)pf, &pos)) { + fsetpos((FILE*)pfdup, &pos); + } + return pfdup; +} + +struct IPerlStdIO perlStdIO = +{ + PerlStdIOStdin, + PerlStdIOStdout, + PerlStdIOStderr, + PerlStdIOOpen, + PerlStdIOClose, + PerlStdIOEof, + PerlStdIOError, + PerlStdIOClearerr, + PerlStdIOGetc, + PerlStdIOGetBase, + PerlStdIOGetBufsiz, + PerlStdIOGetCnt, + PerlStdIOGetPtr, + PerlStdIOGets, + PerlStdIOPutc, + PerlStdIOPuts, + PerlStdIOFlush, + PerlStdIOUngetc, + PerlStdIOFileno, + PerlStdIOFdopen, + PerlStdIOReopen, + PerlStdIORead, + PerlStdIOWrite, + PerlStdIOSetBuf, + PerlStdIOSetVBuf, + PerlStdIOSetCnt, + PerlStdIOSetPtrCnt, + PerlStdIOSetlinebuf, + PerlStdIOPrintf, + PerlStdIOVprintf, + PerlStdIOTell, + PerlStdIOSeek, + PerlStdIORewind, + PerlStdIOTmpfile, + PerlStdIOGetpos, + PerlStdIOSetpos, + PerlStdIOInit, + PerlStdIOInitOSExtras, + PerlStdIOFdupopen, +}; + + +#undef IPERL2HOST +#define IPERL2HOST(x) IPerlLIO2Host(x) + +/* IPerlLIO */ +int +PerlLIOAccess(struct IPerlLIO* piPerl, const char *path, int mode) +{ + return win32_access(path, mode); +} + +int +PerlLIOChmod(struct IPerlLIO* piPerl, const char *filename, int pmode) +{ + return win32_chmod(filename, pmode); +} + +int +PerlLIOChown(struct IPerlLIO* piPerl, const char *filename, uid_t owner, gid_t group) +{ + return chown(filename, owner, group); +} + +int +PerlLIOChsize(struct IPerlLIO* piPerl, int handle, long size) +{ + return chsize(handle, size); +} + +int +PerlLIOClose(struct IPerlLIO* piPerl, int handle) +{ + return win32_close(handle); +} + +int +PerlLIODup(struct IPerlLIO* piPerl, int handle) +{ + return win32_dup(handle); +} + +int +PerlLIODup2(struct IPerlLIO* piPerl, int handle1, int handle2) +{ + return win32_dup2(handle1, handle2); +} + +int +PerlLIOFlock(struct IPerlLIO* piPerl, int fd, int oper) +{ + return win32_flock(fd, oper); +} + +int +PerlLIOFileStat(struct IPerlLIO* piPerl, int handle, struct stat *buffer) +{ + return fstat(handle, buffer); +} + +int +PerlLIOIOCtl(struct IPerlLIO* piPerl, int i, unsigned int u, char *data) +{ + return win32_ioctlsocket((SOCKET)i, (long)u, (u_long*)data); +} + +int +PerlLIOIsatty(struct IPerlLIO* piPerl, int fd) +{ + return isatty(fd); +} + +int +PerlLIOLink(struct IPerlLIO* piPerl, const char*oldname, const char *newname) +{ + return win32_link(oldname, newname); +} + +long +PerlLIOLseek(struct IPerlLIO* piPerl, int handle, long offset, int origin) +{ + return win32_lseek(handle, offset, origin); +} + +int +PerlLIOLstat(struct IPerlLIO* piPerl, const char *path, struct stat *buffer) +{ + return win32_stat(path, buffer); +} + +char* +PerlLIOMktemp(struct IPerlLIO* piPerl, char *Template) +{ + return mktemp(Template); +} + +int +PerlLIOOpen(struct IPerlLIO* piPerl, const char *filename, int oflag) +{ + return win32_open(filename, oflag); +} + +int +PerlLIOOpen3(struct IPerlLIO* piPerl, const char *filename, int oflag, int pmode) +{ + return win32_open(filename, oflag, pmode); +} + +int +PerlLIORead(struct IPerlLIO* piPerl, int handle, void *buffer, unsigned int count) +{ + return win32_read(handle, buffer, count); +} + +int +PerlLIORename(struct IPerlLIO* piPerl, const char *OldFileName, const char *newname) +{ + return win32_rename(OldFileName, newname); +} + +int +PerlLIOSetmode(struct IPerlLIO* piPerl, int handle, int mode) +{ + return win32_setmode(handle, mode); +} + +int +PerlLIONameStat(struct IPerlLIO* piPerl, const char *path, struct stat *buffer) +{ + return win32_stat(path, buffer); +} + +char* +PerlLIOTmpnam(struct IPerlLIO* piPerl, char *string) +{ + return tmpnam(string); +} + +int +PerlLIOUmask(struct IPerlLIO* piPerl, int pmode) +{ + return umask(pmode); +} + +int +PerlLIOUnlink(struct IPerlLIO* piPerl, const char *filename) +{ + return win32_unlink(filename); +} + +int +PerlLIOUtime(struct IPerlLIO* piPerl, char *filename, struct utimbuf *times) +{ + return win32_utime(filename, times); +} + +int +PerlLIOWrite(struct IPerlLIO* piPerl, int handle, const void *buffer, unsigned int count) +{ + return win32_write(handle, buffer, count); +} + +struct IPerlLIO perlLIO = +{ + PerlLIOAccess, + PerlLIOChmod, + PerlLIOChown, + PerlLIOChsize, + PerlLIOClose, + PerlLIODup, + PerlLIODup2, + PerlLIOFlock, + PerlLIOFileStat, + PerlLIOIOCtl, + PerlLIOIsatty, + PerlLIOLink, + PerlLIOLseek, + PerlLIOLstat, + PerlLIOMktemp, + PerlLIOOpen, + PerlLIOOpen3, + PerlLIORead, + PerlLIORename, + PerlLIOSetmode, + PerlLIONameStat, + PerlLIOTmpnam, + PerlLIOUmask, + PerlLIOUnlink, + PerlLIOUtime, + PerlLIOWrite, +}; + + +#undef IPERL2HOST +#define IPERL2HOST(x) IPerlDir2Host(x) + +/* IPerlDIR */ +int +PerlDirMakedir(struct IPerlDir* piPerl, const char *dirname, int mode) +{ + return win32_mkdir(dirname, mode); +} + +int +PerlDirChdir(struct IPerlDir* piPerl, const char *dirname) +{ + return IPERL2HOST(piPerl)->Chdir(dirname); +} + +int +PerlDirRmdir(struct IPerlDir* piPerl, const char *dirname) +{ + return win32_rmdir(dirname); +} + +int +PerlDirClose(struct IPerlDir* piPerl, DIR *dirp) +{ + return win32_closedir(dirp); +} + +DIR* +PerlDirOpen(struct IPerlDir* piPerl, char *filename) +{ + return win32_opendir(filename); +} + +struct direct * +PerlDirRead(struct IPerlDir* piPerl, DIR *dirp) +{ + return win32_readdir(dirp); +} + +void +PerlDirRewind(struct IPerlDir* piPerl, DIR *dirp) +{ + win32_rewinddir(dirp); +} + +void +PerlDirSeek(struct IPerlDir* piPerl, DIR *dirp, long loc) +{ + win32_seekdir(dirp, loc); +} + +long +PerlDirTell(struct IPerlDir* piPerl, DIR *dirp) +{ + return win32_telldir(dirp); +} + +char* +PerlDirMapPathA(struct IPerlDir* piPerl, const char* path) +{ + return IPERL2HOST(piPerl)->MapPathA(path); +} + +WCHAR* +PerlDirMapPathW(struct IPerlDir* piPerl, const WCHAR* path) +{ + return IPERL2HOST(piPerl)->MapPathW(path); +} + +struct IPerlDir perlDir = +{ + PerlDirMakedir, + PerlDirChdir, + PerlDirRmdir, + PerlDirClose, + PerlDirOpen, + PerlDirRead, + PerlDirRewind, + PerlDirSeek, + PerlDirTell, + PerlDirMapPathA, + PerlDirMapPathW, +}; + + +/* IPerlSock */ +u_long +PerlSockHtonl(struct IPerlSock* piPerl, u_long hostlong) +{ + return win32_htonl(hostlong); +} + +u_short +PerlSockHtons(struct IPerlSock* piPerl, u_short hostshort) +{ + return win32_htons(hostshort); +} + +u_long +PerlSockNtohl(struct IPerlSock* piPerl, u_long netlong) +{ + return win32_ntohl(netlong); +} + +u_short +PerlSockNtohs(struct IPerlSock* piPerl, u_short netshort) +{ + return win32_ntohs(netshort); +} + +SOCKET PerlSockAccept(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* addr, int* addrlen) +{ + return win32_accept(s, addr, addrlen); +} + +int +PerlSockBind(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen) +{ + return win32_bind(s, name, namelen); +} + +int +PerlSockConnect(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen) +{ + return win32_connect(s, name, namelen); +} + +void +PerlSockEndhostent(struct IPerlSock* piPerl) +{ + win32_endhostent(); +} + +void +PerlSockEndnetent(struct IPerlSock* piPerl) +{ + win32_endnetent(); +} + +void +PerlSockEndprotoent(struct IPerlSock* piPerl) +{ + win32_endprotoent(); +} + +void +PerlSockEndservent(struct IPerlSock* piPerl) +{ + win32_endservent(); +} + +struct hostent* +PerlSockGethostbyaddr(struct IPerlSock* piPerl, const char* addr, int len, int type) +{ + return win32_gethostbyaddr(addr, len, type); +} + +struct hostent* +PerlSockGethostbyname(struct IPerlSock* piPerl, const char* name) +{ + return win32_gethostbyname(name); +} + +struct hostent* +PerlSockGethostent(struct IPerlSock* piPerl) +{ + dTHXo; + Perl_croak(aTHX_ "gethostent not implemented!\n"); + return NULL; +} + +int +PerlSockGethostname(struct IPerlSock* piPerl, char* name, int namelen) +{ + return win32_gethostname(name, namelen); +} + +struct netent * +PerlSockGetnetbyaddr(struct IPerlSock* piPerl, long net, int type) +{ + return win32_getnetbyaddr(net, type); +} + +struct netent * +PerlSockGetnetbyname(struct IPerlSock* piPerl, const char *name) +{ + return win32_getnetbyname((char*)name); +} + +struct netent * +PerlSockGetnetent(struct IPerlSock* piPerl) +{ + return win32_getnetent(); +} + +int PerlSockGetpeername(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen) +{ + return win32_getpeername(s, name, namelen); +} + +struct protoent* +PerlSockGetprotobyname(struct IPerlSock* piPerl, const char* name) +{ + return win32_getprotobyname(name); +} + +struct protoent* +PerlSockGetprotobynumber(struct IPerlSock* piPerl, int number) +{ + return win32_getprotobynumber(number); +} + +struct protoent* +PerlSockGetprotoent(struct IPerlSock* piPerl) +{ + return win32_getprotoent(); +} + +struct servent* +PerlSockGetservbyname(struct IPerlSock* piPerl, const char* name, const char* proto) +{ + return win32_getservbyname(name, proto); +} + +struct servent* +PerlSockGetservbyport(struct IPerlSock* piPerl, int port, const char* proto) +{ + return win32_getservbyport(port, proto); +} + +struct servent* +PerlSockGetservent(struct IPerlSock* piPerl) +{ + return win32_getservent(); +} + +int +PerlSockGetsockname(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen) +{ + return win32_getsockname(s, name, namelen); +} + +int +PerlSockGetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, char* optval, int* optlen) +{ + return win32_getsockopt(s, level, optname, optval, optlen); +} + +unsigned long +PerlSockInetAddr(struct IPerlSock* piPerl, const char* cp) +{ + return win32_inet_addr(cp); +} + +char* +PerlSockInetNtoa(struct IPerlSock* piPerl, struct in_addr in) +{ + return win32_inet_ntoa(in); +} + +int +PerlSockListen(struct IPerlSock* piPerl, SOCKET s, int backlog) +{ + return win32_listen(s, backlog); +} + +int +PerlSockRecv(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags) +{ + return win32_recv(s, buffer, len, flags); +} + +int +PerlSockRecvfrom(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags, struct sockaddr* from, int* fromlen) +{ + return win32_recvfrom(s, buffer, len, flags, from, fromlen); +} + +int +PerlSockSelect(struct IPerlSock* piPerl, int nfds, char* readfds, char* writefds, char* exceptfds, const struct timeval* timeout) +{ + return win32_select(nfds, (Perl_fd_set*)readfds, (Perl_fd_set*)writefds, (Perl_fd_set*)exceptfds, timeout); +} + +int +PerlSockSend(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags) +{ + return win32_send(s, buffer, len, flags); +} + +int +PerlSockSendto(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags, const struct sockaddr* to, int tolen) +{ + return win32_sendto(s, buffer, len, flags, to, tolen); +} + +void +PerlSockSethostent(struct IPerlSock* piPerl, int stayopen) +{ + win32_sethostent(stayopen); +} + +void +PerlSockSetnetent(struct IPerlSock* piPerl, int stayopen) +{ + win32_setnetent(stayopen); +} + +void +PerlSockSetprotoent(struct IPerlSock* piPerl, int stayopen) +{ + win32_setprotoent(stayopen); +} + +void +PerlSockSetservent(struct IPerlSock* piPerl, int stayopen) +{ + win32_setservent(stayopen); +} + +int +PerlSockSetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, const char* optval, int optlen) +{ + return win32_setsockopt(s, level, optname, optval, optlen); +} + +int +PerlSockShutdown(struct IPerlSock* piPerl, SOCKET s, int how) +{ + return win32_shutdown(s, how); +} + +SOCKET +PerlSockSocket(struct IPerlSock* piPerl, int af, int type, int protocol) +{ + return win32_socket(af, type, protocol); +} + +int +PerlSockSocketpair(struct IPerlSock* piPerl, int domain, int type, int protocol, int* fds) +{ + dTHXo; + Perl_croak(aTHX_ "socketpair not implemented!\n"); + return 0; +} + +int +PerlSockClosesocket(struct IPerlSock* piPerl, SOCKET s) +{ + return win32_closesocket(s); +} + +int +PerlSockIoctlsocket(struct IPerlSock* piPerl, SOCKET s, long cmd, u_long *argp) +{ + return win32_ioctlsocket(s, cmd, argp); +} + +struct IPerlSock perlSock = +{ + PerlSockHtonl, + PerlSockHtons, + PerlSockNtohl, + PerlSockNtohs, + PerlSockAccept, + PerlSockBind, + PerlSockConnect, + PerlSockEndhostent, + PerlSockEndnetent, + PerlSockEndprotoent, + PerlSockEndservent, + PerlSockGethostname, + PerlSockGetpeername, + PerlSockGethostbyaddr, + PerlSockGethostbyname, + PerlSockGethostent, + PerlSockGetnetbyaddr, + PerlSockGetnetbyname, + PerlSockGetnetent, + PerlSockGetprotobyname, + PerlSockGetprotobynumber, + PerlSockGetprotoent, + PerlSockGetservbyname, + PerlSockGetservbyport, + PerlSockGetservent, + PerlSockGetsockname, + PerlSockGetsockopt, + PerlSockInetAddr, + PerlSockInetNtoa, + PerlSockListen, + PerlSockRecv, + PerlSockRecvfrom, + PerlSockSelect, + PerlSockSend, + PerlSockSendto, + PerlSockSethostent, + PerlSockSetnetent, + PerlSockSetprotoent, + PerlSockSetservent, + PerlSockSetsockopt, + PerlSockShutdown, + PerlSockSocket, + PerlSockSocketpair, + PerlSockClosesocket, +}; + + +/* IPerlProc */ + +#define EXECF_EXEC 1 +#define EXECF_SPAWN 2 + +void +PerlProcAbort(struct IPerlProc* piPerl) +{ + win32_abort(); +} + +char * +PerlProcCrypt(struct IPerlProc* piPerl, const char* clear, const char* salt) +{ + return win32_crypt(clear, salt); +} + +void +PerlProcExit(struct IPerlProc* piPerl, int status) +{ + exit(status); +} + +void +PerlProc_Exit(struct IPerlProc* piPerl, int status) +{ + _exit(status); +} + +int +PerlProcExecl(struct IPerlProc* piPerl, const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3) +{ + return execl(cmdname, arg0, arg1, arg2, arg3); +} + +int +PerlProcExecv(struct IPerlProc* piPerl, const char *cmdname, const char *const *argv) +{ + return win32_execvp(cmdname, argv); +} + +int +PerlProcExecvp(struct IPerlProc* piPerl, const char *cmdname, const char *const *argv) +{ + return win32_execvp(cmdname, argv); +} + +uid_t +PerlProcGetuid(struct IPerlProc* piPerl) +{ + return getuid(); +} + +uid_t +PerlProcGeteuid(struct IPerlProc* piPerl) +{ + return geteuid(); +} + +gid_t +PerlProcGetgid(struct IPerlProc* piPerl) +{ + return getgid(); +} + +gid_t +PerlProcGetegid(struct IPerlProc* piPerl) +{ + return getegid(); +} + +char * +PerlProcGetlogin(struct IPerlProc* piPerl) +{ + return g_getlogin(); +} + +int +PerlProcKill(struct IPerlProc* piPerl, int pid, int sig) +{ + return win32_kill(pid, sig); +} + +int +PerlProcKillpg(struct IPerlProc* piPerl, int pid, int sig) +{ + dTHXo; + Perl_croak(aTHX_ "killpg not implemented!\n"); + return 0; +} + +int +PerlProcPauseProc(struct IPerlProc* piPerl) +{ + return win32_sleep((32767L << 16) + 32767); +} + +PerlIO* +PerlProcPopen(struct IPerlProc* piPerl, const char *command, const char *mode) +{ + dTHXo; + PERL_FLUSHALL_FOR_CHILD; + return (PerlIO*)win32_popen(command, mode); +} + +int +PerlProcPclose(struct IPerlProc* piPerl, PerlIO *stream) +{ + return win32_pclose((FILE*)stream); +} + +int +PerlProcPipe(struct IPerlProc* piPerl, int *phandles) +{ + return win32_pipe(phandles, 512, O_BINARY); +} + +int +PerlProcSetuid(struct IPerlProc* piPerl, uid_t u) +{ + return setuid(u); +} + +int +PerlProcSetgid(struct IPerlProc* piPerl, gid_t g) +{ + return setgid(g); +} + +int +PerlProcSleep(struct IPerlProc* piPerl, unsigned int s) +{ + return win32_sleep(s); +} + +int +PerlProcTimes(struct IPerlProc* piPerl, struct tms *timebuf) +{ + return win32_times(timebuf); +} + +int +PerlProcWait(struct IPerlProc* piPerl, int *status) +{ + return win32_wait(status); +} + +int +PerlProcWaitpid(struct IPerlProc* piPerl, int pid, int *status, int flags) +{ + return win32_waitpid(pid, status, flags); +} + +Sighandler_t +PerlProcSignal(struct IPerlProc* piPerl, int sig, Sighandler_t subcode) +{ + return 0; +} + +#ifdef USE_ITHREADS +static DWORD WINAPI +win32_start_child(LPVOID arg) +{ + PerlInterpreter *my_perl = (PerlInterpreter*)arg; + GV *tmpgv; + int status; +#ifdef PERL_OBJECT + CPerlObj *pPerl = (CPerlObj*)my_perl; +#endif +#ifdef PERL_SYNC_FORK + static long sync_fork_id = 0; + long id = ++sync_fork_id; +#endif + + + PERL_SET_INTERP(my_perl); + + /* set $$ to pseudo id */ +#ifdef PERL_SYNC_FORK + w32_pseudo_id = id; +#else + w32_pseudo_id = GetCurrentThreadId(); +#endif + if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV)) + sv_setiv(GvSV(tmpgv), -(IV)w32_pseudo_id); + hv_clear(PL_pidstatus); + + /* push a zero on the stack (we are the child) */ + { + djSP; + dTARGET; + PUSHi(0); + PUTBACK; + } + + /* continue from next op */ + PL_op = PL_op->op_next; + + { + dJMPENV; + volatile int oldscope = PL_scopestack_ix; + +restart: + JMPENV_PUSH(status); + switch (status) { + case 0: + CALLRUNOPS(aTHX); + status = 0; + break; + case 2: + while (PL_scopestack_ix > oldscope) + LEAVE; + FREETMPS; + PL_curstash = PL_defstash; + if (PL_endav && !PL_minus_c) + call_list(oldscope, PL_endav); + status = STATUS_NATIVE_EXPORT; + break; + case 3: + if (PL_restartop) { + POPSTACK_TO(PL_mainstack); + PL_op = PL_restartop; + PL_restartop = Nullop; + goto restart; + } + PerlIO_printf(Perl_error_log, "panic: restartop\n"); + FREETMPS; + status = 1; + break; + } + JMPENV_POP; + + /* XXX hack to avoid perl_destruct() freeing optree */ + PL_main_root = Nullop; + } + + /* destroy everything (waits for any pseudo-forked children) */ + perl_destruct(my_perl); + perl_free(my_perl); + +#ifdef PERL_SYNC_FORK + return id; +#else + return (DWORD)status; +#endif +} +#endif /* USE_ITHREADS */ + +int +PerlProcFork(struct IPerlProc* piPerl) +{ + dTHXo; +#ifdef USE_ITHREADS + DWORD id; + HANDLE handle; + CPerlHost *h = new CPerlHost(*(CPerlHost*)w32_internal_host); + PerlInterpreter *new_perl = perl_clone_using((PerlInterpreter*)aTHXo, 1, + h->m_pHostperlMem, + h->m_pHostperlMemShared, + h->m_pHostperlMemParse, + h->m_pHostperlEnv, + h->m_pHostperlStdIO, + h->m_pHostperlLIO, + h->m_pHostperlDir, + h->m_pHostperlSock, + h->m_pHostperlProc + ); + new_perl->Isys_intern.internal_host = h; +# ifdef PERL_SYNC_FORK + id = win32_start_child((LPVOID)new_perl); + PERL_SET_INTERP(aTHXo); +# else + handle = CreateThread(NULL, 0, win32_start_child, + (LPVOID)new_perl, 0, &id); + PERL_SET_INTERP(aTHXo); + if (!handle) + Perl_croak(aTHX_ "panic: pseudo fork() failed"); + w32_pseudo_child_handles[w32_num_pseudo_children] = handle; + w32_pseudo_child_pids[w32_num_pseudo_children] = id; + ++w32_num_pseudo_children; +# endif + return -(int)id; +#else + Perl_croak(aTHX_ "fork() not implemented!\n"); + return -1; +#endif /* USE_ITHREADS */ +} + +int +PerlProcGetpid(struct IPerlProc* piPerl) +{ + return win32_getpid(); +} + +void* +PerlProcDynaLoader(struct IPerlProc* piPerl, const char* filename) +{ + return win32_dynaload(filename); +} + +void +PerlProcGetOSError(struct IPerlProc* piPerl, SV* sv, DWORD dwErr) +{ + win32_str_os_error(sv, dwErr); +} + +BOOL +PerlProcDoCmd(struct IPerlProc* piPerl, char *cmd) +{ + do_spawn2(cmd, EXECF_EXEC); + return FALSE; +} + +int +PerlProcSpawn(struct IPerlProc* piPerl, char* cmds) +{ + return do_spawn2(cmds, EXECF_SPAWN); +} + +int +PerlProcSpawnvp(struct IPerlProc* piPerl, int mode, const char *cmdname, const char *const *argv) +{ + return win32_spawnvp(mode, cmdname, argv); +} + +int +PerlProcASpawn(struct IPerlProc* piPerl, void *vreally, void **vmark, void **vsp) +{ + return do_aspawn(vreally, vmark, vsp); +} + +struct IPerlProc perlProc = +{ + PerlProcAbort, + PerlProcCrypt, + PerlProcExit, + PerlProc_Exit, + PerlProcExecl, + PerlProcExecv, + PerlProcExecvp, + PerlProcGetuid, + PerlProcGeteuid, + PerlProcGetgid, + PerlProcGetegid, + PerlProcGetlogin, + PerlProcKill, + PerlProcKillpg, + PerlProcPauseProc, + PerlProcPopen, + PerlProcPclose, + PerlProcPipe, + PerlProcSetuid, + PerlProcSetgid, + PerlProcSleep, + PerlProcTimes, + PerlProcWait, + PerlProcWaitpid, + PerlProcSignal, + PerlProcFork, + PerlProcGetpid, + PerlProcDynaLoader, + PerlProcGetOSError, + PerlProcDoCmd, + PerlProcSpawn, + PerlProcSpawnvp, + PerlProcASpawn, +}; + + +/* + * CPerlHost + */ + +CPerlHost::CPerlHost(void) +{ + m_pvDir = new VDir(); + m_pVMem = new VMem(); + m_pVMemShared = new VMem(); + m_pVMemParse = new VMem(); + + m_pvDir->Init(NULL, m_pVMem); + + m_dwEnvCount = 0; + m_lppEnvList = NULL; + + CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem)); + CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared)); + CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse)); + CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv)); + CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO)); + CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO)); + CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir)); + CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock)); + CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc)); + + m_pHostperlMem = &m_hostperlMem; + m_pHostperlMemShared = &m_hostperlMemShared; + m_pHostperlMemParse = &m_hostperlMemParse; + m_pHostperlEnv = &m_hostperlEnv; + m_pHostperlStdIO = &m_hostperlStdIO; + m_pHostperlLIO = &m_hostperlLIO; + m_pHostperlDir = &m_hostperlDir; + m_pHostperlSock = &m_hostperlSock; + m_pHostperlProc = &m_hostperlProc; +} + +#define SETUPEXCHANGE(xptr, iptr, table) \ + STMT_START { \ + if (xptr) { \ + iptr = *xptr; \ + *xptr = &table; \ + } \ + else { \ + iptr = &table; \ + } \ + } STMT_END + +CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, + struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, + struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, + struct IPerlDir** ppDir, struct IPerlSock** ppSock, + struct IPerlProc** ppProc) +{ + m_pvDir = new VDir(0); + m_pVMem = new VMem(); + m_pVMemShared = new VMem(); + m_pVMemParse = new VMem(); + + m_pvDir->Init(NULL, m_pVMem); + + m_dwEnvCount = 0; + m_lppEnvList = NULL; + + CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem)); + CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared)); + CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse)); + CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv)); + CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO)); + CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO)); + CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir)); + CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock)); + CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc)); + + SETUPEXCHANGE(ppMem, m_pHostperlMem, m_hostperlMem); + SETUPEXCHANGE(ppMemShared, m_pHostperlMemShared, m_hostperlMemShared); + SETUPEXCHANGE(ppMemParse, m_pHostperlMemParse, m_hostperlMemParse); + SETUPEXCHANGE(ppEnv, m_pHostperlEnv, m_hostperlEnv); + SETUPEXCHANGE(ppStdIO, m_pHostperlStdIO, m_hostperlStdIO); + SETUPEXCHANGE(ppLIO, m_pHostperlLIO, m_hostperlLIO); + SETUPEXCHANGE(ppDir, m_pHostperlDir, m_hostperlDir); + SETUPEXCHANGE(ppSock, m_pHostperlSock, m_hostperlSock); + SETUPEXCHANGE(ppProc, m_pHostperlProc, m_hostperlProc); +} +#undef SETUPEXCHANGE + +CPerlHost::CPerlHost(CPerlHost& host) +{ + m_pVMem = new VMem(); + m_pVMemShared = host.GetMemShared(); + m_pVMemParse = host.GetMemParse(); + + /* duplicate directory info */ + m_pvDir = new VDir(0); + m_pvDir->Init(host.GetDir(), m_pVMem); + + CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem)); + CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared)); + CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse)); + CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv)); + CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO)); + CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO)); + CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir)); + CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock)); + CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc)); + m_pHostperlMem = &m_hostperlMem; + m_pHostperlMemShared = &m_hostperlMemShared; + m_pHostperlMemParse = &m_hostperlMemParse; + m_pHostperlEnv = &m_hostperlEnv; + m_pHostperlStdIO = &m_hostperlStdIO; + m_pHostperlLIO = &m_hostperlLIO; + m_pHostperlDir = &m_hostperlDir; + m_pHostperlSock = &m_hostperlSock; + m_pHostperlProc = &m_hostperlProc; + + m_dwEnvCount = 0; + m_lppEnvList = NULL; + + /* duplicate environment info */ + LPSTR lpPtr; + DWORD dwIndex = 0; + while(lpPtr = host.GetIndex(dwIndex)) + Add(lpPtr); +} + +CPerlHost::~CPerlHost(void) +{ +// Reset(); + delete m_pvDir; + m_pVMemParse->Release(); + m_pVMemShared->Release(); + m_pVMem->Release(); +} + +LPSTR +CPerlHost::Find(LPCSTR lpStr) +{ + LPSTR lpPtr; + LPSTR* lppPtr = Lookup(lpStr); + if(lppPtr != NULL) { + for(lpPtr = *lppPtr; *lpPtr != '\0' && *lpPtr != '='; ++lpPtr) + ; + + if(*lpPtr == '=') + ++lpPtr; + + return lpPtr; + } + return NULL; +} + +int +lookup(const void *arg1, const void *arg2) +{ // Compare strings + char*ptr1, *ptr2; + char c1,c2; + + ptr1 = *(char**)arg1; + ptr2 = *(char**)arg2; + for(;;) { + c1 = *ptr1++; + c2 = *ptr2++; + if(c1 == '\0' || c1 == '=') { + if(c2 == '\0' || c2 == '=') + break; + + return -1; // string 1 < string 2 + } + else if(c2 == '\0' || c2 == '=') + return 1; // string 1 > string 2 + else if(c1 != c2) { + c1 = toupper(c1); + c2 = toupper(c2); + if(c1 != c2) { + if(c1 < c2) + return -1; // string 1 < string 2 + + return 1; // string 1 > string 2 + } + } + } + return 0; +} + +LPSTR* +CPerlHost::Lookup(LPCSTR lpStr) +{ + return (LPSTR*)bsearch(&lpStr, m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), lookup); +} + +int +compare(const void *arg1, const void *arg2) +{ // Compare strings + char*ptr1, *ptr2; + char c1,c2; + + ptr1 = *(char**)arg1; + ptr2 = *(char**)arg2; + for(;;) { + c1 = *ptr1++; + c2 = *ptr2++; + if(c1 == '\0' || c1 == '=') { + if(c1 == c2) + break; + + return -1; // string 1 < string 2 + } + else if(c2 == '\0' || c2 == '=') + return 1; // string 1 > string 2 + else if(c1 != c2) { + c1 = toupper(c1); + c2 = toupper(c2); + if(c1 != c2) { + if(c1 < c2) + return -1; // string 1 < string 2 + + return 1; // string 1 > string 2 + } + } + } + return 0; +} + +void +CPerlHost::Add(LPCSTR lpStr) +{ + dTHXo; + char szBuffer[1024]; + LPSTR *lpPtr; + int index, length = strlen(lpStr)+1; + + for(index = 0; lpStr[index] != '\0' && lpStr[index] != '='; ++index) + szBuffer[index] = lpStr[index]; + + szBuffer[index] = '\0'; + + // replacing ? + lpPtr = Lookup(szBuffer); + if(lpPtr != NULL) { + Renew(*lpPtr, length, char); + strcpy(*lpPtr, lpStr); + } + else { + ++m_dwEnvCount; + Renew(m_lppEnvList, m_dwEnvCount, LPSTR); + New(1, m_lppEnvList[m_dwEnvCount-1], length, char); + if(m_lppEnvList[m_dwEnvCount-1] != NULL) { + strcpy(m_lppEnvList[m_dwEnvCount-1], lpStr); + qsort(m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), compare); + } + else + --m_dwEnvCount; + } +} + +DWORD +CPerlHost::CalculateEnvironmentSpace(void) +{ + DWORD index; + DWORD dwSize = 0; + for(index = 0; index < m_dwEnvCount; ++index) + dwSize += strlen(m_lppEnvList[index]) + 1; + + return dwSize; +} + +void +CPerlHost::FreeLocalEnvironmentStrings(LPSTR lpStr) +{ + dTHXo; + Safefree(lpStr); +} + +char* +CPerlHost::GetChildDir(void) +{ + dTHXo; + int length; + char* ptr; + New(0, ptr, MAX_PATH+1, char); + if(ptr) { + m_pvDir->GetCurrentDirectoryA(MAX_PATH+1, ptr); + length = strlen(ptr)-1; + if(length > 0) { + if((ptr[length] == '\\') || (ptr[length] == '/')) + ptr[length] = 0; + } + } + return ptr; +} + +void +CPerlHost::FreeChildDir(char* pStr) +{ + dTHXo; + Safefree(pStr); +} + +LPSTR +CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir) +{ + dTHXo; + LPSTR lpStr, lpPtr, lpEnvPtr, lpTmp, lpLocalEnv, lpAllocPtr; + DWORD dwSize, dwEnvIndex; + int nLength, compVal; + + // get the process environment strings + lpAllocPtr = lpTmp = (LPSTR)GetEnvironmentStrings(); + + // step over current directory stuff + while(*lpTmp == '=') + lpTmp += strlen(lpTmp) + 1; + + // save the start of the environment strings + lpEnvPtr = lpTmp; + for(dwSize = 1; *lpTmp != '\0'; lpTmp += strlen(lpTmp) + 1) { + // calculate the size of the environment strings + dwSize += strlen(lpTmp) + 1; + } + + // add the size of current directories + dwSize += vDir.CalculateEnvironmentSpace(); + + // add the additional space used by changes made to the environment + dwSize += CalculateEnvironmentSpace(); + + New(1, lpStr, dwSize, char); + lpPtr = lpStr; + if(lpStr != NULL) { + // build the local environment + lpStr = vDir.BuildEnvironmentSpace(lpStr); + + dwEnvIndex = 0; + lpLocalEnv = GetIndex(dwEnvIndex); + while(*lpEnvPtr != '\0') { + if(lpLocalEnv == NULL) { + // all environment overrides have been added + // so copy string into place + strcpy(lpStr, lpEnvPtr); + nLength = strlen(lpEnvPtr) + 1; + lpStr += nLength; + lpEnvPtr += nLength; + } + else { + // determine which string to copy next + compVal = compare(&lpEnvPtr, &lpLocalEnv); + if(compVal < 0) { + strcpy(lpStr, lpEnvPtr); + nLength = strlen(lpEnvPtr) + 1; + lpStr += nLength; + lpEnvPtr += nLength; + } + else { + char *ptr = strchr(lpLocalEnv, '='); + if(ptr && ptr[1]) { + strcpy(lpStr, lpLocalEnv); + lpStr += strlen(lpLocalEnv) + 1; + } + lpLocalEnv = GetIndex(dwEnvIndex); + if(compVal == 0) { + // this string was replaced + lpEnvPtr += strlen(lpEnvPtr) + 1; + } + } + } + } + + // add final NULL + *lpStr = '\0'; + } + + // release the process environment strings + FreeEnvironmentStrings(lpAllocPtr); + + return lpPtr; +} + +void +CPerlHost::Reset(void) +{ + dTHXo; + if(m_lppEnvList != NULL) { + for(DWORD index = 0; index < m_dwEnvCount; ++index) { + Safefree(m_lppEnvList[index]); + m_lppEnvList[index] = NULL; + } + } + m_dwEnvCount = 0; +} + +void +CPerlHost::Clearenv(void) +{ + char ch; + LPSTR lpPtr, lpStr, lpEnvPtr; + if(m_lppEnvList != NULL) { + /* set every entry to an empty string */ + for(DWORD index = 0; index < m_dwEnvCount; ++index) { + char* ptr = strchr(m_lppEnvList[index], '='); + if(ptr) { + *++ptr = 0; + } + } + } + + /* get the process environment strings */ + lpStr = lpEnvPtr = (LPSTR)GetEnvironmentStrings(); + + /* step over current directory stuff */ + while(*lpStr == '=') + lpStr += strlen(lpStr) + 1; + + while(*lpStr) { + lpPtr = strchr(lpStr, '='); + if(lpPtr) { + ch = *++lpPtr; + *lpPtr = 0; + Add(lpStr); + *lpPtr = ch; + } + lpStr += strlen(lpStr) + 1; + } + + FreeEnvironmentStrings(lpEnvPtr); +} + + +char* +CPerlHost::Getenv(const char *varname) +{ + char* pEnv = Find(varname); + if(pEnv == NULL) { + pEnv = win32_getenv(varname); + } + else { + if(!*pEnv) + pEnv = 0; + } + + return pEnv; +} + +int +CPerlHost::Putenv(const char *envstring) +{ + Add(envstring); + return 0; +} + +int +CPerlHost::Chdir(const char *dirname) +{ + dTHXo; + int ret; + if (USING_WIDE()) { + WCHAR wBuffer[MAX_PATH]; + A2WHELPER(dirname, wBuffer, sizeof(wBuffer)); + ret = m_pvDir->SetCurrentDirectoryW(wBuffer); + } + else + ret = m_pvDir->SetCurrentDirectoryA((char*)dirname); + if(ret < 0) { + errno = ENOENT; + } + return ret; +} + +#endif /* ___PerlHost_H___ */ diff --git a/win32/perllib.c b/win32/perllib.c index 9cd542b9df..9ccf5a0043 100644 --- a/win32/perllib.c +++ b/win32/perllib.c @@ -15,7 +15,7 @@ #ifdef PERL_IMPLICIT_SYS #include "win32iop.h" #include <fcntl.h> -#endif +#endif /* PERL_IMPLICIT_SYS */ /* Register any extra external extensions */ @@ -35,1284 +35,13 @@ xs_init(pTHXo) } #ifdef PERL_IMPLICIT_SYS -/* IPerlMem */ -void* -PerlMemMalloc(struct IPerlMem *I, size_t size) -{ - return win32_malloc(size); -} -void* -PerlMemRealloc(struct IPerlMem *I, void* ptr, size_t size) -{ - return win32_realloc(ptr, size); -} -void -PerlMemFree(struct IPerlMem *I, void* ptr) -{ - win32_free(ptr); -} - -struct IPerlMem perlMem = -{ - PerlMemMalloc, - PerlMemRealloc, - PerlMemFree, -}; - - -/* IPerlEnv */ -extern char * g_win32_get_privlib(char *pl); -extern char * g_win32_get_sitelib(char *pl); - - -char* -PerlEnvGetenv(struct IPerlEnv *I, const char *varname) -{ - return win32_getenv(varname); -}; -int -PerlEnvPutenv(struct IPerlEnv *I, const char *envstring) -{ - return win32_putenv(envstring); -}; - -char* -PerlEnvGetenv_len(struct IPerlEnv *I, const char* varname, unsigned long* len) -{ - char *e = win32_getenv(varname); - if (e) - *len = strlen(e); - return e; -} - -int -PerlEnvUname(struct IPerlEnv *I, struct utsname *name) -{ - return win32_uname(name); -} - -void -PerlEnvClearenv(struct IPerlEnv *I) -{ - dTHXo; - char *envv = GetEnvironmentStrings(); - char *cur = envv; - STRLEN len; - while (*cur) { - char *end = strchr(cur,'='); - if (end && end != cur) { - *end = '\0'; - my_setenv(cur,Nullch); - *end = '='; - cur = end + strlen(end+1)+2; - } - else if ((len = strlen(cur))) - cur += len+1; - } - FreeEnvironmentStrings(envv); -} - -void* -PerlEnvGetChildEnv(struct IPerlEnv *I) -{ - return NULL; -} - -void -PerlEnvFreeChildEnv(struct IPerlEnv *I, void* env) -{ -} - -char* -PerlEnvGetChildDir(struct IPerlEnv *I) -{ - return NULL; -} - -void -PerlEnvFreeChildDir(struct IPerlEnv *I, char* dir) -{ -} - -unsigned long -PerlEnvOsId(struct IPerlEnv *I) -{ - return win32_os_id(); -} - -char* -PerlEnvLibPath(struct IPerlEnv *I, char *pl) -{ - return g_win32_get_privlib(pl); -} - -char* -PerlEnvSiteLibPath(struct IPerlEnv *I, char *pl) -{ - return g_win32_get_sitelib(pl); -} - -struct IPerlEnv perlEnv = -{ - PerlEnvGetenv, - PerlEnvPutenv, - PerlEnvGetenv_len, - PerlEnvUname, - PerlEnvClearenv, - PerlEnvGetChildEnv, - PerlEnvFreeChildEnv, - PerlEnvGetChildDir, - PerlEnvFreeChildDir, - PerlEnvOsId, - PerlEnvLibPath, - PerlEnvSiteLibPath, -}; - - -/* PerlStdIO */ -PerlIO* -PerlStdIOStdin(struct IPerlStdIO *I) -{ - return (PerlIO*)win32_stdin(); -} - -PerlIO* -PerlStdIOStdout(struct IPerlStdIO *I) -{ - return (PerlIO*)win32_stdout(); -} - -PerlIO* -PerlStdIOStderr(struct IPerlStdIO *I) -{ - return (PerlIO*)win32_stderr(); -} - -PerlIO* -PerlStdIOOpen(struct IPerlStdIO *I, const char *path, const char *mode) -{ - return (PerlIO*)win32_fopen(path, mode); -} - -int -PerlStdIOClose(struct IPerlStdIO *I, PerlIO* pf) -{ - return win32_fclose(((FILE*)pf)); -} - -int -PerlStdIOEof(struct IPerlStdIO *I, PerlIO* pf) -{ - return win32_feof((FILE*)pf); -} - -int -PerlStdIOError(struct IPerlStdIO *I, PerlIO* pf) -{ - return win32_ferror((FILE*)pf); -} - -void -PerlStdIOClearerr(struct IPerlStdIO *I, PerlIO* pf) -{ - win32_clearerr((FILE*)pf); -} - -int -PerlStdIOGetc(struct IPerlStdIO *I, PerlIO* pf) -{ - return win32_getc((FILE*)pf); -} - -char* -PerlStdIOGetBase(struct IPerlStdIO *I, PerlIO* pf) -{ -#ifdef FILE_base - FILE *f = (FILE*)pf; - return FILE_base(f); -#else - return Nullch; -#endif -} - -int -PerlStdIOGetBufsiz(struct IPerlStdIO *I, PerlIO* pf) -{ -#ifdef FILE_bufsiz - FILE *f = (FILE*)pf; - return FILE_bufsiz(f); -#else - return (-1); -#endif -} - -int -PerlStdIOGetCnt(struct IPerlStdIO *I, PerlIO* pf) -{ -#ifdef USE_STDIO_PTR - FILE *f = (FILE*)pf; - return FILE_cnt(f); -#else - return (-1); -#endif -} - -char* -PerlStdIOGetPtr(struct IPerlStdIO *I, PerlIO* pf) -{ -#ifdef USE_STDIO_PTR - FILE *f = (FILE*)pf; - return FILE_ptr(f); -#else - return Nullch; -#endif -} - -char* -PerlStdIOGets(struct IPerlStdIO *I, PerlIO* pf, char* s, int n) -{ - return win32_fgets(s, n, (FILE*)pf); -} - -int -PerlStdIOPutc(struct IPerlStdIO *I, PerlIO* pf, int c) -{ - return win32_fputc(c, (FILE*)pf); -} - -int -PerlStdIOPuts(struct IPerlStdIO *I, PerlIO* pf, const char *s) -{ - return win32_fputs(s, (FILE*)pf); -} - -int -PerlStdIOFlush(struct IPerlStdIO *I, PerlIO* pf) -{ - return win32_fflush((FILE*)pf); -} - -int -PerlStdIOUngetc(struct IPerlStdIO *I, PerlIO* pf,int c) -{ - return win32_ungetc(c, (FILE*)pf); -} - -int -PerlStdIOFileno(struct IPerlStdIO *I, PerlIO* pf) -{ - return win32_fileno((FILE*)pf); -} - -PerlIO* -PerlStdIOFdopen(struct IPerlStdIO *I, int fd, const char *mode) -{ - return (PerlIO*)win32_fdopen(fd, mode); -} - -PerlIO* -PerlStdIOReopen(struct IPerlStdIO *I, const char*path, const char*mode, PerlIO* pf) -{ - return (PerlIO*)win32_freopen(path, mode, (FILE*)pf); -} - -SSize_t -PerlStdIORead(struct IPerlStdIO *I, PerlIO* pf, void *buffer, Size_t size) -{ - return win32_fread(buffer, 1, size, (FILE*)pf); -} - -SSize_t -PerlStdIOWrite(struct IPerlStdIO *I, PerlIO* pf, const void *buffer, Size_t size) -{ - return win32_fwrite(buffer, 1, size, (FILE*)pf); -} - -void -PerlStdIOSetBuf(struct IPerlStdIO *I, PerlIO* pf, char* buffer) -{ - win32_setbuf((FILE*)pf, buffer); -} - -int -PerlStdIOSetVBuf(struct IPerlStdIO *I, PerlIO* pf, char* buffer, int type, Size_t size) -{ - return win32_setvbuf((FILE*)pf, buffer, type, size); -} - -void -PerlStdIOSetCnt(struct IPerlStdIO *I, PerlIO* pf, int n) -{ -#ifdef STDIO_CNT_LVALUE - FILE *f = (FILE*)pf; - FILE_cnt(f) = n; -#endif -} - -void -PerlStdIOSetPtrCnt(struct IPerlStdIO *I, PerlIO* pf, char * ptr, int n) -{ -#ifdef STDIO_PTR_LVALUE - FILE *f = (FILE*)pf; - FILE_ptr(f) = ptr; - FILE_cnt(f) = n; -#endif -} - -void -PerlStdIOSetlinebuf(struct IPerlStdIO *I, PerlIO* pf) -{ - win32_setvbuf((FILE*)pf, NULL, _IOLBF, 0); -} - -int -PerlStdIOPrintf(struct IPerlStdIO *I, PerlIO* pf, const char *format,...) -{ - va_list(arglist); - va_start(arglist, format); - return win32_vfprintf((FILE*)pf, format, arglist); -} - -int -PerlStdIOVprintf(struct IPerlStdIO *I, PerlIO* pf, const char *format, va_list arglist) -{ - return win32_vfprintf((FILE*)pf, format, arglist); -} - -long -PerlStdIOTell(struct IPerlStdIO *I, PerlIO* pf) -{ - return win32_ftell((FILE*)pf); -} - -int -PerlStdIOSeek(struct IPerlStdIO *I, PerlIO* pf, off_t offset, int origin) -{ - return win32_fseek((FILE*)pf, offset, origin); -} - -void -PerlStdIORewind(struct IPerlStdIO *I, PerlIO* pf) -{ - win32_rewind((FILE*)pf); -} - -PerlIO* -PerlStdIOTmpfile(struct IPerlStdIO *I) -{ - return (PerlIO*)win32_tmpfile(); -} - -int -PerlStdIOGetpos(struct IPerlStdIO *I, PerlIO* pf, Fpos_t *p) -{ - return win32_fgetpos((FILE*)pf, p); -} - -int -PerlStdIOSetpos(struct IPerlStdIO *I, PerlIO* pf, const Fpos_t *p) -{ - return win32_fsetpos((FILE*)pf, p); -} -void -PerlStdIOInit(struct IPerlStdIO *I) -{ -} - -void -PerlStdIOInitOSExtras(struct IPerlStdIO *I) -{ - Perl_init_os_extras(); -} - -int -PerlStdIOOpenOSfhandle(struct IPerlStdIO *I, long osfhandle, int flags) -{ - return win32_open_osfhandle(osfhandle, flags); -} - -int -PerlStdIOGetOSfhandle(struct IPerlStdIO *I, int filenum) -{ - return win32_get_osfhandle(filenum); -} - - -struct IPerlStdIO perlStdIO = -{ - PerlStdIOStdin, - PerlStdIOStdout, - PerlStdIOStderr, - PerlStdIOOpen, - PerlStdIOClose, - PerlStdIOEof, - PerlStdIOError, - PerlStdIOClearerr, - PerlStdIOGetc, - PerlStdIOGetBase, - PerlStdIOGetBufsiz, - PerlStdIOGetCnt, - PerlStdIOGetPtr, - PerlStdIOGets, - PerlStdIOPutc, - PerlStdIOPuts, - PerlStdIOFlush, - PerlStdIOUngetc, - PerlStdIOFileno, - PerlStdIOFdopen, - PerlStdIOReopen, - PerlStdIORead, - PerlStdIOWrite, - PerlStdIOSetBuf, - PerlStdIOSetVBuf, - PerlStdIOSetCnt, - PerlStdIOSetPtrCnt, - PerlStdIOSetlinebuf, - PerlStdIOPrintf, - PerlStdIOVprintf, - PerlStdIOTell, - PerlStdIOSeek, - PerlStdIORewind, - PerlStdIOTmpfile, - PerlStdIOGetpos, - PerlStdIOSetpos, - PerlStdIOInit, - PerlStdIOInitOSExtras, -}; - - -/* IPerlLIO */ -int -PerlLIOAccess(struct IPerlLIO *I, const char *path, int mode) -{ - return access(path, mode); -} - -int -PerlLIOChmod(struct IPerlLIO *I, const char *filename, int pmode) -{ - return chmod(filename, pmode); -} - -int -PerlLIOChown(struct IPerlLIO *I, const char *filename, uid_t owner, gid_t group) -{ - return chown(filename, owner, group); -} - -int -PerlLIOChsize(struct IPerlLIO *I, int handle, long size) -{ - return chsize(handle, size); -} - -int -PerlLIOClose(struct IPerlLIO *I, int handle) -{ - return win32_close(handle); -} - -int -PerlLIODup(struct IPerlLIO *I, int handle) -{ - return win32_dup(handle); -} - -int -PerlLIODup2(struct IPerlLIO *I, int handle1, int handle2) -{ - return win32_dup2(handle1, handle2); -} - -int -PerlLIOFlock(struct IPerlLIO *I, int fd, int oper) -{ - return win32_flock(fd, oper); -} - -int -PerlLIOFileStat(struct IPerlLIO *I, int handle, struct stat *buffer) -{ - return fstat(handle, buffer); -} - -int -PerlLIOIOCtl(struct IPerlLIO *I, int i, unsigned int u, char *data) -{ - return win32_ioctlsocket((SOCKET)i, (long)u, (u_long*)data); -} - -int -PerlLIOIsatty(struct IPerlLIO *I, int fd) -{ - return isatty(fd); -} - -int -PerlLIOLink(struct IPerlLIO *I, const char*oldname, const char *newname) -{ - return win32_link(oldname, newname); -} - -long -PerlLIOLseek(struct IPerlLIO *I, int handle, long offset, int origin) -{ - return win32_lseek(handle, offset, origin); -} - -int -PerlLIOLstat(struct IPerlLIO* p, const char *path, struct stat *buffer) -{ - return win32_stat(path, buffer); -} - -char* -PerlLIOMktemp(struct IPerlLIO *I, char *Template) -{ - return mktemp(Template); -} - -int -PerlLIOOpen(struct IPerlLIO *I, const char *filename, int oflag) -{ - return win32_open(filename, oflag); -} - -int -PerlLIOOpen3(struct IPerlLIO *I, const char *filename, int oflag, int pmode) -{ - int ret; - if(stricmp(filename, "/dev/null") == 0) - ret = open("NUL", oflag, pmode); - else - ret = open(filename, oflag, pmode); - - return ret; -} - -int -PerlLIORead(struct IPerlLIO *I, int handle, void *buffer, unsigned int count) -{ - return win32_read(handle, buffer, count); -} - -int -PerlLIORename(struct IPerlLIO *I, const char *OldFileName, const char *newname) -{ - return win32_rename(OldFileName, newname); -} - -int -PerlLIOSetmode(struct IPerlLIO *I, int handle, int mode) -{ - return win32_setmode(handle, mode); -} - -int -PerlLIONameStat(struct IPerlLIO *I, const char *path, struct stat *buffer) -{ - return win32_stat(path, buffer); -} - -char* -PerlLIOTmpnam(struct IPerlLIO *I, char *string) -{ - return tmpnam(string); -} - -int -PerlLIOUmask(struct IPerlLIO *I, int pmode) -{ - return umask(pmode); -} - -int -PerlLIOUnlink(struct IPerlLIO *I, const char *filename) -{ - chmod(filename, S_IREAD | S_IWRITE); - return unlink(filename); -} - -int -PerlLIOUtime(struct IPerlLIO *I, char *filename, struct utimbuf *times) -{ - return win32_utime(filename, times); -} - -int -PerlLIOWrite(struct IPerlLIO *I, int handle, const void *buffer, unsigned int count) -{ - return win32_write(handle, buffer, count); -} - -struct IPerlLIO perlLIO = -{ - PerlLIOAccess, - PerlLIOChmod, - PerlLIOChown, - PerlLIOChsize, - PerlLIOClose, - PerlLIODup, - PerlLIODup2, - PerlLIOFlock, - PerlLIOFileStat, - PerlLIOIOCtl, - PerlLIOIsatty, - PerlLIOLink, - PerlLIOLseek, - PerlLIOLstat, - PerlLIOMktemp, - PerlLIOOpen, - PerlLIOOpen3, - PerlLIORead, - PerlLIORename, - PerlLIOSetmode, - PerlLIONameStat, - PerlLIOTmpnam, - PerlLIOUmask, - PerlLIOUnlink, - PerlLIOUtime, - PerlLIOWrite, -}; - -/* IPerlDIR */ -int -PerlDirMakedir(struct IPerlDir *I, const char *dirname, int mode) -{ - return win32_mkdir(dirname, mode); -} - -int -PerlDirChdir(struct IPerlDir *I, const char *dirname) -{ - return win32_chdir(dirname); -} - -int -PerlDirRmdir(struct IPerlDir *I, const char *dirname) -{ - return win32_rmdir(dirname); -} - -int -PerlDirClose(struct IPerlDir *I, DIR *dirp) -{ - return win32_closedir(dirp); -} - -DIR* -PerlDirOpen(struct IPerlDir *I, char *filename) -{ - return win32_opendir(filename); -} - -struct direct * -PerlDirRead(struct IPerlDir *I, DIR *dirp) -{ - return win32_readdir(dirp); -} - -void -PerlDirRewind(struct IPerlDir *I, DIR *dirp) -{ - win32_rewinddir(dirp); -} - -void -PerlDirSeek(struct IPerlDir *I, DIR *dirp, long loc) -{ - win32_seekdir(dirp, loc); -} - -long -PerlDirTell(struct IPerlDir *I, DIR *dirp) -{ - return win32_telldir(dirp); -} - -struct IPerlDir perlDir = -{ - PerlDirMakedir, - PerlDirChdir, - PerlDirRmdir, - PerlDirClose, - PerlDirOpen, - PerlDirRead, - PerlDirRewind, - PerlDirSeek, - PerlDirTell, -}; - - -/* IPerlSock */ -u_long -PerlSockHtonl(struct IPerlSock *I, u_long hostlong) -{ - return win32_htonl(hostlong); -} - -u_short -PerlSockHtons(struct IPerlSock *I, u_short hostshort) -{ - return win32_htons(hostshort); -} - -u_long -PerlSockNtohl(struct IPerlSock *I, u_long netlong) -{ - return win32_ntohl(netlong); -} - -u_short -PerlSockNtohs(struct IPerlSock *I, u_short netshort) -{ - return win32_ntohs(netshort); -} - -SOCKET PerlSockAccept(struct IPerlSock *I, SOCKET s, struct sockaddr* addr, int* addrlen) -{ - return win32_accept(s, addr, addrlen); -} - -int -PerlSockBind(struct IPerlSock *I, SOCKET s, const struct sockaddr* name, int namelen) -{ - return win32_bind(s, name, namelen); -} - -int -PerlSockConnect(struct IPerlSock *I, SOCKET s, const struct sockaddr* name, int namelen) -{ - return win32_connect(s, name, namelen); -} - -void -PerlSockEndhostent(struct IPerlSock *I) -{ - win32_endhostent(); -} - -void -PerlSockEndnetent(struct IPerlSock *I) -{ - win32_endnetent(); -} - -void -PerlSockEndprotoent(struct IPerlSock *I) -{ - win32_endprotoent(); -} - -void -PerlSockEndservent(struct IPerlSock *I) -{ - win32_endservent(); -} - -struct hostent* -PerlSockGethostbyaddr(struct IPerlSock *I, const char* addr, int len, int type) -{ - return win32_gethostbyaddr(addr, len, type); -} - -struct hostent* -PerlSockGethostbyname(struct IPerlSock *I, const char* name) -{ - return win32_gethostbyname(name); -} - -struct hostent* -PerlSockGethostent(struct IPerlSock *I) -{ - dTHXo; - Perl_croak(aTHX_ "gethostent not implemented!\n"); - return NULL; -} - -int -PerlSockGethostname(struct IPerlSock *I, char* name, int namelen) -{ - return win32_gethostname(name, namelen); -} - -struct netent * -PerlSockGetnetbyaddr(struct IPerlSock *I, long net, int type) -{ - return win32_getnetbyaddr(net, type); -} - -struct netent * -PerlSockGetnetbyname(struct IPerlSock *I, const char *name) -{ - return win32_getnetbyname((char*)name); -} - -struct netent * -PerlSockGetnetent(struct IPerlSock *I) -{ - return win32_getnetent(); -} - -int PerlSockGetpeername(struct IPerlSock *I, SOCKET s, struct sockaddr* name, int* namelen) -{ - return win32_getpeername(s, name, namelen); -} - -struct protoent* -PerlSockGetprotobyname(struct IPerlSock *I, const char* name) -{ - return win32_getprotobyname(name); -} - -struct protoent* -PerlSockGetprotobynumber(struct IPerlSock *I, int number) -{ - return win32_getprotobynumber(number); -} - -struct protoent* -PerlSockGetprotoent(struct IPerlSock *I) -{ - return win32_getprotoent(); -} - -struct servent* -PerlSockGetservbyname(struct IPerlSock *I, const char* name, const char* proto) -{ - return win32_getservbyname(name, proto); -} - -struct servent* -PerlSockGetservbyport(struct IPerlSock *I, int port, const char* proto) -{ - return win32_getservbyport(port, proto); -} - -struct servent* -PerlSockGetservent(struct IPerlSock *I) -{ - return win32_getservent(); -} - -int -PerlSockGetsockname(struct IPerlSock *I, SOCKET s, struct sockaddr* name, int* namelen) -{ - return win32_getsockname(s, name, namelen); -} - -int -PerlSockGetsockopt(struct IPerlSock *I, SOCKET s, int level, int optname, char* optval, int* optlen) -{ - return win32_getsockopt(s, level, optname, optval, optlen); -} - -unsigned long -PerlSockInetAddr(struct IPerlSock *I, const char* cp) -{ - return win32_inet_addr(cp); -} - -char* -PerlSockInetNtoa(struct IPerlSock *I, struct in_addr in) -{ - return win32_inet_ntoa(in); -} - -int -PerlSockListen(struct IPerlSock *I, SOCKET s, int backlog) -{ - return win32_listen(s, backlog); -} - -int -PerlSockRecv(struct IPerlSock *I, SOCKET s, char* buffer, int len, int flags) -{ - return win32_recv(s, buffer, len, flags); -} - -int -PerlSockRecvfrom(struct IPerlSock *I, SOCKET s, char* buffer, int len, int flags, struct sockaddr* from, int* fromlen) -{ - return win32_recvfrom(s, buffer, len, flags, from, fromlen); -} - -int -PerlSockSelect(struct IPerlSock *I, int nfds, char* readfds, char* writefds, char* exceptfds, const struct timeval* timeout) -{ - return win32_select(nfds, (Perl_fd_set*)readfds, (Perl_fd_set*)writefds, (Perl_fd_set*)exceptfds, timeout); -} - -int -PerlSockSend(struct IPerlSock *I, SOCKET s, const char* buffer, int len, int flags) -{ - return win32_send(s, buffer, len, flags); -} - -int -PerlSockSendto(struct IPerlSock *I, SOCKET s, const char* buffer, int len, int flags, const struct sockaddr* to, int tolen) -{ - return win32_sendto(s, buffer, len, flags, to, tolen); -} - -void -PerlSockSethostent(struct IPerlSock *I, int stayopen) -{ - win32_sethostent(stayopen); -} - -void -PerlSockSetnetent(struct IPerlSock *I, int stayopen) -{ - win32_setnetent(stayopen); -} - -void -PerlSockSetprotoent(struct IPerlSock *I, int stayopen) -{ - win32_setprotoent(stayopen); -} - -void -PerlSockSetservent(struct IPerlSock *I, int stayopen) -{ - win32_setservent(stayopen); -} - -int -PerlSockSetsockopt(struct IPerlSock *I, SOCKET s, int level, int optname, const char* optval, int optlen) -{ - return win32_setsockopt(s, level, optname, optval, optlen); -} - -int -PerlSockShutdown(struct IPerlSock *I, SOCKET s, int how) -{ - return win32_shutdown(s, how); -} - -SOCKET -PerlSockSocket(struct IPerlSock *I, int af, int type, int protocol) -{ - return win32_socket(af, type, protocol); -} - -int -PerlSockSocketpair(struct IPerlSock *I, int domain, int type, int protocol, int* fds) -{ - dTHXo; - Perl_croak(aTHX_ "socketpair not implemented!\n"); - return 0; -} - -int -PerlSockClosesocket(struct IPerlSock *I, SOCKET s) -{ - return win32_closesocket(s); -} - -int -PerlSockIoctlsocket(struct IPerlSock *I, SOCKET s, long cmd, u_long *argp) -{ - return win32_ioctlsocket(s, cmd, argp); -} - -struct IPerlSock perlSock = -{ - PerlSockHtonl, - PerlSockHtons, - PerlSockNtohl, - PerlSockNtohs, - PerlSockAccept, - PerlSockBind, - PerlSockConnect, - PerlSockEndhostent, - PerlSockEndnetent, - PerlSockEndprotoent, - PerlSockEndservent, - PerlSockGethostname, - PerlSockGetpeername, - PerlSockGethostbyaddr, - PerlSockGethostbyname, - PerlSockGethostent, - PerlSockGetnetbyaddr, - PerlSockGetnetbyname, - PerlSockGetnetent, - PerlSockGetprotobyname, - PerlSockGetprotobynumber, - PerlSockGetprotoent, - PerlSockGetservbyname, - PerlSockGetservbyport, - PerlSockGetservent, - PerlSockGetsockname, - PerlSockGetsockopt, - PerlSockInetAddr, - PerlSockInetNtoa, - PerlSockListen, - PerlSockRecv, - PerlSockRecvfrom, - PerlSockSelect, - PerlSockSend, - PerlSockSendto, - PerlSockSethostent, - PerlSockSetnetent, - PerlSockSetprotoent, - PerlSockSetservent, - PerlSockSetsockopt, - PerlSockShutdown, - PerlSockSocket, - PerlSockSocketpair, - PerlSockClosesocket, -}; - - -/* IPerlProc */ - -#define EXECF_EXEC 1 -#define EXECF_SPAWN 2 - -extern char * g_getlogin(void); -extern int do_spawn2(char *cmd, int exectype); -#ifdef PERL_OBJECT -extern int g_do_aspawn(void *vreally, void **vmark, void **vsp); -#define do_aspawn g_do_aspawn -#endif -EXTERN_C PerlInterpreter* perl_alloc_using(struct IPerlMem* pMem, - struct IPerlEnv* pEnv, struct IPerlStdIO* pStdIO, - struct IPerlLIO* pLIO, struct IPerlDir* pDir, - struct IPerlSock* pSock, struct IPerlProc* pProc); - -void -PerlProcAbort(struct IPerlProc *I) -{ - win32_abort(); -} - -char * -PerlProcCrypt(struct IPerlProc *I, const char* clear, const char* salt) -{ - return win32_crypt(clear, salt); -} - -void -PerlProcExit(struct IPerlProc *I, int status) -{ - exit(status); -} - -void -PerlProc_Exit(struct IPerlProc *I, int status) -{ - _exit(status); -} - -int -PerlProcExecl(struct IPerlProc *I, const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3) -{ - return execl(cmdname, arg0, arg1, arg2, arg3); -} - -int -PerlProcExecv(struct IPerlProc *I, const char *cmdname, const char *const *argv) -{ - return win32_execvp(cmdname, argv); -} - -int -PerlProcExecvp(struct IPerlProc *I, const char *cmdname, const char *const *argv) -{ - return win32_execvp(cmdname, argv); -} - -uid_t -PerlProcGetuid(struct IPerlProc *I) -{ - return getuid(); -} - -uid_t -PerlProcGeteuid(struct IPerlProc *I) -{ - return geteuid(); -} - -gid_t -PerlProcGetgid(struct IPerlProc *I) -{ - return getgid(); -} - -gid_t -PerlProcGetegid(struct IPerlProc *I) -{ - return getegid(); -} - -char * -PerlProcGetlogin(struct IPerlProc *I) -{ - return g_getlogin(); -} - -int -PerlProcKill(struct IPerlProc *I, int pid, int sig) -{ - return win32_kill(pid, sig); -} - -int -PerlProcKillpg(struct IPerlProc *I, int pid, int sig) -{ - dTHXo; - Perl_croak(aTHX_ "killpg not implemented!\n"); - return 0; -} - -int -PerlProcPauseProc(struct IPerlProc *I) -{ - return win32_sleep((32767L << 16) + 32767); -} - -PerlIO* -PerlProcPopen(struct IPerlProc *I, const char *command, const char *mode) -{ - dTHXo; - PERL_FLUSHALL_FOR_CHILD; - return (PerlIO*)win32_popen(command, mode); -} - -int -PerlProcPclose(struct IPerlProc *I, PerlIO *stream) -{ - return win32_pclose((FILE*)stream); -} - -int -PerlProcPipe(struct IPerlProc *I, int *phandles) -{ - return win32_pipe(phandles, 512, O_BINARY); -} - -int -PerlProcSetuid(struct IPerlProc *I, uid_t u) -{ - return setuid(u); -} - -int -PerlProcSetgid(struct IPerlProc *I, gid_t g) -{ - return setgid(g); -} - -int -PerlProcSleep(struct IPerlProc *I, unsigned int s) -{ - return win32_sleep(s); -} - -int -PerlProcTimes(struct IPerlProc *I, struct tms *timebuf) -{ - return win32_times(timebuf); -} - -int -PerlProcWait(struct IPerlProc *I, int *status) -{ - return win32_wait(status); -} - -int -PerlProcWaitpid(struct IPerlProc *I, int pid, int *status, int flags) -{ - return win32_waitpid(pid, status, flags); -} - -Sighandler_t -PerlProcSignal(struct IPerlProc *I, int sig, Sighandler_t subcode) -{ - return 0; -} - -void* -PerlProcDynaLoader(struct IPerlProc *I, const char* filename) -{ - return win32_dynaload(filename); -} - -void -PerlProcGetOSError(struct IPerlProc *I, SV* sv, DWORD dwErr) -{ - win32_str_os_error(sv, dwErr); -} - -BOOL -PerlProcDoCmd(struct IPerlProc *I, char *cmd) -{ - do_spawn2(cmd, EXECF_EXEC); - return FALSE; -} - -int -PerlProcSpawn(struct IPerlProc *I, char* cmds) -{ - return do_spawn2(cmds, EXECF_SPAWN); -} - -int -PerlProcSpawnvp(struct IPerlProc *I, int mode, const char *cmdname, const char *const *argv) -{ - return win32_spawnvp(mode, cmdname, argv); -} - -int -PerlProcASpawn(struct IPerlProc *I, void *vreally, void **vmark, void **vsp) -{ - return do_aspawn(vreally, vmark, vsp); -} - -struct IPerlProc perlProc = -{ - PerlProcAbort, - PerlProcCrypt, - PerlProcExit, - PerlProc_Exit, - PerlProcExecl, - PerlProcExecv, - PerlProcExecvp, - PerlProcGetuid, - PerlProcGeteuid, - PerlProcGetgid, - PerlProcGetegid, - PerlProcGetlogin, - PerlProcKill, - PerlProcKillpg, - PerlProcPauseProc, - PerlProcPopen, - PerlProcPclose, - PerlProcPipe, - PerlProcSetuid, - PerlProcSetgid, - PerlProcSleep, - PerlProcTimes, - PerlProcWait, - PerlProcWaitpid, - PerlProcSignal, - PerlProcDynaLoader, - PerlProcGetOSError, - PerlProcDoCmd, - PerlProcSpawn, - PerlProcSpawnvp, - PerlProcASpawn, -}; - -/*#include "perlhost.h" */ +#include "perlhost.h" EXTERN_C void perl_get_host_info(struct IPerlMemInfo* perlMemInfo, + struct IPerlMemInfo* perlMemSharedInfo, + struct IPerlMemInfo* perlMemParseInfo, struct IPerlEnvInfo* perlEnvInfo, struct IPerlStdIOInfo* perlStdIOInfo, struct IPerlLIOInfo* perlLIOInfo, @@ -1320,31 +49,39 @@ perl_get_host_info(struct IPerlMemInfo* perlMemInfo, struct IPerlSockInfo* perlSockInfo, struct IPerlProcInfo* perlProcInfo) { - if(perlMemInfo) { + if (perlMemInfo) { Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*); perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); } - if(perlEnvInfo) { + if (perlMemSharedInfo) { + Copy(&perlMem, &perlMemSharedInfo->perlMemList, perlMemSharedInfo->nCount, void*); + perlMemSharedInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); + } + if (perlMemParseInfo) { + Copy(&perlMem, &perlMemParseInfo->perlMemList, perlMemParseInfo->nCount, void*); + perlMemParseInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); + } + if (perlEnvInfo) { Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*); perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*)); } - if(perlStdIOInfo) { + if (perlStdIOInfo) { Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*); perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*)); } - if(perlLIOInfo) { + if (perlLIOInfo) { Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*); perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*)); } - if(perlDirInfo) { + if (perlDirInfo) { Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*); perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*)); } - if(perlSockInfo) { + if (perlSockInfo) { Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*); perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*)); } - if(perlProcInfo) { + if (perlProcInfo) { Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*); perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*)); } @@ -1352,142 +89,173 @@ perl_get_host_info(struct IPerlMemInfo* perlMemInfo, #ifdef PERL_OBJECT -EXTERN_C PerlInterpreter* perl_alloc_using(struct IPerlMem* pMem, - struct IPerlEnv* pEnv, struct IPerlStdIO* pStdIO, - struct IPerlLIO* pLIO, struct IPerlDir* pDir, - struct IPerlSock* pSock, struct IPerlProc* pProc) +EXTERN_C PerlInterpreter* +perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, + struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, + struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, + struct IPerlDir** ppDir, struct IPerlSock** ppSock, + struct IPerlProc** ppProc) { - CPerlObj* pPerl = NULL; + PerlInterpreter *my_perl = NULL; try { - pPerl = Perl_alloc(pMem, pEnv, pStdIO, pLIO, pDir, pSock, pProc); + CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv, + ppStdIO, ppLIO, ppDir, ppSock, ppProc); + + if (pHost) { + my_perl = perl_alloc_using(pHost->m_pHostperlMem, + pHost->m_pHostperlMemShared, + pHost->m_pHostperlMemParse, + pHost->m_pHostperlEnv, + pHost->m_pHostperlStdIO, + pHost->m_pHostperlLIO, + pHost->m_pHostperlDir, + pHost->m_pHostperlSock, + pHost->m_pHostperlProc); + if (my_perl) { + CPerlObj* pPerl = (CPerlObj*)my_perl; + w32_internal_host = pHost; + } + } } catch(...) { win32_fprintf(stderr, "%s\n", "Error: Unable to allocate memory"); - pPerl = NULL; - } - if(pPerl) - { - SetPerlInterpreter(pPerl); - return (PerlInterpreter*)pPerl; + my_perl = NULL; } - SetPerlInterpreter(NULL); - return NULL; + + return my_perl; } -#undef perl_alloc -#undef perl_construct -#undef perl_destruct -#undef perl_free -#undef perl_run -#undef perl_parse -EXTERN_C PerlInterpreter* perl_alloc(void) +EXTERN_C PerlInterpreter* +perl_alloc(void) { - CPerlObj* pPerl = NULL; + PerlInterpreter* my_perl = NULL; try { - pPerl = Perl_alloc(&perlMem, &perlEnv, &perlStdIO, &perlLIO, - &perlDir, &perlSock, &perlProc); + CPerlHost* pHost = new CPerlHost(); + if (pHost) { + my_perl = perl_alloc_using(pHost->m_pHostperlMem, + pHost->m_pHostperlMemShared, + pHost->m_pHostperlMemParse, + pHost->m_pHostperlEnv, + pHost->m_pHostperlStdIO, + pHost->m_pHostperlLIO, + pHost->m_pHostperlDir, + pHost->m_pHostperlSock, + pHost->m_pHostperlProc); + if (my_perl) { + CPerlObj* pPerl = (CPerlObj*)my_perl; + w32_internal_host = pHost; + } + } } catch(...) { win32_fprintf(stderr, "%s\n", "Error: Unable to allocate memory"); - pPerl = NULL; - } - if(pPerl) - { - SetPerlInterpreter(pPerl); - return (PerlInterpreter*)pPerl; + my_perl = NULL; } - SetPerlInterpreter(NULL); - return NULL; + + return my_perl; } -EXTERN_C void perl_construct(PerlInterpreter* sv_interp) +EXTERN_C void +perl_construct(PerlInterpreter* my_perl) { - CPerlObj* pPerl = (CPerlObj*)sv_interp; + CPerlObj* pPerl = (CPerlObj*)my_perl; try { - pPerl->perl_construct(); + Perl_construct(); } catch(...) { win32_fprintf(stderr, "%s\n", "Error: Unable to construct data structures"); - pPerl->perl_free(); + CPerlHost* pHost = (CPerlHost*)w32_internal_host; + Perl_free(); + delete pHost; SetPerlInterpreter(NULL); } } -EXTERN_C void perl_destruct(PerlInterpreter* sv_interp) +EXTERN_C void +perl_destruct(PerlInterpreter* my_perl) { - CPerlObj* pPerl = (CPerlObj*)sv_interp; + CPerlObj* pPerl = (CPerlObj*)my_perl; +#ifdef DEBUGGING + Perl_destruct(); +#else try { - pPerl->perl_destruct(); + Perl_destruct(); } catch(...) { } +#endif } -EXTERN_C void perl_free(PerlInterpreter* sv_interp) +EXTERN_C void +perl_free(PerlInterpreter* my_perl) { - CPerlObj* pPerl = (CPerlObj*)sv_interp; + CPerlObj* pPerl = (CPerlObj*)my_perl; +#ifdef DEBUGGING + CPerlHost* pHost = (CPerlHost*)w32_internal_host; + Perl_free(); + delete pHost; +#else try { - pPerl->perl_free(); + CPerlHost* pHost = (CPerlHost*)w32_internal_host; + Perl_free(); + delete pHost; } catch(...) { } +#endif SetPerlInterpreter(NULL); } -EXTERN_C int perl_run(PerlInterpreter* sv_interp) +EXTERN_C int +perl_run(PerlInterpreter* my_perl) { - CPerlObj* pPerl = (CPerlObj*)sv_interp; + CPerlObj* pPerl = (CPerlObj*)my_perl; +#ifdef DEBUGGING + return Perl_run(); +#else int retVal; try { - retVal = pPerl->perl_run(); + retVal = Perl_run(); } -/* - catch(int x) - { - // this is where exit() should arrive - retVal = x; - } -*/ catch(...) { win32_fprintf(stderr, "Error: Runtime exception\n"); retVal = -1; } return retVal; +#endif } -EXTERN_C int perl_parse(PerlInterpreter* sv_interp, void (*xsinit)(CPerlObj*), int argc, char** argv, char** env) +EXTERN_C int +perl_parse(PerlInterpreter* my_perl, void (*xsinit)(CPerlObj*), int argc, char** argv, char** env) { int retVal; - CPerlObj* pPerl = (CPerlObj*)sv_interp; + CPerlObj* pPerl = (CPerlObj*)my_perl; +#ifdef DEBUGGING + retVal = Perl_parse(xsinit, argc, argv, env); +#else try { - retVal = pPerl->perl_parse(xsinit, argc, argv, env); + retVal = Perl_parse(xsinit, argc, argv, env); } -/* - catch(int x) - { - // this is where exit() should arrive - retVal = x; - } -*/ catch(...) { win32_fprintf(stderr, "Error: Parse exception\n"); retVal = -1; } +#endif *win32_errno() = 0; return retVal; } @@ -1500,15 +268,30 @@ EXTERN_C int perl_parse(PerlInterpreter* sv_interp, void (*xsinit)(CPerlObj*), i EXTERN_C PerlInterpreter* perl_alloc(void) { - return perl_alloc_using(&perlMem, &perlEnv, &perlStdIO, &perlLIO, - &perlDir, &perlSock, &perlProc); + PerlInterpreter *my_perl = NULL; + CPerlHost* pHost = new CPerlHost(); + if (pHost) { + my_perl = perl_alloc_using(pHost->m_pHostperlMem, + pHost->m_pHostperlMemShared, + pHost->m_pHostperlMemParse, + pHost->m_pHostperlEnv, + pHost->m_pHostperlStdIO, + pHost->m_pHostperlLIO, + pHost->m_pHostperlDir, + pHost->m_pHostperlSock, + pHost->m_pHostperlProc); + if (my_perl) { + w32_internal_host = pHost; + } + } + return my_perl; } #endif /* PERL_OBJECT */ - #endif /* PERL_IMPLICIT_SYS */ -extern HANDLE w32_perldll_handle; +EXTERN_C HANDLE w32_perldll_handle; + static DWORD g_TlsAllocIndex; EXTERN_C DllExport bool @@ -1563,9 +346,24 @@ RunPerl(int argc, char **argv, char **env) exitstatus = perl_parse(my_perl, xs_init, argc, argv, env); if (!exitstatus) { -#ifdef USE_ITHREADS /* XXXXXX testing */ - new_perl = perl_clone(my_perl, 0); - Perl_push_scope(new_perl); /* ENTER; (hack in lieu of perl_destruct()) */ +#if defined(TOP_CLONE) && defined(USE_ITHREADS) /* XXXXXX testing */ +# ifdef PERL_OBJECT + CPerlHost *h = new CPerlHost(); + new_perl = perl_clone_using(my_perl, 1, + h->m_pHostperlMem, + h->m_pHostperlMemShared, + h->m_pHostperlMemParse, + h->m_pHostperlEnv, + h->m_pHostperlStdIO, + h->m_pHostperlLIO, + h->m_pHostperlDir, + h->m_pHostperlSock, + h->m_pHostperlProc + ); + CPerlObj *pPerl = (CPerlObj*)new_perl; +# else + new_perl = perl_clone(my_perl, 1); +# endif exitstatus = perl_run( new_perl ); SetPerlInterpreter(my_perl); #else @@ -1606,7 +404,7 @@ DllMain(HANDLE hModule, /* DLL module handle */ _fmode = O_BINARY; #endif g_TlsAllocIndex = TlsAlloc(); - DisableThreadLibraryCalls(hModule); + DisableThreadLibraryCalls((HMODULE)hModule); w32_perldll_handle = hModule; break; @@ -1630,4 +428,3 @@ DllMain(HANDLE hModule, /* DLL module handle */ } return TRUE; } - diff --git a/win32/runperl.c b/win32/runperl.c index 8e6b249b44..85fd831759 100644 --- a/win32/runperl.c +++ b/win32/runperl.c @@ -2,10 +2,6 @@ #include "perl.h" #ifdef __GNUC__ -/* - * GNU C does not do __declspec() - */ -#define __declspec(foo) /* Mingw32 defaults to globing command line * This is inconsistent with other Win32 ports and diff --git a/win32/vdir.h b/win32/vdir.h new file mode 100644 index 0000000000..50822a7aa4 --- /dev/null +++ b/win32/vdir.h @@ -0,0 +1,505 @@ +/* vdir.h + * + * (c) 1999 Microsoft Corporation. All rights reserved. + * Portions (c) 1999 ActiveState Tool Corp, http://www.ActiveState.com/ + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + */ + +#ifndef ___VDir_H___ +#define ___VDir_H___ + +const int driveCount = 30; + +class VDir +{ +public: + VDir(int bManageDir = 1); + ~VDir() {}; + + void Init(VDir* pDir, VMem *pMem); + void SetDefaultA(char const *pDefault); + void SetDefaultW(WCHAR const *pDefault); + char* MapPathA(const char *pInName); + WCHAR* MapPathW(const WCHAR *pInName); + int SetCurrentDirectoryA(char *lpBuffer); + int SetCurrentDirectoryW(WCHAR *lpBuffer); + inline const char *GetDirA(int index) + { + return dirTableA[index]; + }; + inline const WCHAR *GetDirW(int index) + { + return dirTableW[index]; + }; + inline int GetDefault(void) { return nDefault; }; + + inline char* GetCurrentDirectoryA(int dwBufSize, char *lpBuffer) + { + char* ptr = dirTableA[nDefault]; + while (dwBufSize--) + { + if ((*lpBuffer++ = *ptr++) == '\0') + break; + } + return lpBuffer; + }; + inline WCHAR* GetCurrentDirectoryW(int dwBufSize, WCHAR *lpBuffer) + { + WCHAR* ptr = dirTableW[nDefault]; + while (dwBufSize--) + { + if ((*lpBuffer++ = *ptr++) == '\0') + break; + } + return lpBuffer; + }; + + + DWORD CalculateEnvironmentSpace(void); + LPSTR BuildEnvironmentSpace(LPSTR lpStr); + +protected: + int SetDirA(char const *pPath, int index); + void FromEnvA(char *pEnv, int index); + inline const char *GetDefaultDirA(void) + { + return dirTableA[nDefault]; + }; + + inline void SetDefaultDirA(char const *pPath, int index) + { + SetDirA(pPath, index); + nDefault = index; + }; + int SetDirW(WCHAR const *pPath, int index); + inline const WCHAR *GetDefaultDirW(void) + { + return dirTableW[nDefault]; + }; + + inline void SetDefaultDirW(WCHAR const *pPath, int index) + { + SetDirW(pPath, index); + nDefault = index; + }; + + inline int DriveIndex(char chr) + { + return (chr | 0x20)-'a'; + }; + + VMem *pMem; + int nDefault, bManageDirectory; + char *dirTableA[driveCount]; + char szLocalBufferA[MAX_PATH+1]; + WCHAR *dirTableW[driveCount]; + WCHAR szLocalBufferW[MAX_PATH+1]; +}; + + +VDir::VDir(int bManageDir /* = 1 */) +{ + nDefault = 0; + bManageDirectory = bManageDir; + memset(dirTableA, 0, sizeof(dirTableA)); + memset(dirTableW, 0, sizeof(dirTableW)); +} + +void VDir::Init(VDir* pDir, VMem *p) +{ + int index; + DWORD driveBits; + int nSave; + char szBuffer[MAX_PATH*driveCount]; + + pMem = p; + if (pDir) { + for (index = 0; index < driveCount; ++index) { + SetDirW(pDir->GetDirW(index), index); + } + nDefault = pDir->GetDefault(); + } + else { + nSave = bManageDirectory; + bManageDirectory = 0; + driveBits = GetLogicalDrives(); + if (GetLogicalDriveStrings(sizeof(szBuffer), szBuffer)) { + char* pEnv = GetEnvironmentStrings(); + char* ptr = szBuffer; + for (index = 0; index < driveCount; ++index) { + if (driveBits & (1<<index)) { + ptr += SetDirA(ptr, index) + 1; + FromEnvA(pEnv, index); + } + } + FreeEnvironmentStrings(pEnv); + } + SetDefaultA("."); + bManageDirectory = nSave; + } +} + +int VDir::SetDirA(char const *pPath, int index) +{ + char chr, *ptr; + int length = 0; + WCHAR wBuffer[MAX_PATH+1]; + if (index < driveCount && pPath != NULL) { + length = strlen(pPath); + pMem->Free(dirTableA[index]); + ptr = dirTableA[index] = (char*)pMem->Malloc(length+2); + if (ptr != NULL) { + strcpy(ptr, pPath); + ptr += length-1; + chr = *ptr++; + if (chr != '\\' && chr != '/') { + *ptr++ = '\\'; + *ptr = '\0'; + } + MultiByteToWideChar(CP_ACP, 0, dirTableA[index], -1, + wBuffer, (sizeof(wBuffer)/sizeof(WCHAR))); + length = wcslen(wBuffer); + pMem->Free(dirTableW[index]); + dirTableW[index] = (WCHAR*)pMem->Malloc((length+1)*2); + if (dirTableW[index] != NULL) { + wcscpy(dirTableW[index], wBuffer); + } + } + } + + if(bManageDirectory) + ::SetCurrentDirectoryA(pPath); + + return length; +} + +void VDir::FromEnvA(char *pEnv, int index) +{ /* gets the directory for index from the environment variable. */ + while (*pEnv != '\0') { + if ((pEnv[0] == '=') && (DriveIndex(pEnv[1]) == index)) { + SetDirA(&pEnv[4], index); + break; + } + else + pEnv += strlen(pEnv)+1; + } +} + +void VDir::SetDefaultA(char const *pDefault) +{ + char szBuffer[MAX_PATH+1]; + char *pPtr; + + if (GetFullPathNameA(pDefault, sizeof(szBuffer), szBuffer, &pPtr)) { + if (*pDefault != '.' && pPtr != NULL) + *pPtr = '\0'; + + SetDefaultDirA(szBuffer, DriveIndex(szBuffer[0])); + } +} + +int VDir::SetDirW(WCHAR const *pPath, int index) +{ + WCHAR chr, *ptr; + char szBuffer[MAX_PATH+1]; + int length = 0; + if (index < driveCount && pPath != NULL) { + length = wcslen(pPath); + pMem->Free(dirTableW[index]); + ptr = dirTableW[index] = (WCHAR*)pMem->Malloc((length+2)*2); + if (ptr != NULL) { + wcscpy(ptr, pPath); + ptr += length-1; + chr = *ptr++; + if (chr != '\\' && chr != '/') { + *ptr++ = '\\'; + *ptr = '\0'; + } + WideCharToMultiByte(CP_ACP, 0, dirTableW[index], -1, szBuffer, sizeof(szBuffer), NULL, NULL); + length = strlen(szBuffer); + pMem->Free(dirTableA[index]); + dirTableA[index] = (char*)pMem->Malloc(length+1); + if (dirTableA[index] != NULL) { + strcpy(dirTableA[index], szBuffer); + } + } + } + + if(bManageDirectory) + ::SetCurrentDirectoryW(pPath); + + return length; +} + +void VDir::SetDefaultW(WCHAR const *pDefault) +{ + WCHAR szBuffer[MAX_PATH+1]; + WCHAR *pPtr; + + if (GetFullPathNameW(pDefault, (sizeof(szBuffer)/sizeof(WCHAR)), szBuffer, &pPtr)) { + if (*pDefault != '.' && pPtr != NULL) + *pPtr = '\0'; + + SetDefaultDirW(szBuffer, DriveIndex((char)szBuffer[0])); + } +} + +inline BOOL IsPathSep(char ch) +{ + return (ch == '\\' || ch == '/'); +} + +inline void DoGetFullPathNameA(char* lpBuffer, DWORD dwSize, char* Dest) +{ + char *pPtr; + + /* + * On WinNT GetFullPathName does not fail, (or at least always + * succeeds when the drive is valid) WinNT does set *Dest to Nullch + * On Win98 GetFullPathName will set last error if it fails, but + * does not touch *Dest + */ + *Dest = '\0'; + GetFullPathNameA(lpBuffer, dwSize, Dest, &pPtr); +} + +char *VDir::MapPathA(const char *pInName) +{ /* + * possiblities -- relative path or absolute path with or without drive letter + * OR UNC name + */ + char szBuffer[(MAX_PATH+1)*2]; + char szlBuf[MAX_PATH+1]; + + if (strlen(pInName) > MAX_PATH) { + strncpy(szlBuf, pInName, MAX_PATH); + if (IsPathSep(pInName[0]) && !IsPathSep(pInName[1])) { + /* absolute path - reduce length by 2 for drive specifier */ + szlBuf[MAX_PATH-2] = '\0'; + } + else + szlBuf[MAX_PATH] = '\0'; + pInName = szlBuf; + } + /* strlen(pInName) is now <= MAX_PATH */ + + if (pInName[1] == ':') { + /* has drive letter */ + if (IsPathSep(pInName[2])) { + /* absolute with drive letter */ + strcpy(szLocalBufferA, pInName); + } + else { + /* relative path with drive letter */ + strcpy(szBuffer, GetDirA(DriveIndex(*pInName))); + strcat(szBuffer, &pInName[2]); + if(strlen(szBuffer) > MAX_PATH) + szBuffer[MAX_PATH] = '\0'; + + DoGetFullPathNameA(szBuffer, sizeof(szLocalBufferA), szLocalBufferA); + } + } + else { + /* no drive letter */ + if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) { + /* UNC name */ + strcpy(szLocalBufferA, pInName); + } + else { + strcpy(szBuffer, GetDefaultDirA()); + if (IsPathSep(pInName[0])) { + /* absolute path */ + szLocalBufferA[0] = szBuffer[0]; + szLocalBufferA[1] = szBuffer[1]; + strcpy(&szLocalBufferA[2], pInName); + } + else { + /* relative path */ + strcat(szBuffer, pInName); + if (strlen(szBuffer) > MAX_PATH) + szBuffer[MAX_PATH] = '\0'; + + DoGetFullPathNameA(szBuffer, sizeof(szLocalBufferA), szLocalBufferA); + } + } + } + + return szLocalBufferA; +} + +int VDir::SetCurrentDirectoryA(char *lpBuffer) +{ + HANDLE hHandle; + WIN32_FIND_DATA win32FD; + char szBuffer[MAX_PATH+1], *pPtr; + int length, nRet = -1; + + GetFullPathNameA(MapPathA(lpBuffer), sizeof(szBuffer), szBuffer, &pPtr); + /* if the last char is a '\\' or a '/' then add + * an '*' before calling FindFirstFile + */ + length = strlen(szBuffer); + if(length > 0 && IsPathSep(szBuffer[length-1])) { + szBuffer[length] = '*'; + szBuffer[length+1] = '\0'; + } + + hHandle = FindFirstFileA(szBuffer, &win32FD); + if (hHandle != INVALID_HANDLE_VALUE) { + FindClose(hHandle); + + /* if an '*' was added remove it */ + if(szBuffer[length] == '*') + szBuffer[length] = '\0'; + + SetDefaultDirA(szBuffer, DriveIndex(szBuffer[0])); + nRet = 0; + } + return nRet; +} + +DWORD VDir::CalculateEnvironmentSpace(void) +{ /* the current directory environment strings are stored as '=d=d:\path' */ + int index; + DWORD dwSize = 0; + for (index = 0; index < driveCount; ++index) { + if (dirTableA[index] != NULL) { + dwSize += strlen(dirTableA[index]) + 4; /* add 1 for trailing NULL and 3 for '=d=' */ + } + } + return dwSize; +} + +LPSTR VDir::BuildEnvironmentSpace(LPSTR lpStr) +{ /* store the current directory environment strings as '=d=d:\path' */ + int index; + LPSTR lpDirStr; + for (index = 0; index < driveCount; ++index) { + lpDirStr = dirTableA[index]; + if (lpDirStr != NULL) { + lpStr[0] = '='; + lpStr[1] = lpDirStr[0]; + lpStr[2] = '='; + strcpy(&lpStr[3], lpDirStr); + lpStr += strlen(lpDirStr) + 4; /* add 1 for trailing NULL and 3 for '=d=' */ + } + } + return lpStr; +} + +inline BOOL IsPathSep(WCHAR ch) +{ + return (ch == '\\' || ch == '/'); +} + +inline void DoGetFullPathNameW(WCHAR* lpBuffer, DWORD dwSize, WCHAR* Dest) +{ + WCHAR *pPtr; + + /* + * On WinNT GetFullPathName does not fail, (or at least always + * succeeds when the drive is valid) WinNT does set *Dest to Nullch + * On Win98 GetFullPathName will set last error if it fails, but + * does not touch *Dest + */ + *Dest = '\0'; + GetFullPathNameW(lpBuffer, dwSize, Dest, &pPtr); +} + +WCHAR* VDir::MapPathW(const WCHAR *pInName) +{ /* + * possiblities -- relative path or absolute path with or without drive letter + * OR UNC name + */ + WCHAR szBuffer[(MAX_PATH+1)*2]; + WCHAR szlBuf[MAX_PATH+1]; + + if (wcslen(pInName) > MAX_PATH) { + wcsncpy(szlBuf, pInName, MAX_PATH); + if (IsPathSep(pInName[0]) && !IsPathSep(pInName[1])) { + /* absolute path - reduce length by 2 for drive specifier */ + szlBuf[MAX_PATH-2] = '\0'; + } + else + szlBuf[MAX_PATH] = '\0'; + pInName = szlBuf; + } + /* strlen(pInName) is now <= MAX_PATH */ + + if (pInName[1] == ':') { + /* has drive letter */ + if (IsPathSep(pInName[2])) { + /* absolute with drive letter */ + wcscpy(szLocalBufferW, pInName); + } + else { + /* relative path with drive letter */ + wcscpy(szBuffer, GetDirW(DriveIndex((char)*pInName))); + wcscat(szBuffer, &pInName[2]); + if(wcslen(szBuffer) > MAX_PATH) + szBuffer[MAX_PATH] = '\0'; + + DoGetFullPathNameW(szBuffer, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW); + } + } + else { + /* no drive letter */ + if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) { + /* UNC name */ + wcscpy(szLocalBufferW, pInName); + } + else { + wcscpy(szBuffer, GetDefaultDirW()); + if (IsPathSep(pInName[0])) { + /* absolute path */ + szLocalBufferW[0] = szBuffer[0]; + szLocalBufferW[1] = szBuffer[1]; + wcscpy(&szLocalBufferW[2], pInName); + } + else { + /* relative path */ + wcscat(szBuffer, pInName); + if (wcslen(szBuffer) > MAX_PATH) + szBuffer[MAX_PATH] = '\0'; + + DoGetFullPathNameW(szBuffer, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW); + } + } + } + return szLocalBufferW; +} + +int VDir::SetCurrentDirectoryW(WCHAR *lpBuffer) +{ + HANDLE hHandle; + WIN32_FIND_DATAW win32FD; + WCHAR szBuffer[MAX_PATH+1], *pPtr; + int length, nRet = -1; + + GetFullPathNameW(MapPathW(lpBuffer), (sizeof(szBuffer)/sizeof(WCHAR)), szBuffer, &pPtr); + /* if the last char is a '\\' or a '/' then add + * an '*' before calling FindFirstFile + */ + length = wcslen(szBuffer); + if(length > 0 && IsPathSep(szBuffer[length-1])) { + szBuffer[length] = '*'; + szBuffer[length+1] = '\0'; + } + + hHandle = FindFirstFileW(szBuffer, &win32FD); + if (hHandle != INVALID_HANDLE_VALUE) { + FindClose(hHandle); + + /* if an '*' was added remove it */ + if(szBuffer[length] == '*') + szBuffer[length] = '\0'; + + SetDefaultDirW(szBuffer, DriveIndex((char)szBuffer[0])); + nRet = 0; + } + return nRet; +} + +#endif /* ___VDir_H___ */ diff --git a/win32/vmem.h b/win32/vmem.h new file mode 100644 index 0000000000..cf3f502ca0 --- /dev/null +++ b/win32/vmem.h @@ -0,0 +1,703 @@ +/* vmem.h + * + * (c) 1999 Microsoft Corporation. All rights reserved. + * Portions (c) 1999 ActiveState Tool Corp, http://www.ActiveState.com/ + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * + * Knuth's boundary tag algorithm Vol #1, Page 440. + * + * Each block in the heap has tag words before and after it, + * TAG + * block + * TAG + * The size is stored in these tags as a long word, and includes the 8 bytes + * of overhead that the boundary tags consume. Blocks are allocated on long + * word boundaries, so the size is always multiples of long words. When the + * block is allocated, bit 0, (the tag bit), of the size is set to 1. When + * a block is freed, it is merged with adjacent free blocks, and the tag bit + * is set to 0. + * + * A linked list is used to manage the free list. The first two long words of + * the block contain double links. These links are only valid when the block + * is freed, therefore space needs to be reserved for them. Thus, the minimum + * block size (not counting the tags) is 8 bytes. + * + * Since memory allocation may occur on a single threaded, explict locks are + * provided. + * + */ + +#ifndef ___VMEM_H_INC___ +#define ___VMEM_H_INC___ + +const long lAllocStart = 0x00010000; /* start at 64K */ +const long minBlockSize = sizeof(void*)*2; +const long sizeofTag = sizeof(long); +const long blockOverhead = sizeofTag*2; +const long minAllocSize = minBlockSize+blockOverhead; + +typedef BYTE* PBLOCK; /* pointer to a memory block */ + +/* + * Macros for accessing hidden fields in a memory block: + * + * SIZE size of this block (tag bit 0 is 1 if block is allocated) + * PSIZE size of previous physical block + */ + +#define SIZE(block) (*(ULONG*)(((PBLOCK)(block))-sizeofTag)) +#define PSIZE(block) (*(ULONG*)(((PBLOCK)(block))-(sizeofTag*2))) +inline void SetTags(PBLOCK block, long size) +{ + SIZE(block) = size; + PSIZE(block+(size&~1)) = size; +} + +/* + * Free list pointers + * PREV pointer to previous block + * NEXT pointer to next block + */ + +#define PREV(block) (*(PBLOCK*)(block)) +#define NEXT(block) (*(PBLOCK*)((block)+sizeof(PBLOCK))) +inline void SetLink(PBLOCK block, PBLOCK prev, PBLOCK next) +{ + PREV(block) = prev; + NEXT(block) = next; +} +inline void Unlink(PBLOCK p) +{ + PBLOCK next = NEXT(p); + PBLOCK prev = PREV(p); + NEXT(prev) = next; + PREV(next) = prev; +} +inline void AddToFreeList(PBLOCK block, PBLOCK pInList) +{ + PBLOCK next = NEXT(pInList); + NEXT(pInList) = block; + SetLink(block, pInList, next); + PREV(next) = block; +} + + +/* Macro for rounding up to the next sizeof(long) */ +#define ROUND_UP(n) (((ULONG)(n)+sizeof(long)-1)&~(sizeof(long)-1)) +#define ROUND_UP64K(n) (((ULONG)(n)+0x10000-1)&~(0x10000-1)) +#define ROUND_DOWN(n) ((ULONG)(n)&~(sizeof(long)-1)) + +/* + * HeapRec - a list of all non-contiguous heap areas + * + * Each record in this array contains information about a non-contiguous heap area. + */ + +const int maxHeaps = 64; +const long lAllocMax = 0x80000000; /* max size of allocation */ + +typedef struct _HeapRec +{ + PBLOCK base; /* base of heap area */ + ULONG len; /* size of heap area */ +} HeapRec; + + +class VMem +{ +public: + VMem(); + ~VMem(); + virtual void* Malloc(size_t size); + virtual void* Realloc(void* pMem, size_t size); + virtual void Free(void* pMem); + virtual void GetLock(void); + virtual void FreeLock(void); + virtual int IsLocked(void); + virtual long Release(void); + virtual long AddRef(void); + + inline BOOL CreateOk(void) + { + return m_hHeap != NULL; + }; + + void ReInit(void); + +protected: + void Init(void); + int Getmem(size_t size); + int HeapAdd(void* ptr, size_t size); + void* Expand(void* block, size_t size); + void WalkHeap(void); + + HANDLE m_hHeap; // memory heap for this script + char m_FreeDummy[minAllocSize]; // dummy free block + PBLOCK m_pFreeList; // pointer to first block on free list + PBLOCK m_pRover; // roving pointer into the free list + HeapRec m_heaps[maxHeaps]; // list of all non-contiguous heap areas + int m_nHeaps; // no. of heaps in m_heaps + long m_lAllocSize; // current alloc size + long m_lRefCount; // number of current users + CRITICAL_SECTION m_cs; // access lock +}; + +// #define _DEBUG_MEM +#ifdef _DEBUG_MEM +#define ASSERT(f) if(!(f)) DebugBreak(); + +inline void MEMODS(char *str) +{ + OutputDebugString(str); + OutputDebugString("\n"); +} + +inline void MEMODSlx(char *str, long x) +{ + char szBuffer[512]; + sprintf(szBuffer, "%s %lx\n", str, x); + OutputDebugString(szBuffer); +} + +#define WALKHEAP() WalkHeap() +#define WALKHEAPTRACE() m_pRover = NULL; WalkHeap() + +#else + +#define ASSERT(f) +#define MEMODS(x) +#define MEMODSlx(x, y) +#define WALKHEAP() +#define WALKHEAPTRACE() + +#endif + + +VMem::VMem() +{ + m_lRefCount = 1; + BOOL bRet = (NULL != (m_hHeap = HeapCreate(HEAP_NO_SERIALIZE, + lAllocStart, /* initial size of heap */ + 0))); /* no upper limit on size of heap */ + ASSERT(bRet); + + InitializeCriticalSection(&m_cs); + + Init(); +} + +VMem::~VMem(void) +{ + ASSERT(HeapValidate(m_hHeap, HEAP_NO_SERIALIZE, NULL)); + WALKHEAPTRACE(); + DeleteCriticalSection(&m_cs); + BOOL bRet = HeapDestroy(m_hHeap); + ASSERT(bRet); +} + +void VMem::ReInit(void) +{ + for(int index = 0; index < m_nHeaps; ++index) + HeapFree(m_hHeap, HEAP_NO_SERIALIZE, m_heaps[index].base); + + Init(); +} + +void VMem::Init(void) +{ /* + * Initialize the free list by placing a dummy zero-length block on it. + * Set the number of non-contiguous heaps to zero. + */ + m_pFreeList = m_pRover = (PBLOCK)(&m_FreeDummy[minBlockSize]); + PSIZE(m_pFreeList) = SIZE(m_pFreeList) = 0; + PREV(m_pFreeList) = NEXT(m_pFreeList) = m_pFreeList; + + m_nHeaps = 0; + m_lAllocSize = lAllocStart; +} + +void* VMem::Malloc(size_t size) +{ + WALKHEAP(); + + /* + * Adjust the real size of the block to be a multiple of sizeof(long), and add + * the overhead for the boundary tags. Disallow negative or zero sizes. + */ + size_t realsize = (size < blockOverhead) ? minAllocSize : (size_t)ROUND_UP(size) + minBlockSize; + if((int)realsize < minAllocSize || size == 0) + return NULL; + + /* + * Start searching the free list at the rover. If we arrive back at rover without + * finding anything, allocate some memory from the heap and try again. + */ + PBLOCK ptr = m_pRover; /* start searching at rover */ + int loops = 2; /* allow two times through the loop */ + for(;;) { + size_t lsize = SIZE(ptr); + ASSERT((lsize&1)==0); + /* is block big enough? */ + if(lsize >= realsize) { + /* if the remainder is too small, don't bother splitting the block. */ + size_t rem = lsize - realsize; + if(rem < minAllocSize) { + if(m_pRover == ptr) + m_pRover = NEXT(ptr); + + /* Unlink the block from the free list. */ + Unlink(ptr); + } + else { + /* + * split the block + * The remainder is big enough to split off into a new block. + * Use the end of the block, resize the beginning of the block + * no need to change the free list. + */ + SetTags(ptr, rem); + ptr += SIZE(ptr); + lsize = realsize; + } + /* Set the boundary tags to mark it as allocated. */ + SetTags(ptr, lsize | 1); + return ((void *)ptr); + } + + /* + * This block was unsuitable. If we've gone through this list once already without + * finding anything, allocate some new memory from the heap and try again. + */ + ptr = NEXT(ptr); + if(ptr == m_pRover) { + if(!(loops-- && Getmem(realsize))) { + return NULL; + } + ptr = m_pRover; + } + } +} + +void* VMem::Realloc(void* block, size_t size) +{ + WALKHEAP(); + + /* if size is zero, free the block. */ + if(size == 0) { + Free(block); + return (NULL); + } + + /* if block pointer is NULL, do a Malloc(). */ + if(block == NULL) + return Malloc(size); + + /* + * Grow or shrink the block in place. + * if the block grows then the next block will be used if free + */ + if(Expand(block, size) != NULL) + return block; + + /* + * adjust the real size of the block to be a multiple of sizeof(long), and add the + * overhead for the boundary tags. Disallow negative or zero sizes. + */ + size_t realsize = (size < blockOverhead) ? minAllocSize : (size_t)ROUND_UP(size) + minBlockSize; + if((int)realsize < minAllocSize) + return NULL; + + /* + * see if the previous block is free, and is it big enough to cover the new size + * if merged with the current block. + */ + PBLOCK ptr = (PBLOCK)block; + size_t cursize = SIZE(ptr) & ~1; + size_t psize = PSIZE(ptr); + if((psize&1) == 0 && (psize + cursize) >= realsize) { + PBLOCK prev = ptr - psize; + if(m_pRover == prev) + m_pRover = NEXT(prev); + + /* Unlink the next block from the free list. */ + Unlink(prev); + + /* Copy contents of old block to new location, make it the current block. */ + memmove(prev, ptr, cursize); + cursize += psize; /* combine sizes */ + ptr = prev; + + size_t rem = cursize - realsize; + if(rem >= minAllocSize) { + /* + * The remainder is big enough to be a new block. Set boundary + * tags for the resized block and the new block. + */ + prev = ptr + realsize; + /* + * add the new block to the free list. + * next block cannot be free + */ + SetTags(prev, rem); + AddToFreeList(prev, m_pFreeList); + cursize = realsize; + } + /* Set the boundary tags to mark it as allocated. */ + SetTags(ptr, cursize | 1); + return ((void *)ptr); + } + + /* Allocate a new block, copy the old to the new, and free the old. */ + if((ptr = (PBLOCK)Malloc(size)) != NULL) { + memmove(ptr, block, cursize-minBlockSize); + Free(block); + } + return ((void *)ptr); +} + +void VMem::Free(void* p) +{ + WALKHEAP(); + + /* Ignore null pointer. */ + if(p == NULL) + return; + + PBLOCK ptr = (PBLOCK)p; + + /* Check for attempt to free a block that's already free. */ + size_t size = SIZE(ptr); + if((size&1) == 0) { + MEMODSlx("Attempt to free previously freed block", (long)p); + return; + } + size &= ~1; /* remove allocated tag */ + + /* if previous block is free, add this block to it. */ + int linked = FALSE; + size_t psize = PSIZE(ptr); + if((psize&1) == 0) { + ptr -= psize; /* point to previous block */ + size += psize; /* merge the sizes of the two blocks */ + linked = TRUE; /* it's already on the free list */ + } + + /* if the next physical block is free, merge it with this block. */ + PBLOCK next = ptr + size; /* point to next physical block */ + size_t nsize = SIZE(next); + if((nsize&1) == 0) { + /* block is free move rover if needed */ + if(m_pRover == next) + m_pRover = NEXT(next); + + /* unlink the next block from the free list. */ + Unlink(next); + + /* merge the sizes of this block and the next block. */ + size += nsize; + } + + /* Set the boundary tags for the block; */ + SetTags(ptr, size); + + /* Link the block to the head of the free list. */ + if(!linked) { + AddToFreeList(ptr, m_pFreeList); + } +} + +void VMem::GetLock(void) +{ + EnterCriticalSection(&m_cs); +} + +void VMem::FreeLock(void) +{ + LeaveCriticalSection(&m_cs); +} + +int VMem::IsLocked(void) +{ + BOOL bAccessed = TryEnterCriticalSection(&m_cs); + if(bAccessed) { + LeaveCriticalSection(&m_cs); + } + return !bAccessed; +} + + +long VMem::Release(void) +{ + long lCount = InterlockedDecrement(&m_lRefCount); + if(!lCount) + delete this; + return lCount; +} + +long VMem::AddRef(void) +{ + long lCount = InterlockedIncrement(&m_lRefCount); + return lCount; +} + + +int VMem::Getmem(size_t requestSize) +{ /* returns -1 is successful 0 if not */ + void *ptr; + + /* Round up size to next multiple of 64K. */ + size_t size = (size_t)ROUND_UP64K(requestSize); + + /* + * if the size requested is smaller than our current allocation size + * adjust up + */ + if(size < (unsigned long)m_lAllocSize) + size = m_lAllocSize; + + /* Update the size to allocate on the next request */ + if(m_lAllocSize != lAllocMax) + m_lAllocSize <<= 1; + + if(m_nHeaps != 0) { + /* Expand the last allocated heap */ + ptr = HeapReAlloc(m_hHeap, HEAP_REALLOC_IN_PLACE_ONLY|HEAP_ZERO_MEMORY|HEAP_NO_SERIALIZE, + m_heaps[m_nHeaps-1].base, + m_heaps[m_nHeaps-1].len + size); + if(ptr != 0) { + HeapAdd(((char*)ptr) + m_heaps[m_nHeaps-1].len, size); + return -1; + } + } + + /* + * if we didn't expand a block to cover the requested size + * allocate a new Heap + * the size of this block must include the additional dummy tags at either end + * the above ROUND_UP64K may not have added any memory to include this. + */ + if(size == requestSize) + size = (size_t)ROUND_UP64K(requestSize+(sizeofTag*2)); + + ptr = HeapAlloc(m_hHeap, HEAP_ZERO_MEMORY|HEAP_NO_SERIALIZE, size); + if(ptr == 0) { + MEMODSlx("HeapAlloc failed on size!!!", size); + return 0; + } + + HeapAdd(ptr, size); + return -1; +} + +int VMem::HeapAdd(void *p, size_t size) +{ /* if the block can be succesfully added to the heap, returns 0; otherwise -1. */ + int index; + + /* Check size, then round size down to next long word boundary. */ + if(size < minAllocSize) + return -1; + + size = (size_t)ROUND_DOWN(size); + PBLOCK ptr = (PBLOCK)p; + + /* + * Search for another heap area that's contiguous with the bottom of this new area. + * (It should be extremely unusual to find one that's contiguous with the top). + */ + for(index = 0; index < m_nHeaps; ++index) { + if(ptr == m_heaps[index].base + (int)m_heaps[index].len) { + /* + * The new block is contiguous with a previously allocated heap area. Add its + * length to that of the previous heap. Merge it with the the dummy end-of-heap + * area marker of the previous heap. + */ + m_heaps[index].len += size; + break; + } + } + + if(index == m_nHeaps) { + /* The new block is not contiguous. Add it to the heap list. */ + if(m_nHeaps == maxHeaps) { + return -1; /* too many non-contiguous heaps */ + } + m_heaps[m_nHeaps].base = ptr; + m_heaps[m_nHeaps].len = size; + m_nHeaps++; + + /* + * Reserve the first LONG in the block for the ending boundary tag of a dummy + * block at the start of the heap area. + */ + size -= minBlockSize; + ptr += minBlockSize; + PSIZE(ptr) = 1; /* mark the dummy previous block as allocated */ + } + + /* + * Convert the heap to one large block. Set up its boundary tags, and those of + * marker block after it. The marker block before the heap will already have + * been set up if this heap is not contiguous with the end of another heap. + */ + SetTags(ptr, size | 1); + PBLOCK next = ptr + size; /* point to dummy end block */ + SIZE(next) = 1; /* mark the dummy end block as allocated */ + + /* + * Link the block to the start of the free list by calling free(). + * This will merge the block with any adjacent free blocks. + */ + Free(ptr); + return 0; +} + + +void* VMem::Expand(void* block, size_t size) +{ + /* + * Adjust the size of the block to be a multiple of sizeof(long), and add the + * overhead for the boundary tags. Disallow negative or zero sizes. + */ + size_t realsize = (size < blockOverhead) ? minAllocSize : (size_t)ROUND_UP(size) + minBlockSize; + if((int)realsize < minAllocSize || size == 0) + return NULL; + + PBLOCK ptr = (PBLOCK)block; + + /* if the current size is the same as requested, do nothing. */ + size_t cursize = SIZE(ptr) & ~1; + if(cursize == realsize) { + return block; + } + + /* if the block is being shrunk, convert the remainder of the block into a new free block. */ + if(realsize <= cursize) { + size_t nextsize = cursize - realsize; /* size of new remainder block */ + if(nextsize >= minAllocSize) { + /* + * Split the block + * Set boundary tags for the resized block and the new block. + */ + SetTags(ptr, realsize | 1); + ptr += realsize; + + /* + * add the new block to the free list. + * call Free to merge this block with next block if free + */ + SetTags(ptr, nextsize | 1); + Free(ptr); + } + + return block; + } + + PBLOCK next = ptr + cursize; + size_t nextsize = SIZE(next); + + /* Check the next block for consistency.*/ + if((nextsize&1) == 0 && (nextsize + cursize) >= realsize) { + /* + * The next block is free and big enough. Add the part that's needed + * to our block, and split the remainder off into a new block. + */ + if(m_pRover == next) + m_pRover = NEXT(next); + + /* Unlink the next block from the free list. */ + Unlink(next); + cursize += nextsize; /* combine sizes */ + + size_t rem = cursize - realsize; /* size of remainder */ + if(rem >= minAllocSize) { + /* + * The remainder is big enough to be a new block. + * Set boundary tags for the resized block and the new block. + */ + next = ptr + realsize; + /* + * add the new block to the free list. + * next block cannot be free + */ + SetTags(next, rem); + AddToFreeList(next, m_pFreeList); + cursize = realsize; + } + /* Set the boundary tags to mark it as allocated. */ + SetTags(ptr, cursize | 1); + return ((void *)ptr); + } + return NULL; +} + +#ifdef _DEBUG_MEM +#define LOG_FILENAME "P:\\Apps\\Perl\\Result.txt" + +void MemoryUsageMessage(char *str, long x, long y, int c) +{ + static FILE* fp = NULL; + char szBuffer[512]; + if(str) { + if(!fp) + fp = fopen(LOG_FILENAME, "w"); + sprintf(szBuffer, str, x, y, c); + fputs(szBuffer, fp); + } + else { + fflush(fp); + fclose(fp); + } +} + +void VMem::WalkHeap(void) +{ + if(!m_pRover) { + MemoryUsageMessage("VMem heaps used %d\n", m_nHeaps, 0, 0); + } + + /* Walk all the heaps - verify structures */ + for(int index = 0; index < m_nHeaps; ++index) { + PBLOCK ptr = m_heaps[index].base; + size_t size = m_heaps[index].len; + ASSERT(HeapValidate(m_hHeap, HEAP_NO_SERIALIZE, p)); + + /* set over reserved header block */ + size -= minBlockSize; + ptr += minBlockSize; + PBLOCK pLast = ptr + size; + ASSERT(PSIZE(ptr) == 1); /* dummy previous block is allocated */ + ASSERT(SIZE(pLast) == 1); /* dummy next block is allocated */ + while(ptr < pLast) { + ASSERT(ptr > m_heaps[index].base); + size_t cursize = SIZE(ptr) & ~1; + ASSERT((PSIZE(ptr+cursize) & ~1) == cursize); + if(!m_pRover) { + MemoryUsageMessage("Memory Block %08x: Size %08x %c\n", (long)ptr, cursize, (SIZE(p)&1) ? 'x' : ' '); + } + if(!(SIZE(ptr)&1)) { + /* this block is on the free list */ + PBLOCK tmp = NEXT(ptr); + while(tmp != ptr) { + ASSERT((SIZE(tmp)&1)==0); + if(tmp == m_pFreeList) + break; + ASSERT(NEXT(tmp)); + tmp = NEXT(tmp); + } + if(tmp == ptr) { + MemoryUsageMessage("Memory Block %08x: Size %08x free but not in free list\n", (long)ptr, cursize, 0); + } + } + ptr += cursize; + } + } + if(!m_pRover) { + MemoryUsageMessage(NULL, 0, 0, 0); + } +} +#endif + +#endif /* ___VMEM_H_INC___ */ diff --git a/win32/win32.c b/win32/win32.c index 6566f9a7f4..78955fc046 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -15,6 +15,8 @@ #define Win32_Winsock #endif #include <windows.h> +#include <winnt.h> +#include <io.h> /* #include "config.h" */ @@ -95,11 +97,20 @@ static char * get_emd_part(SV **leading, char *trailing, ...); static void remove_dead_process(long deceased); static long find_pid(int pid); static char * qualified_path(const char *cmd); +#ifdef USE_ITHREADS +static void remove_dead_pseudo_process(long child); +static long find_pseudo_pid(int pid); +#endif +START_EXTERN_C HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE; char w32_module_name[MAX_PATH+1]; +END_EXTERN_C + static DWORD w32_platform = (DWORD)-1; +#define ONE_K_BUFSIZE 1024 + int IsWin95(void) { @@ -165,12 +176,13 @@ get_emd_part(SV **prev_pathp, char *trailing_path, ...) char *optr; char *strip; int oldsize, newsize; + STRLEN baselen; va_start(ap, trailing_path); strip = va_arg(ap, char *); - sprintf(base, "%5.3f", - (double)PERL_REVISION + ((double)PERL_VERSION / (double)1000)); + sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION); + baselen = strlen(base); if (!*w32_module_name) { GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE) @@ -202,10 +214,10 @@ get_emd_part(SV **prev_pathp, char *trailing_path, ...) /* avoid stripping component if there is no slash, * or it doesn't match ... */ if (!ptr || stricmp(ptr+1, strip) != 0) { - /* ... but not if component matches 5.00X* */ + /* ... but not if component matches m|5\.$patchlevel.*| */ if (!ptr || !(*strip == '5' && *(ptr+1) == '5' - && strncmp(strip, base, 5) == 0 - && strncmp(ptr+1, base, 5) == 0)) + && strncmp(strip, base, baselen) == 0 + && strncmp(ptr+1, base, baselen) == 0)) { *optr = '/'; ptr = optr; @@ -272,12 +284,6 @@ win32_get_sitelib(char *pl) * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/site/$]/lib"; */ sprintf(pathstr, "site/%s/lib", pl); (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch); - if (!sv1 && strlen(pl) == 7) { - /* pl may have been SUBVERSION-specific; try again without - * SUBVERSION */ - sprintf(pathstr, "site/%.5s/lib", pl); - (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch); - } /* $HKCU{'sitelib'} || $HKLM{'sitelib'} . ---; */ (void)get_regstr(sitelib, &sv2); @@ -349,17 +355,17 @@ PerlIO * Perl_my_popen(pTHX_ char *cmd, char *mode) { #ifdef FIXCMD -#define fixcmd(x) { \ - char *pspace = strchr((x),' '); \ - if (pspace) { \ - char *p = (x); \ - while (p < pspace) { \ - if (*p == '/') \ - *p = '\\'; \ - p++; \ - } \ - } \ - } +#define fixcmd(x) { \ + char *pspace = strchr((x),' '); \ + if (pspace) { \ + char *p = (x); \ + while (p < pspace) { \ + if (*p == '/') \ + *p = '\\'; \ + p++; \ + } \ + } \ + } #else #define fixcmd(x) #endif @@ -389,6 +395,17 @@ win32_os_id(void) return (unsigned long)w32_platform; } +DllExport int +win32_getpid(void) +{ +#ifdef USE_ITHREADS + dTHXo; + if (w32_pseudo_id) + return -((int)w32_pseudo_id); +#endif + return _getpid(); +} + /* Tokenize a string. Words are null-separated, and the list * ends with a doubled null. Any character (except null and * including backslash) may be escaped by preceding it with a @@ -685,10 +702,10 @@ win32_opendir(char *filename) /* do the FindFirstFile call */ if (USING_WIDE()) { A2WHELPER(scanname, wbuffer, sizeof(wbuffer)); - fh = FindFirstFileW(wbuffer, &wFindData); + fh = FindFirstFileW(PerlDir_mapW(wbuffer), &wFindData); } else { - fh = FindFirstFileA(scanname, &aFindData); + fh = FindFirstFileA(PerlDir_mapA(scanname), &aFindData); } dirp->handle = fh; if (fh == INVALID_HANDLE_VALUE) { @@ -911,8 +928,8 @@ static long find_pid(int pid) { dTHXo; - long child; - for (child = 0 ; child < w32_num_children ; ++child) { + long child = w32_num_children; + while (--child >= 0) { if (w32_child_pids[child] == pid) return child; } @@ -933,18 +950,72 @@ remove_dead_process(long child) } } +#ifdef USE_ITHREADS +static long +find_pseudo_pid(int pid) +{ + dTHXo; + long child = w32_num_pseudo_children; + while (--child >= 0) { + if (w32_pseudo_child_pids[child] == pid) + return child; + } + return -1; +} + +static void +remove_dead_pseudo_process(long child) +{ + if (child >= 0) { + dTHXo; + CloseHandle(w32_pseudo_child_handles[child]); + Copy(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child], + (w32_num_pseudo_children-child-1), HANDLE); + Copy(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child], + (w32_num_pseudo_children-child-1), DWORD); + w32_num_pseudo_children--; + } +} +#endif + DllExport int win32_kill(int pid, int sig) { + dTHXo; HANDLE hProcess; - hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid); - if (hProcess && TerminateProcess(hProcess, sig)) - CloseHandle(hProcess); - else { - errno = EINVAL; - return -1; +#ifdef USE_ITHREADS + if (pid < 0) { + /* it is a pseudo-forked child */ + long child = find_pseudo_pid(-pid); + if (child >= 0) { + hProcess = w32_pseudo_child_handles[child]; + if (TerminateThread(hProcess, sig)) { + remove_dead_pseudo_process(child); + return 0; + } + } } - return 0; + else +#endif + { + long child = find_pid(pid); + if (child >= 0) { + hProcess = w32_child_handles[child]; + if (TerminateProcess(hProcess, sig)) { + remove_dead_process(child); + return 0; + } + } + else { + hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid); + if (hProcess && TerminateProcess(hProcess, sig)) { + CloseHandle(hProcess); + return 0; + } + } + } + errno = EINVAL; + return -1; } /* @@ -995,9 +1066,11 @@ win32_stat(const char *path, struct stat *buffer) /* This also gives us an opportunity to determine the number of links. */ if (USING_WIDE()) { A2WHELPER(path, wbuffer, sizeof(wbuffer)); + wcscpy(wbuffer, PerlDir_mapW(wbuffer)); handle = CreateFileW(wbuffer, 0, 0, NULL, OPEN_EXISTING, 0, NULL); } else { + path = PerlDir_mapA(path); handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL); } if (handle != INVALID_HANDLE_VALUE) { @@ -1007,10 +1080,13 @@ win32_stat(const char *path, struct stat *buffer) CloseHandle(handle); } - if (USING_WIDE()) + /* wbuffer or path will be mapped correctly above */ + if (USING_WIDE()) { res = _wstat(wbuffer, (struct _stat *)buffer); - else + } + else { res = stat(path, buffer); + } buffer->st_nlink = nlink; if (res < 0) { @@ -1213,9 +1289,9 @@ win32_putenv(const char *name) New(1309,wCuritem,length,WCHAR); A2WHELPER(name, wCuritem, length*sizeof(WCHAR)); wVal = wcschr(wCuritem, '='); - if(wVal) { + if (wVal) { *wVal++ = '\0'; - if(SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL)) + if (SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL)) relval = 0; } Safefree(wCuritem); @@ -1224,7 +1300,7 @@ win32_putenv(const char *name) New(1309,curitem,strlen(name)+1,char); strcpy(curitem, name); val = strchr(curitem, '='); - if(val) { + if (val) { /* The sane way to deal with the environment. * Has these advantages over putenv() & co.: * * enables us to store a truly empty value in the @@ -1240,7 +1316,7 @@ win32_putenv(const char *name) * GSAR 97-06-07 */ *val++ = '\0'; - if(SetEnvironmentVariableA(curitem, *val ? val : NULL)) + if (SetEnvironmentVariableA(curitem, *val ? val : NULL)) relval = 0; } Safefree(curitem); @@ -1254,11 +1330,11 @@ win32_putenv(const char *name) static long filetime_to_clock(PFILETIME ft) { - __int64 qw = ft->dwHighDateTime; - qw <<= 32; - qw |= ft->dwLowDateTime; - qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */ - return (long) qw; + __int64 qw = ft->dwHighDateTime; + qw <<= 32; + qw |= ft->dwLowDateTime; + qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */ + return (long) qw; } DllExport int @@ -1309,6 +1385,43 @@ filetime_from_time(PFILETIME pFileTime, time_t Time) } DllExport int +win32_unlink(const char *filename) +{ + dTHXo; + int ret; + DWORD attrs; + + if (USING_WIDE()) { + WCHAR wBuffer[MAX_PATH]; + + A2WHELPER(filename, wBuffer, sizeof(wBuffer)); + wcscpy(wBuffer, PerlDir_mapW(wBuffer)); + attrs = GetFileAttributesW(wBuffer); + if (attrs & FILE_ATTRIBUTE_READONLY) { + (void)SetFileAttributesW(wBuffer, attrs & ~FILE_ATTRIBUTE_READONLY); + ret = _wunlink(wBuffer); + if (ret == -1) + (void)SetFileAttributesW(wBuffer, attrs); + } + else + ret = _wunlink(wBuffer); + } + else { + filename = PerlDir_mapA(filename); + attrs = GetFileAttributesA(filename); + if (attrs & FILE_ATTRIBUTE_READONLY) { + (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY); + ret = unlink(filename); + if (ret == -1) + (void)SetFileAttributesA(filename, attrs); + } + else + ret = unlink(filename); + } + return ret; +} + +DllExport int win32_utime(const char *filename, struct utimbuf *times) { dTHXo; @@ -1322,9 +1435,11 @@ win32_utime(const char *filename, struct utimbuf *times) int rc; if (USING_WIDE()) { A2WHELPER(filename, wbuffer, sizeof(wbuffer)); + wcscpy(wbuffer, PerlDir_mapW(wbuffer)); rc = _wutime(wbuffer, (struct _utimbuf*)times); } else { + filename = PerlDir_mapA(filename); rc = utime(filename, times); } /* EACCES: path specifies directory or readonly file */ @@ -1458,8 +1573,27 @@ win32_waitpid(int pid, int *status, int flags) { dTHXo; int retval = -1; - if (pid == -1) + if (pid == -1) /* XXX threadid == 1 ? */ return win32_wait(status); +#ifdef USE_ITHREADS + else if (pid < 0) { + long child = find_pseudo_pid(-pid); + if (child >= 0) { + HANDLE hThread = w32_pseudo_child_handles[child]; + DWORD waitcode = WaitForSingleObject(hThread, INFINITE); + if (waitcode != WAIT_FAILED) { + if (GetExitCodeThread(hThread, &waitcode)) { + *status = (int)((waitcode & 0xff) << 8); + retval = (int)w32_pseudo_child_pids[child]; + remove_dead_pseudo_process(child); + return retval; + } + } + else + errno = ECHILD; + } + } +#endif else { long child = find_pid(pid); if (child >= 0) { @@ -1498,6 +1632,28 @@ win32_wait(int *status) int i, retval; DWORD exitcode, waitcode; +#ifdef USE_ITHREADS + if (w32_num_pseudo_children) { + waitcode = WaitForMultipleObjects(w32_num_pseudo_children, + w32_pseudo_child_handles, + FALSE, + INFINITE); + if (waitcode != WAIT_FAILED) { + if (waitcode >= WAIT_ABANDONED_0 + && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children) + i = waitcode - WAIT_ABANDONED_0; + else + i = waitcode - WAIT_OBJECT_0; + if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) { + *status = (int)((exitcode & 0xff) << 8); + retval = (int)w32_pseudo_child_pids[i]; + remove_dead_pseudo_process(i); + return retval; + } + } + } +#endif + if (!w32_num_children) { errno = ECHILD; return -1; @@ -1903,9 +2059,9 @@ win32_fopen(const char *filename, const char *mode) if (USING_WIDE()) { A2WHELPER(mode, wMode, sizeof(wMode)); A2WHELPER(filename, wBuffer, sizeof(wBuffer)); - return _wfopen(wBuffer, wMode); + return _wfopen(PerlDir_mapW(wBuffer), wMode); } - return fopen(filename, mode); + return fopen(PerlDir_mapA(filename), mode); } #ifndef USE_SOCKETS_AS_HANDLES @@ -1936,9 +2092,9 @@ win32_freopen(const char *path, const char *mode, FILE *stream) if (USING_WIDE()) { A2WHELPER(mode, wMode, sizeof(wMode)); A2WHELPER(path, wBuffer, sizeof(wBuffer)); - return _wfreopen(wBuffer, wMode, stream); + return _wfreopen(PerlDir_mapW(wBuffer), wMode, stream); } - return freopen(path, mode, stream); + return freopen(PerlDir_mapA(path), mode, stream); } DllExport int @@ -2210,8 +2366,13 @@ Nt4CreateHardLinkW( StreamId.dwStreamId = BACKUP_LINK; StreamId.dwStreamAttributes = 0; StreamId.dwStreamNameSize = 0; +#if defined(__BORLANDC__) || defined(__MINGW32__) + StreamId.Size.u.HighPart = 0; + StreamId.Size.u.LowPart = dwLen; +#else StreamId.Size.HighPart = 0; StreamId.Size.LowPart = dwLen; +#endif bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten, FALSE, FALSE, &lpContext); @@ -2244,7 +2405,8 @@ win32_link(const char *oldname, const char *newname) if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) && (A2WHELPER(newname, wNewName, sizeof(wNewName))) && - pfnCreateHardLinkW(wNewName, wOldName, NULL)) + (wcscpy(wOldName, PerlDir_mapW(wOldName)), + pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL))) { return 0; } @@ -2257,6 +2419,7 @@ win32_rename(const char *oname, const char *newname) { WCHAR wOldName[MAX_PATH]; WCHAR wNewName[MAX_PATH]; + char szOldName[MAX_PATH]; BOOL bResult; /* XXX despite what the documentation says about MoveFileEx(), * it doesn't work under Windows95! @@ -2266,11 +2429,13 @@ win32_rename(const char *oname, const char *newname) if (USING_WIDE()) { A2WHELPER(oname, wOldName, sizeof(wOldName)); A2WHELPER(newname, wNewName, sizeof(wNewName)); - bResult = MoveFileExW(wOldName,wNewName, + wcscpy(wOldName, PerlDir_mapW(wOldName)); + bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName), MOVEFILE_COPY_ALLOWED|MOVEFILE_REPLACE_EXISTING); } else { - bResult = MoveFileExA(oname,newname, + strcpy(szOldName, PerlDir_mapA(szOldName)); + bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), MOVEFILE_COPY_ALLOWED|MOVEFILE_REPLACE_EXISTING); } if (!bResult) { @@ -2401,9 +2566,9 @@ win32_open(const char *path, int flag, ...) if (USING_WIDE()) { A2WHELPER(path, wBuffer, sizeof(wBuffer)); - return _wopen(wBuffer, flag, pmode); + return _wopen(PerlDir_mapW(wBuffer), flag, pmode); } - return open(path,flag,pmode); + return open(PerlDir_mapA(path), flag, pmode); } DllExport int @@ -2430,10 +2595,240 @@ win32_dup2(int fd1,int fd2) return dup2(fd1,fd2); } +#ifdef PERL_MSVCRT_READFIX + +#define LF 10 /* line feed */ +#define CR 13 /* carriage return */ +#define CTRLZ 26 /* ctrl-z means eof for text */ +#define FOPEN 0x01 /* file handle open */ +#define FEOFLAG 0x02 /* end of file has been encountered */ +#define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */ +#define FPIPE 0x08 /* file handle refers to a pipe */ +#define FAPPEND 0x20 /* file handle opened O_APPEND */ +#define FDEV 0x40 /* file handle refers to device */ +#define FTEXT 0x80 /* file handle is in text mode */ +#define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */ + +/* + * Control structure for lowio file handles + */ +typedef struct { + long osfhnd; /* underlying OS file HANDLE */ + char osfile; /* attributes of file (e.g., open in text mode?) */ + char pipech; /* one char buffer for handles opened on pipes */ + int lockinitflag; + CRITICAL_SECTION lock; +} ioinfo; + + +/* + * Array of arrays of control structures for lowio files. + */ +EXTERN_C _CRTIMP ioinfo* __pioinfo[]; + +/* + * Definition of IOINFO_L2E, the log base 2 of the number of elements in each + * array of ioinfo structs. + */ +#define IOINFO_L2E 5 + +/* + * Definition of IOINFO_ARRAY_ELTS, the number of elements in ioinfo array + */ +#define IOINFO_ARRAY_ELTS (1 << IOINFO_L2E) + +/* + * Access macros for getting at an ioinfo struct and its fields from a + * file handle + */ +#define _pioinfo(i) (__pioinfo[(i) >> IOINFO_L2E] + ((i) & (IOINFO_ARRAY_ELTS - 1))) +#define _osfhnd(i) (_pioinfo(i)->osfhnd) +#define _osfile(i) (_pioinfo(i)->osfile) +#define _pipech(i) (_pioinfo(i)->pipech) + +int __cdecl _fixed_read(int fh, void *buf, unsigned cnt) +{ + int bytes_read; /* number of bytes read */ + char *buffer; /* buffer to read to */ + int os_read; /* bytes read on OS call */ + char *p, *q; /* pointers into buffer */ + char peekchr; /* peek-ahead character */ + ULONG filepos; /* file position after seek */ + ULONG dosretval; /* o.s. return value */ + + /* validate handle */ + if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) || + !(_osfile(fh) & FOPEN)) + { + /* out of range -- return error */ + errno = EBADF; + _doserrno = 0; /* not o.s. error */ + return -1; + } + + EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */ + + bytes_read = 0; /* nothing read yet */ + buffer = (char*)buf; + + if (cnt == 0 || (_osfile(fh) & FEOFLAG)) { + /* nothing to read or at EOF, so return 0 read */ + goto functionexit; + } + + if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) { + /* a pipe/device and pipe lookahead non-empty: read the lookahead + * char */ + *buffer++ = _pipech(fh); + ++bytes_read; + --cnt; + _pipech(fh) = LF; /* mark as empty */ + } + + /* read the data */ + + if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL)) + { + /* ReadFile has reported an error. recognize two special cases. + * + * 1. map ERROR_ACCESS_DENIED to EBADF + * + * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it + * means the handle is a read-handle on a pipe for which + * all write-handles have been closed and all data has been + * read. */ + + if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) { + /* wrong read/write mode should return EBADF, not EACCES */ + errno = EBADF; + _doserrno = dosretval; + bytes_read = -1; + goto functionexit; + } + else if (dosretval == ERROR_BROKEN_PIPE) { + bytes_read = 0; + goto functionexit; + } + else { + bytes_read = -1; + goto functionexit; + } + } + + bytes_read += os_read; /* update bytes read */ + + if (_osfile(fh) & FTEXT) { + /* now must translate CR-LFs to LFs in the buffer */ + + /* set CRLF flag to indicate LF at beginning of buffer */ + /* if ((os_read != 0) && (*(char *)buf == LF)) */ + /* _osfile(fh) |= FCRLF; */ + /* else */ + /* _osfile(fh) &= ~FCRLF; */ + + _osfile(fh) &= ~FCRLF; + + /* convert chars in the buffer: p is src, q is dest */ + p = q = (char*)buf; + while (p < (char *)buf + bytes_read) { + if (*p == CTRLZ) { + /* if fh is not a device, set ctrl-z flag */ + if (!(_osfile(fh) & FDEV)) + _osfile(fh) |= FEOFLAG; + break; /* stop translating */ + } + else if (*p != CR) + *q++ = *p++; + else { + /* *p is CR, so must check next char for LF */ + if (p < (char *)buf + bytes_read - 1) { + if (*(p+1) == LF) { + p += 2; + *q++ = LF; /* convert CR-LF to LF */ + } + else + *q++ = *p++; /* store char normally */ + } + else { + /* This is the hard part. We found a CR at end of + buffer. We must peek ahead to see if next char + is an LF. */ + ++p; + + dosretval = 0; + if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1, + (LPDWORD)&os_read, NULL)) + dosretval = GetLastError(); + + if (dosretval != 0 || os_read == 0) { + /* couldn't read ahead, store CR */ + *q++ = CR; + } + else { + /* peekchr now has the extra character -- we now + have several possibilities: + 1. disk file and char is not LF; just seek back + and copy CR + 2. disk file and char is LF; store LF, don't seek back + 3. pipe/device and char is LF; store LF. + 4. pipe/device and char isn't LF, store CR and + put char in pipe lookahead buffer. */ + if (_osfile(fh) & (FDEV|FPIPE)) { + /* non-seekable device */ + if (peekchr == LF) + *q++ = LF; + else { + *q++ = CR; + _pipech(fh) = peekchr; + } + } + else { + /* disk file */ + if (peekchr == LF) { + /* nothing read yet; must make some + progress */ + *q++ = LF; + /* turn on this flag for tell routine */ + _osfile(fh) |= FCRLF; + } + else { + HANDLE osHandle; /* o.s. handle value */ + /* seek back */ + if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1) + { + if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1) + dosretval = GetLastError(); + } + if (peekchr != LF) + *q++ = CR; + } + } + } + } + } + } + + /* we now change bytes_read to reflect the true number of chars + in the buffer */ + bytes_read = q - (char *)buf; + } + +functionexit: + LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */ + + return bytes_read; +} + +#endif /* PERL_MSVCRT_READFIX */ + DllExport int win32_read(int fd, void *buf, unsigned int cnt) { +#ifdef PERL_MSVCRT_READFIX + return _fixed_read(fd, buf, cnt); +#else return read(fd, buf, cnt); +#endif } DllExport int @@ -2445,21 +2840,64 @@ win32_write(int fd, const void *buf, unsigned int cnt) DllExport int win32_mkdir(const char *dir, int mode) { - return mkdir(dir); /* just ignore mode */ + dTHXo; + if (USING_WIDE()) { + WCHAR wBuffer[MAX_PATH]; + A2WHELPER(dir, wBuffer, sizeof(wBuffer)); + return _wmkdir(PerlDir_mapW(wBuffer)); + } + return mkdir(PerlDir_mapA(dir)); /* just ignore mode */ } DllExport int win32_rmdir(const char *dir) { - return rmdir(dir); + dTHXo; + if (USING_WIDE()) { + WCHAR wBuffer[MAX_PATH]; + A2WHELPER(dir, wBuffer, sizeof(wBuffer)); + return _wrmdir(PerlDir_mapW(wBuffer)); + } + return rmdir(PerlDir_mapA(dir)); } DllExport int win32_chdir(const char *dir) { + dTHXo; + if (USING_WIDE()) { + WCHAR wBuffer[MAX_PATH]; + A2WHELPER(dir, wBuffer, sizeof(wBuffer)); + return _wchdir(wBuffer); + } return chdir(dir); } +DllExport int +win32_access(const char *path, int mode) +{ + dTHXo; + if (USING_WIDE()) { + WCHAR wBuffer[MAX_PATH]; + A2WHELPER(path, wBuffer, sizeof(wBuffer)); + return _waccess(PerlDir_mapW(wBuffer), mode); + } + return access(PerlDir_mapA(path), mode); +} + +DllExport int +win32_chmod(const char *path, int mode) +{ + dTHXo; + if (USING_WIDE()) { + WCHAR wBuffer[MAX_PATH]; + A2WHELPER(path, wBuffer, sizeof(wBuffer)); + return _wchmod(PerlDir_mapW(wBuffer), mode); + } + return chmod(PerlDir_mapA(path), mode); +} + + static char * create_command_line(const char* command, const char * const *args) { @@ -2592,12 +3030,28 @@ free_childenv(void* d) char* get_childdir(void) { - return NULL; + dTHXo; + char* ptr; + char szfilename[(MAX_PATH+1)*2]; + if (USING_WIDE()) { + WCHAR wfilename[MAX_PATH+1]; + GetCurrentDirectoryW(MAX_PATH+1, wfilename); + W2AHELPER(wfilename, szfilename, sizeof(szfilename)); + } + else { + GetCurrentDirectoryA(MAX_PATH+1, szfilename); + } + + New(0, ptr, strlen(szfilename)+1, char); + strcpy(ptr, szfilename); + return ptr; } void free_childdir(char* d) { + dTHXo; + Safefree(d); } @@ -2722,12 +3176,26 @@ RETVAL: DllExport int win32_execv(const char *cmdname, const char *const *argv) { +#ifdef USE_ITHREADS + dTHXo; + /* if this is a pseudo-forked child, we just want to spawn + * the new program, and return */ + if (w32_pseudo_id) + return spawnv(P_WAIT, cmdname, (char *const *)argv); +#endif return execv(cmdname, (char *const *)argv); } DllExport int win32_execvp(const char *cmdname, const char *const *argv) { +#ifdef USE_ITHREADS + dTHXo; + /* if this is a pseudo-forked child, we just want to spawn + * the new program, and return */ + if (w32_pseudo_id) + return win32_spawnvp(P_WAIT, cmdname, (char *const *)argv); +#endif return execvp(cmdname, (char *const *)argv); } @@ -2927,44 +3395,14 @@ win32_dynaload(const char* filename) if (USING_WIDE()) { WCHAR wfilename[MAX_PATH]; A2WHELPER(filename, wfilename, sizeof(wfilename)); - hModule = LoadLibraryExW(wfilename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH); + hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH); } else { - hModule = LoadLibraryExA(filename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH); + hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH); } return hModule; } -DllExport int -win32_add_host(char *nameId, void *data) -{ - /* - * This must be called before the script is parsed, - * therefore no locking of threads is needed - */ - dTHXo; - struct host_link *link; - New(1314, link, 1, struct host_link); - link->host_data = data; - link->nameId = nameId; - link->next = w32_host_link; - w32_host_link = link; - return 1; -} - -DllExport void * -win32_get_host_data(char *nameId) -{ - dTHXo; - struct host_link *link = w32_host_link; - while(link) { - if(strEQ(link->nameId, nameId)) - return link->host_data; - link = link->next; - } - return Nullch; -} - /* * Extras. */ @@ -2973,19 +3411,19 @@ static XS(w32_GetCwd) { dXSARGS; - SV *sv = sv_newmortal(); - /* Make one call with zero size - return value is required size */ - DWORD len = GetCurrentDirectory((DWORD)0,NULL); - SvUPGRADE(sv,SVt_PV); - SvGROW(sv,len); - SvCUR(sv) = GetCurrentDirectory((DWORD) SvLEN(sv), SvPVX(sv)); + /* Make the host for current directory */ + char* ptr = PerlEnv_get_childdir(); /* - * If result != 0 + * If ptr != Nullch * then it worked, set PV valid, - * else leave it 'undef' + * else return 'undef' */ - EXTEND(SP,1); - if (SvCUR(sv)) { + if (ptr) { + SV *sv = sv_newmortal(); + sv_setpv(sv, ptr); + PerlEnv_free_childdir(ptr); + + EXTEND(SP,1); SvPOK_on(sv); ST(0) = sv; XSRETURN(1); @@ -2999,7 +3437,7 @@ XS(w32_SetCwd) dXSARGS; if (items != 1) Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)"); - if (SetCurrentDirectory(SvPV_nolen(ST(0)))) + if (!PerlDir_chdir(SvPV_nolen(ST(0)))) XSRETURN_YES; XSRETURN_NO; @@ -3122,7 +3560,7 @@ XS(w32_DomainName) if (hNetApi32) FreeLibrary(hNetApi32); if (GetUserName(name,&size)) { - char sid[1024]; + char sid[ONE_K_BUFSIZE]; DWORD sidlen = sizeof(sid); char dname[256]; DWORD dnamelen = sizeof(dname); @@ -3161,19 +3599,34 @@ static XS(w32_GetOSVersion) { dXSARGS; - OSVERSIONINFO osver; + OSVERSIONINFOA osver; - osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); - if (GetVersionEx(&osver)) { + if (USING_WIDE()) { + OSVERSIONINFOW osverw; + char szCSDVersion[sizeof(osverw.szCSDVersion)]; + osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); + if (!GetVersionExW(&osverw)) { + XSRETURN_EMPTY; + } + W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion)); + XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion))); + osver.dwMajorVersion = osverw.dwMajorVersion; + osver.dwMinorVersion = osverw.dwMinorVersion; + osver.dwBuildNumber = osverw.dwBuildNumber; + osver.dwPlatformId = osverw.dwPlatformId; + } + else { + osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA); + if (!GetVersionExA(&osver)) { + XSRETURN_EMPTY; + } XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion))); - XPUSHs(newSViv(osver.dwMajorVersion)); - XPUSHs(newSViv(osver.dwMinorVersion)); - XPUSHs(newSViv(osver.dwBuildNumber)); - XPUSHs(newSViv(osver.dwPlatformId)); - PUTBACK; - return; } - XSRETURN_EMPTY; + XPUSHs(newSViv(osver.dwMajorVersion)); + XPUSHs(newSViv(osver.dwMinorVersion)); + XPUSHs(newSViv(osver.dwBuildNumber)); + XPUSHs(newSViv(osver.dwPlatformId)); + PUTBACK; } static @@ -3197,15 +3650,27 @@ XS(w32_FormatMessage) { dXSARGS; DWORD source = 0; - char msgbuf[1024]; + char msgbuf[ONE_K_BUFSIZE]; if (items != 1) Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)"); - if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, - &source, SvIV(ST(0)), 0, - msgbuf, sizeof(msgbuf)-1, NULL)) - XSRETURN_PV(msgbuf); + if (USING_WIDE()) { + WCHAR wmsgbuf[ONE_K_BUFSIZE]; + if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM, + &source, SvIV(ST(0)), 0, + wmsgbuf, ONE_K_BUFSIZE-1, NULL)) + { + W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf)); + XSRETURN_PV(msgbuf); + } + } + else { + if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM, + &source, SvIV(ST(0)), 0, + msgbuf, sizeof(msgbuf)-1, NULL)) + XSRETURN_PV(msgbuf); + } XSRETURN_UNDEF; } @@ -3358,9 +3823,24 @@ static XS(w32_CopyFile) { dXSARGS; + BOOL bResult; if (items != 3) Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)"); - if (CopyFile(SvPV_nolen(ST(0)), SvPV_nolen(ST(1)), !SvTRUE(ST(2)))) + if (USING_WIDE()) { + WCHAR wSourceFile[MAX_PATH]; + WCHAR wDestFile[MAX_PATH]; + A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile)); + wcscpy(wSourceFile, PerlDir_mapW(wSourceFile)); + A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile)); + bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2))); + } + else { + char szSourceFile[MAX_PATH]; + strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0)))); + bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2))); + } + + if (bResult) XSRETURN_YES; XSRETURN_NO; } @@ -3377,6 +3857,12 @@ Perl_init_os_extras(void) w32_fdpid = newAV(); /* XXX needs to be in Perl_win32_init()? */ New(1313, w32_children, 1, child_tab); w32_num_children = 0; + w32_init_socktype = 0; +#ifdef USE_ITHREADS + w32_pseudo_id = 0; + New(1313, w32_pseudo_children, 1, child_tab); + w32_num_pseudo_children = 0; +#endif /* these names are Activeware compatible */ newXS("Win32::GetCwd", w32_GetCwd, file); @@ -3428,6 +3914,13 @@ Perl_win32_init(int *argcp, char ***argvp) } #ifdef USE_ITHREADS + +# ifdef PERL_OBJECT +# undef Perl_sys_intern_dup +# define Perl_sys_intern_dup CPerlObj::Perl_sys_intern_dup +# define pPerl this +# endif + void Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst) { @@ -3435,34 +3928,11 @@ Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst) dst->perlshell_vec = (char**)NULL; dst->perlshell_items = 0; dst->fdpid = newAV(); - New(1313, dst->children, 1, child_tab); + Newz(1313, dst->children, 1, child_tab); + Newz(1313, dst->pseudo_children, 1, child_tab); + dst->pseudo_id = 0; dst->children->num = 0; - dst->hostlist = src->hostlist; /* XXX */ dst->thr_intern.Winit_socktype = src->thr_intern.Winit_socktype; } #endif -#ifdef USE_BINMODE_SCRIPTS - -void -win32_strip_return(SV *sv) -{ - char *s = SvPVX(sv); - char *e = s+SvCUR(sv); - char *d = s; - while (s < e) - { - if (*s == '\r' && s[1] == '\n') - { - *d++ = '\n'; - s += 2; - } - else - { - *d++ = *s++; - } - } - SvCUR_set(sv,d-SvPVX(sv)); -} - -#endif diff --git a/win32/win32.h b/win32/win32.h index 9eaf76a2d4..9d56578229 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -9,6 +9,10 @@ #ifndef _INC_WIN32_PERL5 #define _INC_WIN32_PERL5 +#ifndef _WIN32_WINNT +# define _WIN32_WINNT 0x0400 /* needed for TryEnterCriticalSection() etc. */ +#endif + #if defined(PERL_OBJECT) || defined(PERL_IMPLICIT_SYS) || defined(PERL_CAPI) # define DYNAMIC_ENV_FETCH # define ENV_HV_NAME "___ENV_HV_NAME___" @@ -33,18 +37,6 @@ # define __int64 long long # endif # define Win32_Winsock -/* GCC does not do __declspec() - render it a nop - * and turn on options to avoid importing data - */ -#ifndef __declspec -# define __declspec(x) -#endif -# ifndef PERL_OBJECT -# define PERL_GLOBAL_STRUCT -# ifndef MULTIPLICITY -# define MULTIPLICITY -# endif -# endif #endif /* Define DllExport akin to perl's EXT, @@ -53,6 +45,8 @@ * otherwise import it. */ +/* now even GCC supports __declspec() */ + #if defined(PERL_OBJECT) #define DllExport #else @@ -165,6 +159,7 @@ struct utsname { #define _access access #define _chdir chdir +#define _getpid getpid #include <sys/types.h> #ifndef DllMain @@ -187,6 +182,9 @@ struct utsname { # define MEMBER_TO_FPTR(name) &(name) #endif +/* Borland C thinks that a pointer to a member variable is 12 bytes in size. */ +#define PERL_MEMBER_PTR_SIZE 12 + #endif #ifdef _MSC_VER /* Microsoft Visual C++ */ @@ -196,45 +194,8 @@ typedef long gid_t; typedef unsigned short mode_t; #pragma warning(disable: 4018 4035 4101 4102 4244 4245 4761) -#ifndef PERL_OBJECT - /* Visual C thinks that a pointer to a member variable is 16 bytes in size. */ -#define STRUCT_MGVTBL_DEFINITION \ -struct mgvtbl { \ - union { \ - int (CPERLscope(*svt_get))(pTHX_ SV *sv, MAGIC* mg); \ - char handle_VC_problem1[16]; \ - }; \ - union { \ - int (CPERLscope(*svt_set))(pTHX_ SV *sv, MAGIC* mg); \ - char handle_VC_problem2[16]; \ - }; \ - union { \ - U32 (CPERLscope(*svt_len))(pTHX_ SV *sv, MAGIC* mg); \ - char handle_VC_problem3[16]; \ - }; \ - union { \ - int (CPERLscope(*svt_clear))(pTHX_ SV *sv, MAGIC* mg); \ - char handle_VC_problem4[16]; \ - }; \ - union { \ - int (CPERLscope(*svt_free))(pTHX_ SV *sv, MAGIC* mg); \ - char handle_VC_problem5[16]; \ - }; \ -} - -#define BASEOP_DEFINITION \ - OP* op_next; \ - OP* op_sibling; \ - OP* (CPERLscope(*op_ppaddr))(pTHX); \ - char handle_VC_problem[12]; \ - PADOFFSET op_targ; \ - OPCODE op_type; \ - U16 op_seq; \ - U8 op_flags; \ - U8 op_private; - -#endif /* PERL_OBJECT */ +#define PERL_MEMBER_PTR_SIZE 16 #endif /* _MSC_VER */ @@ -248,9 +209,6 @@ typedef long gid_t; #define flushall _flushall #define fcloseall _fcloseall -#undef __attribute__ -#define __attribute__(x) - #ifndef CP_UTF8 # define CP_UTF8 65001 #endif @@ -266,18 +224,50 @@ typedef long gid_t; # endif #endif -#ifndef _O_NOINHERIT -# define _O_NOINHERIT 0x0080 -# ifndef _NO_OLDNAMES -# define O_NOINHERIT _O_NOINHERIT -# endif -#endif - #endif /* __MINGW32__ */ /* compatibility stuff for other compilers goes here */ +#if !defined(PERL_OBJECT) && defined(PERL_MEMBER_PTR_SIZE) +# define STRUCT_MGVTBL_DEFINITION \ +struct mgvtbl { \ + union { \ + int (CPERLscope(*svt_get))(pTHX_ SV *sv, MAGIC* mg); \ + char handle_VC_problem1[PERL_MEMBER_PTR_SIZE]; \ + }; \ + union { \ + int (CPERLscope(*svt_set))(pTHX_ SV *sv, MAGIC* mg); \ + char handle_VC_problem2[PERL_MEMBER_PTR_SIZE]; \ + }; \ + union { \ + U32 (CPERLscope(*svt_len))(pTHX_ SV *sv, MAGIC* mg); \ + char handle_VC_problem3[PERL_MEMBER_PTR_SIZE]; \ + }; \ + union { \ + int (CPERLscope(*svt_clear))(pTHX_ SV *sv, MAGIC* mg); \ + char handle_VC_problem4[PERL_MEMBER_PTR_SIZE]; \ + }; \ + union { \ + int (CPERLscope(*svt_free))(pTHX_ SV *sv, MAGIC* mg); \ + char handle_VC_problem5[PERL_MEMBER_PTR_SIZE]; \ + }; \ +} + +# define BASEOP_DEFINITION \ + OP* op_next; \ + OP* op_sibling; \ + OP* (CPERLscope(*op_ppaddr))(pTHX); \ + char handle_VC_problem[PERL_MEMBER_PTR_SIZE-sizeof(OP*)]; \ + PADOFFSET op_targ; \ + OPCODE op_type; \ + U16 op_seq; \ + U8 op_flags; \ + U8 op_private; + +#endif /* !PERL_OBJECT && PERL_MEMBER_PTR_SIZE */ + + START_EXTERN_C /* For UNIX compatibility. */ @@ -340,12 +330,10 @@ typedef char * caddr_t; /* In malloc.c (core address). */ #define PERL_CORE #endif -#ifdef USE_BINMODE_SCRIPTS -#define PERL_SCRIPT_MODE "rb" -EXT void win32_strip_return(struct sv *sv); +#ifdef PERL_TEXTMODE_SCRIPTS +# define PERL_SCRIPT_MODE "r" #else -#define PERL_SCRIPT_MODE "r" -#define win32_strip_return(sv) NOOP +# define PERL_SCRIPT_MODE "rb" #endif /* @@ -378,22 +366,20 @@ struct thread_intern { typedef struct { long num; DWORD pids[MAXIMUM_WAIT_OBJECTS]; + HANDLE handles[MAXIMUM_WAIT_OBJECTS]; } child_tab; -struct host_link { - char * nameId; - void * host_data; - struct host_link * next; -}; - struct interp_intern { char * perlshell_tokens; char ** perlshell_vec; long perlshell_items; struct av * fdpid; child_tab * children; - HANDLE child_handles[MAXIMUM_WAIT_OBJECTS]; - struct host_link * hostlist; +#ifdef USE_ITHREADS + DWORD pseudo_id; + child_tab * pseudo_children; +#endif + void * internal_host; #ifndef USE_THREADS struct thread_intern thr_intern; #endif @@ -407,8 +393,13 @@ struct interp_intern { #define w32_children (PL_sys_intern.children) #define w32_num_children (w32_children->num) #define w32_child_pids (w32_children->pids) -#define w32_child_handles (PL_sys_intern.child_handles) -#define w32_host_link (PL_sys_intern.hostlist) +#define w32_child_handles (w32_children->handles) +#define w32_pseudo_id (PL_sys_intern.pseudo_id) +#define w32_pseudo_children (PL_sys_intern.pseudo_children) +#define w32_num_pseudo_children (w32_pseudo_children->num) +#define w32_pseudo_child_pids (w32_pseudo_children->pids) +#define w32_pseudo_child_handles (w32_pseudo_children->handles) +#define w32_internal_host (PL_sys_intern.internal_host) #ifdef USE_THREADS # define w32_strerror_buffer (thr->i.Wstrerror_buffer) # define w32_getlogin_buffer (thr->i.Wgetlogin_buffer) @@ -435,6 +426,20 @@ struct interp_intern { #define USING_WIDE() (PerlEnv_os_id() == VER_PLATFORM_WIN32_NT) +#ifdef USE_ITHREADS +# define PERL_WAIT_FOR_CHILDREN \ + STMT_START { \ + if (w32_pseudo_children && w32_num_pseudo_children) { \ + long children = w32_num_pseudo_children; \ + WaitForMultipleObjects(children, \ + w32_pseudo_child_handles, \ + TRUE, INFINITE); \ + while (children) \ + CloseHandle(w32_pseudo_child_handles[--children]); \ + } \ + } STMT_END +#endif + /* * This provides a layer of functions and macros to ensure extensions will * get to use the same RTL functions as the core. diff --git a/win32/win32iop.h b/win32/win32iop.h index 566ed57d51..d7c2ac4f74 100644 --- a/win32/win32iop.h +++ b/win32/win32iop.h @@ -132,6 +132,7 @@ DllExport int win32_stat(const char *path, struct stat *buf); DllExport char* win32_longpath(char *path); DllExport int win32_ioctl(int i, unsigned int u, char *data); DllExport int win32_link(const char *oldname, const char *newname); +DllExport int win32_unlink(const char *f); DllExport int win32_utime(const char *f, struct utimbuf *t); DllExport int win32_uname(struct utsname *n); DllExport int win32_wait(int *status); @@ -139,6 +140,9 @@ DllExport int win32_waitpid(int pid, int *status, int flags); DllExport int win32_kill(int pid, int sig); DllExport unsigned long win32_os_id(void); DllExport void* win32_dynaload(const char*filename); +DllExport int win32_access(const char *path, int mode); +DllExport int win32_chmod(const char *path, int mode); +DllExport int win32_getpid(void); DllExport char * win32_crypt(const char *txt, const char *salt); @@ -162,6 +166,7 @@ END_EXTERN_C #undef times #undef alarm #undef ioctl +#undef unlink #undef utime #undef uname #undef wait @@ -254,6 +259,9 @@ END_EXTERN_C #define getchar win32_getchar #undef putchar #define putchar win32_putchar +#define access(p,m) win32_access(p,m) +#define chmod(p,m) win32_chmod(p,m) + #if !defined(MYMALLOC) || !defined(PERL_CORE) #undef malloc @@ -273,6 +281,7 @@ END_EXTERN_C #define alarm win32_alarm #define ioctl win32_ioctl #define link win32_link +#define unlink win32_unlink #define utime win32_utime #define uname win32_uname #define wait win32_wait @@ -286,6 +295,7 @@ END_EXTERN_C #define rewinddir win32_rewinddir #define closedir win32_closedir #define os_id win32_os_id +#define getpid win32_getpid #undef crypt #define crypt(t,s) win32_crypt(t,s) diff --git a/win32/win32thread.h b/win32/win32thread.h index 4fa3e2f3bf..d4f8ee409e 100644 --- a/win32/win32thread.h +++ b/win32/win32thread.h @@ -1,8 +1,7 @@ #ifndef _WIN32THREAD_H #define _WIN32THREAD_H -#define WIN32_LEAN_AND_MEAN -#include <windows.h> +#include "win32.h" typedef struct win32_cond { LONG waiters; HANDLE sem; } perl_cond; typedef DWORD perl_key; @@ -193,7 +192,7 @@ END_EXTERN_C if ((WaitForSingleObject((t)->self,INFINITE) == WAIT_FAILED) \ || (GetExitCodeThread((t)->self,(LPDWORD)(avp)) == 0) \ || (CloseHandle((t)->self) == 0)) \ - Perl_croak(aTHX_ "panic: JOIN"); \ + Perl_croak(aTHX_ "panic: JOIN"); \ } STMT_END #endif /* !USE_RTL_THREAD_API || _MSC_VER */ |