diff options
| author | markm <markm@FreeBSD.org> | 1999-05-02 14:33:17 +0000 |
|---|---|---|
| committer | markm <markm@FreeBSD.org> | 1999-05-02 14:33:17 +0000 |
| commit | 77644ee620b6a79cf8c538abaf7cd301a875528d (patch) | |
| tree | b4adabf341898a4378f4b7f8c7fb65f3f7c77769 /contrib | |
| parent | 4fcbc3669aa997848e15198cc9fb856287a6788c (diff) | |
| download | FreeBSD-src-77644ee620b6a79cf8c538abaf7cd301a875528d.zip FreeBSD-src-77644ee620b6a79cf8c538abaf7cd301a875528d.tar.gz | |
Maintenance releace 3 of perl5.005. Includes support for threads.
Diffstat (limited to 'contrib')
418 files changed, 22733 insertions, 4951 deletions
diff --git a/contrib/perl5/Changes b/contrib/perl5/Changes index 325ffeb..00a38d5 100644 --- a/contrib/perl5/Changes +++ b/contrib/perl5/Changes @@ -20,7 +20,6 @@ current addresses (as of July 1998): Abigail <abigail@fnx.com> Kenneth Albanowski <kjahds@kjahds.com> Russ Allbery <rra@stanford.edu> - Graham Barr <gbarr@ti.com> Spider Boardman <spider@orb.nashua.nh.us> Tom Christiansen <tchrist@perl.com> Hallvard B Furuseth <h.b.furuseth@usit.uio.no> @@ -50,10 +49,11 @@ current addresses (as of July 1998): And the Keepers of the Patch Pumpkin: Charles Bailey <bailey@hmivax.humgen.upenn.edu> + Graham Barr <gbarr@pobox.com> Malcolm Beattie <mbeattie@sable.ox.ac.uk> Tim Bunce <Tim.Bunce@ig.co.uk> Andy Dougherty <doughera@lafcol.lafayette.edu> - Gurusamy Sarathy <gsar@engin.umich.edu> + Gurusamy Sarathy <gsar@umich.edu> Chip Salzenberg <chip@perl.com> And, of course, the Author of Perl: @@ -74,6 +74,3446 @@ indicator: ---------------- +Version 5.005_03 Third maintenance release of 5.005 +---------------- + +____________________________________________________________________________ +[ 3198] By: gbarr on 1999/03/28 22:21:49 + Log: redo #3193 which #3195 undid + Branch: maint-5.005/perl + ! pod/perlhist.pod +____________________________________________________________________________ +[ 3197] By: gbarr on 1999/03/28 21:04:04 + Log: Updated CPAN.pm to 1.48 + Branch: maint-5.005/perl + ! lib/CPAN.pm lib/CPAN/FirstTime.pm lib/CPAN/Nox.pm +____________________________________________________________________________ +[ 3196] By: gbarr on 1999/03/28 17:21:27 + Log: AIX hints update from Jarkko + Branch: maint-5.005/perl + ! hints/aix.sh +____________________________________________________________________________ +[ 3195] By: jhi on 1999/03/28 16:42:54 + Log: Update perlhist on 5_03. + Branch: maint-5.005/perl + ! pod/perlhist.pod +____________________________________________________________________________ +[ 3193] By: gsar on 1999/03/28 09:46:29 + Log: =end needs matching =begin (or installhtml will croak) + Branch: maint-5.005/perl + ! pod/perlhist.pod +____________________________________________________________________________ +[ 3192] By: gsar on 1999/03/28 09:10:15 + Log: update pod/Makefile + Branch: maint-5.005/perl + ! pod/Makefile +____________________________________________________________________________ +[ 3191] By: gsar on 1999/03/28 08:43:47 + Log: integrate change#3180 from mainline + + fix bogus OPf_REF context for the BLOCK in C<grep BLOCK @foo> + (sometimes caused bizarreness in the BLOCK) + Branch: maint-5.005/perl + +> t/op/grep.t + !> MANIFEST op.c +____________________________________________________________________________ +[ 3190] By: gsar on 1999/03/28 08:29:51 + Log: integrate change#3147 from mainline + + warn about newfangled vfork() caveats + Branch: maint-5.005/perl + ! Configure +____________________________________________________________________________ +[ 3189] By: gsar on 1999/03/28 08:22:00 + Log: various pod niggles + Branch: maint-5.005/perl + ! pod/perl.pod pod/perldebug.pod pod/perldiag.pod + ! pod/perlfunc.pod pod/perlhist.pod +____________________________________________________________________________ +[ 3188] By: gsar on 1999/03/28 07:37:43 + Log: integrate binary compatible variant of change#3098 from mainline + Branch: maint-5.005/perl + ! op.c perl.h t/base/lex.t toke.c +____________________________________________________________________________ +[ 3187] By: gsar on 1999/03/28 07:31:16 + Log: regularize CAPI declarations (CAPI extensions now build under + the Borland compiler) + Branch: maint-5.005/perl + ! win32/GenCAPI.pl +____________________________________________________________________________ +[ 3186] By: gsar on 1999/03/28 07:26:33 + Log: ensure XS_LOCKS stuff happens *before* XSUB is entered under + -DPERL_CAPI + Branch: maint-5.005/perl + ! XSlock.h win32/GenCAPI.pl win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 3185] By: gbarr on 1999/03/28 06:37:41 + Log: integrate change #2846 from mainline + + a modified version of suggested patch for pack template 'Z'; added docs + From: "Valeriy E. Ushakov" <uwe@ptc.spbu.ru> + Date: Mon, 16 Jun 1997 03:00:31 +0400 (MSD) + Message-ID: <%lOHpzIuGV@snark.ptc.spbu.ru> + Subject: lack of pack/unpack letter with useful symmetry for C null delimited strings + Branch: maint-5.005/perl + ! pod/perldelta.pod pod/perlfunc.pod pp.c + !> t/op/pack.t +____________________________________________________________________________ +[ 3184] By: gbarr on 1999/03/28 06:35:50 + Log: integrate change # 3160 from mainline + + better description of OP_UNSTACK (s/unstack/iteration finalizer/) + Branch: maint-5.005/perl + ! opcode.h opcode.pl +____________________________________________________________________________ +[ 3182] By: gbarr on 1999/03/28 03:40:28 + Log: Integrate changes #3067 and #3106 from mainline + + exempt $foo::a,$foo::b from warnings only if sort() was seen in package foo + From: Graham Barr <gbarr@ti.com> + Date: Wed, 3 Mar 1999 17:23:56 -0600 + Message-ID: <19990303172356.F7442@dal.asp.ti.com> + Subject: Re: 'use strict' doesn't work for one-letter variables + + change#3067 failed package.t due to needless creation of $a and $b; + fixed to do that only for C<sort BLOCK|CODE @foo>, not C<sort(@foo)> + Branch: maint-5.005/perl + ! gv.c op.c t/pragma/warn-1global +____________________________________________________________________________ +[ 3179] By: gsar on 1999/03/28 02:14:04 + Log: fix thread segfault when passing large number of arguments to child + a la C<Thread->new($foo, 1..1000)> + Branch: maint-5.005/perl + ! ext/Thread/Thread.xs t/lib/thread.t +____________________________________________________________________________ +[ 3178] By: gbarr on 1999/03/28 01:39:23 + Log: fix $Config{'usethreads'} typo in perlthrtut + + From: Ian Maloney <szhmf9@wsblob.ubs.com> + Date: Thu, 25 Mar 1999 16:40:14 +0100 (MET) + Message-Id: <199903251540.QAA02439@wsblob.> + Subject: perlthrtut documentation error + Branch: maint-5.005/perl + ! pod/perlthrtut.pod +____________________________________________________________________________ +[ 3177] By: gbarr on 1999/03/28 01:09:59 + Log: Integrate #2910 from mainline + + slurping an empty file should return '' rather than undef, with + commensurate effects on ARGV processing + Branch: maint-5.005/perl + ! pod/perldelta.pod pp_hot.c sv.h + !> t/io/argv.t +____________________________________________________________________________ +[ 3176] By: gbarr on 1999/03/28 00:00:30 + Log: Integrate relevant doc changes from mainline + Branch: maint-5.005/perl + !> (integrate 34 files) +____________________________________________________________________________ +[ 3175] By: gbarr on 1999/03/27 19:20:32 + Log: Integrated #2352 and #2397 from mainline + + Implement $^C to allow perl access to -c flag - I think this + was agreed once... + + Update docs and English.pm for $^C + Branch: maint-5.005/perl + ! gv.c mg.c + !> lib/English.pm +____________________________________________________________________________ +[ 3174] By: gbarr on 1999/03/27 18:21:01 + Log: Update Copyright year + Branch: maint-5.005/perl + ! EXTERN.h INTERN.h README av.c av.h cop.h cv.h deb.c doio.c + ! doop.c dump.c form.h gv.c gv.h handy.h hv.c hv.h mg.c mg.h + ! op.c op.h perl.h perly.y pp.c pp.h pp_ctl.c pp_hot.c pp_sys.c + ! regcomp.c regexec.c run.c scope.c sv.c sv.h toke.c util.c + ! util.h +____________________________________________________________________________ +[ 3173] By: gbarr on 1999/03/27 18:19:47 + Log: Update Test.pm to VERSION 1.122 from CPAN + Branch: maint-5.005/perl + ! lib/Test.pm +____________________________________________________________________________ +[ 3154] By: jhi on 1999/03/24 21:40:51 + Log: Reword the shared library search path (LD_LIBRARY_PATH) info + based on suggestions from Andy Dougherty. + Branch: maint-5.005/perl + ! INSTALL +____________________________________________________________________________ +[ 3146] By: jhi on 1999/03/24 09:20:14 + Log: Bring in changes #2808 and #2812 (from mainline perl) + that enhance the perlbug checklist. + Branch: maint-5.005/perl + ! utils/perlbug.PL +____________________________________________________________________________ +[ 3130] By: jhi on 1999/03/23 22:02:23 + Log: Don't use config.msg to remind about the + LD_LIBRARY_PATH because Makefile.SH takes + care of that. + + Use shrplib in DEC O^W^Digital U^W^WTru64 UNIX. + This used to be the default but in some MT or another it + was dropped because of some transient error or another. + Branch: maint-5.005/perl + ! Configure hints/dec_osf.sh +____________________________________________________________________________ +[ 3122] By: jhi on 1999/03/19 21:12:14 + Log: Describe the new Benchmark feature in more detail. + Branch: cfgperl + ! pod/perldelta.pod + Branch: maint-5.005/perl + ! pod/perldelta.pod +____________________________________________________________________________ +[ 3121] By: jhi on 1999/03/19 08:16:12 + Log: AVAILABILITY tuning. + Branch: cfgperl + ! pod/perl.pod + Branch: maint-5.005/perl + ! pod/perl.pod +____________________________________________________________________________ +[ 3119] By: jhi on 1999/03/17 14:33:43 + Log: More Apollo fixes. + Branch: maint-5.005/perl + ! README.apollo hints/apollo.sh t/lib/io_udp.t +____________________________________________________________________________ +[ 3118] By: jhi on 1999/03/16 17:23:39 + Log: Nada. + Branch: maint-5.005/perl + ! README.apollo +____________________________________________________________________________ +[ 3117] By: jhi on 1999/03/16 17:18:49 + Log: Apollo DomainOS AVAILABILITY. + Branch: cfgperl + ! pod/perl.pod + Branch: maint-5.005/perl + ! pod/perl.pod +____________________________________________________________________________ +[ 3116] By: jhi on 1999/03/16 17:14:00 + Log: Apollo DomainOS patch + From: Johann Klasek <jk@auto.tuwien.ac.at> + Subject: Re: DomainPerl + Date: Tue, 16 Mar 1999 17:46:32 +0100 + Message-ID: <19990316174632.A19759@euklid.auto.tuwien.ac.at> + Branch: maint-5.005/perl + + README.apollo apollo/netinet/in.h + ! MANIFEST hints/apollo.sh +____________________________________________________________________________ +[ 3115] By: jhi on 1999/03/16 14:23:54 + Log: From: Paul Marquess <pmarquess@bfsec.bt.co.uk> + To: Gurusamy Sarathy <gsar@activestate.com>, + Graham Barr <gbarr@pobox.com> + Cc: Perl5 Porters <perl5-porters@perl.org>, + "Paul.Marquess" <Paul.Marquess@btinternet.com> + Subject: [PATCH 5.005_56 & 5.005_03_T6] Upgrade DB_File to version 1.65 + Date: Sun, 14 Mar 1999 14:43:57 -0000 + Message-Id: <199903141841.NAA17040@defender.perl.org> + Branch: maint-5.005/perl + ! ext/DB_File/Changes ext/DB_File/DB_File.pm + ! ext/DB_File/DB_File.xs ext/DB_File/typemap +____________________________________________________________________________ +[ 3114] By: jhi on 1999/03/16 12:42:20 + Log: Mention Rhapsody in 5.005_5X perldelta, + and in Rhapsody and Netware in 5.005_0X and 5.005_5X + *planned* AVAILABILITY. + Branch: cfgperl + ! pod/perl.pod pod/perldelta.pod + Branch: maint-5.005/perl + ! pod/perl.pod +____________________________________________________________________________ +[ 3113] By: jhi on 1999/03/16 10:38:53 + Log: perldelta niggling. + Branch: cfgperl + ! pod/perldelta.pod + Branch: maint-5.005/perl + ! pod/perldelta.pod +____________________________________________________________________________ +[ 3111] By: jhi on 1999/03/16 10:28:10 + Log: AVAILABILITY update: still mention PowerUX, + Novell Netware now has sources available. + Branch: cfgperl + ! pod/perl.pod + Branch: maint-5.005/perl + ! pod/perl.pod +____________________________________________________________________________ +[ 3105] By: jhi on 1999/03/12 15:54:57 + Log: Recognize the NetBSD packages collection. + Branch: maint-5.005/perl + ! hints/netbsd.sh +____________________________________________________________________________ +[ 3104] By: jhi on 1999/03/12 09:07:04 + Log: From: pvhp@forte.com (Peter Prymmer) + To: jhi@iki.fi, perl-mvs@perl.org, perlbug@perl.com + Subject: [PATCH MT6,_56] was Re: Not OK: perl 5.00503 +MAINT_TRIAL_6 on os390 06.00 (UNINSTALLED) + Date: Thu, 11 Mar 99 14:24:54 PST + Message-Id: <9903112224.AA24346@forte.com> + Branch: maint-5.005/perl + ! README.os390 t/lib/posix.t +____________________________________________________________________________ +[ 3102] By: jhi on 1999/03/10 11:01:20 + Log: From: pvhp@forte.com (Peter Prymmer) + To: perl5-porters@perl.org + Subject: [5.005_03-MT6]Patch: time passes + Date: Tue, 9 Mar 99 18:42:17 PST + Message-Id: <9903100242.AA29057@forte.com> + Branch: maint-5.005/perl + ! perl.c +____________________________________________________________________________ +[ 3101] By: jhi on 1999/03/10 10:30:15 + Log: From: Mark-Jason Dominus <mjd@plover.com> + To: perl5-porters@perl.com + Subject: Minor fix to perlfunc.pod + Date: Mon, 08 Mar 1999 20:05:53 -0500 + Message-ID: <19990309010553.13757.qmail@plover.com> + Branch: maint-5.005/perl + ! pod/perlfunc.pod +____________________________________________________________________________ +[ 3094] By: jhi on 1999/03/06 16:16:15 + Log: From: Mark Kettenis <kettenis@wins.uva.nl> + To: jhi@iki.fi + Subject: Oops + Date: Sat, 6 Mar 1999 17:15:35 +0100 (CET) + Message-Id: <199903061615.RAA00207@delius.kettenis.nl> + Branch: maint-5.005/perl + ! README.hurd +____________________________________________________________________________ +[ 3093] By: jhi on 1999/03/06 15:59:46 + Log: From: Mark Kettenis <kettenis@wins.uva.nl> + To: jhi@iki.fi + Subject: New Hurd README + Date: Sat, 6 Mar 1999 16:46:12 +0100 (CET) + Message-Id: <199903061601.RAA00185@delius.kettenis.nl> + Branch: maint-5.005/perl + ! README.hurd +____________________________________________________________________________ +[ 3092] By: jhi on 1999/03/06 12:52:06 + Log: From: Paul_Green@stratus.com + To: perl5-porters@perl.org + Cc: jhi@iki.fi, Paul_Green@stratus.com + Subject: [PATCH 5.005_03-MAINT_TRIAL_6]: platform: vos -- updates to VOS port of Perl5 + Date: Fri, 5 Mar 1999 18:08:49 -0500 + Message-ID: <1D1A4EF7AD4DD211A80D00A0C9D7DB665A035A@exna1.stratus.com> + Branch: maint-5.005/perl + ! vos/config.h vos/config_h.SH_orig +____________________________________________________________________________ +[ 3091] By: jhi on 1999/03/06 12:42:21 + Log: From: Dan Sugalski <sugalskd@osshe.edu> + To: perl5-porters@perl.org, vmsperl@perl.org + Subject: [PATCH 5.005_03-MT6]VMS build patch + Date: Fri, 05 Mar 1999 12:36:19 -0800 + Message-Id: <3.0.6.32.19990305123619.02d326a0@ous.edu> + Branch: maint-5.005/perl + ! vms/subconfigure.com +____________________________________________________________________________ +[ 3090] By: gsar on 1999/03/06 04:40:03 + Log: integrate change#3089 from mainline + + tolerate CRs after options + Branch: maint-5.005/perl + !> perl.c +____________________________________________________________________________ +[ 3086] By: gbarr on 1999/03/05 01:48:05 + Log: #3085 was a bit premature, this is MT6 as 2 files were + missing from MANIFEST + Branch: maint-5.005/perl + ! MANIFEST +____________________________________________________________________________ +[ 3085] By: gbarr on 1999/03/05 01:41:06 + Log: Trial release 6 + Branch: maint-5.005/perl + ! Changes +____________________________________________________________________________ +[ 3084] By: gbarr on 1999/03/05 01:34:07 + Log: Don't process - as a file in Errno_pm.PL + + From: Jarkko Hietaniemi <jhi@iki.fi> + Date: Thu, 4 Mar 1999 13:29:23 +0200 (EET) + Message-ID: <14046.28307.561693.849859@alpha.hut.fi> + Subject: Re: maint-5.005 + Branch: maint-5.005/perl + ! ext/Errno/Errno_pm.PL +____________________________________________________________________________ +[ 3081] By: gsar on 1999/03/05 00:14:33 + Log: protect against doubled backslashes + Branch: maint-5.005/perl + ! ext/Errno/Errno_pm.PL +____________________________________________________________________________ +[ 3080] By: gsar on 1999/03/04 23:37:20 + Log: pick up AIX hints from mainline + Branch: maint-5.005/perl + !> hints/aix.sh +____________________________________________________________________________ +[ 3079] By: gsar on 1999/03/04 21:09:43 + Log: tweak cast and crew + Branch: maint-5.005/perl + ! Changes +____________________________________________________________________________ +[ 3078] By: gsar on 1999/03/04 21:03:04 + Log: update patchlevel, Changes + Branch: maint-5.005/perl + ! Changes README.win32 patchlevel.h + !> pod/perlhist.pod +____________________________________________________________________________ +[ 3075] By: gsar on 1999/03/04 07:36:53 + Log: integrate changes#3037,3041 from mainline + + fix longstanding bug: searches for lexicals originating within eval'' + weren't stopping at the subroutine boundary correctly + -- + fix subtle bug in eval'' testsuite + Branch: maint-5.005/perl + !> op.c proto.h t/op/eval.t +____________________________________________________________________________ +[ 3074] By: gsar on 1999/03/04 07:32:15 + Log: integrate change#3048 from mainline + + updated HP-UX notes from Jeff Okamoto <okamoto@xfiles.intercon.hp.com> + Branch: maint-5.005/perl + !> MANIFEST README.hpux +____________________________________________________________________________ +[ 3073] By: gsar on 1999/03/04 07:29:43 + Log: integrate changes#3014,3015,3021,3032,3034,3045 from mainline + + more "correct" utbuf for utime() + -- + avoid modifying readonly values from qw() + -- + ansify perlio.c, fix PerlIO-ish typos + -- + add README.hpux + -- + s/print STDERR/warn/ suggested by abigail@fnx.com; add $VERSION + -- + destroy PL_svref_mutex in perl_destruct() + Branch: maint-5.005/perl + +> README.hpux + !> MANIFEST doio.c ext/DynaLoader/dl_beos.xs + !> ext/DynaLoader/dl_cygwin32.xs iperlsys.h + !> lib/ExtUtils/MM_Unix.pm lib/Getopt/Std.pm perl.c perlio.c +____________________________________________________________________________ +[ 3072] By: gsar on 1999/03/04 07:12:15 + Log: integrate changes#2978,2979 from mainline + + bring '*' prototype closer to how it behaves internally + -- + doc for change#2978 + Branch: maint-5.005/perl + +> t/lib/fatal.t + !> MANIFEST lib/Fatal.pm op.c pod/perlsub.pod t/comp/proto.t +____________________________________________________________________________ +[ 3071] By: gsar on 1999/03/04 07:05:50 + Log: integrate changes#2919,2920,2921,2928,2932,2933 from mainline + + applied suggested patch, with several language/readability tweaks + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Fri, 29 Jan 1999 00:25:02 -0500 + Message-ID: <19990129002502.C2898@monk.mps.ohio-state.edu> + Subject: Re: [PATCH 5.005_*] Better parsing docs + -- + tweak READ() docs to mention $buffer must be altered by reference + -- + use New() et al., rather than safemalloc() et al. + From: jan.dubois@ibm.net (Jan Dubois) + Date: Fri, 29 Jan 1999 23:27:22 +0100 + Message-ID: <36bd33f2.51029616@smtp1.ibm.net> + Subject: [PATCH _03-MT5] POSIX.xs memory API + -- + allow the Carp routines to pass through exception objects + -- + clarify what a "line" is + -- + From: "J. van Krieken" <John.van.Krieken@ATComputing.nl> + Date: Thu, 4 Feb 1999 17:25:25 +0100 (MET) + Message-Id: <199902041625.RAA14489@atcmpg.ATComputing.nl> + Subject: s2p incorrectly handles hold space commands + Branch: maint-5.005/perl + !> ext/POSIX/POSIX.xs lib/Carp.pm pod/perlfunc.pod pod/perlop.pod + !> pod/perltie.pod pod/perlvar.pod x2p/s2p.PL +____________________________________________________________________________ +[ 3070] By: gsar on 1999/03/04 06:43:57 + Log: integrate changes#2748,2753,2754,2819,2824,2855,2866,2867,2869,2885,2888,2889 + from mainline + + From: "Jonathan I. Kamens" <jik@kamens.brookline.ma.us> + Date: Thu, 3 Dec 1998 15:10:17 -0500 + Message-Id: <199812032010.PAA09692@jik.shore.net> + Subject: sample checksum code in "perlfunc" man page is wrong + -- + Todo tweaks + -- + Todo updates from Andy Dougherty <doughera@lafayette.edu> + -- + avoid garbage in db->dirbuf + From: Masahiro KAJIURA <masahiro.kajiura@toshiba.co.jp> + Date: Sat, 05 Dec 1998 14:14:54 +0900 + Message-Id: <199812050514.OAA23268@toshiba.co.jp> + Subject: SDBM bug + -- + tweak doc on bitwise ops + -- + applied suggested patch; added tests + From: Adam Krolnik <adamk@gypsy.cyrix.com> + Date: Sat, 12 Dec 98 15:30:18 -0600 + Message-Id: <9812122130.AA03717@gypsy.eng.cyrix.com> + Subject: Range operation doesn't handle IV_MAX + -- + display full pathname of unreadable files + -- + av_extend() doc tweak from Jan Dubois + -- + update win32/pod.mak + -- + note how to find REG_INFTY limit + -- + add note about test-notty target + -- + tweak PERL_STRICT_CR notes + Branch: maint-5.005/perl + !> Porting/pumpkin.pod README.win32 Todo Todo-5.005 + !> ext/SDBM_File/sdbm/sdbm.c pod/perldelta.pod pod/perlfunc.pod + !> pod/perlguts.pod pod/perlop.pod pod/perlre.pod pp_ctl.c + !> t/op/range.t utils/perldoc.PL win32/pod.mak +____________________________________________________________________________ +[ 3069] By: gsar on 1999/03/04 06:02:29 + Log: integrate change#2747 from mainline + + typos in Pod/Text.pm + Branch: maint-5.005/perl + !> lib/Pod/Text.pm +____________________________________________________________________________ +[ 3059] By: jhi on 1999/03/03 22:46:43 + Log: Document HP-UX 11 Y2K patch effect, based on + + From: "Richard L. England" <richard_england@mentorg.com> + To: perlbug@perl.com + CC: "England, Richard" <richard_england@mentorg.com> + Subject: test io/fs.t number 18 fails on HPUX 11.0 when Y2K patch installed. + Date: Fri, 26 Feb 1999 15:35:49 -0800 + Message-ID: <36D72FD4.4136C84F@mentorg.com> + Branch: maint-5.005/perl + ! INSTALL +____________________________________________________________________________ +[ 3057] By: jhi on 1999/03/03 21:42:22 + Log: The *symbols patch (for Kurt's h2ph fixes) haunted us in AIX. + Branch: maint-5.005/perl + ! Configure +____________________________________________________________________________ +[ 3056] By: jhi on 1999/03/03 21:21:46 + Log: Fixed the pthreads_created_joinable test messed up + by the Mach cthreads change. + Branch: maint-5.005/perl + ! Configure +____________________________________________________________________________ +[ 3055] By: jhi on 1999/03/03 18:17:55 + Log: Configure and make gotchas. + Branch: maint-5.005/perl + ! INSTALL +____________________________________________________________________________ +[ 3051] By: jhi on 1999/03/02 08:24:52 + Log: From: Dan Sugalski <sugalskd@osshe.edu> + To: perl5-porters@perl.org, vmsperl@perl.org + Subject: [PATCH 5.005_0x and 5.005_5x]Minor update to README.VMS + Date: Mon, 01 Mar 1999 16:10:57 -0800 + Message-Id: <3.0.6.32.19990301161057.03b1fc00@ous.edu> + Branch: cfgperl + ! README.vms + Branch: maint-5.005/perl + ! README.vms +____________________________________________________________________________ +[ 3049] By: jhi on 1999/03/02 07:34:21 + Log: From: Spider Boardman <spider@leggy.zk3.dec.com> + To: perl5-porters@perl.org + Subject: [PATCH] Eliminate (valid) warning in byterun.c + Date: Mon, 01 Mar 1999 17:27:59 -0500 + Message-Id: <199903012227.RAA00181@leggy.zk3.dec.com> + Branch: cfgperl + ! bytecode.h + Branch: maint-5.005/perl + ! bytecode.h +____________________________________________________________________________ +[ 3028] By: jhi on 1999/02/26 14:40:00 + Log: HP-UX 11 threads. + + From: Jeff Okamoto <okamoto@xfiles.intercon.hp.com> + To: perl5-porters@perl.org + Cc: jhi@cc.hut.fi + Subject: Maint 5 and _54 with threading on HP-UX 11.00 + Date: Wed, 3 Feb 1999 12:57:18 -0800 (PST) + Message-Id: <199902032057.MAA10218@xfiles.intercon.hp.com> + + NOTE from jhi: the hpux hints could still be more robust by + disabling gdbm when necessary. + + Currently if there's a libgdbm.sl (gdbm 1.7.3) which is pre-11, + linking -lgdbm -lpthread creates an executable that instantly + core dumps on a pthreads internal panic: + + ./gdpt + + Pthread internal error: message: __libc_reinit() failed, file: ../pthreads/pthread.c, line: 1096 + Return Pointer is 0xc082bf33 + 17639 quit (core dumped) ./gdpt + + You don't have to *use* either gdbm or pthreads in the executable, + just linking them together is enough. Workaround is to recompile + the GDBM under HP-UX 11, that makes the problem to go away. + Branch: maint-5.005/perl + ! hints/hpux.sh thread.h +____________________________________________________________________________ +[ 3027] By: jhi on 1999/02/26 09:04:29 + Log: From: abigail@fnx.com + To: perl5-porters@perl.org (Perl Porters) + Subject: [PATCH 5.005_02 Getopt::Std] warn() instead of print STDERR. + Date: Thu, 25 Feb 1999 22:08:41 -0500 (EST) + Message-ID: <19990226030841.5985.qmail@alexandra.wayne.fnx.com> + Branch: maint-5.005/perl + ! lib/Getopt/Std.pm +____________________________________________________________________________ +[ 3026] By: jhi on 1999/02/26 08:18:26 + Log: full_ar wasn't propagated. + Branch: maint-5.005/perl + ! Configure +____________________________________________________________________________ +[ 3013] By: jhi on 1999/02/22 19:27:44 + Log: Fix MacPerl version, change PowerUX to PowerMAX. + + From: Chris Nandor <pudge@pobox.com> + To: jhi@iki.fi + Cc: perl5-porters@perl.org + Subject: Re: perl current availability as documented by perl.pod + Date: Sun, 21 Feb 1999 11:06:03 -0500 + Message-Id: <v04020a07b2f5df60c9e3@[192.168.0.77]> + + From: Tom Horsley <Tom.Horsley@mail.ccur.com> + To: jhi@iki.fi + Cc: perl5-porters@perl.org + Subject: Re: perl current availability as documented by perl.pod + Date: Mon, 22 Feb 1999 13:08:30 GMT + Message-Id: <199902221308.NAA19971@cleo.ccur.com> + Branch: cfgperl + ! pod/perl.pod + Branch: maint-5.005/perl + ! pod/perl.pod +____________________________________________________________________________ +[ 3010] By: jhi on 1999/02/22 10:21:55 + Log: From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + To: gbarr@pobox.com (Graham Barr) + Cc: perl5-porters@perl.org + Subject: [PATCH 5.005_03-MT5] DB_File 1.64 patch + Date: Mon, 22 Feb 1999 10:12:34 +0000 (GMT) + Message-Id: <9902221012.AA17784@claudius.bfsec.bt.co.uk> + Branch: maint-5.005/perl + ! ext/DB_File/Changes ext/DB_File/DB_File.pm + ! ext/DB_File/DB_File.xs ext/DB_File/typemap t/lib/db-recno.t +____________________________________________________________________________ +[ 3005] By: jhi on 1999/02/22 08:35:30 + Log: Configure/Perl knew how to look for use Mach cthreads + but Configure didn't let them to be used ($osname 'next'). + Branch: cfgperl + ! Configure config_h.SH + Branch: maint-5.005/perl + ! Configure +____________________________________________________________________________ +[ 3004] By: jhi on 1999/02/21 15:46:02 + Log: Update Acorn AVAILABILITY. + Branch: cfgperl + ! pod/perl.pod + Branch: maint-5.005/perl + ! pod/perl.pod +____________________________________________________________________________ +[ 3003] By: jhi on 1999/02/21 14:50:42 + Log: From: rjk@linguist.dartmouth.edu (Ronald J. Kimball) + To: perl5-porters@perl.org (Perl 5 Porters) + Subject: PATCH: perlref.pod - symbolic ref example + Date: Sat, 20 Feb 1999 17:32:11 -0500 (EST) + Message-Id: <199902202232.RAA62306@linguist.dartmouth.edu> + Branch: cfgperl + ! pod/perlref.pod + Branch: maint-5.005/perl + ! pod/perlref.pod +____________________________________________________________________________ +[ 3000] By: jhi on 1999/02/21 14:15:31 + Log: pack s/l for negative numbers was broken on platforms + where sizeof(short) != 2 or sizeof(long) != 4 (Alpha, Cray). + pack v was broken for sizeof(short) == 8 big-endian platforms + (Cray), only zeros were produced. + Branch: maint-5.005/perl + ! perl.h pod/perlfunc.pod pp.c t/op/pack.t +____________________________________________________________________________ +[ 2997] By: jhi on 1999/02/20 14:00:26 + Log: Glossary update. + Branch: maint-5.005/perl + ! Porting/Glossary +____________________________________________________________________________ +[ 2995] By: jhi on 1999/02/20 12:25:10 + Log: Document #2893, Mach cthreads support. + Branch: maint-5.005/perl + ! pod/perldelta.pod +____________________________________________________________________________ +[ 2986] By: jhi on 1999/02/19 23:26:34 + Log: Remove the unnecessary osf1 -D__LANGUAGE_C__. + Branch: maint-5.005/perl + ! Configure +____________________________________________________________________________ +[ 2983] By: jhi on 1999/02/19 20:35:51 + Log: Mach cthreads: + From: brie@corp.home.net (Brian Harrison) + Subject: perl5.005_02 patch for mthreads + To: perl5-porters@perl.org + Date: Fri, 23 Oct 1998 14:20:57 -0700 (PDT) + Message-ID: <Pine.GSO.4.04.9810231410220.11111-200000@sulaco.eos.home.net> + Branch: maint-5.005/perl + ! Configure Porting/Glossary config_h.SH malloc.c perl.h + ! thread.h +____________________________________________________________________________ +[ 2981] By: jhi on 1999/02/19 19:49:03 + Log: From: "Kurt D. Starsinic" <kstar@chapin.edu> + To: Chaim Frenkel <chaimf@pobox.com>, + Russ Allbery <rra@stanford.edu>, + Jarkko Hietaniemi <jhi@iki.fi>, + Gurusamy Sarathy <gsar@activestate.com>, + Graham Barr <gbarr@pobox.com> + Cc: bdensch@ameritech.net, perlbug@perl.com + Subject: [PATCH] Re: Solaris 7 for Intel + Message-ID: <19990219124404.A30182@O2.chapin.edu> + + and Glossary update. + Branch: maint-5.005/perl + ! Configure Makefile.SH Porting/Glossary +____________________________________________________________________________ +[ 2980] By: gbarr on 1999/02/19 16:06:53 + Log: Make result of h2xs work when user adds C<use strict> + Branch: maint-5.005/perl + ! utils/h2xs.PL +____________________________________________________________________________ +[ 2976] By: gsar on 1999/02/18 21:54:09 + Log: integrate change#2975 from mainline + + distinguish eval'' from BEGIN|INIT|END CVs (fixes buggy propagation + of lexical searches in BEGIN|INIT|END) + Branch: maint-5.005/perl + !> cop.h cv.h op.c perly.c perly.y pp_ctl.c t/op/misc.t + !> vms/perly_c.vms +____________________________________________________________________________ +[ 2971] By: jhi on 1999/02/18 11:14:24 + Log: AIX syscalls.exp scan missed explicitly 32/64-bit syscalls. + + From: Joe Buehler <jhpb@hekimian.com> + To: perl5-porters@perl.org + Subject: setsid not detected by perl 5.005_02 configure under AIX 4.3 + Date: 12 Feb 1999 11:25:21 -0500 + Message-ID: <yd3lni3613i.fsf@ganymede.hekimian.com> + Branch: maint-5.005/perl + ! Configure +____________________________________________________________________________ +[ 2967] By: jhi on 1999/02/17 23:12:59 + Log: Make SCO/Unixware scan to work in Unixware, too. + + From: Tom Hughes <thh@cyberscience.com> + To: perlbug@perl.com + Subject: Not OK: perl 5.00555 on i386-svr4 [actually Unixware 2.1] (UNINSTALLED) + Date: 17 Feb 1999 15:34:15 +0000 + Message-ID: <yekg185nix4.fsf@elva.cyberscience.com> + Branch: maint-5.005/perl + ! Configure +____________________________________________________________________________ +[ 2956] By: jhi on 1999/02/15 21:03:28 + Log: OpenBSD sparc SHMLBA (like change #2945). + Branch: maint-5.005/perl + ! ext/IPC/SysV/SysV.xs +____________________________________________________________________________ +[ 2950] By: jhi on 1999/02/15 13:37:28 + Log: AVAILABILITY sync. + Branch: maint-5.005/perl + ! pod/perl.pod +____________________________________________________________________________ +[ 2906] By: jhi on 1999/02/13 14:55:47 + Log: AVAILABILITY sync. + Branch: maint-5.005/perl + ! pod/perl.pod +____________________________________________________________________________ +[ 2905] By: gsar on 1999/02/13 00:12:53 + Log: integrate change#2898 from mainline + + support win32_putenv() + Branch: maint-5.005/perl + !> mg.c util.c win32/GenCAPI.pl win32/makedef.pl win32/perlhost.h + !> win32/win32.c win32/win32iop.h +____________________________________________________________________________ +[ 2904] By: jhi on 1999/02/12 21:23:30 + Log: Add README.hurd, from Mark Kettenis <kettenis@wins.uva.nl>. + Branch: maint-5.005/perl + + README.hurd + ! MANIFEST +____________________________________________________________________________ +[ 2900] By: jhi on 1999/02/12 12:07:28 + Log: SCO ODT/OSR release scanning. + Branch: maint-5.005/perl + ! Configure +____________________________________________________________________________ +[ 2897] By: jhi on 1999/02/12 11:24:25 + Log: Undo a big bad paste from change #2884. + Branch: maint-5.005/perl + ! hints/openbsd.sh +____________________________________________________________________________ +[ 2896] By: jhi on 1999/02/12 11:19:52 + Log: Update the error message of db-recno.t to DB version 1.86 + and the URL to www.sleepycat.com instead of www.bostic.com. + Branch: maint-5.005/perl + ! t/lib/db-recno.t +____________________________________________________________________________ +[ 2895] By: gsar on 1999/02/12 11:18:59 + Log: integrate change#2854 from mainline + + compatibility fix: magic non-propagation in foreach implicit localization + Branch: maint-5.005/perl + !> pp_ctl.c t/op/local.t +____________________________________________________________________________ +[ 2884] By: jhi on 1999/02/12 08:36:14 + Log: OpenBSD pthreads awareness, thanks to + David Leonard <david.leonard@csee.uq.edu.au> + Branch: maint-5.005/perl + ! Configure hints/openbsd.sh +____________________________________________________________________________ +[ 2883] By: jhi on 1999/02/12 08:29:51 + Log: AVAILABILITY sync. + Branch: maint-5.005/perl + ! pod/perl.pod +____________________________________________________________________________ +[ 2878] By: jhi on 1999/02/11 22:00:50 + Log: Replace changes #2783, #2784, #2785, with a single tested + patch from Francois Desarmenien <desar@club-internet.fr>. + Branch: maint-5.005/perl + ! MANIFEST ext/GDBM_File/hints/sco.pl ext/IPC/SysV/SysV.xs + ! hints/sco.sh +____________________________________________________________________________ +[ 2876] By: jhi on 1999/02/11 20:43:17 + Log: From: Chris Nandor <pudge@pobox.com> + To: perl5-porters@perl.org + Subject: [PATCH] perlport.pod 1.39 + Date: Thu, 11 Feb 1999 12:28:35 -0500 + Message-Id: <v04020a2db2e8c3177123@[192.168.0.77]> + Branch: maint-5.005/perl + ! pod/perlport.pod +____________________________________________________________________________ +[ 2875] By: jhi on 1999/02/11 20:35:08 + Log: The fpsetmask() really is SCO5 only. + Branch: maint-5.005/perl + ! unixish.h +____________________________________________________________________________ +[ 2874] By: jhi on 1999/02/11 20:32:06 + Log: Change #2783 missed these. + Branch: maint-5.005/perl + ! ext/IPC/SysV/SysV.xs unixish.h +____________________________________________________________________________ +[ 2873] By: jhi on 1999/02/11 20:27:45 + Log: Import the change #2810 from cfgperl. + Branch: maint-5.005/perl + + ext/GDBM_File/hints/sco.pl + ! MANIFEST hints/sco.sh unixish.h +____________________________________________________________________________ +[ 2872] By: jhi on 1999/02/11 19:57:37 + Log: Sync the current AVAILABILITY. + Branch: maint-5.005/perl + ! pod/perl.pod pod/perldelta.pod +____________________________________________________________________________ +[ 2871] By: jhi on 1999/02/11 19:42:54 + Log: Copied the GNU/Hurd hints file over from cfgperl + because it works well enough (there are still some + rough edges in Hurd), verified via private + email from Mark Kettenis <kettenis@wins.uva.nl> + Branch: maint-5.005/perl + + hints/gnu.sh +____________________________________________________________________________ +[ 2864] By: jhi on 1999/02/11 08:45:00 + Log: From: Spider Boardman <spider@zk3.dec.com> + To: perlbug@perl.com + Subject: Not OK: perl 5.00503 +MAINT_TRIAL_5 on RISC-ultrix 4.4 (UNINSTALLED) + Date: Wed, 10 Feb 1999 23:33:31 -0500 + Message-Id: <9902110433.AA12816@abyss.zk3.dec.com> + Branch: maint-5.005/perl + ! doio.c ext/IPC/SysV/SysV.xs hints/ultrix_4.sh +____________________________________________________________________________ +[ 2863] By: jhi on 1999/02/11 08:35:35 + Log: AVAILABILITY. + Branch: maint-5.005/perl + ! pod/perl.pod +____________________________________________________________________________ +[ 2858] By: gsar on 1999/02/11 07:10:59 + Log: remove dup hunk + Branch: maint-5.005/perl + ! pod/perldelta.pod +____________________________________________________________________________ +[ 2857] By: gsar on 1999/02/11 07:09:20 + Log: sync with parent version of perldelta.pod + Branch: maint-5.005/perl + !> pod/perldelta.pod +____________________________________________________________________________ +[ 2853] By: gsar on 1999/02/11 00:33:06 + Log: integrate change#2816 from mainline + + minor bug in dumping blessed subrefs + Branch: maint-5.005/perl + !> ext/Data/Dumper/Dumper.pm +____________________________________________________________________________ +[ 2852] By: gsar on 1999/02/10 23:17:49 + Log: fair warning about -Dusethreads + Branch: maint-5.005/perl + ! Configure INSTALL README.threads +____________________________________________________________________________ +[ 2851] By: jhi on 1999/02/10 23:00:39 + Log: Snapshot of the ongoing AVAILABILITY discussion. + Branch: maint-5.005/perl + ! pod/perl.pod +____________________________________________________________________________ +[ 2850] By: jhi on 1999/02/10 16:07:32 + Log: OS390 and Windows AVAILABILITY entries enhanced. + Branch: maint-5.005/perl + ! pod/perl.pod +____________________________________________________________________________ +[ 2849] By: jhi on 1999/02/10 12:39:46 + Log: AS/400 and Mac were not described right. + Branch: maint-5.005/perl + ! pod/perl.pod +____________________________________________________________________________ +[ 2848] By: jhi on 1999/02/10 09:13:49 + Log: Added AVAILABILITY section. + Branch: maint-5.005/perl + ! pod/perl.pod +____________________________________________________________________________ +[ 2837] By: jhi on 1999/02/08 14:51:39 + Log: Fix typo introduced in change #2836. + Branch: maint-5.005/perl + ! Configure +____________________________________________________________________________ +[ 2836] By: jhi on 1999/02/08 14:44:31 + Log: Augment change #2809, the h2ph-*symbols patch. + Branch: maint-5.005/perl + ! Configure t/lib/h2ph.pht +____________________________________________________________________________ +[ 2815] By: gsar on 1999/02/05 03:44:50 + Log: integrate change#2242 from mainline + + fix skipspace() to properly account for newlines in eval''-ed + strings (caused bogus line numbers in diagnostics and debugger) + Branch: maint-5.005/perl + !> toke.c +____________________________________________________________________________ +[ 2814] By: jhi on 1999/02/04 21:21:39 + Log: Stratus perlport update. + Branch: maint-5.005/perl + ! pod/perlport.pod +____________________________________________________________________________ +[ 2813] By: jhi on 1999/02/04 21:16:54 + Log: Stratus VOS update. + + From: Paul_Green@stratus.com + To: jhi@iki.fi + Subject: RE: VOS changes for Perl5.005_03 are ready! + Date: Thu, 4 Feb 1999 14:51:07 -0500 + Message-ID: <1D1A4EF7AD4DD211A80D00A0C9D7DB665A0168@exna1.stratus.com> + Branch: maint-5.005/perl + + vos/vos_accept.c + ! MANIFEST README.vos perl.c pod/perlport.pod vos/Changes + ! vos/build.cm vos/compile_perl.cm vos/config.h + ! vos/config_h.SH_orig vos/perl.bind vos/test_vos_dummies.c + ! vos/vos_dummies.c vos/vosish.h +____________________________________________________________________________ +[ 2809] By: jhi on 1999/02/03 19:54:16 + Log: h2ph fixes + Configure patch to support them. + + From: "Kurt D. Starsinic" <kstar@chapin.edu> + To: Graham Barr <gbarr@pobox.com>, Jarkko Hietaniemi <jhi@iki.fi>, + Gurusamy Sarathy <gsar@engin.umich.edu> + Cc: perl5-porters@perl.org + Subject: [PATCH 5.00503_MT5] h2ph.PL + Date: Tue, 2 Feb 1999 19:48:06 -0500 + Message-ID: <19990202194806.E10647@O2.chapin.edu> + Branch: maint-5.005/perl + ! Configure utils/h2ph.PL +____________________________________________________________________________ +[ 2802] By: jhi on 1999/02/02 17:41:23 + Log: From: John Bley <jbb6@acpub.duke.edu> + To: perlbug@perl.org + Subject: [PATCH]5.005_54 (DOC) fix minor typos + Date: Tue, 2 Feb 1999 07:52:52 -0500 (EST) + Message-ID: <Pine.SOL.3.91.990202075115.23589A-100000@soc11.acpub.duke.edu> + Branch: maint-5.005/perl + ! pod/perlre.pod +____________________________________________________________________________ +[ 2790] By: jhi on 1999/02/02 16:51:45 + Log: Re-introduce the typo corrections (update to CGI 2.46 + overran them). + Branch: maint-5.005/perl + ! lib/CGI.pm +____________________________________________________________________________ +[ 2781] By: jhi on 1999/02/02 14:27:01 + Log: Update the MkLinux note. + Branch: maint-5.005/perl + ! hints/linux.sh +____________________________________________________________________________ +[ 2775] By: jhi on 1999/02/02 13:13:24 + Log: Mention lib/Dumpvalue.pm. + Branch: maint-5.005/perl + ! pod/roffitall +____________________________________________________________________________ +[ 2767] By: jhi on 1999/02/02 12:29:57 + Log: Demangle spaces to tab+space. + Branch: maint-5.005/perl + ! hints/freebsd.sh +____________________________________________________________________________ +[ 2758] By: jhi on 1999/02/02 10:51:26 + Log: Detypo. + Branch: maint-5.005/perl + ! lib/Math/Trig.pm +____________________________________________________________________________ +[ 2755] By: jhi on 1999/02/02 09:07:51 + Log: Make FreeBSD 2.2.7 work with -Duseshrplib -ders. + Branch: maint-5.005/perl + ! hints/freebsd.sh +____________________________________________________________________________ +[ 2752] By: jhi on 1999/02/01 22:15:12 + Log: Add perlthrtut.pod. + + From: Dan Sugalski <sugalskd@osshe.edu> + To: perl5-porters@perl.org + Subject: perlthrtut.pod + Date: Mon, 01 Feb 1999 10:57:11 -0800 + Message-Id: <3.0.6.32.19990201105711.02e62540@ous.edu> + Branch: maint-5.005/perl + + pod/perlthrtut.pod + ! MANIFEST pod/Makefile pod/buildtoc pod/perldelta.pod + ! pod/roffitall +____________________________________________________________________________ +[ 2741] By: gbarr on 1999/02/01 03:00:42 + Log: Fix typecasts in #2728 + + From: "G. Del Merritt" <del@intranetics.com> + Date: Fri, 29 Jan 1999 11:47:25 -0700 + Message-Id: <199901291847.LAA04828@jhereg.perl.com> + Subject: Not OK: perl 5.00503 +MAINT_TRIAL_5 on MSWin32-x86-object 4.0 (PATCH included) + Branch: maint-5.005/perl + ! ext/POSIX/POSIX.xs +____________________________________________________________________________ +[ 2740] By: gsar on 1999/02/01 02:43:07 + Log: CAPI inheritance tweak and doc + Branch: maint-5.005/perl + ! lib/ExtUtils/MakeMaker.pm +____________________________________________________________________________ +[ 2739] By: jhi on 1999/01/31 18:31:54 + Log: Undo changes #2730 and #2731 and replace them + with an extensively tested patch from + Anton Berezin <tobez@plab.ku.dk> (via private email). + Branch: maint-5.005/perl + ! Makefile.SH hints/freebsd.sh +____________________________________________________________________________ +[ 2738] By: gsar on 1999/01/31 05:04:32 + Log: fix bogus CAPI inheritance from change#2541 + Branch: maint-5.005/perl + ! lib/ExtUtils/MakeMaker.pm +____________________________________________________________________________ +[ 2737] By: gsar on 1999/01/31 04:55:06 + Log: remove the big ugly thing jhi sneezed into INSTALL :-) + Branch: maint-5.005/perl + ! INSTALL +____________________________________________________________________________ +[ 2736] By: jhi on 1999/01/30 12:57:06 + Log: From: pvhp@forte.com (Peter Prymmer) + To: perl-mvs@perl.org, perlbug@perl.com + Subject: Not OK: perl 5.00503 +MAINT_TRIAL_5 on os390 05.00 (UNINSTALLED) + Date: Fri, 29 Jan 99 19:22:31 PST + Message-Id: <9901300322.AA19136@forte.com> + + (slighty edited at the end) + Branch: maint-5.005/perl + ! README.os390 +____________________________________________________________________________ +[ 2735] By: jhi on 1999/01/30 11:49:54 + Log: Undo 5.005-devel random, srandom mention. + Branch: maint-5.005/perl + ! INSTALL +____________________________________________________________________________ +[ 2734] By: jhi on 1999/01/29 22:22:00 + Log: Add perlreftut. + Branch: maint-5.005/perl + + pod/perlreftut.pod + ! MANIFEST pod/perl.pod pod/perldelta.pod pod/roffitall +____________________________________________________________________________ +[ 2732] By: gsar on 1999/01/29 20:09:44 + Log: integrate change#2720 from mainline + + missing space while munging CCFLAGS for PERL_CAPI + Branch: maint-5.005/perl + !> lib/ExtUtils/MM_Unix.pm +____________________________________________________________________________ +[ 2731] By: jhi on 1999/01/29 14:33:12 + Log: FreeBSD version numbers can be like "2.2.8-release". + Branch: maint-5.005/perl + ! hints/freebsd.sh +____________________________________________________________________________ +[ 2730] By: jhi on 1999/01/29 12:40:38 + Log: FreeBSD hints iteration (hopefully convergent). + usethreads: require at least FreeBSD 2.2.8. + signal type: mirror change #2429 in cfgperl. + Branch: maint-5.005/perl + ! hints/freebsd.sh +____________________________________________________________________________ +[ 2729] By: gbarr on 1999/01/29 05:06:32 + Log: Trial release 5 + Branch: maint-5.005/perl + ! Changes patchlevel.h pod/perlhist.pod +____________________________________________________________________________ +[ 2728] By: gbarr on 1999/01/29 04:10:37 + Log: From: Ted Law <tedlaw@cibcwg.com> + Date: Wed, 27 Jan 1999 14:54:03 -0500 (EST) + Message-Id: <199901271954.OAA07391@dcm2.cibcwg.com> + Subject: POSIX::strftime buffer overflow problem + Branch: maint-5.005/perl + ! ext/POSIX/POSIX.xs +____________________________________________________________________________ +[ 2728] By: gbarr on 1999/01/29 04:10:37 + Log: From: Ted Law <tedlaw@cibcwg.com> + Date: Wed, 27 Jan 1999 14:54:03 -0500 (EST) + Message-Id: <199901271954.OAA07391@dcm2.cibcwg.com> + Subject: POSIX::strftime buffer overflow problem + Branch: maint-5.005/perl + ! ext/POSIX/POSIX.xs +____________________________________________________________________________ +[ 2727] By: gbarr on 1999/01/29 04:09:57 + Log: From: Tom Spindler <dogcow@isi.net> + Date: Thu, 28 Jan 1999 17:15:11 -0800 + Message-ID: <19990128171510.A11778@isi.net> + Subject: [PATCH] BeOS dynamic loading support for perl5.005_03_MT4 + Branch: maint-5.005/perl + + ext/DynaLoader/dl_beos.xs + ! Configure MANIFEST Makefile.SH README.beos hints/beos.sh + ! lib/ExtUtils/MM_Unix.pm +____________________________________________________________________________ +[ 2726] By: gbarr on 1999/01/29 03:30:51 + Log: Remove use of File::Slurp in t/lib/textfill.t + Branch: maint-5.005/perl + ! t/lib/textfill.t +____________________________________________________________________________ +[ 2725] By: gbarr on 1999/01/29 03:11:41 + Log: From: Gurusamy Sarathy <gsar@ActiveState.com> + Date: Wed, 27 Jan 1999 23:14:33 -0800 + Message-Id: <199901280714.XAA10176@activestate.com> + Subject: Re: NOT OK: "@INC contains: ." after make install - MAINT_TRIAL_4 - 5.005_03 maintenance trial 4 MSWin32-x86-object + Branch: maint-5.005/perl + ! win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 2724] By: jhi on 1999/01/28 19:27:15 + Log: Change jhi@iki.fi to perlbug@perl.com. + Cosmetic change in semctl probing messages. + Branch: maint-5.005/perl + ! Configure hints/freebsd.sh +____________________________________________________________________________ +[ 2723] By: jhi on 1999/01/28 17:27:49 + Log: Yet another typo in a test program. + Branch: maint-5.005/perl + ! Configure +____________________________________________________________________________ +[ 2722] By: jhi on 1999/01/28 17:13:52 + Log: The pthreads_created_joinable test had a typo, + by blind luck the default value works almost anywhere. + Branch: maint-5.005/perl + ! Configure +____________________________________________________________________________ +[ 2721] By: jhi on 1999/01/28 13:04:23 + Log: MinT support, adapted from change #2594. + Branch: maint-5.005/perl + + README.mint ext/POSIX/hints/mint.pl hints/mint.sh + + mint/Makefile mint/README mint/errno.h mint/pwd.c mint/stdio.h + + mint/sys/time.h mint/time.h + ! MANIFEST doio.c malloc.c miniperlmain.c perl.c + ! pod/perldelta.pod t/io/fs.t t/lib/safe2.t t/op/groups.t + ! t/op/mkdir.t t/op/taint.t +____________________________________________________________________________ +[ 2719] By: jhi on 1999/01/27 19:49:49 + Log: From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + To: perl5-porters@perl.org + Subject: Re: [PATCH] perl5.005_03-MAINT_TRIAL_3: clarify Sv[INU]V versus Sv[INU]VX in perlguts + Date: Tue, 26 Jan 1999 22:25:07 +0000 + Message-Id: <E105Gux-0000Ac-00@taurus.cus.cam.ac.uk> + Branch: maint-5.005/perl + ! pod/perlguts.pod +____________________________________________________________________________ +[ 2718] By: jhi on 1999/01/27 19:46:04 + Log: io/fs.t fails test #18 (sense of tests appears to have been + changed incompletely; this patch just skips the test attached, + a la test #17 preceding it). + + From: "G. Del Merritt" <del@intranetics.com> + To: perlbug@perl.com + Subject: NOT OK: perl 5.00503 +MAINT_TRIAL_4 on MSWin32-x86-object (PATCHES included) + Date: Tue, 26 Jan 1999 12:09:09 -0700 + Message-Id: <199901261909.MAA25525@jhereg.perl.com> + Branch: maint-5.005/perl + ! t/io/fs.t +____________________________________________________________________________ +[ 2717] By: jhi on 1999/01/27 19:44:46 + Log: Miniperl fails to build (pp_sys.c was changed and iperlsys.h wasn't) + + From: "G. Del Merritt" <del@intranetics.com> + To: perlbug@perl.com + Subject: NOT OK: perl 5.00503 +MAINT_TRIAL_4 on MSWin32-x86-object (PATCHES included) + Date: Tue, 26 Jan 1999 12:09:09 -0700 + Message-Id: <199901261909.MAA25525@jhereg.perl.com> + Branch: maint-5.005/perl + ! iperlsys.h +____________________________________________________________________________ +[ 2716] By: jhi on 1999/01/27 19:38:36 + Log: From: Dan Sugalski <sugalskd@osshe.edu> + To: perlbug@perl.com, vmsperl@perl.org + Subject: NOT OK: perl 5.00503 +MAINT_TRIAL_4 on VMSAXP (Patch included, of course) + Date: Tue, 26 Jan 1999 14:40:38 -0800 + Message-Id: <3.0.6.32.19990126144038.02e5d650@ous.edu> + + From: Dan Sugalski <sugalskd@osshe.edu> + To: perl5-porters@perl.org, vmsperl@perl.org + Subject: [PATCH 5.005_03-MAILT_TRIAL_4]VMS test patches + Date: Tue, 26 Jan 1999 14:55:29 -0800 + Message-Id: <3.0.6.32.19990126145529.02f22280@ous.edu> + Branch: maint-5.005/perl + ! t/lib/textfill.t t/lib/textwrap.t vms/ext/Stdio/test.pl + ! vms/subconfigure.com +____________________________________________________________________________ +[ 2715] By: jhi on 1999/01/27 19:34:28 + Log: From: Mark Bixby <markb@spock.dis.cccd.edu> + To: perl5-porters@perl.org + Subject: [PATCH perl5.005_03-MAINT_TRIAL_4] MPE port tweaks + Date: Tue, 26 Jan 1999 16:32:18 -0800 (PST) + Message-Id: <199901270032.QAA13395@spock.dis.cccd.edu> + Branch: maint-5.005/perl + ! hints/mpeix.sh mpeix/relink +____________________________________________________________________________ +[ 2714] By: jhi on 1999/01/27 19:32:41 + Log: NetBSD does not do setruid, setrgid. + Branch: maint-5.005/perl + ! hints/netbsd.sh +____________________________________________________________________________ +[ 2713] By: jhi on 1999/01/27 19:28:53 + Log: FreeBSD usethreads, based on private email with + Anton Berezin <tobez@plab.ku.dk>. + Branch: maint-5.005/perl + ! hints/freebsd.sh +____________________________________________________________________________ +[ 2712] By: jhi on 1999/01/27 19:26:17 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + To: Mailing list Perl5 <perl5-porters@perl.org> + Subject: [PATCH 5.005_*] OS/2 threads + Date: Tue, 26 Jan 1999 13:39:46 -0500 + Message-ID: <19990126133946.A11594@monk.mps.ohio-state.edu> + Branch: maint-5.005/perl + ! os2/os2ish.h +____________________________________________________________________________ +[ 2711] By: jhi on 1999/01/27 19:24:28 + Log: "make ok", "make okfile", and "make nok" were broken + with -Duseshrplib, because of a shared typo. + + From: Spider Boardman <spider@web.zk3.dec.com> + To: perlbug@perl.com + Subject: Not OK: perl 5.00503 +MAINT_TRIAL_4 on alpha-dec_osf-thread 5.0 (UNINSTALLED) + Date: Wed, 27 Jan 1999 12:27:15 -0500 + Message-Id: <199901271727.MAA233455@web.zk3.dec.com> + Branch: maint-5.005/perl + ! Makefile.SH +____________________________________________________________________________ +[ 2710] By: jhi on 1999/01/27 19:22:23 + Log: Errno fixes: + + From: Spider Boardman <spider@web.zk3.dec.com> + To: perlbug@perl.com + Subject: Not OK: perl 5.00503 +MAINT_TRIAL_4 on alpha-dec_osf-thread 5.0 (UNINSTALLED) + Date: Wed, 27 Jan 1999 12:27:15 -0500 + Message-Id: <199901271727.MAA233455@web.zk3.dec.com> + + From: Spider Boardman <spider@web.zk3.dec.com> + To: perlbug@perl.com + Subject: Not OK: perl 5.00503 +MAINT_TRIAL_4 on alpha-dec_osf-thread 5.0 (UNINSTALLED) + Date: Wed, 27 Jan 1999 13:31:16 -0500 + Message-Id: <199901271831.NAA241001@web.zk3.dec.com> + Branch: maint-5.005/perl + ! Configure ext/Errno/Errno_pm.PL +____________________________________________________________________________ +[ 2709] By: jhi on 1999/01/27 19:17:35 + Log: Fix Configure installusrbinperl: + + From: Spider Boardman <spider@web.zk3.dec.com> + To: jhi@iki.fi + cc: perl5-porters@perl.org + Subject: Re: Not OK: perl 5.00503 +MAINT_TRIAL_4 on alpha-dec_osf-thread 5.0 (UNINSTALLED) + Date: Wed, 27 Jan 1999 13:03:35 -0500 + Message-Id: <199901271803.NAA238257@web.zk3.dec.com> + Branch: maint-5.005/perl + ! Configure +____________________________________________________________________________ +[ 2708] By: gbarr on 1999/01/26 04:14:42 + Log: Trial release 4 + Branch: maint-5.005/perl + ! Changes patchlevel.h pod/perlhist.pod +____________________________________________________________________________ +[ 2707] By: gbarr on 1999/01/26 02:06:17 + Log: Add redef IO::Handle::* for setv?buf() + Branch: maint-5.005/perl + ! ext/POSIX/POSIX.pm +____________________________________________________________________________ +[ 2706] By: jhi on 1999/01/24 22:26:12 + Log: Better AIX libc nm scan. + Branch: maint-5.005/perl + ! Configure +____________________________________________________________________________ +[ 2703] By: jhi on 1999/01/24 14:26:18 + Log: Minor Configure adjustments. + Branch: maint-5.005/perl + ! Configure +____________________________________________________________________________ +[ 2702] By: jhi on 1999/01/24 13:57:33 + Log: Use usethreads.cbu consistently. + Branch: maint-5.005/perl + ! Configure hints/aix.sh hints/dec_osf.sh hints/dos_djgpp.sh + ! hints/freebsd.sh hints/hpux.sh hints/irix_4.sh hints/irix_5.sh + ! hints/irix_6.sh hints/irix_6_0.sh hints/irix_6_1.sh + ! hints/linux.sh hints/os2.sh hints/solaris_2.sh +____________________________________________________________________________ +[ 2701] By: jhi on 1999/01/24 13:55:43 + Log: Mention year-1900 and month 0..11 also here. + Branch: maint-5.005/perl + ! lib/Time/Local.pm +____________________________________________________________________________ +[ 2700] By: jhi on 1999/01/24 13:52:36 + Log: Document Configure -Uinstallusrbinperl. + Branch: maint-5.005/perl + ! INSTALL pod/perldelta.pod +____________________________________________________________________________ +[ 2699] By: jhi on 1999/01/24 13:01:57 + Log: perlopentut was missing. + Branch: maint-5.005/perl + + pod/perlopentut.pod + ! MANIFEST pod/perldelta.pod +____________________________________________________________________________ +[ 2697] By: jhi on 1999/01/24 12:31:33 + Log: Remove t/op/grent.t (t/op/pwent.t was removed by #2685). + Branch: maint-5.005/perl + - t/op/grent.t + ! MANIFEST +____________________________________________________________________________ +[ 2696] By: gsar on 1999/01/24 11:39:39 + Log: integrate changes#2255,2694 from mainline + + another win32 portability fix: make sysread() and syswrite() + work on sockets + + better notes on 'make' on win32 + Branch: maint-5.005/perl + ! README.win32 pp_sys.c win32/win32.h +____________________________________________________________________________ +[ 2693] By: gbarr on 1999/01/24 00:53:31 + Log: Integrate changes #2646,2647 from cfgperl + + Show LANGUAGE env var when needed. (Augment change #2645). + + SHMLBA strikes back in NetBSD/sparc. + + From: Dave Nelson <David.Nelson@bellcow.com> + To: jhi@iki.fi + Subject: perl5.005_02 + IPC::SysV + NetBSD/Sparc + Date: Mon, 18 Jan 1999 22:07:56 -0600 + Message-Id: <199901190407.WAA02543@longhorn.bellcow.com> + Branch: maint-5.005/perl + ! util.c utils/perlbug.PL + !> ext/IPC/SysV/SysV.xs +____________________________________________________________________________ +[ 2692] By: gbarr on 1999/01/24 00:28:52 + Log: Integrate #2630 from mainline and an errno save fix + Branch: maint-5.005/perl + !> doio.c +____________________________________________________________________________ +[ 2691] By: gbarr on 1999/01/24 00:28:37 + Log: Update CGI modules to 2.46 and Getopt::Long to 2.19 + Branch: maint-5.005/perl + ! lib/CGI.pm lib/CGI/Carp.pm lib/CGI/Cookie.pm lib/CGI/Fast.pm + ! lib/CGI/Push.pm lib/Getopt/Long.pm t/lib/cgi-html.t +____________________________________________________________________________ +[ 2690] By: gbarr on 1999/01/23 23:35:39 + Log: Integrate #2681 from cfgperl + + Better (I hope) LANGUAGE documentation. + Branch: maint-5.005/perl + !> pod/perllocale.pod +____________________________________________________________________________ +[ 2689] By: gbarr on 1999/01/23 23:31:59 + Log: More nosuid patches + + From: Jarkko Hietaniemi <jhi@iki.fi> + Date: Fri, 22 Jan 1999 12:12:45 +0200 (EET) + Message-ID: <13992.20253.269284.841300@alpha.hut.fi> + Subject: Re: [PATCH] 5.005*: the "nosuid" problem: v2 + Branch: maint-5.005/perl + ! Configure config_h.SH perl.c perl.h pod/perldelta.pod + ! pod/perldiag.pod +____________________________________________________________________________ +[ 2688] By: gbarr on 1999/01/23 23:03:39 + Log: From: Anton Berezin <tobez@plab.ku.dk> + Date: 21 Jan 1999 17:07:28 +0100 + Message-ID: <86emood2yn.fsf@lion.plab.ku.dk> + Subject: [PATCH 5.005_54] hints/freebsd.sh - reflect the birth of version 4.0 + Branch: maint-5.005/perl + ! hints/freebsd.sh +____________________________________________________________________________ +[ 2687] By: gbarr on 1999/01/23 22:52:58 + Log: overload syntax is no longer experimental + Branch: maint-5.005/perl + ! lib/overload.pm +____________________________________________________________________________ +[ 2685] By: gbarr on 1999/01/23 22:15:46 + Log: Remove t/op/pwent.t added from cfgperl, but is not robust. + Branch: maint-5.005/perl + - t/op/pwent.t + ! MANIFEST +____________________________________________________________________________ +[ 2684] By: gbarr on 1999/01/23 22:13:07 + Log: More doc typos from Abigail, and undo some in lib/diagnostics.pm + from change #2672 + + From: abigail@fnx.com + Date: Tue, 19 Jan 1999 19:32:42 -0500 (EST) + Message-Id: <19990120003242.19938.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL3 lib/CGI.pm] Typos + + From: abigail@fnx.com + Date: Tue, 19 Jan 1999 19:40:41 -0500 (EST) + Message-Id: <19990120004041.20052.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL3 lib/CPAN.pm] Typos + Branch: maint-5.005/perl + ! lib/CGI.pm lib/CPAN.pm lib/diagnostics.pm +____________________________________________________________________________ +[ 2677] By: gbarr on 1999/01/22 03:38:07 + Log: Integrate #2645, #2648 and update patching.pod + + Document the GNU LANGUAGE env var. + + Mention /usr/share/locale. + + From: Daniel Grisinger <dgris@moiraine.dimensional.com> + Date: 21 Jan 1999 00:17:35 -0700 + Message-Id: <m31zkpqels.fsf_-_@moiraine.dimensional.com> + Subject: [PATCH] patching.pod, misc fixes (was Re: Which ? What ? Why ? When ?) + Branch: maint-5.005/perl + ! Porting/patching.pod + !> pod/perllocale.pod +____________________________________________________________________________ +[ 2676] By: gbarr on 1999/01/22 01:54:02 + Log: Fixup FindBin to use File::Spec + + Message-Id: <19990120185157.D24479@west-tip.transeda.com> + Date: Wed, 20 Jan 1999 18:51:57 +0000 + From: Paul Johnson <pjcj@transeda.com> + Subject: Re: [PATCH] 5005_54 Make FindBin work with UNC paths + Branch: maint-5.005/perl + ! lib/FindBin.pm +____________________________________________________________________________ +[ 2675] By: gbarr on 1999/01/22 01:38:31 + Log: Add new config values added for nosuid fix into VMS configure + + From: Dan Sugalski <sugalskd@osshe.edu> + Date: Wed, 20 Jan 1999 12:05:18 -0800 + Message-Id: <3.0.6.32.19990120120518.00a98470@ous.edu> + Subject: [PATCH 5.005_03MT3]VMS configure tweak + Branch: maint-5.005/perl + ! vms/subconfigure.com +____________________________________________________________________________ +[ 2674] By: gbarr on 1999/01/22 01:36:35 + Log: Fix for buggy compiler optimization on dec for pack("I",...) + + From: Achim Bohnet <ach@mpe.mpg.de> + Date: Wed, 20 Jan 1999 20:25:53 +0100 + Message-Id: <199901201925.UAA16940@o06.xray.mpe.mpg.de> + Subject: [PATCH] Not OK: perl 5.00503 +MAINT_TRIAL_3 on alpha-dec_osf 4.0 + Branch: maint-5.005/perl + ! pp.c +____________________________________________________________________________ +[ 2673] By: gbarr on 1999/01/22 01:29:37 + Log: OS/2 patches from Ilya + + Date: Thu, 21 Jan 1999 02:08:27 -0500 + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Subject: [PATCH 5.00*] makedepend + Message-Id: <19990121020827.A25509@monk.mps.ohio-state.edu> + + Date: Thu, 21 Jan 1999 02:46:34 -0500 + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Subject: [PATCH 5.005_*] Errno.pm suffers from \\ too + Message-Id: <19990121024634.A25600@monk.mps.ohio-state.edu> + + Date: Thu, 21 Jan 1999 02:50:16 -0500 + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Subject: [PATCH 5.005_03] Resend of OS/2 patch + Message-Id: <19990121025016.A25612@monk.mps.ohio-state.edu> + + Date: Thu, 21 Jan 1999 03:58:29 -0500 + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Subject: [PATCH 5.005_*] OS2::PrfDB was exploiting a bug in U32 XSUBs + Message-Id: <19990121035829.A25822@monk.mps.ohio-state.edu> + Branch: maint-5.005/perl + ! ext/Errno/Errno_pm.PL makedepend.SH os2/Changes + ! os2/Makefile.SHs os2/OS2/PrfDB/PrfDB.xs os2/os2.c +____________________________________________________________________________ +[ 2672] By: gbarr on 1999/01/22 01:05:45 + Log: More doc typo patches from Abigail + + From: abigail@fnx.com + Message-Id: <19990120001410.19645.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL 3 lib/AutoLoader.pm] Typos + Date: Tue, 19 Jan 1999 19:14:10 -0500 (EST) + + From: abigail@fnx.com + Message-Id: <19990120004312.20152.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL3 lib/Carp.pm] Typo + Date: Tue, 19 Jan 1999 19:43:12 -0500 (EST) + + From: abigail@fnx.com + Message-Id: <19990120004429.20190.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL3 lib/Cwd.pm] Typo + Date: Tue, 19 Jan 1999 19:44:29 -0500 (EST) + + From: abigail@fnx.com + Message-Id: <19990120005241.20693.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL3 lib/Safe.pm] Typo + Date: Tue, 19 Jan 1999 19:52:41 -0500 (EST) + + From: abigail@fnx.com + Message-Id: <19990120005525.20788.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL3 lib/SelfLoader.pm] Typos + Date: Tue, 19 Jan 1999 19:55:25 -0500 (EST) + + From: abigail@fnx.com + Message-Id: <19990120005821.20926.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL3 lib/Symbol.pm] Typo + Date: Tue, 19 Jan 1999 19:58:21 -0500 (EST) + + From: abigail@fnx.com + Message-Id: <19990120010002.20973.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL3 lib/Test.pm] Typo + Date: Tue, 19 Jan 1999 20:00:02 -0500 (EST) + + From: abigail@fnx.com + Message-Id: <19990120013823.23015.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL3 lib/diagnostics.pm] Typos (ignore + Date: Tue, 19 Jan 1999 20:38:23 -0500 (EST) + + From: abigail@fnx.com + Message-Id: <19990120013909.23085.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL3 lib/ops.pm] Typo + Date: Tue, 19 Jan 1999 20:39:09 -0500 (EST) + + From: abigail@fnx.com + Message-Id: <19990120015817.24306.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL3 lib/overload.pm] Typos + Date: Tue, 19 Jan 1999 20:58:16 -0500 (EST) + + From: abigail@fnx.com + Message-Id: <19990120020326.24373.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL3 lib/re.pm] Typos + Date: Tue, 19 Jan 1999 21:03:26 -0500 (EST) + Branch: maint-5.005/perl + ! ext/Opcode/Safe.pm ext/Opcode/ops.pm ext/re/re.pm + ! lib/AutoLoader.pm lib/Carp.pm lib/Cwd.pm lib/SelfLoader.pm + ! lib/Symbol.pm lib/Test.pm lib/diagnostics.pm lib/overload.pm +____________________________________________________________________________ +[ 2671] By: gbarr on 1999/01/22 00:40:13 + Log: Fix win32 for Borland compiler and spaces in paths + + From: Gurusamy Sarathy <gsar@activestate.com> + Date: Mon, 18 Jan 1999 20:33:17 -0800 + Message-Id: <199901190433.UAA03656@activestate.com> + Subject: [PATCH] 5.005_03-trial3 win32 issues + Branch: maint-5.005/perl + ! README.win32 win32/Makefile win32/config_sh.PL + ! win32/makefile.mk win32/runperl.c +____________________________________________________________________________ +[ 2637] By: gbarr on 1999/01/18 02:52:18 + Log: Update DB_File to 1.63 + + From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Date: Tue, 29 Dec 1998 16:23:54 +0000 (GMT) + Message-Id: <9812291623.AA20884@claudius.bfsec.bt.co.uk> + Subject: PATCH DB_File 1.63 for 5.005_54 & 5.005_03 + Branch: maint-5.005/perl + ! ext/DB_File/Changes ext/DB_File/DB_File.pm + ! ext/DB_File/DB_File.xs ext/DB_File/dbinfo ext/DB_File/typemap +____________________________________________________________________________ +[ 2636] By: gbarr on 1999/01/17 18:03:31 + Log: Trial release 3 + Branch: maint-5.005/perl + ! Changes patchlevel.h +____________________________________________________________________________ +[ 2635] By: gbarr on 1999/01/17 17:32:01 + Log: Update to CPAN-1.44 + + From: Mark-Jason Dominus <mjd@plover.com> + Date: Sat, 16 Jan 1999 17:22:06 -0500 + Message-ID: <19990116222206.3674.qmail@plover.com> + Subject: Re: DOC PATCH (5.005_54 perlsub.pod) + Branch: maint-5.005/perl + ! lib/CPAN.pm lib/CPAN/FirstTime.pm lib/CPAN/Nox.pm + ! pod/perlsub.pod +____________________________________________________________________________ +[ 2634] By: gbarr on 1999/01/17 17:27:12 + Log: Fix for suidperl when script is on a nosuid filesystem + + From: Jarkko Hietaniemi <jhi@iki.fi> + Date: Sun, 17 Jan 1999 16:27:06 +0200 (EET) + Message-ID: <13985.62266.324824.292401@alpha.hut.fi> + Subject: [PATCH] 5.005*: the "nosuid" problem: v2 + Branch: maint-5.005/perl + ! Configure config_h.SH perl.c perl.h pod/perldiag.pod +____________________________________________________________________________ +[ 2618] By: gbarr on 1999/01/16 19:18:26 + Log: Added Dumpvalue.pm + + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Mon, 7 Dec 1998 02:44:25 -0500 (EST) + Message-Id: <199812070744.CAA18949@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_*] Dumpvar.pm + Branch: maint-5.005/perl + + lib/Dumpvalue.pm + ! MANIFEST pod/perldelta.pod +____________________________________________________________________________ +[ 2617] By: gbarr on 1999/01/16 19:09:36 + Log: Minor change to perlxstut and added perlopentut.pod + + From: Nathan Torkington <gnat@frii.com> + Date: Sat, 26 Dec 1998 14:28:21 +1300 (NZDT) + Message-ID: <13956.15285.933914.320849@localhost.frii.com> + Subject: [PATCH] perlxstut.pod fix + + From: Tom Christiansen <tchrist@jhereg.perl.com> + Date: Sat, 09 Jan 1999 08:13:18 -0700 + Message-Id: <199901091513.IAA17512@jhereg.perl.com> + Subject: perlopentut.pod + Branch: maint-5.005/perl + ! MANIFEST pod/perl.pod pod/perldelta.pod pod/perlxstut.pod + ! pod/roffitall +____________________________________________________________________________ +[ 2616] By: gbarr on 1999/01/16 18:59:55 + Log: Win32 changes from Jan + + From: jan.dubois@ibm.net (Jan Dubois) + Date: Fri, 15 Jan 1999 23:38:35 +0100 + Message-ID: <36a7c10d.16311905@smtp1.ibm.net> + Subject: [PATCH 5.005_03m2] Win32 Makefile patches + + From: jan.dubois@ibm.net (Jan Dubois) + Date: Sat, 16 Jan 1999 13:02:45 +0100 + Message-ID: <36a07da6.10722337@smtp1.ibm.net> + Subject: [PATCH 5.005_03m2] minor tweaks to README.win32 + Branch: maint-5.005/perl + ! README.win32 win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 2615] By: gbarr on 1999/01/16 18:48:48 + Log: Jumbo patch from Sarathy for PERL_OBJECT & USE_THREADS + + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Date: Thu, 07 Jan 1999 00:12:00 -0500 + Message-Id: <199901070512.AAA23568@aatma.engin.umich.edu> + Subject: Re: [PATCH 5.005_03-MAINT_TRIAL2] fixes for PERL_OBJECT and USE_THREADS builds + + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Date: Thu, 14 Jan 1999 19:21:46 -0500 + Message-Id: <199901150021.TAA01886@aatma.engin.umich.edu> + Subject: Re: [PATCH 5.005_03-MAINT_TRIAL2] fixes for PERL_OBJECT and USE_THREADS builds + Branch: maint-5.005/perl + ! embed.h global.sym lib/ExtUtils/MM_Unix.pm objXSUB.h objpp.h + ! op.c perl.c perl.h perly.c perly.y perly_c.diff pp.c proto.h + ! sv.c t/io/fs.t toke.c win32/GenCAPI.pl win32/config.bc + ! win32/makedef.pl win32/runperl.c win32/win32.c +____________________________________________________________________________ +[ 2614] By: gbarr on 1999/01/16 16:48:38 + Log: From: Jarkko Hietaniemi <jhi@iki.fi> + Date: Fri, 15 Jan 1999 17:28:34 +0200 (EET) + Message-Id: <199901151528.RAA08785@alpha.hut.fi> + Subject: [PATCH] 5.005_03-MAINT_TRIAL_2: NetBSD patches + + From: Jarkko Hietaniemi <jhi@iki.fi> + Date: Fri, 15 Jan 1999 18:44:19 +0200 (EET) + Message-Id: <199901151644.SAA08184@alpha.hut.fi> + Subject: [PATCH] 5.005_03-MAINT_TRIAL_2: allow skipping the "install also as /usr/bin/perl" question of installperl + + From: Jarkko Hietaniemi <jhi@iki.fi> + Date: Fri, 15 Jan 1999 18:52:29 +0200 (EET) + Message-Id: <199901151652.SAA11259@alpha.hut.fi> + Subject: the promised "installusrbinperl + NetBSD" fix + Branch: maint-5.005/perl + ! Configure Makefile.SH hints/netbsd.sh installperl + ! makedepend.SH unixish.h +____________________________________________________________________________ +[ 2613] By: gbarr on 1999/01/16 16:28:40 + Log: From: Laszlo Molnar <ml1050@freemail.c3.hu> + Date: Thu, 14 Jan 1999 22:37:26 +0100 + Message-ID: <19990114223726.A177@beeblebrox> + Subject: [PATCH for 5.005_03-MAINT_TRIAL_2] dos-djgpp update + Branch: maint-5.005/perl + ! djgpp/config.over djgpp/djgpp.c +____________________________________________________________________________ +[ 2612] By: gbarr on 1999/01/16 16:27:25 + Log: Hints for sco.sh to automatically support dynamic linking + + From: Peter Wolfe <wolfe@teloseng.com> + Date: Mon, 11 Jan 1999 11:50:20 -0800 (PST) + Message-Id: <199901111950.LAA01703@titan.teloseng.com> + Subject: SCO 3.2v5 patch for perl5.005_03-MAINT_TRIAL_1 + Branch: maint-5.005/perl + ! hints/sco.sh +____________________________________________________________________________ +[ 2610] By: gbarr on 1999/01/14 03:07:33 + Log: Fix login in installperl for pods + + From: Robin Barker <rmb1@cise.npl.co.uk> + Date: Mon, 4 Jan 1999 13:50:10 GMT + Message-Id: <199901041350.NAA19665@cyclone.cise.npl.co.uk> + Subject: PATCH to installperl + Branch: maint-5.005/perl + ! installperl +____________________________________________________________________________ +[ 2609] By: gbarr on 1999/01/14 03:04:37 + Log: Fix incorrect "used only once" warnings + + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Fri, 8 Jan 1999 04:37:10 -0500 + Message-ID: <19990108043710.A14390@monk.mps.ohio-state.edu> + Subject: Re: change#965 flakiness + Branch: maint-5.005/perl + ! gv.c +____________________________________________________________________________ +[ 2608] By: gbarr on 1999/01/14 02:56:46 + Log: Fixed double GLOB de-reference + + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Date: Sat, 09 Jan 1999 23:40:24 -0500 + Message-Id: <199901100440.XAA12360@aatma.engin.umich.edu> + Subject: Re: IO::Pipe with perl -d (on HPUX) + Branch: maint-5.005/perl + ! ext/IO/lib/IO/Pipe.pm +____________________________________________________________________________ +[ 2607] By: gbarr on 1999/01/14 02:53:40 + Log: Added Carp::cluck to perldelta.pod + Branch: maint-5.005/perl + ! pod/perldelta.pod +____________________________________________________________________________ +[ 2606] By: gbarr on 1999/01/14 02:44:04 + Log: New perlfaq*.pod from Tom (private mail) + Branch: maint-5.005/perl + ! pod/perlfaq.pod pod/perlfaq1.pod pod/perlfaq2.pod + ! pod/perlfaq3.pod pod/perlfaq4.pod pod/perlfaq5.pod + ! pod/perlfaq6.pod pod/perlfaq7.pod pod/perlfaq8.pod + ! pod/perlfaq9.pod +____________________________________________________________________________ +[ 2584] By: gbarr on 1999/01/08 04:50:56 + Log: implemented Ilya's suggested fix, and added a testcase + + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Tue, 5 Jan 1999 00:56:01 -0500 (EST) + Message-Id: <199901050556.AAA02597@monk.mps.ohio-state.edu> + Subject: Re: Text::ParseWords: regex fix + Branch: maint-5.005/perl + ! lib/Text/ParseWords.pm t/lib/parsewords.t +____________________________________________________________________________ +[ 2583] By: gbarr on 1999/01/08 04:50:03 + Log: From: Jarkko Hietaniemi <jhi@iki.fi> + Date: Thu, 7 Jan 1999 12:47:38 +0200 (EET) + Message-Id: <199901071047.MAA24100@alpha.hut.fi> + Subject: [PATCH] 5.005_03-MAINT_TRIAL_2: ext/Errno_pm.PL: understand wrapper cppstdins + Branch: maint-5.005/perl + ! ext/Errno/Errno_pm.PL +____________________________________________________________________________ +[ 2582] By: gbarr on 1999/01/08 03:37:55 + Log: More doc changes from Abigail, and included change #2575 from cfgperl + + From: abigail@fnx.com + Message-ID: <19990107041434.22326.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL2 lib/Time/gmtime.pm] Typo fix + Date: Wed, 6 Jan 1999 23:14:34 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990107041746.22376.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL2 lib/Time/localtime.pm] Typo fix + Date: Wed, 6 Jan 1999 23:17:46 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990107042105.22527.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL2 lib/User/grent.pm] Typo fix + Date: Wed, 6 Jan 1999 23:21:05 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990107042254.22624.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL2 lib/User/pwent.pw] Typo fix + Date: Wed, 6 Jan 1999 23:22:54 -0500 (EST) + Branch: maint-5.005/perl + ! lib/Math/Trig.pm lib/Time/gmtime.pm lib/Time/localtime.pm + ! lib/User/grent.pm lib/User/pwent.pm +____________________________________________________________________________ +[ 2578] By: gbarr on 1999/01/07 04:30:26 + Log: From: Dan Sugalski <sugalskd@osshe.edu> + Date: Wed, 06 Jan 1999 13:47:34 -0800 + Message-Id: <3.0.6.32.19990106134734.0334d260@ous.edu> + Subject: [PATCH 5.005_02-MT2, 5.005_5x]VMS.C tweak for occasional system() error + Branch: maint-5.005/perl + ! vms/vms.c +____________________________________________________________________________ +[ 2577] By: gbarr on 1999/01/07 04:26:28 + Log: Another set of doc patches from Abigail + + From: abigail@fnx.com + Message-ID: <19990107032132.20124.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRAIL2 lib/Net/hostent.pm] Typo fix + Date: Wed, 6 Jan 1999 22:21:32 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990107032445.20178.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL2 lib/Net/netent.pm] Typo fix + Date: Wed, 6 Jan 1999 22:24:45 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990107032834.20362.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRAIL2 lib/Term/Complete.pm] Typo fix + Date: Wed, 6 Jan 1999 22:28:34 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990107033136.20440.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRAIL2 lib/Term/ReadLine.pm] Typo fix + Date: Wed, 6 Jan 1999 22:31:36 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990107033351.20540.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL2 lib/CGI/Apache.pm] Typo fix + Date: Wed, 6 Jan 1999 22:33:51 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990107033933.20707.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL2 lib/CGI/Push.pm] Typo fix + Date: Wed, 6 Jan 1999 22:39:33 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990107034548.20936.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL2 lib/File/Copy.pm] Typo fixes + Date: Wed, 6 Jan 1999 22:45:48 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990107034856.21056.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL2 lib/File/Spec.pm] Typo fix + Date: Wed, 6 Jan 1999 22:48:56 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990107035113.21174.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL2 lib/File/Spec/Mac.pm] Typo fixes + Date: Wed, 6 Jan 1999 22:51:13 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990107035612.21522.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL2 lib/Math/BigFloat.pm] Typo fix + Date: Wed, 6 Jan 1999 22:56:12 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990107035842.21585.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL2 lib/Math/BigInt.pm] Typo fixes + Date: Wed, 6 Jan 1999 22:58:41 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990107040644.22009.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL2 lib/Text/Wrap.pm] Typo fixes + Date: Wed, 6 Jan 1999 23:06:44 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990107040955.22087.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL2 lib/Tie/Array.pm] Typo fixes + Date: Wed, 6 Jan 1999 23:09:55 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990107041136.22174.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL2 lib/Tie/Hash.pm] Typo fix + Date: Wed, 6 Jan 1999 23:11:36 -0500 (EST) + Branch: maint-5.005/perl + ! lib/CGI/Apache.pm lib/CGI/Push.pm lib/File/Copy.pm + ! lib/File/Spec.pm lib/File/Spec/Mac.pm lib/Math/BigFloat.pm + ! lib/Math/BigInt.pm lib/Net/hostent.pm lib/Net/netent.pm + ! lib/Term/Complete.pm lib/Term/ReadLine.pm lib/Text/Wrap.pm + ! lib/Tie/Array.pm lib/Tie/Hash.pm +____________________________________________________________________________ +[ 2568] By: gbarr on 1999/01/06 03:13:15 + Log: From: jan.dubois@ibm.net (Jan Dubois) + Date: Wed, 06 Jan 1999 01:24:09 +0100 + Message-ID: <3696aa85.18259325@smtp1.ibm.net> + Subject: [PATCH 5.005_03-MAINT_TRIAL2] fixes for PERL_OBJECT and USE_THREADS builds + Branch: maint-5.005/perl + ! embed.h global.sym objXSUB.h objpp.h perl.c proto.h + ! win32/GenCAPI.pl win32/makedef.pl +____________________________________________________________________________ +[ 2567] By: gbarr on 1999/01/06 02:31:28 + Log: From: Dan Sugalski <sugalskd@osshe.edu> + Date: Tue, 05 Jan 1999 16:47:31 -0800 + Message-Id: <3.0.6.32.19990105164731.00b5b2d0@ous.edu> + Subject: [PATCH 5.005_03-MAINT_TRIAL_2]taint.c fix for VMS + Branch: maint-5.005/perl + ! taint.c +____________________________________________________________________________ +[ 2566] By: gbarr on 1999/01/06 02:29:05 + Log: From: "W. Phillip Moore" <wpm@ms.com> + Date: Tue, 5 Jan 1999 12:40:27 -0500 (EST) + Message-ID: <13970.20107.190314.549471@zappa> + Subject: [PATCH] POSIX getpgrp is not -w clean + Branch: maint-5.005/perl + ! ext/POSIX/POSIX.pm +____________________________________________________________________________ +[ 2565] By: gbarr on 1999/01/06 02:19:00 + Log: From: Slaven Rezic <eserte@cs.tu-berlin.de> + Date: Mon, 4 Jan 1999 23:01:46 +0100 (CET) + Message-Id: <199901042201.XAA01875@cabulja.herceg.de> + Subject: FindBin.pm on Win32 systems + Branch: maint-5.005/perl + ! lib/FindBin.pm +____________________________________________________________________________ +[ 2564] By: gbarr on 1999/01/06 02:13:23 + Log: From: Mark Bixby <markb@spock.dis.cccd.edu> + Date: Mon, 4 Jan 1999 13:34:58 -0800 (PST) + Message-Id: <199901042134.NAA18852@spock.dis.cccd.edu> + Subject: [PATCH 5.005_03-MAINT_TRIAL_2] t/op/sysio.t for MPE/iX + Branch: maint-5.005/perl + ! t/op/sysio.t +____________________________________________________________________________ +[ 2563] By: gbarr on 1999/01/06 02:03:44 + Log: From: Jarkko Hietaniemi <jhi@cc.hut.fi> + Date: Mon, 4 Jan 1999 19:25:03 +0200 (EET) + Message-Id: <199901041725.TAA30462@alpha.hut.fi> + Subject: [PATCH] 5.005_03-MAINT_TRIAL_2: undo untrue HP-UX 64-bitness (mostly harmless but misleading) + Branch: maint-5.005/perl + ! hints/hpux.sh +____________________________________________________________________________ +[ 2562] By: gbarr on 1999/01/06 02:02:18 + Log: Jumbo doc patch from Abigail + + From: abigail@fnx.com + Message-ID: <19990105170142.4889.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03-TRIAL2 lib/ExtUtils/Liblist.pm] pod fixes + Date: Tue, 5 Jan 1999 12:01:42 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990105172855.5115.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 MAINT2 lib/ExtUtils/Commands.pm] Typo fix. + Date: Tue, 5 Jan 1999 12:28:55 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990105173808.5260.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH perl5.005_03 MAINT3 lib/ExtUtils/Embed.pm] Typo fix + Date: Tue, 5 Jan 1999 12:38:08 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990105174859.5533.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 MAINT2 lib/ExtUtils/Install.pm] Typo fix + Date: Tue, 5 Jan 1999 12:48:59 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990105174947.5547.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 lib/ExtUtils/MM_Unix.pm] Typo fixes + Date: Tue, 5 Jan 1999 12:49:46 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990105182301.5966.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 lib/ExtUtils/MakeMaker.pm] Typos fixes. + Date: Tue, 5 Jan 1999 13:23:00 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990105183344.6065.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL2 lib/ExtUtils/Manifest.pm] Typo fixes + Date: Tue, 5 Jan 1999 13:33:44 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990105184028.6220.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL2 lib/ExtUtils/Mksymlists.pm] Typo fix + Date: Tue, 5 Jan 1999 13:40:28 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990106012015.9451.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL2 lib/IO/Pipe.pm] Typo fixes. + Date: Tue, 5 Jan 1999 20:20:15 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990106012047.9459.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRAIL2 lib/IO/Seekable.pm] Typo fixes + Date: Tue, 5 Jan 1999 20:20:47 -0500 (EST) + + From: abigail@fnx.com + Message-ID: <19990106012338.9536.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_03 TRIAL2 lib/IO/Socket.pm] Typo fix + Date: Tue, 5 Jan 1999 20:23:38 -0500 (EST) + Branch: maint-5.005/perl + ! ext/IO/lib/IO/Pipe.pm ext/IO/lib/IO/Seekable.pm + ! ext/IO/lib/IO/Socket.pm lib/ExtUtils/Command.pm + ! lib/ExtUtils/Embed.pm lib/ExtUtils/Install.pm + ! lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_Unix.pm + ! lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Manifest.pm + ! lib/ExtUtils/Mksymlists.pm +____________________________________________________________________________ +[ 2560] By: gbarr on 1999/01/03 16:59:01 + Log: Trial release 2 + Branch: maint-5.005/perl + ! Changes patchlevel.h +____________________________________________________________________________ +[ 2559] By: gbarr on 1999/01/02 15:37:35 + Log: From: Blair Zajac <bzajac@geostaff.com> + Date: Wed, 23 Dec 1998 17:13:32 -0800 + Message-ID: <3681953C.8B6A90AA@geostaff.com> + Subject: Tie::SubstrHash patch + Branch: maint-5.005/perl + ! lib/Tie/SubstrHash.pm +____________________________________________________________________________ +[ 2558] By: gbarr on 1999/01/02 15:30:01 + Log: integrate change #2544 + + From: Tim Bunce <Tim.Bunce@ig.co.uk> + Subject: bug in pod2man search for perl binary [5.005_5x] + Date: Sat, 12 Dec 1998 23:08:51 +0000 + Message-ID: <19981212230851.A20578@ig.co.uk> + Branch: maint-5.005/perl + !> pod/pod2man.PL +____________________________________________________________________________ +[ 2557] By: gbarr on 1999/01/02 15:20:42 + Log: integrate change #2548 + + From: Hugo van der Sanden <hv@crypt.compulink.co.uk> + To: perl5-porters@perl.org + cc: hv@crypt0.demon.co.uk + Subject: [bug 5.004_54] duplicate error message + Date: Thu, 31 Dec 1998 04:05:25 +0000 + Message-Id: <199812310405.EAA00386@crypt.compulink.co.uk> + + Message-ID: <13963.60672.134591.383377@alias-2.pr.mcs.net> + From: Stephen McCamant <smccam@uclink4.berkeley.edu> + To: hv@crypt0.demon.co.uk + Cc: perl5-porters@perl.org + Subject: [PATCH _54] Re: duplicate error message + Date: Thu, 31 Dec 1998 16:10:13 -0600 (CST) + + Message-Id: <199901010732.HAA02926@crypt.compulink.co.uk> + From: Hugo van der Sanden <hv@crypt.compulink.co.uk> + To: Stephen McCamant <smccam@uclink4.berkeley.edu> + cc: hv@crypt0.demon.co.uk, perl5-porters@perl.org + Subject: [TEST PATCH _54] Re: duplicate error message + Date: Fri, 01 Jan 1999 07:32:14 +0000 + Branch: maint-5.005/perl + ! op.c t/pragma/warn-1global taint.c +____________________________________________________________________________ +[ 2556] By: gbarr on 1999/01/02 15:18:58 + Log: From: abigail@fnx.com + Date: Mon, 28 Dec 1998 14:16:12 -0500 (EST) + Message-ID: <19981228191612.8380.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_02; lib/fields.pm] Typos in pod. + Branch: maint-5.005/perl + ! lib/fields.pm +____________________________________________________________________________ +[ 2555] By: gbarr on 1999/01/02 15:11:45 + Log: intregrate change #2547 + + From: Chris Nandor <pudge@pobox.com> + Subject: Re: [PATCH] perlport.pod 1.38 + Date: Thu, 31 Dec 1998 09:06:48 -0500 + Message-Id: <v04020a1db2b1352ec92a@[192.168.0.77]> + Branch: maint-5.005/perl + !> pod/perlport.pod +____________________________________________________________________________ +[ 2543] By: gbarr on 1998/12/31 06:17:13 + Log: integrated relevant parts og changes #2385 & #2387 from mainline + + various fixes for race conditions under threads: mutex locks based + on PL_threadnum were seriously flawed, since it means more than one + thread could enter the critical region; PL_na was global instead of + thread-local; child thread could finish and free thr structures + before Thread->new() got around to creating the Thread object; + cv_clone() needed locking, as it mucks with PL_comppad and other + global data; new_struct_thread() needed to lock template-thread's + mutex while copying its data + + another threads reliability fix: serialize writes to thr->threadsv + avoid most uses of PL_na (which is much more inefficient than a + simple local); update docs to suit; PL_na now being thr->Tna may + be a minor compatibility issue for extensions--will require dTHR + outside of XSUBs (those get automatic dTHR) + Branch: maint-5.005/perl + ! XSUB.h djgpp/djgpp.c doio.c doop.c dump.c embedvar.h + ! ext/DynaLoader/dl_next.xs ext/IO/IO.xs ext/Opcode/Opcode.xs + ! ext/POSIX/POSIX.xs ext/Thread/Thread.xs ext/attrs/attrs.xs + ! gv.c malloc.c mg.c objXSUB.h op.c os2/OS2/REXX/REXX.xs + ! os2/os2.c perl.c perlvars.h perly.c perly.y pod/perlcall.pod + ! pod/perlembed.pod pod/perlguts.pod pod/perlxs.pod pp.c pp.h + ! pp_ctl.c pp_hot.c pp_sys.c run.c sv.c taint.c thread.h toke.c + ! universal.c util.c vms/ext/Stdio/Stdio.xs vms/perly_c.vms + ! vms/vms.c win32/win32.c win32/win32thread.c +____________________________________________________________________________ +[ 2542] By: gbarr on 1998/12/30 14:46:40 + Log: doc updates + + From: abigail@fnx.com + Date: Wed, 23 Dec 1998 22:32:07 -0500 (EST) + Message-ID: <19981224033207.16751.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_02] Typo in documentation of pod2html. + + From: abigail@fnx.com + Date: Wed, 23 Dec 1998 22:59:59 -0500 (EST) + Message-ID: <19981224035959.16994.qmail@alexandra.wayne.fnx.com> + Subject: [PATCH 5.005_02] Re: m// doc is buggy (was Re: m'$foo' is undocumented) + + pod/perldelta.pod from: + From: Jarkko Hietaniemi <jhi@iki.fi> + Date: Thu, 17 Dec 1998 16:13:34 +0200 (EET) + Message-ID: <13945.4494.140163.973953@alpha.hut.fi> + Subject: Re: important UNDOC issues for 5.005_54 + Branch: maint-5.005/perl + ! pod/perldelta.pod pod/perlop.pod pod/pod2html.PL +____________________________________________________________________________ +[ 2541] By: gbarr on 1998/12/30 14:37:14 + Log: From: jan.dubois@ibm.net (Jan Dubois) + Date: Wed, 23 Dec 1998 21:26:38 +0100 + Message-ID: <36895086.8849224@smtp1.ibm.net> + Subject: [PATCH 5.005_03m1] subdirectory Makefiles should inherit CAPI setting from command line + Branch: maint-5.005/perl + ! lib/ExtUtils/MakeMaker.pm +____________________________________________________________________________ +[ 2538] By: gbarr on 1998/12/29 14:41:29 + Log: From: Jarkko Hietaniemi <jhi@iki.fi> + Date: Tue, 22 Dec 1998 10:57:48 +0200 (EET) + Message-ID: <13951.24332.932827.831376@alpha.hut.fi> + Subject: Re: x operator broken in DEC Alpha for 8-bit characters (Re: Digest-MD5-2.00 test fails on DEC Alpha - a patch) + Branch: maint-5.005/perl + ! t/op/repeat.t util.c +____________________________________________________________________________ +[ 2535] By: gbarr on 1998/12/29 14:27:56 + Log: From: Jarkko Hietaniemi <jhi@iki.fi> + Date: Fri, 18 Dec 1998 16:39:27 +0200 (EET) + Message-ID: <13946.26911.140905.387070@alpha.hut.fi> + Subject: Math::Trig, Math::Complex, Fcntl, addressed (Re: Undocumentation Issues for 5.005) + Branch: maint-5.005/perl + ! pod/perldelta.pod +____________________________________________________________________________ +[ 2534] By: gbarr on 1998/12/29 14:23:02 + Log: From: Jarkko Hietaniemi <jhi@iki.fi> + Date: Tue, 15 Dec 1998 17:52:32 +0200 (EET) + Message-ID: <13942.34240.66558.169330@alpha.hut.fi> + Subject: some doc link fixes + Branch: maint-5.005/perl + ! pod/perlcall.pod pod/perldata.pod pod/perldiag.pod + ! pod/perlfaq5.pod pod/perlfaq7.pod pod/perlfunc.pod + ! pod/perlguts.pod pod/perllocale.pod pod/perlobj.pod + ! pod/perlsub.pod pod/perlvar.pod +____________________________________________________________________________ +[ 2533] By: gbarr on 1998/12/29 14:23:00 + Log: From: Chris Nandor <pudge@pobox.com> + Date: Sat, 19 Dec 1998 12:54:34 -0500 + Message-Id: <v04020a03b2a194aaa676@[192.168.0.77]> + Subject: [PATCH] perlport.pod v1.37 + Branch: maint-5.005/perl + ! pod/perlport.pod +____________________________________________________________________________ +[ 2531] By: gbarr on 1998/12/29 14:12:25 + Log: change in_pod pattern to /^=\w/ from /^=/ + From: Frank Ridderbusch <Frank.Ridderbusch@pdb.siemens.de> + Date: Tue, 15 Dec 1998 16:23:12 +0100 (MET) + Message-ID: <13942.32480.700000.640927@utensil> + Subject: Minor Bug in AutoSplit.qm in 5.005 and 5.004 + Branch: maint-5.005/perl + ! lib/AutoSplit.pm +____________________________________________________________________________ +[ 2530] By: gbarr on 1998/12/29 14:09:51 + Log: undo the "perlsyn intrusion" into perlfunc + Branch: maint-5.005/perl + ! pod/perlfunc.pod +____________________________________________________________________________ +[ 2529] By: gbarr on 1998/12/29 14:04:35 + Log: From: Jarkko Hietaniemi <hietanie@koah.research.nokia.com> + Date: Sun, 13 Dec 1998 14:54:56 +0200 (EET) + Message-Id: <199812131254.OAA24494@koah.research.nokia.com> + Subject: ignore_versioned_libs isn't used anywhere (it became ignore_versioned_solibs) + Branch: maint-5.005/perl + ! hints/linux.sh +____________________________________________________________________________ +[ 2528] By: gbarr on 1998/12/29 13:59:49 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Wed, 28 Oct 1998 01:20:33 -0500 (EST) + Message-Id: <199810280620.BAA06893@monk.mps.ohio-state.edu> + Subject: [PATCH 5.00552] Make sort respect overloading + Branch: maint-5.005/perl + ! pp_ctl.c t/pragma/overload.t +____________________________________________________________________________ +[ 2527] By: gbarr on 1998/12/29 13:58:56 + Log: doc update, quads only work on 64-but platforms + Branch: maint-5.005/perl + ! pod/perlfunc.pod +____________________________________________________________________________ +[ 2526] By: gbarr on 1998/12/29 13:49:55 + Log: From: Andy Dougherty <doughera@lafayette.edu> + Date: Tue, 1 Dec 1998 12:50:27 -0500 (EST) + Message-Id: <Pine.SUN.3.96.981201124929.4288H-100000@newton.phys> + Subject: [PATCH 5.005_xx] erroneous 'none' in lddlflags + Branch: maint-5.005/perl + ! Configure +____________________________________________________________________________ +[ 2512] By: gbarr on 1998/12/28 14:56:36 + Log: change t/op/pwent.t to ignore NIS includes + From: achampio@lehman.com (Alan Champion) + Date: Tue, 1 Dec 1998 15:18:03 GMT + Message-Id: <9812011518.AA00005@lonhpov1.lehman.com> + Subject: Not OK: perl 5.00503 +MAINT_TRIAL_1 on sun4-solaris 2.3 (UNINSTALLED) + + From: pvhp@forte.com (Peter Prymmer) + Date: Fri, 4 Dec 98 17:11:41 PST + Message-Id: <9812050111.AA16778@forte.com> + Subject: [PATCH 5.005_03-MAINT_TRIAL_1 && 5.005_54]dumper and searchdict ebcdic style + Branch: maint-5.005/perl + ! t/lib/dumper.t t/lib/searchdict.t t/op/pwent.t +____________________________________________________________________________ +[ 2511] By: gbarr on 1998/12/28 14:55:28 + Log: From: jan.dubois@ibm.net (Jan Dubois) + Date: Tue, 01 Dec 1998 00:07:33 +0100 + Message-ID: <366921b5.14512598@smtp1.ibm.net> + Subject: Re: 5.005_03-MAINT-TRIAL1, [PATCH] to compile on Win32 + + From: jan.dubois@ibm.net (Jan Dubois) + Date: Wed, 02 Dec 1998 00:24:54 +0100 + Message-ID: <366a77bb.19498126@smtp1.ibm.net> + Subject: Re: 5.005_03-MAINT-TRIAL1, [PATCH] spaces in filenames support + Branch: maint-5.005/perl + ! perl.h proto.h taint.c win32/GenCAPI.pl win32/Makefile + ! win32/config.bc win32/config.gc win32/config.vc + ! win32/config_sh.PL win32/makedef.pl +____________________________________________________________________________ +[ 2510] By: gbarr on 1998/12/28 14:37:35 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Tue, 1 Dec 1998 00:34:08 -0500 (EST) + Message-Id: <199812010534.AAA21371@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_*] Debugger 'v' command + Branch: maint-5.005/perl + ! lib/perl5db.pl +____________________________________________________________________________ +[ 2478] By: gbarr on 1998/12/13 16:02:24 + Log: From: pvhp@forte.com (Peter Prymmer) + Date: Mon, 30 Nov 98 21:08:36 PST + Message-Id: <9812010508.AA07791@forte.com> + Subject: [PATCH 5.005_03t1 && 5.005_54]dll linkage side decks for OS/390 + Branch: maint-5.005/perl + ! hints/os390.sh +____________________________________________________________________________ +[ 2477] By: gbarr on 1998/12/13 16:00:23 + Log: From: Dan Sugalski <sugalskd@osshe.edu> + Date: Mon, 30 Nov 1998 17:08:12 -0800 + Message-Id: <3.0.6.32.19981130170812.00b12b70@ous.edu> + Subject: [PATCH 5.005_03]Minor VMS patches needed to build + Branch: maint-5.005/perl + ! lib/ExtUtils/MM_VMS.pm vms/subconfigure.com +____________________________________________________________________________ +[ 2476] By: gbarr on 1998/12/13 15:30:58 + Log: From: pvhp@forte.com (Peter Prymmer) + Date: Fri, 4 Dec 98 00:37:32 PST + Message-Id: <9812040837.AA10908@forte.com> + Subject: Re: [PATCH 5.005_03-MAINT-TRIAL1] some tweaks to the build process for OS/390 + Branch: maint-5.005/perl + ! Makefile.SH regcomp.c +____________________________________________________________________________ +[ 2472] By: gbarr on 1998/12/12 17:12:28 + Log: undo changes to Exporter.pm from #2312 + Branch: maint-5.005/perl + ! lib/Exporter.pm +____________________________________________________________________________ +[ 2471] By: gbarr on 1998/12/12 17:09:39 + Log: integrate change#2459 from cfgperl + + enclose case want_vtbl_collxfrm with #ifdef USE_LOCALE_COLLATE + + From: hansm@icgroup.nl + Subject: Not OK: perl 5.00503 +MAINT_TRIAL_1 on OPENSTEP-Mach 4_1 (UNINSTALLED) + Date: Sun, 6 Dec 98 22:19:54 +0100 + Message-Id: <9812062116.AA26445@icgned.icgroup.nl> + Branch: maint-5.005/perl + ! util.c +____________________________________________________________________________ +[ 2470] By: gbarr on 1998/12/12 16:46:03 + Log: re-sync'd Text::Wrap with new version from CPAN + Branch: maint-5.005/perl + +> t/lib/textfill.t + ! MANIFEST + !> lib/Text/Wrap.pm t/lib/textwrap.t +____________________________________________________________________________ +[ 2469] By: gbarr on 1998/12/12 15:58:43 + Log: integrate changes#2435,2436 from cfgperl + + Pod::Html and Pod::Text were not locale-savvy: + for example in =head1 all non-ASCII-\w-runs were + turned into underscores in NAME tags. This could + result in several NAME tags becoming identical. + Reported by: + + From: Fyodor Krasnov <fyodor@aha.ru> + Subject: pod2html vs Russian Characters + To: Tom.Christiansen@snn.aha.ru, tchrist@perl.com + Date: Tue, 24 Nov 1998 19:00:36 +0300 (MSK) + Message-Id: <199811241600.TAA05149@stat.aha.ru> + + One paste too many in #2435. + Branch: maint-5.005/perl + !> lib/Pod/Html.pm lib/Pod/Text.pm +____________________________________________________________________________ +[ 2468] By: gbarr on 1998/12/12 15:01:58 + Log: redirect trail program to error msg file in Configure + + From: Andy Dougherty <doughera@lafayette.edu> + Date: Tue, 1 Dec 1998 13:40:12 -0500 (EST) + Message-Id: <Pine.SUN.3.96.981201133546.4288K-100000@newton.phys> + Subject: [PATCH 5.005_xx] Missing redirection of simple test program + Branch: maint-5.005/perl + ! Configure +____________________________________________________________________________ +[ 2467] By: gbarr on 1998/12/12 14:52:24 + Log: Change reall_srchlen back to an int from a #define + + From: Graham Barr <gbarr@ti.com> + Date: Mon, 30 Nov 1998 14:29:14 -0600 + Message-ID: <19981130142914.X1504@asic.sc.ti.com> + Subject: [PATCH 5.005_03-MT!] Re: one compilation warning from 5_03-MT1 + Branch: maint-5.005/perl + ! malloc.c +____________________________________________________________________________ +[ 2466] By: gbarr on 1998/12/12 14:40:56 + Log: s/SCM_CREDENTIALSS/SCM_CREDENTIALs/ in Socket.xs + + From: Andy Dougherty <doughera@lafayette.edu> + Date: Thu, 3 Dec 1998 11:26:25 -0500 (EST) + Message-Id: <Pine.SUN.3.96.981203112330.8800H-100000@newton.phys> + Subject: [PATCH 5.005_03-MAINT_TRIAL_1] Trivial grammar patch + Branch: maint-5.005/perl + ! Porting/Glossary + !> ext/Socket/Socket.xs +____________________________________________________________________________ +[ 2456] By: gsar on 1998/12/06 13:49:02 + Log: branch perldelta.pod + Branch: maint-5.005/perl + +> pod/perldelta.pod +____________________________________________________________________________ +[ 2455] By: gsar on 1998/12/06 13:47:21 + Log: clobber perldelta.pod to reestablish branch from perl5005delta.pod + Branch: maint-5.005/perl + - pod/perldelta.pod +____________________________________________________________________________ +[ 2415] By: gbarr on 1998/11/30 02:31:15 + Log: Chnages,patchlevel.h etc... + Branch: maint-5.005/perl + ! Changes MANIFEST patchlevel.h t/op/tr.t win32/Makefile + ! win32/config_H.bc win32/config_H.gc win32/config_H.vc + ! win32/makefile.mk +____________________________________________________________________________ +[ 2411] By: gbarr on 1998/11/30 01:31:22 + Log: integrated changes#2323,2353,2369 + + From: maeda@src.ricoh.co.jp + Date: Tue, 24 Nov 1998 10:37:45 +0900 + Message-Id: <199811240137.KAA05867@luna.src.ricoh.co.jp> + Subject: format "..." bug + + Locale collation, ctype, and numeric, were initialized wrong + (if LC_ALL or LANG were unset, so were the collation/ctype/numeric), + as reported by + + From: Ilya.Sandler@etak.com (Ilya Sandler) + Subject: a bug in locale handling: LC_COLLATE ignored sometimes + Date: 25 Nov 1998 04:53:52 +0200 + Message-ID: <MLIST_199811250226.SAA12590@axi001.etak.sw> + + allow final period in a file (not followed by a newline) to + terminate format spec + Branch: maint-5.005/perl + ! pp_ctl.c toke.c util.c + !> t/op/write.t +____________________________________________________________________________ +[ 2408] By: gbarr on 1998/11/30 01:29:19 + Log: integrated ext/B/... changes from mainline + Branch: maint-5.005/perl + !> ext/B/B.pm ext/B/B.xs ext/B/B/Assembler.pm ext/B/B/C.pm + !> ext/B/B/Disassembler.pm +____________________________________________________________________________ +[ 2404] By: gbarr on 1998/11/30 00:26:36 + Log: integrate some of change#2318 from mainline + Branch: maint-5.005/perl + +> t/op/grent.t t/op/pwent.t + !> ext/DB_File/Changes ext/DB_File/DB_File.pm + !> ext/DB_File/DB_File.xs ext/POSIX/hints/dynixptx.pl + !> ext/Socket/Socket.pm ext/Socket/Socket.xs lib/Benchmark.pm + !> pod/perldata.pod t/op/sort.t +____________________________________________________________________________ +[ 2398] By: gbarr on 1998/11/29 22:11:16 + Log: integrate changes#2254,2259,2335,2345,2348,2361,2368,2380 from mainline + + win32_recvfrom() compatibility fix + + From: "Kurt D. Starsinic" <kstar@chapin.edu> + Subject: Re: [PATCH] Re: pod2man bug in date generated line + To: Albert Dvornik <bert@genscan.com>, "Larry W. Virden" <lvirden@cas.org> + Cc: perlbug@perl.com + Date: 20 Nov 1998 21:30:17 +0200 + Message-ID: <MLIST_19981120131523.A464@O2.chapin.edu> + + make $1 et al readonly under threads; make C<undef $1> fail like + C<$1 = undef> does + + fix typo in pp_defined() causing C<defined %tied> to fail + + more conservative version of changes#2345,2346,2347; those break + C<defined(@{"foo::ISA"})> which seems to be extensively used in + the libs :-( + + fix uninitialized warnings + From: Brian Callaghan <callagh@itginc.com> + Date: Thu, 19 Nov 1998 17:49:10 -0800 + Message-Id: <3654CA96.B64FCAEB@itginc.com> + Subject: Complete.pm patch (version 1.1) + + Liblist tweak suggested by Swen Thuemmler <Swen.Thuemmler@paderlinx.de>; + add C<$Config{installarchlib}/CORE> to the default locations searched + on win32 + + prefer IO::Handle for IO if FileHandle:: is empty (as suggested by + Tim Bunce) + Branch: maint-5.005/perl + ! gv.c op.c pp.c + !> lib/ExtUtils/Liblist.pm lib/Term/Complete.pm pod/perlfaq4.pod + !> pod/pod2man.PL t/op/undef.t win32/win32sck.c +____________________________________________________________________________ +[ 2315] By: gbarr on 1998/11/27 05:16:50 + Log: integrate change#2246 from mainline, while still allowing + C<sort $globref @foo> + + allow C<sort $coderef @foo> + Branch: maint-5.005/perl + ! op.c sv.c + !> t/op/sort.t +____________________________________________________________________________ +[ 2314] By: gbarr on 1998/11/27 04:03:58 + Log: integrate change#2159 from mainline + + Data::Dumper update + Branch: maint-5.005/perl + !> ext/Data/Dumper/Changes ext/Data/Dumper/Dumper.pm + !> ext/Data/Dumper/Dumper.xs ext/Data/Dumper/Todo t/lib/dumper.t +____________________________________________________________________________ +[ 2313] By: gbarr on 1998/11/27 03:04:21 + Log: Fix typo in change#2312 + Branch: maint-5.005/perl + ! ext/Thread/Thread.xs +____________________________________________________________________________ +[ 2312] By: gbarr on 1998/11/27 03:03:03 + Log: integrate change#1837,1967,1986,2060,2068,2146,2214,2224,2300,2301 from mainline + + (via private mail) + From: Charles Bailey <BAILEY@newman.upenn.edu> + Date: Sat, 05 Sep 1998 01:23:58 -0400 (EDT) + Message-id: <01J1FH7R43NS002F14@cor.newman.upenn.edu> + Subject: [Patch 5.005_02] Miscellaneous VMS cleanup + + correct bugs exposed in MM_Unix.pm by commenting out Selfloader + (MAN3PODS cannot be set to ' '; stray stricture violation) + + qualify names of builtins + + handle '::' in section names properly + From: Graham Barr <gbarr@pobox.com> + Date: Sat, 17 Oct 1998 12:57:54 -0500 + Message-ID: <19981017125754.C510@pobox.com> + Subject: Re: pod2html + + From: Zachary Miller <zcmiller@simon.er.usgs.gov> + Date: Tue, 20 Oct 1998 20:52:20 -0500 + Message-Id: <199810210152.UAA07792@simon.er.usgs.gov> + Subject: Exporter.pm's export_to_level() argument handling buggy + + hand-apply whitespace-mutiliated patch + From: "vishal bhatia" <vishalb@hotmail.com> + Date: Wed, 28 Oct 1998 23:45:32 PST + Message-ID: <19981029074534.2334.qmail@hotmail.com> + Subject: [PATCH 5.005_52]Compiling modules,more bugfixes for B + + typo in newHVhv() + + avoid endless loops in Text::Wrap (from a suggestion by Lupe + Christoph <lupe@alanya.m.isar.de>) + + properly free temporaries created by threads + + fix PL_defoutgv leak under threads + Branch: maint-5.005/perl + !> (integrate 31 files) +____________________________________________________________________________ +[ 2311] By: gbarr on 1998/11/27 01:31:36 + Log: integrate change#2210 from mainline + + fix AvREALISH bogusness + Branch: maint-5.005/perl + ! av.c + !> t/op/array.t +____________________________________________________________________________ +[ 2310] By: gbarr on 1998/11/27 00:20:21 + Log: integrate changes#2235,2299,2300 from mainline + + catch a neophyte trap: open(<FH>), close(<FH>) etc. + + fix C<if (...) { package Foo; ... }> misoptimization that fails + to set the package for the block properly + + properly free temporaries created by threads + Branch: maint-5.005/perl + ! ext/Thread/Thread.xs op.c perl.h util.c + !> t/comp/package.t +____________________________________________________________________________ +[ 2309] By: gbarr on 1998/11/27 00:16:36 + Log: integrate change#2298 from mainline + Branch: maint-5.005/perl + !> universal.c +____________________________________________________________________________ +[ 2308] By: gbarr on 1998/11/27 00:11:44 + Log: Updates for MPE/iX DynaLoader and installperl, via private mail + forwarded by Jarkko Hietaniemi from Mark Bixby + Branch: maint-5.005/perl + ! ext/DynaLoader/dl_mpeix.xs installperl +____________________________________________________________________________ +[ 2307] By: gbarr on 1998/11/27 00:07:27 + Log: Remove docs for feature not in _0* + Branch: maint-5.005/perl + ! pod/perlfunc.pod +____________________________________________________________________________ +[ 2306] By: gbarr on 1998/11/26 23:44:47 + Log: Allow PL_FILES to have multiple targets from one source by allowing + an array ref as the value in the hash + Branch: maint-5.005/perl + ! lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MM_VMS.pm + ! lib/ExtUtils/MakeMaker.pm +____________________________________________________________________________ +[ 2305] By: gbarr on 1998/11/26 23:38:06 + Log: fix unsigned variables to use SvUV and sv_setuv + Branch: maint-5.005/perl + ! lib/ExtUtils/typemap +____________________________________________________________________________ +[ 2304] By: gbarr on 1998/11/26 23:36:17 + Log: Fix embeded \n in ABSTRACT and <> in AUTHOR + Branch: maint-5.005/perl + ! lib/ExtUtils/MM_Unix.pm +____________________________________________________________________________ +[ 2302] By: gbarr on 1998/11/26 15:27:03 + Log: integrate changes#2177,2189,2228,2229 from cfgperl + + 0**0 = 1, from + + From: d-lewart@uiuc.edu (Daniel S. Lewart) + Subject: Math::Complex 0**0 patches + Date: Sun, 1 Nov 1998 19:21:48 -0600 (CST) + Message-Id: <199811020121.TAA28310@staff2.cso.uiuc.edu> + + sysio.t failure: fix undefined order of evaluation, from + + From: Spider Boardman <spider@web.zk3.dec.com> + Subject: Not OK: perl 5.00553 on alpha-thread 5.0 [PATCH] + Date: 4 Nov 1998 01:22:30 +0200 + Message-ID: <MLIST_199811032227.RAA143892@web.zk3.dec.com> + + From: "Martin J. Bligh" <mbligh@sequent.com> + Message-ID: <187803647.910720870@w-186d219.rhe.sequent.com> + Subject: Re: Making Perl work on DYNIX/ptx + Date: Tue, 10 Nov 1998 18:01:10 -0800 + + From: "Martin J. Bligh" <mbligh@sequent.com> + Subject: Re: Making Perl work on DYNIX/ptx + Date: Tue, 10 Nov 1998 16:24:26 -0800 + Message-ID: <181999655.910715066@w-186d219.rhe.sequent.com> + Branch: maint-5.005/perl + +> ext/DB_File/hints/dynixptx.pl ext/POSIX/hints/dynixptx.pl + ! pp_sys.c + !> hints/dynixptx.sh lib/Math/Complex.pm t/lib/complex.t +____________________________________________________________________________ +[ 2297] By: gbarr on 1998/11/24 02:32:38 + Log: integrate change#2266 from cfgperl + From: John Tobey <jtobey@channel1.com> + Subject: [PATCH] perlfaq typos + To: perl5-porters@perl.com + Date: 22 Nov 1998 04:25:15 +0200 + Message-ID: <MLIST_m0zhPeF-000FOgC@feynman.localnet> + Branch: maint-5.005/perl + !> pod/perlfaq3.pod pod/perlfaq4.pod pod/perlfaq5.pod + !> pod/perlfaq7.pod pod/perlfaq8.pod +____________________________________________________________________________ +[ 2296] By: gbarr on 1998/11/24 01:39:18 + Log: integrated changes#2011,2092,2106,2108,2143 from cfgperl + + More robust yacc/bison failure output handling. + + More robustness. + + Bison says 'parse error', not 'parser error'. + + The "parse error" must be converted to "syntax error", + just matching it aint' enough. + + There can be multiple yacc/bison errors. + Branch: maint-5.005/perl + !> t/comp/require.t t/op/misc.t t/pragma/subs.t + !> t/pragma/warning.t +____________________________________________________________________________ +[ 2295] By: gbarr on 1998/11/24 00:49:28 + Log: integrate change#1823 from mainline + From: Joe Buehler <jhpb@hekimian.com> + Date: 29 Aug 1998 17:13:28 -0400 + Message-ID: <yd37lzro5jb.fsf@pandora.hekimian.com> + Subject: patches for perl 5.005_51 under U/WIN + Branch: maint-5.005/perl + +> hints/uwin.sh + ! Configure + !> installman makedepend.SH t/lib/posix.t +____________________________________________________________________________ +[ 2258] By: gbarr on 1998/11/21 20:48:02 + Log: Another Configure patch from Jarkko + Branch: maint-5.005/perl + ! Configure +____________________________________________________________________________ +[ 2257] By: gbarr on 1998/11/21 17:23:13 + Log: Big Configure patch from Jarkko Hietaniemi <jhi@iki.fi> via + private mail + Branch: maint-5.005/perl + ! Configure Makefile.SH config_h.SH hints/dec_osf.sh + ! hints/freebsd.sh hints/irix_6.sh hints/linux.sh + ! hints/next_3.sh hints/os390.sh pp_sys.c +____________________________________________________________________________ +[ 2239] By: gbarr on 1998/11/14 03:59:58 + Log: more doc changes from mainline + Branch: maint-5.005/perl + ! pod/perldiag.pod pod/perlfunc.pod pod/perlre.pod + !> INSTALL README.vms vms/ext/Stdio/Stdio.pm +____________________________________________________________________________ +[ 2238] By: gbarr on 1998/11/14 02:51:51 + Log: integrate doc changes from mainline, including + changes#1796,1811,1830,1831,1844,1846,1876,1905,2149,2152 + Branch: maint-5.005/perl + !> README.os390 pod/perl.pod pod/perldelta.pod pod/perlfaq1.pod + !> pod/perlform.pod pod/perlfunc.pod pod/perlguts.pod + !> pod/perlipc.pod pod/perllocale.pod pod/perlport.pod + !> pod/perlref.pod pod/perlrun.pod pod/perlvar.pod pod/perlxs.pod + !> pod/pod2man.PL +____________________________________________________________________________ +[ 2237] By: gbarr on 1998/11/14 02:51:49 + Log: integrate change#1847 from mainline + From: Roderick Schertler <roderick@argon.org> + Date: Wed, 09 Sep 1998 23:52:48 -0400 + Message-ID: <20567.905399568@eeyore.ibcinc.com> + Subject: seed srand from /dev/urandom when possible + Branch: maint-5.005/perl + ! pp.c +____________________________________________________________________________ +[ 2232] By: gbarr on 1998/11/13 03:12:37 + Log: integrate change#2215 from mainline + set close-on-exec bit on pipe() FDs + Branch: maint-5.005/perl + ! pod/perlfunc.pod pod/perlvar.pod pp_sys.c +____________________________________________________________________________ +[ 2231] By: gbarr on 1998/11/13 02:16:03 + Log: integrate change#2188 from mainline + fix return value of win32_pclose() + Branch: maint-5.005/perl + !> win32/win32.c +____________________________________________________________________________ +[ 2218] By: gbarr on 1998/11/08 16:48:44 + Log: From: Graham Barr <gbarr@ti.com> + Date: Mon, 2 Nov 1998 07:38:52 -0600 + Message-ID: <19981102073852.A12751@asic.sc.ti.com> + Subject: [PATCH 5.005_*] Re: IPC::Msg 1.03 + Branch: maint-5.005/perl + ! ext/IPC/SysV/Msg.pm +____________________________________________________________________________ +[ 2217] By: gbarr on 1998/11/08 05:22:39 + Log: fix changes in 2213 not to break binary compat + Branch: maint-5.005/perl + ! pp_ctl.c proto.h +____________________________________________________________________________ +[ 2216] By: gbarr on 1998/11/08 04:21:01 + Log: integrate change#2192 from mainline + indeterminate order-of-evaluation fixes + Branch: maint-5.005/perl + ! mg.c +____________________________________________________________________________ +[ 2213] By: gbarr on 1998/11/08 00:39:44 + Log: integrate change#2051 from mainline + properly restore PL_rsfp_filters after require + Branch: maint-5.005/perl + ! embed.h global.sym objXSUB.h objpp.h pp_ctl.c proto.h scope.c + ! scope.h +____________________________________________________________________________ +[ 2212] By: gbarr on 1998/11/07 23:13:29 + Log: integrate changes#1914,1925,1926,1945,1956,1987 from mainline + + normalize tm struct passed to strftime() with mktime() + From: Spider Boardman <spider@orb.nashua.nh.us> + Date: Wed, 30 Sep 1998 15:12:09 -0400 + Message-Id: <199809301912.PAA26119@Orb.Nashua.NH.US> + Subject: [PATCH 5.005_52] Re: POSIX::strftime returns incorrect date + + disable USE_THREADS when PERL_OBJECT is enabled + + From: Mark-Jason Dominus <mjd@plover.com> + Date: Sun, 04 Oct 1998 14:48:11 -0400 + Message-ID: <19981004184811.16048.qmail@plover.com> + Subject: PATCH: perldoc -f does not locate -e, -r, -x, etc. + + defer "deep recursion" warnings until CXt_SUB context is properly + set up + + Mutexen should be initialized only once. + + perldoc pod update + From: Daniel Grisinger <dgris@perrin.dimensional.com> + Date: 06 Oct 1998 23:56:51 -0600 + Message-ID: <m3g1d0kj8c.fsf@perrin.dimensional.com> + Subject: [PATCH _02 and _52] perldoc + Branch: maint-5.005/perl + ! gv.c op.c pp_hot.c + !> ext/POSIX/POSIX.pod ext/POSIX/POSIX.xs utils/perldoc.PL + !> win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 2207] By: gbarr on 1998/11/06 01:36:17 + Log: integrate changes#1912,1948 from mainline + change warning about glob process failure + Branch: maint-5.005/perl + ! pod/perldiag.pod pp_hot.c +____________________________________________________________________________ +[ 2200] By: gbarr on 1998/11/05 04:26:26 + Log: integrate changes#1840,1855,1860,1882,1884,1891,1900,1907 from mainline + pl2bat tweak from Tye McQueen <tye@metronet.com> + + reset errno after C<require> search (as suggested by Larry) + + upgrade to CPAN-1.40 + + missing file in last submit (1881) + + temporarily disable perl malloc for a2p until we clean up + conflicting malloc() declarations everywhere + + Fixed apostrophe problem from Mark Knutsen. + + use SETERRNO() to reset errno (suggested by Charles Bailey) + + applied patches, but retained old behavior for win32 (where compilers + can't read from stdin at all) + From: Graham Barr <gbarr@ti.com> + Date: Mon, 28 Sep 1998 09:41:49 -0500 + Message-ID: <19980928094149.B26576@asic.sc.ti.com> + Subject: Re: 5.005_51 Errno invokes cpprun incorrectly + -- + Date: Tue, 29 Sep 1998 12:35:43 -0500 + Message-ID: <19980929123543.Z26576@asic.sc.ti.com> + Subject: Re: 5.005_51 Errno invokes cpprun incorrectly + + and ext/Errno/Errno_pm.PL from change#2050 + Branch: maint-5.005/perl + ! perl.h pp_ctl.c proto.h sv.h + !> ext/Errno/Errno_pm.PL lib/CPAN.pm lib/CPAN/FirstTime.pm + !> win32/bin/pl2bat.pl x2p/Makefile.SH +____________________________________________________________________________ +[ 2199] By: gbarr on 1998/11/05 03:35:00 + Log: integrate changes#1817,1856,1869,1909 from mainline + updated usethreads hints for hpux 10.X + From: Matthew T Harden <mthard@mthard1.monsanto.com> + Date: Fri, 28 Aug 1998 14:10:42 GMT + Message-Id: <199808281410.AA11058@mthard1.monsanto.com> + Subject: Re: OK: perl 5.00502 on PA-RISC1.1-thread 10.20 (UNINSTALLED) + + update hints for OPENSTEP 4.2 on i386 + From: Gerben Wierda <Gerben_Wierda@RnA.nl> + Date: Sun, 20 Sep 1998 01:03:18 +0200 + Message-Id: <9809192303.AA29190@Spike> + Subject: Perl 5.005_02 compilation problems + + use STRICT_ALIGNMENT on IRIX to allow usemymalloc=y again + From: Scott Henry <scotth@sgi.com> + Date: 13 Aug 1998 09:52:15 PDT + Message-Id: <yd8pve46czk.fsf@hoshi.engr.sgi.com> + Subject: [PATCH] Irix USE_LONG_LONG/malloc.c incompatibility (was...) + + update SCO hints for dynamic loading + From: Andy Dougherty <doughera@lafcol.lafayette.edu> + Date: Mon, 28 Sep 1998 16:50:38 -0400 (EDT) + Message-Id: <Pine.SUN.3.96.980928164648.8130E-100000@newton.phys> + Subject: [PATCH 5.004_04-MAINT_TRIAL_5 and 5.005_xx] Re: Perl on SCO_SV + -- + Date: Tue, 29 Sep 1998 16:48:55 -0400 (EDT) + Message-Id: <Pine.SUN.3.96.980929164612.8634A-100000@newton.phys> + Subject: Re: [PATCH 5.004_04-MAINT_TRIAL_5 and 5.005_xx] Re: Perl on SCO_SV + Branch: maint-5.005/perl + !> hints/hpux.sh hints/irix_6.sh hints/next_4.sh hints/sco.sh +____________________________________________________________________________ +[ 2198] By: gbarr on 1998/11/05 03:00:51 + Log: integrate OS2 changes from mainline, change#1836,1930,1996,2063 + and os2/os2,c from #2145 + + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Sat, 5 Sep 1998 00:14:51 -0400 (EDT) + Message-Id: <199809050414.AAA19801@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_*] OS/2 spawning typos + + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Message-Id: <199810050637.CAA07781@monk.mps.ohio-state.edu> + Date: Mon, 5 Oct 1998 02:37:43 -0400 (EDT) + Subject: [PATCH 5.005_52] Cumulative OS/2-related patch + + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Tue, 13 Oct 1998 04:46:00 -0400 (EDT) + Message-Id: <199810130846.EAA00769@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_52] Memory overrun in os2.c + + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Sun, 18 Oct 1998 23:20:57 -0400 (EDT) + Message-Id: <199810190320.XAA28249@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_*] Improve sbrk() on OS/2 + + remaining PL_foo stragglers + Branch: maint-5.005/perl + ! mg.c perl_exp.SH util.c + !> hints/os2.sh os2/Changes os2/Makefile.SHs os2/os2.c +____________________________________________________________________________ +[ 2197] By: gbarr on 1998/11/05 02:15:53 + Log: integrate changes#1826,1862 from mainline + + From: Jarkko Hietaniemi <jhi@iki.fi> + Date: Wed, 12 Aug 1998 22:41:37 +0300 (EET DST) + Message-Id: <199808121941.WAA06263@alpha.hut.fi> + Subject: [PATCH] 5.004_50 or 5.005_02: get rid of interp.sym because not even AIX needs it + + remove bogus warn() + Branch: maint-5.005/perl + - interp.sym + ! MANIFEST Makefile.SH embed.pl perl_exp.SH +____________________________________________________________________________ +[ 2194] By: gbarr on 1998/11/05 01:26:46 + Log: integarte malloc.c changes from mainline change#1807,2112,2133 + Branch: maint-5.005/perl + !> malloc.c +____________________________________________________________________________ +[ 2193] By: gbarr on 1998/11/05 01:25:31 + Log: integrate changes#1763,1778,1801,1804 from mainline + + From: Stephen McCamant <alias@mcs.com> + Date: Sun, 2 Aug 1998 16:33:18 -0500 (CDT) + Message-ID: <13764.55116.921952.837027@alias-2.pr.mcs.net> + Subject: [PATCH] Eliminate superfluous RV2p[AH]Vs in oops[AH]V() + + Implicit require during compile reset line numbering + + silence redefined warning for XS(INIT) {} + + From: Laszlo Molnar <molnarl@cdata.tvnet.hu> + Date: Sun, 9 Aug 1998 22:38:23 +0200 + Message-ID: <19980809223823.A215@cdata.tvnet.hu> + Subject: [PATCH 5.5002] dos-djgpp update + Branch: maint-5.005/perl + ! op.c pp_ctl.c + !> t/io/fs.t +____________________________________________________________________________ +[ 2176] By: gbarr on 1998/11/02 04:51:48 + Log: integrate change#2030 from mainline + + fix handling of mayhaps-extended @_ in goto &sub + Branch: maint-5.005/perl + ! av.c pp_ctl.c + !> t/op/goto.t +____________________________________________________________________________ +[ 2175] By: gbarr on 1998/11/02 04:32:02 + Log: integrate chnage#1934,1935 from mainline + fix USE_THREADS coredump due to uninitialized PL_hv_fetch_ent_mh + add test for previous fix + Branch: maint-5.005/perl + ! util.c + !> ext/Thread/create.t +____________________________________________________________________________ +[ 2174] By: gbarr on 1998/11/02 04:22:20 + Log: integrate change#1863,1881 from mainline + + provide locked access to string table for USE_THREADS + + serial access to PL_x[inpr]v_root for USE_THREADS + Branch: maint-5.005/perl + ! embedvar.h objXSUB.h perl.c proto.h sv.c + !> hv.c intrpvar.h thread.h +____________________________________________________________________________ +[ 2173] By: gbarr on 1998/11/02 04:10:46 + Log: integrate change#1990 from mainline + + provide option to enable optimization with VC (suggested by Jan + Dubois) + Branch: maint-5.005/perl + !> win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 2172] By: gbarr on 1998/11/02 02:52:29 + Log: integrate changes#1944,1948,1966 from mainline + + change#1614 merely disabled earlier fix (doh!); undo it and properly + fixup the cop_seq value that must be seen by lexical lookups that + emanate within eval'' + + tweak to make fix in change#1944 behave correctly for closures + created within eval'' + Branch: maint-5.005/perl + ! op.c pp_ctl.c pp_hot.c scope.c + !> cop.h t/op/eval.t +____________________________________________________________________________ +[ 2171] By: gbarr on 1998/11/01 03:59:39 + Log: integrate changes 1835,2003,2067 and File::Find change in 1938 + warn on C<my($foo,$foo)> + + silence -w noises (suggested by Greg Bacon) Term::Complete + + From: jan.dubois@ibm.net (Jan Dubois) + Date: Wed, 21 Oct 1998 00:55:51 +0200 + Message-ID: <36380269.55370608@smtp1.ibm.net> + Subject: Make _really_ sure Dynaloader.xs code is initialized only once + Branch: maint-5.005/perl + ! op.c pod/perldiag.pod + !> ext/DynaLoader/DynaLoader_pm.PL lib/File/Find.pm + !> lib/Term/Complete.pm +____________________________________________________________________________ +[ 2170] By: gbarr on 1998/11/01 03:48:38 + Log: integrate change 1992 from mainline + + applied suggested patch with small doc tweak + From: Gisle Aas <gisle@aas.no> + Date: 11 Oct 1998 12:53:13 +0200 + Message-ID: <m3u31bfjza.fsf@furu.g.aas.no> + Subject: Re: [PATCH 5.005_52] Optional syswrite LENGTH argument + Branch: maint-5.005/perl + ! pod/perlfunc.pod pp_sys.c + !> opcode.h opcode.pl t/op/sysio.t t/op/tiehandle.t +____________________________________________________________________________ +[ 2168] By: gbarr on 1998/11/01 01:58:58 + Log: From: jan.dubois@ibm.net (Jan Dubois) + Date: Fri, 09 Oct 1998 23:28:31 +0200 + Message-ID: <36217b7f.3193091@smtp1.ibm.net> + Subject: [PATCH 5.005_02] Allow XS access to vtbl_*s when compiled with PERL_OBJECT + Branch: maint-5.005/perl + ! XSUB.h +____________________________________________________________________________ +[ 2167] By: gbarr on 1998/11/01 01:22:41 + Log: integrate change#2029 from mainline + restore sanity to "constant" references + Branch: maint-5.005/perl + ! op.c pod/perldiag.pod + !> lib/constant.pm t/pragma/constant.t +____________________________________________________________________________ +[ 2166] By: gbarr on 1998/11/01 01:04:24 + Log: integrate changes#1895,1896,2066,2147,2148 from mainline + fix win32_stat() to do the right thing for share names + + small tweak on last change + + recognize '%' as a shell metachar for win32 + From: jan.dubois@ibm.net (Jan Dubois) + Date: Tue, 20 Oct 1998 21:57:35 +0200 + Message-ID: <3636ea31.49170453@smtp1.ibm.net> + Subject: [PATCH 5.005_02, Win32] Re: %ENV% not expanded in backquotes? + + tweaked version of suggested patch + From: Anton Berezin <tobez@plab.ku.dk> + Date: 29 Oct 1998 14:48:54 +0100 + Message-ID: <86yapzv5q1.fsf@lion.plab.ku.dk> + Subject: [PATCH 5.005_52] One more problem with win32_stat and MSVC + + From: Anton Berezin <tobez@plab.ku.dk> + Date: 29 Oct 1998 17:06:25 +0100 + Message-ID: <86pvbbuzcu.fsf@lion.plab.ku.dk> + Subject: [PATCH 5.005_52] win32_opendir() fails on empty drives + Branch: maint-5.005/perl + !> win32/win32.c +____________________________________________________________________________ +[ 2165] By: gbarr on 1998/11/01 00:10:15 + Log: integrated changes#1941,1942,1943,1975,2061,2111,2151 from mainline + + don't longjmp() in pp_goto() (regressive bug from old single-stack + implementation) + + force copy of substrings when matching against temporaries + + ensure recursive attempts to findlex()icals know enough about where + the last eval'' context was encountered + + propagate typeness of lexicals while cloning them + + From: Graham Barr <gbarr@pobox.com> + Date: Sat, 17 Oct 1998 22:22:02 -0500 + Message-ID: <19981017222202.J510@pobox.com> + Subject: Re: '*' prototype does not allow bareword with strict + + smarter C<$SIG{FOO} = BAREWORD;> warning + + From: Mark-Jason Dominus <mjd@plover.com> + Date: Fri, 30 Oct 1998 14:24:23 EST + Message-Id: <19981030192423.27276.qmail@plover.com> + Subject: PATCH: (5.005_02) a2p should use `chomp' instead of `chop' + Branch: maint-5.005/perl + ! op.c pp_ctl.c pp_hot.c t/op/pat.t toke.c + !> t/op/eval.t t/op/runlevel.t x2p/walk.c +____________________________________________________________________________ +[ 2158] By: gbarr on 1998/10/31 05:03:02 + Log: integrate changes#1821 & 1857 from mainline + + s/runops/CALLRUNOPS/ + + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Tue, 22 Sep 1998 17:30:16 -0400 (EDT) + Message-Id: <199809222130.RAA17034@monk.mps.ohio-state.edu> + Subject: More verbose Test::Harness [PATCH] + Branch: maint-5.005/perl + !> cc_runtime.h lib/Test/Harness.pm +____________________________________________________________________________ +[ 2157] By: gbarr on 1998/10/31 02:35:07 + Log: integrate change#1839 from mainline + From: Drago Goricanec <drago@raptor.otsd.ts.fujitsu.co.jp> + Date: Mon, 7 Sep 1998 17:36:09 +0900 + Message-Id: <199809070836.RAA14631@raptor.otsd.ts.fujitsu.co.jp> + Subject: Thread::cond_wait bug in 5.005.51 causes deadlock + Branch: maint-5.005/perl + ! ext/Thread/Thread.xs +____________________________________________________________________________ +[ 2156] By: gbarr on 1998/10/31 02:22:11 + Log: integrate change#1829 from mainline + fix problematic typecast in filter_del() + From: Mark P Lutz <tecmpl1@triton.ca.boeing.com> + Date: Mon, 31 Aug 1998 21:13:11 GMT + Message-Id: <199808312113.VAA53356@triton.ca.boeing.com> + Subject: perl5.005_02 does not build on Cray T90 + Branch: maint-5.005/perl + ! toke.c +____________________________________________________________________________ +[ 2155] By: gbarr on 1998/10/31 01:59:08 + Log: integrate chnages#1824,2118 from mainline + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Sat, 29 Aug 1998 17:38:30 -0400 (EDT) + Message-Id: <199808292138.RAA18359@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_*] Protect debugger from nonlocal exits + + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Wed, 28 Oct 1998 01:23:27 -0500 (EST) + Message-Id: <199810280623.BAA06968@monk.mps.ohio-state.edu> + Subject: [PATCH 5.00552] Minor debugger tweaks + Branch: maint-5.005/perl + !> lib/perl5db.pl +____________________________________________________________________________ +[ 2154] By: gbarr on 1998/10/31 01:06:35 + Log: integrate all lib/ExtUtils/... changes from mainline + Branch: maint-5.005/perl + !> lib/ExtUtils/MM_OS2.pm lib/ExtUtils/MM_Unix.pm + !> lib/ExtUtils/MM_VMS.pm lib/ExtUtils/MM_Win32.pm + !> lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Mkbootstrap.pm + !> lib/ExtUtils/Mksymlists.pm lib/ExtUtils/xsubpp +____________________________________________________________________________ +[ 2139] By: gbarr on 1998/10/30 04:17:53 + Log: apply chnage#2071 from mainline + From: Graham Barr <gbarr@pobox.com> + Date: Sat, 17 Oct 1998 20:42:41 -0500 + Message-ID: <19981017204241.G510@pobox.com> + Subject: Re: taint checking for: use lib "$ENV{'EVIL'}" + Branch: maint-5.005/perl + ! pp_ctl.c +____________________________________________________________________________ +[ 2138] By: gbarr on 1998/10/30 04:14:35 + Log: apply change#2077 from mainline + From: Graham Barr <gbarr@pobox.com> + Date: Sat, 24 Oct 1998 21:45:50 -0500 + Message-ID: <19981024214550.C508@pobox.com> + Subject: Re: die with a reference should use overload "" operator + Branch: maint-5.005/perl + ! pp_ctl.c +____________________________________________________________________________ +[ 2137] By: gbarr on 1998/10/30 04:01:06 + Log: integrate change#1937 from mainline + fix $/ init for USE_THREADS + Branch: maint-5.005/perl + ! perl.c +____________________________________________________________________________ +[ 2136] By: gbarr on 1998/10/30 03:40:55 + Log: apply change#2076 from mainline + From: Graham Barr <gbarr@pobox.com> + Date: Sat, 24 Oct 1998 12:45:21 -0500 + Message-ID: <19981024124521.C512@pobox.com> + Subject: [PATCH 5.005_02] Re: Auto-incrementing tied scalar causes SEGV + Branch: maint-5.005/perl + ! sv.c +____________________________________________________________________________ +[ 2135] By: gbarr on 1998/10/30 03:28:29 + Log: integrate change#1873 from mainline + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Tue, 25 Aug 1998 04:29:49 -0400 (EDT) + Message-Id: <199808250829.EAA02470@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_*] Extraneous warning for (?()A|B) + Branch: maint-5.005/perl + ! regcomp.c +____________________________________________________________________________ +[ 2134] By: gbarr on 1998/10/30 03:15:12 + Log: integrate change#1816 from mainline + don't create empty directories in installperl + From: Robin Barker <rmb1@cise.npl.co.uk> + Date: Fri, 21 Aug 1998 11:29:24 +0100 (BST) + Message-Id: <199808211029.LAA00551@cyclone.cise.npl.co.uk> + Subject: [PATCH 5.005_02] install: empty dirs + Branch: maint-5.005/perl + !> installperl +____________________________________________________________________________ +[ 2132] By: gbarr on 1998/10/30 01:39:00 + Log: integrate changes#1815 & 1828 from mainline + make behavior of /(a{3})+/ like /(aaa)+/ w.r.t where it matches + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Fri, 21 Aug 1998 05:41:02 -0400 (EDT) + Message-Id: <199808210941.FAA16467@monk.mps.ohio-state.edu> + Subject: Re: your mail + + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Mon, 31 Aug 1998 14:52:10 -0400 (EDT) + Message-Id: <199808311852.OAA24676@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_5*] (?>) broken in RE + Branch: maint-5.005/perl + ! regexec.c + !> t/op/re_tests +____________________________________________________________________________ +[ 2131] By: gbarr on 1998/10/30 01:09:19 + Log: integrate change#1947 from mainline + let docatch() pass the buck when restartop turns out to be null, + making exceptions in BEGIN{} propagate as expected + Branch: maint-5.005/perl + ! pp_ctl.c + !> t/op/misc.t +____________________________________________________________________________ +[ 2129] By: gbarr on 1998/10/29 14:53:11 + Log: integrate change#1810 from mainline + fix bogus integerization of pop()'s return value + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Date: Sat, 15 Aug 1998 23:27:54 -0400 + Message-Id: <199808160327.XAA05186@aatma.engin.umich.edu> + Subject: Re: Complex expression does integer arithmetic + Branch: maint-5.005/perl + !> opcode.h opcode.pl +____________________________________________________________________________ +[ 2128] By: gbarr on 1998/10/29 14:28:13 + Log: integrate change#1870 from mainline + From: Dan Sugalski <sugalskd@osshe.edu> + Date: Fri, 14 Aug 1998 09:20:16 PDT + Message-Id: <3.0.5.32.19980814092016.00b37dc0@ous.edu> + Subject: [PATCH 5.005_02] (and _5x I expect) VMS config procedure patch + Branch: maint-5.005/perl + !> configure.com +____________________________________________________________________________ +[ 2127] By: gbarr on 1998/10/29 13:36:29 + Log: Integrate change#1789 from mainline + delay freeing itervar so C<for $i (@a) { return($i) }> works + Branch: maint-5.005/perl + !> cop.h t/cmd/for.t +____________________________________________________________________________ +[ 2123] By: gbarr on 1998/10/29 02:43:01 + Log: Apply change#2075 from mainline + fix C<print $n += 5;> etc. + Branch: maint-5.005/perl + ! toke.c +____________________________________________________________________________ +[ 2122] By: gbarr on 1998/10/29 02:40:31 + Log: Apply change#2070 from mainline + avoid bogus line number in XSUB redefined warnings + Branch: maint-5.005/perl + ! op.c +____________________________________________________________________________ +[ 2121] By: gbarr on 1998/10/29 02:38:59 + Log: Apply change#2052 from mainline + avoid the circular refcnt logic in magic_mutexfree() + Branch: maint-5.005/perl + ! mg.c pp.c pp_hot.c +____________________________________________________________________________ +[ 2120] By: gbarr on 1998/10/29 02:36:23 + Log: Remove "5.005" hard-coded and expose vtbl_* from the perl DLL + From: "Douglas Lankshear" <dougl@ActiveState.com> + Date: Mon, 28 Sep 1998 08:49:13 -0700 + Message-ID: <000001bdeaf7$8a189350$a32fa8c0@tau.Active> + Subject: PATCH [5.005_02] update + Branch: maint-5.005/perl + ! embed.h global.sym objXSUB.h objpp.h perl.h proto.h util.c + ! win32/win32.c +____________________________________________________________________________ +[ 2084] By: gbarr on 1998/10/25 19:09:11 + Log: Integrate change#2069 from mainline + From: Martijn Koster <mak@excitecorp.com> + Date: Wed, 21 Oct 1998 13:12:03 +0100 + Message-ID: <19981021131203.A15661@excitecorp.com> + Subject: File::Path::mkpath reports the wrong error + Branch: maint-5.005/perl + !> lib/File/Path.pm +____________________________________________________________________________ +[ 2083] By: gbarr on 1998/10/25 18:48:39 + Log: Integrate change#1965 from mainline + use better numbers for exitstatus test + Branch: maint-5.005/perl + !> t/op/die_exit.t +____________________________________________________________________________ +[ 2082] By: gbarr on 1998/10/25 18:22:54 + Log: Apply change 2054 from mainline + disallow 'x' in hex numbers (except leading '0x') + From: Gisle Aas <gisle@aas.no> + Date: 16 Oct 1998 16:33:12 +0200 + Message-ID: <m3n26wtw47.fsf@furu.g.aas.no> + Subject: Re: [PATCH 5.005_52] 'x' is not a legal hex digit + Branch: maint-5.005/perl + ! perlvars.h util.c + !> t/op/oct.t +____________________________________________________________________________ +[ 2081] By: gbarr on 1998/10/25 17:58:04 + Log: Apply change #1998 from mainline + skip readonly vars and unref references when doing a reset() + Branch: maint-5.005/perl + ! sv.c +____________________________________________________________________________ +[ 2080] By: gbarr on 1998/10/25 16:06:35 + Log: Integrate changes #2072 & #1993 from mainline + fix bug in B::CC::pp_sassign() + From: "vishal bhatia" <vishalb@hotmail.com> + Date: Sun, 11 Oct 1998 18:41:38 PDT + Message-ID: <19981012014139.19614.qmail@hotmail.com> + Subject: B::CC problems with pp_sassign routine + implement C<goto &func> and other fixes (via private mail) + From: "vishal bhatia" <vishalb@hotmail.com> + Date: Wed, 21 Oct 1998 22:59:03 PDT + Message-Id: <19981022055904.20083.qmail@hotmail.com> + Subject: [PATCH 5.005_52] More fixes for B + Branch: maint-5.005/perl + !> ext/B/B.pm ext/B/B.xs ext/B/B/C.pm ext/B/B/CC.pm +____________________________________________________________________________ +[ 2079] By: gbarr on 1998/10/25 14:08:00 + Log: integrate from mainline more FSF address changes + Branch: maint-5.005/perl + !> Copying ext/B/README lib/Getopt/Long.pm +____________________________________________________________________________ +[ 2053] By: gbarr on 1998/10/25 04:56:47 + Log: From: Graham Barr <gbarr@pobox.com> + Date: Sat, 17 Oct 1998 23:05:18 -0500 + Message-ID: <19981017230518.K510@pobox.com> + Subject: Re: redo LOOP not restoring $` $' $& + Branch: maint-5.005/perl + ! cop.h t/cmd/while.t +____________________________________________________________________________ +[ 2048] By: gbarr on 1998/10/24 04:20:10 + Log: Change Free Software Foundation address in README + Branch: maint-5.005/perl + !> README +____________________________________________________________________________ +[ 2047] By: gbarr on 1998/10/24 04:02:20 + Log: Remove #ifdef DEBUGGING around SvTEMP_off + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Date: Mon, 28 Sep 1998 15:23:39 -0400 + Message-Id: <199809281923.PAA10303@aatma.engin.umich.edu> + Subject: Re: [PATCH] Re: 5.005_52: the miniperl coredump: touch magic and you're toast + Branch: maint-5.005/perl + ! scope.c +____________________________________________________________________________ +[ 2046] By: gbarr on 1998/10/24 04:00:54 + Log: use cpp symbols instead of hardwired constants + From: Hugo van der Sanden <hv@crypt.compulink.co.uk> + Date: Mon, 05 Oct 1998 09:23:33 +0100 + Message-Id: <199810050823.JAA00891@crypt.compulink.co.uk> + Subject: [PATCH 5.005_52] By the numbers (resend) + Branch: maint-5.005/perl + ! op.c +____________________________________________________________________________ +[ 2045] By: gbarr on 1998/10/24 03:50:25 + Log: squelch undef warnings + From: Hugo van der Sanden <hv@crypt.compulink.co.uk> + Date: Fri, 02 Oct 1998 11:01:14 +0100 + Message-Id: <199810021001.LAA19214@crypt.compulink.co.uk> + Subject: [PATCH] Re: Apparent bug in Math::BigInt + Branch: maint-5.005/perl + !> lib/Math/BigInt.pm +____________________________________________________________________________ +[ 2044] By: gbarr on 1998/10/24 03:47:24 + Log: Add note to INSTALL about ANSI C + Branch: maint-5.005/perl + ! INSTALL +____________________________________________________________________________ +[ 2043] By: gbarr on 1998/10/24 02:38:12 + Log: make C<goto &sub> AUTOLOAD-aware (autouse now works for modules + that are autoloaded) + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Date: Thu, 24 Sep 1998 03:01:01 -0400 + Message-Id: <199809240701.DAA16223@aatma.engin.umich.edu> + Subject: Re: autouse and Getopt::Long don't work together anymore + Branch: maint-5.005/perl + ! pp_ctl.c t/op/goto.t +____________________________________________________________________________ +[ 2042] By: gbarr on 1998/10/24 02:16:26 + Log: From: jarkko.hietaniemi@research.nokia.com (Jarkko Hietaniemi) + Date: Wed, 12 Aug 1998 15:42:35 +0300 + Message-Id: <199808121242.PAA29761@comanche.spices> + Subject: [PATCH] 5.004_02 or 5.005_51: fix regexp and tr character ranges in non-ASCII lands + Branch: maint-5.005/perl + + t/op/tr.t + ! MANIFEST perl.h pod/perllocale.pod pod/perlop.pod + ! pod/perlre.pod regcomp.c t/pragma/locale.t toke.c +____________________________________________________________________________ +[ 2021] By: gbarr on 1998/10/20 01:25:23 + Log: From: Chip Salzenberg <chip@perlsupport.com> + Date: Tue, 6 Oct 1998 13:33:05 -0400 + Message-ID: <19981006133305.A2348@perlsupport.com> + Subject: [PATCH] 5.005_02: Eliminate leak on self-ties + Branch: maint-5.005/perl + ! av.c doop.c hv.c mg.c mg.h pp.c pp_hot.c pp_sys.c scope.c + ! t/op/tie.t +____________________________________________________________________________ +[ 2015] By: gbarr on 1998/10/17 21:49:56 + Log: make h2xs generate ANSI prototypes + Branch: maint-5.005/perl + !> utils/h2xs.PL +____________________________________________________________________________ +[ 2014] By: gbarr on 1998/10/17 20:31:42 + Log: Fix POSIX::sigprocmask not to check type of $old parameter + as it is output only + Branch: maint-5.005/perl + ! ext/POSIX/POSIX.xs +____________________________________________________________________________ +[ 2013] By: gbarr on 1998/10/17 17:51:16 + Log: From: "Kurt D. Starsinic" <kstar@chapin.edu> + Date: Thu, 20 Aug 1998 20:59:03 -0400 + Message-ID: <19980820205903.A12908@O2.chapin.edu> + Subject: [PATCH] h2ph misquotes #error directives + + fix h2ph handling of C<#error "foo"> + From: SAKAI Kiyotaka <ksakai@netwk.ntt-at.co.jp> + Date: Thu, 10 Sep 1998 09:59:33 +0900 + Message-Id: <19980910095933N.ksakai@netwk.ntt-at.co.jp> + Subject: [5.005_02] h2ph problem + Branch: maint-5.005/perl + !> t/lib/h2ph.pht utils/h2ph.PL +____________________________________________________________________________ +[ 1985] By: gbarr on 1998/10/17 00:41:40 + Log: s/last/first/ typo in append_list() + Branch: maint-5.005/perl + ! op.c +____________________________________________________________________________ +[ 1984] By: gbarr on 1998/10/17 00:36:51 + Log: From: "Green, Paul" <pgreen@seussnt.stratus.com> + Date: Thu, 10 Sep 1998 00:02:07 -0400 + Message-ID: <646CD0392810D211B04A00A024BF26FB1022EB@terminator.sw.stratus.com> + Subject: RE: [PATCH] 5.005_02 and 5.005_51: Stratus VOS port + Branch: maint-5.005/perl + + README.vos vos/Changes vos/build.cm vos/compile_perl.cm + + vos/config.h vos/config_h.SH_orig vos/perl.bind + + vos/test_vos_dummies.c vos/vos_dummies.c vos/vosish.h + ! MANIFEST perl.c perl.h pod/perlport.pod +____________________________________________________________________________ +[ 1983] By: gbarr on 1998/10/17 00:23:31 + Log: define PUT_svindex(), PUT_opindex() + Branch: maint-5.005/perl + !> ext/B/B/Assembler.pm +____________________________________________________________________________ +[ 1982] By: gbarr on 1998/10/17 00:20:57 + Log: From: Jochen Wiedmann <joe@ispsoft.de> + Date: Thu, 17 Sep 1998 17:16:06 +0200 + Message-ID: <360127B6.E44564A@ispsoft.de> + Subject: [PATCH] ExtUtils::MakeMaker::prompt cannot return 0 + Branch: maint-5.005/perl + ! lib/ExtUtils/MakeMaker.pm +____________________________________________________________________________ +[ 1981] By: gbarr on 1998/10/16 02:58:10 + Log: better CR-handling on shebang line and in formats (fixed variant of + patch suggested by Igor Sysoev <igor@nitek.ru>) + Branch: maint-5.005/perl + ! perl.c toke.c +____________________________________________________________________________ +[ 1980] By: gbarr on 1998/10/16 02:21:57 + Log: From: Roderick Schertler <roderick@argon.org> + Date: 11 Sep 1998 16:19:21 -0400 + Message-ID: <pzyarqpfli.fsf@eeyore.ibcinc.com> + Subject: Re: Open2 and memory leaks + Branch: maint-5.005/perl + !> lib/IPC/Open3.pm +____________________________________________________________________________ +[ 1979] By: gbarr on 1998/10/16 02:15:54 + Log: integrate change #1908 from mainline + Branch: maint-5.005/perl + !> lib/File/Find.pm +____________________________________________________________________________ +[ 1977] By: gbarr on 1998/10/16 01:52:46 + Log: tests missing from change #1794 + Branch: maint-5.005/perl + ! t/op/re_tests +____________________________________________________________________________ +[ 1794] By: gbarr on 1998/09/20 15:59:20 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Tue, 11 Aug 1998 18:43:29 -0400 (EDT) + Message-Id: <199808112243.SAA14243@monk.mps.ohio-state.edu> + Subject: Re: Segmentation fault for /a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/ + Branch: maint-5.005/perl + ! regcomp.c t/op/re_tests +____________________________________________________________________________ +[ 1793] By: gbarr on 1998/09/20 15:39:41 + Log: From: Peter Prymmer <pvhp@forte.com> + Date: Mon, 10 Aug 98 16:58:22 PDT + Message-Id: <9808102358.AA10616@forte.com> + Subject: fix for unpack('u') failures on OS/390 + Branch: maint-5.005/perl + ! pp.c +____________________________________________________________________________ +[ 1792] By: gbarr on 1998/09/20 15:11:33 + Log: From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Date: Sun, 9 Aug 1998 15:51:48 +0100 + Message-Id: <E0z5Wp2-00071p-00@taurus.cus.cam.ac.uk> + Subject: Fix typo, change "an array" to "a hash" + Branch: maint-5.005/perl + ! pod/perlfunc.pod +____________________________________________________________________________ +[ 1791] By: gbarr on 1998/09/20 14:49:26 + Log: From: Gurusamy Sarathy <gsar@engin.umich.edu> + Date: Wed, 16 Sep 1998 22:13:17 -0400 + Message-Id: <199809170213.WAA10546@aatma.engin.umich.edu> + Subject: fill gaps in sig_* entries in win32/config.?c + and resync win32/config.?c with Porting/config.sh to pick up apiversion + Branch: maint-5.005/perl + ! win32/config.bc win32/config.gc win32/config.vc +____________________________________________________________________________ +[ 1790] By: gbarr on 1998/09/20 14:40:56 + Log: From: Gurusamy Sarathy <gsar@engin.umich.edu> + Date: Sun, 06 Sep 1998 15:35:11 -0400 + Message-Id: <199809061935.PAA21531@aatma.engin.umich.edu> + Subject: suppress bogus warning on C<sub x {} x()> + Branch: maint-5.005/perl + ! toke.c +____________________________________________________________________________ +[ 1784] By: nick on 1998/09/12 09:53:36 + Log: Two tweaks to allow quiet compile qith egcs-1.1 + Branch: maint-5.005/perl + ! win32/win32.h +____________________________________________________________________________ +[ 1783] By: gbarr on 1998/09/07 20:33:11 + Log: Subject: index() applied BM optimization to wrong argument + From: larry@wall.org (Larry Wall) + Date: Thu, 3 Sep 1998 12:49:13 -0700 + Message-Id: <199809031949.MAA29566@wall.org>, <199809060004.RAA23792@wall.org> + Branch: maint-5.005/perl + ! op.c util.c +____________________________________________________________________________ +[ 1782] By: gbarr on 1998/09/07 18:54:49 + Log: From: Gurusamy Sarathy <gsar@engin.umich.edu> + Date: Fri, 28 Aug 1998 00:33:15 -0400 + Mssage-Id: <199808280433.AAA06767@aatma.engin.umich.edu> + Subject: socket problems on NT + Branch: maint-5.005/perl + ! objXSUB.h +____________________________________________________________________________ +[ 1759] By: gsar on 1998/08/08 20:57:47 + Log: pending submit of 5.005_02 + Branch: maint-5.005/perl + ! Changes + +---------------- Version 5.005_02 Second maintenance release of 5.005 ---------------- diff --git a/contrib/perl5/Configure b/contrib/perl5/Configure index bc5c59d..5bcdbda 100755 --- a/contrib/perl5/Configure +++ b/contrib/perl5/Configure @@ -21,7 +21,7 @@ # $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $ # # Generated on Tue Jul 7 10:10:21 EDT 1998 [metaconfig 3.0 PL70] -# (with additional metaconfig patches by doughera@lafayette.edu) +# (with additional metaconfig patches by jhi@iki.fi) cat >/tmp/c1$$ <<EOF ARGGGHHHH!!!!! @@ -56,33 +56,6 @@ case "$0" in ;; esac -: the newline for tr -if test X"$trnl" = X; then - case "`echo foo|tr '\n' x 2>/dev/null`" in - foox) - trnl='\n' - ;; - esac -fi -if test X"$trnl" = X; then - case "`echo foo|tr '\012' x 2>/dev/null`" in - foox) - trnl='\012' - ;; - esac -fi -if test -n "$DJGPP"; then - trnl='\012' -fi -if test X"$trnl" = X; then - cat <<EOM >&2 - -$me: Fatal Error: cannot figure out how to translate newlines with 'tr'. - -EOM - exit 1 -fi - : Proper separator for the PATH environment variable p_=: : On OS/2 this directory should exist if this is not floppy only system :-] @@ -193,6 +166,7 @@ d_xenix='' eunicefix='' Mcc='' ar='' +full_ar='' awk='' bash='' bison='' @@ -359,6 +333,14 @@ d_flexfnam='' d_flock='' d_fork='' d_fsetpos='' +i_sysmount='' +d_fstatfs='' +d_statfsflags='' +i_sysstatvfs='' +d_fstatvfs='' +i_mntent='' +d_getmntent='' +d_hasmntopt='' d_ftime='' d_gettimeod='' d_Gconvert='' @@ -391,7 +373,6 @@ d_getservprotos='' d_getsbyname='' d_getsbyport='' d_gnulibc='' -i_arpainet='' d_htonl='' d_inetaton='' d_isascii='' @@ -431,6 +412,8 @@ d_portable='' d_pthread_yield='' d_sched_yield='' d_pthreads_created_joinable='' +i_pthread='' +i_machcthreads='' d_readdir='' d_rewinddir='' d_seekdir='' @@ -540,6 +523,7 @@ dlsrc='' ld='' lddlflags='' usedl='' +ebcdic='' doublesize='' fpostype='' gidtype='' @@ -548,6 +532,7 @@ h_fcntl='' h_sysfile='' db_hashtype='' db_prefixtype='' +i_arpainet='' i_db='' i_dbm='' i_rpcsvcdbm='' @@ -633,6 +618,7 @@ libpth='' loclibpth='' plibpth='' xlibpth='' +ignore_versioned_solibs='' libs='' lns='' lseektype='' @@ -697,11 +683,13 @@ randbits='' installscript='' scriptdir='' scriptdirexp='' +selectminbits='' selecttype='' sh='' sig_name='' sig_name_init='' sig_num='' +sig_num_init='' installsitearch='' sitearch='' sitearchexp='' @@ -719,6 +707,7 @@ startperl='' startsh='' stdchar='' sysman='' +trnl='' uidtype='' nm_opt='' nm_so_opt='' @@ -733,7 +722,6 @@ mips_type='' usrinc='' defvoidused='' voidflags='' -ebcdic='' CONFIG='' define='define' @@ -741,6 +729,12 @@ undef='undef' smallmach='pdp11 i8086 z8000 i80286 iAPX286' rmlist='' +installusrbinperl='' + +ccsymbols='' +cppsymbols='' +cppccsymbols='' + : We must find out about Eunice early eunicefix=':' if test -f /etc/unixtovms; then @@ -836,6 +830,8 @@ plibpth='' : default library list libswanted='' +: some systems want only to use the non-versioned libso:s +ignore_versioned_solibs='' : Possible local include directories to search. : Set locincpth to "" in a hint file to defeat local include searches. locincpth="/usr/local/include /opt/local/include /usr/gnu/include" @@ -904,8 +900,7 @@ case "$sh" in $me: Fatal Error: I can't find a Bourne Shell anywhere. Usually it's in /bin/sh. How did you even get this far? -Please contact me (Andy Dougherty) at doughera@lafayette.edu and -we'll try to straighten this all out. +Please contact perlbug@perl.com and we'll try to straighten this all out. EOM exit 1 ;; @@ -1240,7 +1235,7 @@ cat >extract <<'EOS' CONFIG=true echo "Doing variable substitutions on .SH files..." if test -f $src/MANIFEST; then - set x `awk '{print $1}' <$src/MANIFEST | grep '\.SH'` + set x `awk '{print $1}' <$src/MANIFEST | grep '\.SH$'` else echo "(Looking for .SH files under the source directory.)" set x `(cd $src; find . -name "*.SH" -print)` @@ -1373,7 +1368,7 @@ THIS PACKAGE SEEMS TO BE INCOMPLETE. You have the option of continuing the configuration process, despite the distinct possibility that your kit is damaged, by typing 'y'es. If you do, don't blame me if something goes wrong. I advise you to type 'n'o -and contact the author (doughera@lafayette.edu). +and then contact perlbug@perl.com. EOM echo $n "Continue? [n] $c" >&4 @@ -1396,6 +1391,30 @@ else fi rm -f missing x?? +echo " " +: Find the appropriate value for a newline for tr +if test -n "$DJGPP"; then + trnl='\012' +fi +if test X"$trnl" = X; then + case "`echo foo|tr '\n' x 2>/dev/null`" in + foox) trnl='\n' ;; + esac +fi +if test X"$trnl" = X; then + case "`echo foo|tr '\012' x 2>/dev/null`" in + foox) trnl='\012' ;; + esac +fi +if test X"$trnl" = X; then + cat <<EOM >&2 + +$me: Fatal Error: cannot figure out how to translate newlines with 'tr'. + +EOM + exit 1 +fi + : compute the number of columns on the terminal for proper question formatting case "$COLUMNS" in '') COLUMNS='80';; @@ -1574,7 +1593,7 @@ Much effort has been expended to ensure that this shell script will run on any Unix system. If despite that it blows up on yours, your best bet is to edit Configure and run it again. If you can't run Configure for some reason, you'll have to generate a config.sh file by hand. Whatever problems you -have, let me (doughera@lafayette.edu) know how I blew it. +have, let perlbug@perl.com know how I blew it. This installation script affects things in two ways: @@ -1841,14 +1860,14 @@ ABYZ) *C9D1*|*c9d1*) echo "Hey, this might be EBCDIC." >&4 if test "X$up" = X -o "X$low" = X; then - case "`echo IJ | tr '[A-IJ-RS-Z]' '[a-ij-rs-z]' 2>/dev/null`" in + case "`echo IJ | $tr '[A-IJ-RS-Z]' '[a-ij-rs-z]' 2>/dev/null`" in ij) up='[A-IJ-RS-Z]' low='[a-ij-rs-z]' ;; esac fi if test "X$up" = X -o "X$low" = X; then - case "`echo IJ | tr A-IJ-RS-Z a-ij-rs-z 2>/dev/null`" in + case "`echo IJ | $tr A-IJ-RS-Z a-ij-rs-z 2>/dev/null`" in ij) up='A-IJ-RS-Z' low='a-ij-rs-z' ;; @@ -1941,7 +1960,7 @@ EOM (cd $src/hints; ls -C *.sh) | $sed 's/\.sh/ /g' >&4 dflt='' : Half the following guesses are probably wrong... If you have better - : tests or hints, please send them to doughera@lafayette.edu + : tests or hints, please send them to perlbug@perl.com : The metaconfig authors would also appreciate a copy... $test -f /irix && osname=irix $test -f /xenix && osname=sco_xenix @@ -1968,6 +1987,12 @@ 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" if $test -f $uname; then set X $myuname shift @@ -1982,7 +2007,11 @@ EOM [23]100) osname=mips ;; next*) osname=next ;; i386*) - if $test -f /etc/kconfig; then + tmp=`/bin/uname -X 2>/dev/null|awk '/3\.2v[45]/{ print $(NF) }'` + if $test "$tmp" != "" -a "$3" = "3.2" -a -f '/etc/systemid'; then + osname='sco' + osvers=$tmp + elif $test -f /etc/kconfig; then osname=isc if test "$lns" = "ln -s"; then osvers=4 @@ -1992,6 +2021,7 @@ EOM osvers=2 fi fi + unset tmp ;; pc*) if test -n "$DJGPP"; then @@ -2025,7 +2055,7 @@ EOM osvers="$3" ;; dynixptx*) osname=dynixptx - osvers="$3" + osvers=`echo "$4" | $sed 's/^v//'` ;; freebsd) osname=freebsd osvers="$3" ;; @@ -2386,26 +2416,26 @@ cat <<EOM Perl can be built to take advantage of threads, on some systems. To do so, Configure must be run with -Dusethreads. -(See README.threads for details.) + +Note that threading is a highly experimental feature, and +some known race conditions still remain. If you choose to try +it, be very sure to not actually deploy it for production +purposes. README.threads has more details, and is required +reading if you enable threads. EOM case "$usethreads" in -$define|true|[yY]*) dflt='y';; +$define|true|[yY]*) dflt='y';; *) dflt='n';; 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 -: Look for a hint-file generated 'call-back-unit'. Now that the -: user has specified if a threading perl is to be built, we may need -: to set or change some other defaults. -if $test -f usethreads.cbu; then - . ./usethreads.cbu -fi + case "$d_oldpthreads" in '') : Configure tests would be welcome here. For now, assume undef. val="$undef" ;; @@ -2414,6 +2444,32 @@ esac set d_oldpthreads eval $setvar + +case "$usethreads" in +"$define"|true|[yY]*) +: Look for a hint-file generated 'call-back-unit'. If the +: user has specified that a threading perl is to be built, +: we may need to set or change some other defaults. + if $test -f usethreads.cbu; then + . ./usethreads.cbu + fi + case "$osname" in + aix|dec_osf|dos_djgpp|freebsd|hpux|irix|linux|next|openbsd|os2|solaris|vmesa) + # Known thread-capable platforms. + ;; + *) + cat >&4 <<EOM +$osname is not known to support threads. +Please let perlbug@perl.com know how to do that. + +Cannot continue, aborting. +EOM + exit 1 + ;; + esac # $osname + ;; +esac # $usethreads + : determine the architecture name echo " " if xxx=`./loc arch blurfl $pth`; $test -f "$xxx"; then @@ -3157,7 +3213,7 @@ fi case "$models" in '') $cat >pdp11.c <<'EOP' -main() { +int main() { #ifdef pdp11 exit(0); #else @@ -3442,7 +3498,11 @@ cat <<'EOT' >testcpp.c ABC.XYZ EOT cd .. +if test ! -f cppstdin; then echo 'cat >.$$.c; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' >cppstdin +else + echo "Keeping your $hint cppstdin wrapper." +fi chmod 755 cppstdin wrapper=`pwd`/cppstdin ok='false' @@ -3566,7 +3626,7 @@ false) esac case "$cppstdin" in -"$wrapper") ;; +"$wrapper"|'cppstdin') ;; *) $rm -f $wrapper;; esac $rm -f testcpp.c testcpp.out @@ -3693,7 +3753,8 @@ case "$libswanted" in esac for thislib in $libswanted; do - if xxx=`./loc lib$thislib.$so.[0-9]'*' X $libpth`; $test -f "$xxx"; then + if xxx=`./loc lib$thislib.$so.[0-9]'*' X $libpth`; + $test -f "$xxx" -a "X$ignore_versioned_solibs" = "X"; then echo "Found -l$thislib (shared)." case " $dflt " in *"-l$thislib "*);; @@ -3838,11 +3899,7 @@ if $xxx; then esac; fi' -if ./osf1; then - set signal.h __LANGUAGE_C__; eval $inctest -else - set signal.h LANGUAGE_C; eval $inctest -fi +set signal.h LANGUAGE_C; eval $inctest case "$hint" in none|recommended) dflt="$ccflags $dflt" ;; @@ -3980,10 +4037,21 @@ rmlist="$rmlist pdp11" : coherency check echo " " echo "Checking your choice of C compiler and flags for coherency..." >&4 +$cat > try.c <<'EOF' +#include <stdio.h> +int main() { printf("Ok\n"); exit(0); } +EOF set X $cc $optimize $ccflags -o try $ldflags try.c $libs shift -$cat >try.msg <<EOM -I've tried to compile and run a simple program with: +$cat >try.msg <<'EOM' +I've tried to compile and run the following simple program: + +EOM +$cat try.c >> try.msg + +$cat >> try.msg <<EOM + +I used the command: $* ./try @@ -3991,10 +4059,6 @@ I've tried to compile and run a simple program with: and I got the following output: EOM -$cat > try.c <<'EOF' -#include <stdio.h> -main() { printf("Ok\n"); exit(0); } -EOF dflt=y if sh -c "$cc $optimize $ccflags -o try $ldflags try.c $libs" >>try.msg 2>&1; then if sh -c './try' >>try.msg 2>&1; then @@ -4031,7 +4095,7 @@ y) $cat try.msg >&4 case "$knowitall" in '') - echo "(The supplied flags might be incorrect with this C compiler.)" + echo "(The supplied flags or libraries might be incorrect.)" ;; *) dflt=n;; esac @@ -4149,9 +4213,8 @@ eval $inhdr : determine which malloc to compile in echo " " case "$usemymalloc" in -''|y*|true) dflt='y' ;; -n*|false) dflt='n' ;; -*) dflt="$usemymalloc" ;; +''|[yY]*|true|$define) dflt='y' ;; +*) dflt='n' ;; esac rp="Do you wish to attempt to use the malloc that comes with $package?" . ./myread @@ -4227,7 +4290,7 @@ $rm -f malloc.[co] echo " " echo "Checking out function prototypes..." >&4 $cat >prototype.c <<'EOCP' -main(int argc, char *argv[]) { +int main(int argc, char *argv[]) { exit(0);} EOCP if $cc $ccflags -c prototype.c >prototype.out 2>&1 ; then @@ -4253,7 +4316,7 @@ understands function prototypes. Unfortunately, your C compiler $cc $ccflags doesn't seem to understand them. Sorry about that. -If GNU cc is avaiable for your system, perhaps you could try that instead. +If GNU cc is available for your system, perhaps you could try that instead. Eventually, we hope to support building Perl with pre-ANSI compilers. If you would like to help in that effort, please contact <perlbug@perl.org>. @@ -4296,6 +4359,29 @@ else installbin="$binexp" fi +echo " " +if test -d /usr/bin -a "X$installbin" != X/usr/bin; then + $cat <<EOM +Many scripts expect to perl to be installed as /usr/bin/perl. +I can install the perl you are about to compile also as /usr/bin/perl +(in addition to $installbin/perl). +EOM + case "$installusrbinperl" in + "$undef"|[nN]*) dflt='n';; + *) dflt='y';; + esac + rp="Do you want to install perl as /usr/bin/perl?" + . ./myread + case "$ans" in + [yY]*) val="$define";; + *) val="$undef" ;; + esac +else + val="$undef" +fi +set installusrbinperl +eval $setvar + : define a shorthand compile call compile=' mc_file=$1; @@ -4308,37 +4394,10 @@ shift; $cc $optimize $ccflags $ldflags -o ${mc_file} $* ${mc_file}.c $libs;' echo " " -echo "Determining whether or not we are on an EBCDIC system..." >&4 -cat >tebcdic.c <<EOM -int main() -{ - if ('M'==0xd4) return 0; - return 1; -} -EOM -val=$undef -set tebcdic -if eval $compile_ok; then - if ./tebcdic; then - echo "You have EBCDIC." >&4 - val="$define" - else - echo "Nope, no EBCDIC. Assuming ASCII or some ISO Latin." >&4 - fi -else - echo "I'm unable to compile the test program." >&4 - echo "I'll asuume ASCII or some ISO Latin." >&4 -fi -$rm -f tebcdic.c tebcdic -set ebcdic -eval $setvar - -echo " " echo "Checking for GNU C Library..." >&4 cat >gnulibc.c <<EOM #include <stdio.h> -int -main() +int main() { #ifdef __GLIBC__ exit(0); @@ -4664,6 +4723,10 @@ elif com="$sed -n -e 's/.*\.text n\ \ \ \.//p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun +elif com="sed -n -e 's/^__.*//' -e 's/[ ]*D[ ]*[0-9]*.*//p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun else $nm -p $* 2>/dev/null >libc.tmp $grep fprintf libc.tmp > libc.ptf @@ -4719,7 +4782,7 @@ nm_extract="$com" if $test -f /lib/syscalls.exp; then echo " " echo "Also extracting names from /lib/syscalls.exp for good ole AIX..." >&4 - $sed -n 's/^\([^ ]*\)[ ]*syscall$/\1/p' /lib/syscalls.exp >>libc.list + $sed -n 's/^\([^ ]*\)[ ]*syscall[0-9]*$/\1/p' /lib/syscalls.exp >>libc.list fi ;; esac @@ -4750,7 +4813,7 @@ yes) else tval=false; fi;; *) - echo "main() { extern short $1$tdc; printf(\"%hd\", $1$tc); }" > t.c; + echo "int main() { extern short $1$tdc; printf(\"%hd\", $1$tc); }" > t.c; if $cc $optimize $ccflags $ldflags -o t t.c $libs >/dev/null 2>&1; then tval=true; else tval=false; @@ -4899,7 +4962,7 @@ EOM /* Test for whether ELF binaries are produced */ #include <fcntl.h> #include <stdlib.h> -main() { +int main() { char b[4]; int i = open("a.out",O_RDONLY); if(i == -1) @@ -4944,6 +5007,7 @@ EOM linux|irix*) dflt='-shared' ;; next) dflt='none' ;; solaris) dflt='-G' ;; + beos) dflt='-nostart' ;; sunos) dflt='-assert nodefinitions' ;; svr4*|esix*) dflt="-G $ldflags" ;; *) dflt='none' ;; @@ -4953,6 +5017,10 @@ EOM esac : Try to guess additional flags to pick up local libraries. + : Be careful not to append to a plain 'none' + case "$dflt" in + none) dflt='' ;; + esac for thisflag in $ldflags; do case "$thisflag" in -L*) @@ -5016,7 +5084,7 @@ $undef) ;; *) case "$useshrplib" in '') case "$osname" in - svr4*|dgux|dynixptx|esix|powerux) + svr4*|dgux|dynixptx|esix|powerux|beos) dflt=y also='Building a shared libperl is required for dynamic loading to work on your system.' ;; @@ -5061,21 +5129,9 @@ EOM case "${osname}${osvers}" in next4*) xxx='DYLD_LIBRARY_PATH' ;; os2*) xxx='' ;; # Nothing special needed. + beos*) xxx='' ;; *) xxx='LD_LIBRARY_PATH' ;; esac - if test X"$xxx" != "X"; then - $cat <<EOM | $tee -a ../config.msg >&4 - -To build perl, you must add the current working directory to your -$xxx environment variable before running make. You can do -this with - $xxx=\`pwd\`; export $xxx -for Bourne-style shells, or - setenv $xxx \`pwd\` -for Csh-style shells. You *MUST* do this before running make. - -EOM - fi ;; *) useshrplib='false' ;; esac @@ -5147,7 +5203,7 @@ case "$shrpdir" in *) $cat >&4 <<EOM WARNING: Use of the shrpdir variable for the installation location of the shared $libperl is not supported. It was never documented and -will not work in this version. Let me (doughera@lafayette.edu) +will not work in this version. Let perlbug@perl.com know of any problems this may cause. EOM @@ -5193,6 +5249,9 @@ if "$useshrplib"; then next) # next doesn't like the default... ;; + beos) + # beos doesn't like the default, either. + ;; *) tmp_shrpenv="env LD_RUN_PATH=$shrpdir" ;; @@ -6034,8 +6093,7 @@ char *got; } } -int -main() +int main() { char buf[64]; buf[63] = '\0'; @@ -6121,7 +6179,7 @@ case "$d_access" in #ifdef I_UNISTD #include <unistd.h> #endif -main() { +int main() { exit(R_OK); } EOCP @@ -6197,7 +6255,7 @@ case "$d_getpgrp" in #ifdef I_UNISTD # include <unistd.h> #endif -main() +int main() { if (getuid() == 0) { printf("(I see you are running Configure as super-user...)\n"); @@ -6259,7 +6317,7 @@ case "$d_setpgrp" in #ifdef I_UNISTD # include <unistd.h> #endif -main() +int main() { if (getuid() == 0) { printf("(I see you are running Configure as super-user...)\n"); @@ -6317,7 +6375,7 @@ case "$intsize" in echo "Checking to see how big your integers are..." >&4 $cat >intsize.c <<'EOCP' #include <stdio.h> -main() +int main() { printf("intsize=%d;\n", sizeof(int)); printf("longsize=%d;\n", sizeof(long)); @@ -6413,7 +6471,7 @@ $cat >try.c <<EOCP #include <sys/types.h> #include <signal.h> $signal_t blech(s) int s; { exit(3); } -main() +int main() { $xxx i32; double f, g; @@ -6471,7 +6529,7 @@ $signal_t blech_in_list(s) int s; { exit(4); } unsigned long dummy_long(p) unsigned long p; { return p; } unsigned int dummy_int(p) unsigned int p; { return p; } unsigned short dummy_short(p) unsigned short p; { return p; } -main() +int main() { double f; unsigned long along; @@ -6563,7 +6621,7 @@ if set vprintf val -f d_vprintf; eval $csym; $val; then $cat >vprintf.c <<'EOF' #include <varargs.h> -main() { xxx("foo"); } +int main() { xxx("foo"); } xxx(va_alist) va_dcl @@ -6611,7 +6669,7 @@ echo " " echo 'Checking to see if your C compiler knows about "const"...' >&4 $cat >const.c <<'EOCP' typedef struct spug { int drokk; } spug; -main() +int main() { const char *foo; const spug y; @@ -6703,6 +6761,10 @@ eval $setvar set difftime d_difftime eval $inlibc +: see if sys/stat.h is available +set sys/stat.h i_sysstat +eval $inhdr + : see if this is a dirent system echo " " if xinc=`./findhdr dirent.h`; $test "$xinc"; then @@ -6771,6 +6833,23 @@ set d_dirnamlen eval $setvar $rm -f try.c +hasfield='varname=$1; struct=$2; field=$3; shift; shift; shift; +while $test $# -ge 2; do + case "$1" in + $define) echo "#include <$2>";; + esac ; + shift 2; +done > try.c; +echo "int main () { struct $struct foo; foo.$field = 0; }" >> try.c; +if eval $cc $optimize $ccflags -c try.c >/dev/null 2>&1; then + val="$define"; +else + val="$undef"; +fi; +set $varname; +eval $setvar; +$rm -f try.c try.o' + : see if dlerror exists xxx_runnm="$runnm" runnm=false @@ -6829,7 +6908,7 @@ $cat >fred.c<<EOM extern int fred() ; -main() +int main() { void * handle ; void * symbol ; @@ -6917,7 +6996,7 @@ $cat >open3.c <<'EOCP' #ifdef I_SYS_FILE #include <sys/file.h> #endif -main() { +int main() { if(O_RDONLY); #ifdef O_TRUNC exit(0); @@ -6973,7 +7052,7 @@ case "$o_nonblock" in '') $cat head.c > try.c $cat >>try.c <<'EOCP' -main() { +int main() { #ifdef O_NONBLOCK printf("O_NONBLOCK\n"); exit(0); @@ -7020,7 +7099,7 @@ extern int errno; $signal_t blech(x) int x; { exit(3); } EOCP $cat >> try.c <<'EOCP' -main() +int main() { int pd[2]; int pu[2]; @@ -7178,6 +7257,31 @@ eval $inlibc set gethostbyname d_gethbyname eval $inlibc +: see if this is a sys/param system +set sys/param.h i_sysparam +eval $inhdr + +: see if this is a sys/mount.h system +set sys/mount.h i_sysmount +eval $inhdr + +: see if fstatfs exists +set fstatfs d_fstatfs +eval $inlibc + +: see if statfs knows about mount flags +echo " " +set d_statfsflags statfs f_flags $i_sysparam sys/param.h $i_sysmount sys/mount.h +eval $hasfield + +: see if this is a sysstatvfs.h system +set sys/statvfs.h i_sysstatvfs +eval $inhdr + +: see if fstatvfs exists +set fstatvfs d_fstatvfs +eval $inlibc + : see if gethostent exists set gethostent d_gethent eval $inlibc @@ -7244,6 +7348,18 @@ eval $inlibc set getprotoent d_getpent eval $inlibc +: see if this is a mntent.h system +set mntent.h i_mntent +eval $inhdr + +: see if getmntent exists +set getmntent d_getmntent +eval $inlibc + +: see if hasmntopt exists +set hasmntopt d_hasmntopt +eval $inlibc + : see if getpgid exists set getpgid d_getpgid eval $inlibc @@ -7305,7 +7421,7 @@ esac set netinet/in.h i_niin sys/in.h i_sysin eval $inhdr -: see if this is an arpa/inet.h +: see if arpa/inet.h has to be included set arpa/inet.h i_arpainet eval $inhdr @@ -7411,7 +7527,7 @@ echo " " $cat >isascii.c <<'EOCP' #include <stdio.h> #include <ctype.h> -main() { +int main() { int c = 'A'; if (isascii(c)) exit(0); @@ -7501,7 +7617,7 @@ $define) $echo $n "Checking to see how big your long doubles are...$c" >&4 $cat >try.c <<'EOCP' #include <stdio.h> -main() +int main() { printf("%d\n", sizeof(long double)); } @@ -7518,6 +7634,9 @@ EOCP . ./myread longdblsize="$ans" fi + if $test "X$doublesize" = "X$longdblsize"; then + echo "(That isn't any different from an ordinary double.)" + fi ;; esac $rm -f try.c try @@ -7544,7 +7663,7 @@ $define) $echo $n "Checking to see how big your long longs are...$c" >&4 $cat >try.c <<'EOCP' #include <stdio.h> -main() +int main() { printf("%d\n", sizeof(long long)); } @@ -7561,6 +7680,9 @@ EOCP . ./myread longlongsize="$ans" fi + if $test "X$longsize" = "X$longlongsize"; then + echo "(That isn't any different from an ordinary long.)" + fi ;; esac $rm -f try.c try @@ -7635,7 +7757,7 @@ case "$osname" in freebsd) case "`ipcs 2>&1`" in "SVID messages"*"not configured"*) - echo "But your FreeBSD kernel does not have the msg*(2) configured." >&4 + echo "Your $osname does not have the msg*(2) configured." >&4 h_msg=false val="$undef" set msgctl d_msgctl @@ -7678,10 +7800,10 @@ set poll d_poll eval $inlibc -: see whether the various POSIXish _yields exist within given cccmd +: see whether the various POSIXish _yields exist $cat >try.c <<EOP #include <pthread.h> -main() { +int main() { YIELD(); exit(0); } @@ -7713,10 +7835,18 @@ set d_sched_yield eval $setvar $rm -f try try.* +: see if this is a pthread.h system +set pthread.h i_pthread +eval $inhdr + +: see if this is a mach/cthreads.h system +set mach/cthreads.h i_machcthreads +eval $inhdr + : test whether pthreads are created in joinable -- aka undetached -- state -if test "X$usethreads" = "X$define"; then +if test "X$usethreads" = "X$define" -a "X$i_pthread" = "X$define"; then echo $n "Checking whether pthreads are created joinable. $c" >&4 - $cat >try.c <<'EOCP' + $cat >try.c <<EOCP #include <pthread.h> #include <stdio.h> int main() { @@ -7930,7 +8060,7 @@ EOCP #ifdef I_UNISTD # include <unistd.h> /* Needed for NetBSD */ #endif -main() +int main() { char buf[128], abc[128]; char *b; @@ -8006,7 +8136,7 @@ EOCP #ifdef I_UNISTD # include <unistd.h> /* Needed for NetBSD */ #endif -main() +int main() { char buf[128], abc[128]; char *b; @@ -8084,7 +8214,7 @@ EOCP #ifdef I_UNISTD # include <unistd.h> /* Needed for NetBSD */ #endif -main() +int main() { char a = -1; char b = 0; @@ -8136,7 +8266,7 @@ case "$osname" in freebsd) case "`ipcs 2>&1`" in "SVID messages"*"not configured"*) - echo "But your FreeBSD kernel does not have the sem*(2) configured." >&4 + echo "Your $osname does not have the sem*(2) configured." >&4 h_sem=false val="$undef" set semctl d_semctl @@ -8185,6 +8315,31 @@ case "$d_sem" in $define) : see whether semctl IPC_STAT can use union semun echo " " + $cat > try.h <<END +#ifndef S_IRUSR +# ifdef S_IREAD +# define S_IRUSR S_IREAD +# define S_IWUSR S_IWRITE +# define S_IXUSR S_IEXEC +# else +# define S_IRUSR 0400 +# define S_IWUSR 0200 +# define S_IXUSR 0100 +# endif +# define S_IRGRP (S_IRUSR>>3) +# define S_IWGRP (S_IWUSR>>3) +# define S_IXGRP (S_IXUSR>>3) +# define S_IROTH (S_IRUSR>>6) +# define S_IWOTH (S_IWUSR>>6) +# define S_IXOTH (S_IXUSR>>6) +#endif +#ifndef S_IRWXU +# define S_IRWXU (S_IRUSR|S_IWUSR|S_IXUSR) +# define S_IRWXG (S_IRGRP|S_IWGRP|S_IXGRP) +# define S_IRWXO (S_IROTH|S_IWOTH|S_IXOTH) +#endif +END + $cat > try.c <<END #include <sys/types.h> #include <sys/ipc.h> @@ -8244,7 +8399,7 @@ END case "$d_semctl_semun" in $define) echo "You can use union semun for semctl IPC_STAT." >&4 - also='also' + also='also ' ;; *) echo "You cannot use union semun for semctl IPC_STAT." >&4 also='' @@ -8259,6 +8414,7 @@ END #include <sys/stat.h> #include <stdio.h> #include <errno.h> +#include "try.h" #ifndef errno extern int errno; #endif @@ -8300,11 +8456,12 @@ END eval $setvar case "$d_semctl_semid_ds" in $define) - echo "You can $also use struct semid_ds * for semctl IPC_STAT." >&4 + echo "You can ${also}use struct semid_ds* for semctl IPC_STAT." >&4 ;; - *) echo "You cannot use struct semid_ds * for semctl IPC_STAT." >&4 + *) echo "You cannot use struct semid_ds* for semctl IPC_STAT." >&4 ;; esac + $rm -f try.h ;; *) val="$undef" @@ -8499,7 +8656,7 @@ case "$osname" in freebsd) case "`ipcs 2>&1`" in "SVID shared memory"*"not configured"*) - echo "But your FreeBSD kernel does not have the shm*(2) configured." >&4 + echo "But your $osname does not have the shm*(2) configured." >&4 h_shm=false val="$undef" set shmctl d_shmctl @@ -8533,7 +8690,7 @@ if set sigaction val -f d_sigaction; eval $csym; $val; then #include <stdio.h> #include <sys/types.h> #include <signal.h> -main() +int main() { struct sigaction act, oact; } @@ -8560,7 +8717,7 @@ case "$d_sigsetjmp" in #include <setjmp.h> sigjmp_buf env; int set = 1; -main() +int main() { if (sigsetjmp(env,1)) exit(set); @@ -8619,26 +8776,32 @@ else d_oldsock="$undef" else echo "You don't have Berkeley networking in libc$_a..." >&4 - if test -f /usr/lib/libnet$_a; then - ( ($nm $nm_opt /usr/lib/libnet$_a | eval $nm_extract) || \ - $ar t /usr/lib/libnet$_a) 2>/dev/null >> libc.list - if $contains socket libc.list >/dev/null 2>&1; then - echo "...but the Wollongong group seems to have hacked it in." >&4 - socketlib="-lnet" - sockethdr="-I/usr/netinclude" - d_socket="$define" - if $contains setsockopt libc.list >/dev/null 2>&1; then - d_oldsock="$undef" - else - echo "...using the old 4.1c interface, rather than 4.2" >&4 - d_oldsock="$define" + for net in net socket + do + if test -f /usr/lib/lib$net$_a; then + ( ($nm $nm_opt /usr/lib/lib$net$_a | eval $nm_extract) || \ + $ar t /usr/lib/lib$net$_a) 2>/dev/null >> libc.list + if $contains socket libc.list >/dev/null 2>&1; then + d_socket="$define" + case "$net" in + net) + echo "...but the Wollongong group seems to have hacked it in." >&4 + socketlib="-lnet" + sockethdr="-I/usr/netinclude" + ;; + esac + echo "Found Berkeley sockets interface in lib$net." >& 4 + if $contains setsockopt libc.list >/dev/null 2>&1; then + d_oldsock="$undef" + else + echo "...using the old 4.1c interface, rather than 4.2" >&4 + d_oldsock="$define" + fi + break fi - else - echo "or even in libnet$_a, which is peculiar." >&4 - d_socket="$undef" - d_oldsock="$undef" fi - else + done + if test "X$d_socket" != "X$define"; then echo "or anywhere else I see." >&4 d_socket="$undef" d_oldsock="$undef" @@ -8652,21 +8815,8 @@ eval $inlibc : see if stat knows about block sizes echo " " -xxx=`./findhdr sys/stat.h` -if $contains 'st_blocks;' "$xxx" >/dev/null 2>&1 ; then - if $contains 'st_blksize;' "$xxx" >/dev/null 2>&1 ; then - echo "Your stat() knows about block sizes." >&4 - val="$define" - else - echo "Your stat() doesn't know about block sizes." >&4 - val="$undef" - fi -else - echo "Your stat() doesn't know about block sizes." >&4 - val="$undef" -fi -set d_statblks -eval $setvar +set d_statblks stat st_blocks $i_sysstat sys/stat.h +eval $hasfield : see if _ptr and _cnt from stdio act std echo " " @@ -8716,7 +8866,7 @@ $cat >try.c <<EOP #include <stdio.h> #define FILE_ptr(fp) $stdio_ptr #define FILE_cnt(fp) $stdio_cnt -main() { +int main() { FILE *fp = fopen("try.c", "r"); char c = getc(fp); if ( @@ -8767,7 +8917,7 @@ $define) #include <stdio.h> #define FILE_base(fp) $stdio_base #define FILE_bufsiz(fp) $stdio_bufsiz -main() { +int main() { FILE *fp = fopen("try.c", "r"); char c = getc(fp); if ( @@ -8803,7 +8953,7 @@ eval $inlibc echo " " echo "Checking to see if your C compiler can copy structs..." >&4 $cat >try.c <<'EOCP' -main() +int main() { struct blurfl { int dyick; @@ -9056,7 +9206,16 @@ $define) false) dflt='n';; *) dflt='y';; esac - rp="Some systems have problems with vfork(). Do you want to use it?" + cat <<'EOM' + +Perl can only use a vfork() that doesn't suffer from strict +restrictions on calling functions or modifying global data in +the child. For example, glibc-2.1 contains such a vfork() +that is unsuitable. If your system provides a proper fork() +call, chances are that you do NOT want perl to use vfork(). + +EOM + rp="Do you still want to use vfork()?" . ./myread case "$ans" in y|Y) ;; @@ -9148,7 +9307,7 @@ $rm -f closedir* echo " " echo 'Checking to see if your C compiler knows about "volatile"...' >&4 $cat >try.c <<'EOCP' -main() +int main() { typedef struct _goo_struct goo_struct; goo_struct * volatile goo = ((goo_struct *)0); @@ -9207,7 +9366,7 @@ struct foobar { char foo; double bar; } try; -main() +int main() { printf("%d\n", (char *)&try.bar - (char *)&try.foo); } @@ -9242,7 +9401,7 @@ I'm now running the test program... EOM $cat >try.c <<'EOCP' #include <stdio.h> -main() +int main() { int i; union { @@ -9337,7 +9496,7 @@ $define) #include <sys/types.h> #include <stdio.h> #include <db.h> -main() +int main() { #ifdef DB_VERSION_MAJOR /* DB version >= 2 */ int Major, Minor, Patch ; @@ -9420,7 +9579,7 @@ size_t size; { } HASHINFO info; -main() +int main() { info.hash = hash_cb; } @@ -9465,7 +9624,7 @@ const DBT *key2; { } BTREEINFO info; -main() +int main() { info.prefix = prefix_cb; } @@ -9518,7 +9677,7 @@ sub() { #endif exit(0); } -main() { sub(); } +int main() { sub(); } EOCP if $cc $ccflags -c -DTRY=$defvoidused try.c >.out 2>&1 ; then voidflags=$defvoidused @@ -9590,7 +9749,7 @@ case "$doublesize" in $echo $n "Checking to see how big your double precision numbers are...$c" >&4 $cat >try.c <<'EOCP' #include <stdio.h> -main() +int main() { printf("%d\n", sizeof(double)); } @@ -9610,6 +9769,32 @@ EOCP esac $rm -f try.c try +echo " " +echo "Determining whether or not we are on an EBCDIC system..." >&4 +$cat >tebcdic.c <<EOM +int main() +{ + if ('M'==0xd4) return 0; + return 1; +} +EOM +val=$undef +set tebcdic +if eval $compile_ok; then + if ./tebcdic; then + echo "You have EBCDIC." >&4 + val="$define" + else + echo "Nope, no EBCDIC. Assuming ASCII or some ISO Latin." >&4 + fi +else + echo "I'm unable to compile the test program." >&4 + echo "I'll assume ASCII or some ISO Latin." >&4 +fi +$rm -f tebcdic.c tebcdic +set ebcdic +eval $setvar + : see what type file positions are declared as in the library rp="What is the type for file position used by fsetpos()?" set fpos_t fpostype long stdio.h sys/types.h @@ -9630,6 +9815,12 @@ esac : Store the full pathname to the sed program for use in the C program full_sed=$sed +: Store the full pathname to the ar program for use in the Makefile.SH +: Respect a hint or command line value for full_ar. +case "$full_ar" in +'') full_ar=$ar ;; +esac + : see what type gids are declared as in the kernel echo " " echo "Looking for the type for group ids returned by getgid()." @@ -9928,7 +10119,7 @@ case "$ptrsize" in fi $cat >>try.c <<'EOCP' #include <stdio.h> -main() +int main() { printf("%d\n", sizeof(VOID_PTR)); exit(0); @@ -9966,7 +10157,7 @@ case "$randbits" in #endif EOCP $cat >>try.c <<'EOCP' -main() +int main() { register int i; register unsigned long tmp; @@ -10004,7 +10195,7 @@ echo "Checking how to generate random libraries on your machine..." >&4 echo 'int bar1() { return bar2(); }' > bar1.c echo 'int bar2() { return 2; }' > bar2.c $cat > foo.c <<'EOP' -main() { printf("%d\n", bar1()); exit(0); } +int main() { printf("%d\n", bar1()); exit(0); } EOP $cc $ccflags -c bar1.c >/dev/null 2>&1 $cc $ccflags -c bar2.c >/dev/null 2>&1 @@ -10064,7 +10255,7 @@ if test "X$timeincl" = X; then #ifdef I_SYSSELECT #include <sys/select.h> #endif -main() +int main() { struct tm foo; #ifdef S_TIMEVAL @@ -10148,7 +10339,7 @@ $cat >fd_set.c <<EOCP #ifdef I_SYS_SELECT #include <sys/select.h> #endif -main() { +int main() { fd_set fds; #ifdef TRYBITS @@ -10217,8 +10408,10 @@ EOM : The first arg can be int, unsigned, or size_t : The last arg may or may not be 'const' val='' + : void pointer has been seen but using that + : breaks the selectminbits test for xxx in 'fd_set *' 'int *'; do - for nfd in 'int' 'size_t' 'unsigned' ; do + for nfd in 'int' 'size_t' 'unsigned' 'unsigned long'; do for tmo in 'struct timeval *' 'const struct timeval *'; do case "$val" in '') try="extern select _(($nfd, $xxx, $xxx, $xxx, $tmo));" @@ -10250,6 +10443,100 @@ EOM ;; esac +: check for the select 'width' +case "$selectminbits" in +'') case "$d_select" in + $define) + $cat <<EOM + +Checking to see on how many bits at a time your select() operates... +EOM + $cat >try.c <<EOCP +#include <sys/types.h> +#$i_time I_TIME +#$i_systime I_SYS_TIME +#$i_systimek I_SYS_TIME_KERNEL +#ifdef I_TIME +# include <time.h> +#endif +#ifdef I_SYS_TIME +# ifdef I_SYS_TIME_KERNEL +# define KERNEL +# endif +# include <sys/time.h> +# ifdef I_SYS_TIME_KERNEL +# undef KERNEL +# endif +#endif +#$i_sysselct I_SYS_SELECT +#ifdef I_SYS_SELECT +#include <sys/select.h> +#endif +#include <stdio.h> +$selecttype b; +#define S sizeof(*(b)) +#define MINBITS 64 +#define NBYTES (S * 8 > MINBITS ? S : MINBITS/8) +#define NBITS (NBYTES * 8) +int main() { + char s[NBYTES]; + struct timeval t; + int i; + FILE* fp; + int fd; + + fclose(stdin); + fp = fopen("try.c", "r"); + if (fp == 0) + exit(1); + fd = fileno(fp); + if (fd < 0) + exit(2); + b = ($selecttype)s; + for (i = 0; i < NBITS; i++) + FD_SET(i, b); + t.tv_sec = 0; + t.tv_usec = 0; + select(fd + 1, b, 0, 0, &t); + for (i = NBITS - 1; i > fd && FD_ISSET(i, b); i--); + printf("%d\n", i + 1); + return 0; +} +EOCP + set try + if eval $compile_ok; then + selectminbits=`./try` + case "$selectminbits" in + '') cat >&4 <<EOM +Cannot figure out on how many bits at a time your select() operates. +I'll play safe and guess it is 32 bits. +EOM + selectminbits=32 + bits="32 bits" + ;; + 1) bits="1 bit" ;; + *) bits="$selectminbits bits" ;; + esac + echo "Your select() operates on $bits at a time." >&4 + else + rp='What is the minimum number of bits your select() operates on?' + case "$byteorder" in + 1234|12345678) dflt=32 ;; + *) dflt=1 ;; + esac + . ./myread + val=$ans + selectminbits="$val" + fi + $rm -f try.* try + ;; + *) : no select, so pick a harmless default + selectminbits='32' + ;; + esac + ;; +esac + : Trace out the files included by signal.h, then look for SIGxxx names. : Remove SIGARRAYSIZE used by HPUX. : Remove SIGTYP void lines used by OS2. @@ -10458,7 +10745,13 @@ $eunicefix signal_cmd : generate list of signal names echo " " case "$sig_name_init" in -'') +'') doinit=yes ;; +*) case "$sig_num_init" in + ''|*,*) doinit=yes ;; + esac ;; +esac +case "$doinit" in +yes) echo "Generating a list of signal names and numbers..." >&4 . ./signal_cmd sig_name=`$awk '{printf "%s ", $1}' signal.lst` @@ -10466,7 +10759,9 @@ case "$sig_name_init" in sig_name_init=`$awk 'BEGIN { printf "\"ZERO\", " } { printf "\"%s\", ", $1 } END { printf "0\n" }' signal.lst` - sig_num=`$awk 'BEGIN { printf "0, " } + sig_num=`$awk '{printf "%d ", $2}' signal.lst` + sig_num="0 $sig_num" + sig_num_init=`$awk 'BEGIN { printf "0, " } { printf "%d, ", $2} END { printf "0\n"}' signal.lst` ;; @@ -10498,7 +10793,7 @@ $cat > ssize.c <<EOM #include <sys/types.h> #define Size_t $sizetype #define SSize_t $dflt -main() +int main() { if (sizeof(Size_t) == sizeof(SSize_t)) printf("$dflt\n"); @@ -10814,12 +11109,16 @@ $eunicefix Cppsym ./Cppsym -l $al | $sort | $grep -v '^$' >Cppsym.true : now check the C compiler for additional symbols +postprocess_cc_v='' +case "$osname" in +aix) postprocess_cc_v="|$tr , ' '" ;; +esac $cat >ccsym <<EOS $startsh $cat >tmp.c <<EOF extern int foo; EOF -for i in \`$cc -v -c tmp.c 2>&1\` +for i in \`$cc -v -c tmp.c 2>&1 $postprocess_cc_v\` do case "\$i" in -D*) echo "\$i" | $sed 's/^-D//';; @@ -10828,9 +11127,16 @@ do done $rm -f try.c EOS +unset postprocess_cc_v chmod +x ccsym $eunicefix ccsym -./ccsym | $sort | $uniq >ccsym.raw +./ccsym > ccsym1.raw +if $test -s ccsym1.raw; then + $sort ccsym1.raw | $uniq >ccsym.raw +else + mv ccsym1.raw ccsym.raw +fi + $awk '/\=/ { print $0; next } { print $0"=1" }' ccsym.raw >ccsym.list $awk '{ print $0"=1" }' Cppsym.true >ccsym.true @@ -10838,12 +11144,15 @@ $comm -13 ccsym.true ccsym.list >ccsym.own $comm -12 ccsym.true ccsym.list >ccsym.com $comm -23 ccsym.true ccsym.list >ccsym.cpp also='' -symbols='symbols' if $test -z ccsym.raw; then echo "Your C compiler doesn't seem to define any symbol!" >&4 echo " " echo "However, your C preprocessor defines the following ones:" $cat Cppsym.true + ccsymbols='' + cppsymbols=`$cat Cppsym.true` + cppsymbols=`echo $cppsymbols` + cppccsymbols="$cppsymbols" else if $test -s ccsym.com; then echo "Your C compiler and pre-processor define these symbols:" @@ -10851,20 +11160,26 @@ else also='also ' symbols='ones' $test "$silent" || sleep 1 + cppccsymbols=`$cat ccsym.com` + cppccsymbols=`echo $cppccsymbols` fi if $test -s ccsym.cpp; then $test "$also" && echo " " - echo "Your C pre-processor ${also}defines the following $symbols:" + echo "Your C pre-processor ${also}defines the following symbols:" $sed -e 's/\(.*\)=.*/\1/' ccsym.cpp also='further ' $test "$silent" || sleep 1 + cppsymbols=`$cat ccsym.cpp` + cppsymbols=`echo $cppsymbols` fi if $test -s ccsym.own; then $test "$also" && echo " " - echo "Your C compiler ${also}defines the following cpp variables:" + echo "Your C compiler ${also}defines the following cpp symbols:" $sed -e 's/\(.*\)=1/\1/' ccsym.own $sed -e 's/\(.*\)=.*/\1/' ccsym.own | $uniq >>Cppsym.true $test "$silent" || sleep 1 + ccsymbols=`$cat ccsym.own` + ccsymbols=`echo $ccsymbols` fi fi $rm -f ccsym* @@ -11047,18 +11362,10 @@ fi set i_sysioctl eval $setvar -: see if this is a sys/param system -set sys/param.h i_sysparam -eval $inhdr - : see if sys/resource.h has to be included set sys/resource.h i_sysresrc eval $inhdr -: see if sys/stat.h is available -set sys/stat.h i_sysstat -eval $inhdr - : see if this is a sys/un.h system set sys/un.h i_sysun eval $inhdr @@ -11195,6 +11502,7 @@ for xxx in $known_extensions ; do esac ;; IPC/SysV|ipc/sysv) + : XXX Do we need a useipcsysv variable here case "${d_msg}${d_sem}${d_shm}" in *"${define}"*) avail_ext="$avail_ext $xxx" ;; esac @@ -11441,6 +11749,7 @@ cc='$cc' cccdlflags='$cccdlflags' ccdlflags='$ccdlflags' ccflags='$ccflags' +ccsymbols='$ccsymbols' cf_by='$cf_by' cf_email='$cf_email' cf_time='$cf_time' @@ -11460,6 +11769,8 @@ cpplast='$cpplast' cppminus='$cppminus' cpprun='$cpprun' cppstdin='$cppstdin' +cppsymbols='$cppsymbols' +cppccsymbols='$cppccsymbols' cryptlib='$cryptlib' csh='$csh' d_Gconvert='$d_Gconvert' @@ -11512,6 +11823,11 @@ d_flock='$d_flock' d_fork='$d_fork' d_fpathconf='$d_fpathconf' d_fsetpos='$d_fsetpos' +d_fstatfs='$d_fstatfs' +d_statfsflags='$d_statfsflags' +d_fstatvfs='$d_fstatvfs' +d_getmntent='$d_getmntent' +d_hasmntopt='$d_hasmntopt' d_ftime='$d_ftime' d_getgrent='$d_getgrent' d_getgrps='$d_getgrps' @@ -11706,6 +12022,7 @@ firstmakefile='$firstmakefile' flex='$flex' fpostype='$fpostype' freetype='$freetype' +full_ar='$full_ar' full_csh='$full_csh' full_sed='$full_sed' gccversion='$gccversion' @@ -11734,13 +12051,16 @@ i_grp='$i_grp' i_limits='$i_limits' i_locale='$i_locale' i_malloc='$i_malloc' +i_machcthreads='$i_machcthreads' i_math='$i_math' i_memory='$i_memory' +i_mntent='$i_mntent' i_ndbm='$i_ndbm' i_netdb='$i_netdb' i_neterrno='$i_neterrno' i_niin='$i_niin' i_pwd='$i_pwd' +i_pthread='$i_pthread' i_rpcsvcdbm='$i_rpcsvcdbm' i_sfio='$i_sfio' i_sgtty='$i_sgtty' @@ -11753,12 +12073,14 @@ i_sysfile='$i_sysfile' i_sysfilio='$i_sysfilio' i_sysin='$i_sysin' i_sysioctl='$i_sysioctl' +i_sysmount='$i_sysmount' i_sysndir='$i_sysndir' i_sysparam='$i_sysparam' i_sysresrc='$i_sysresrc' i_sysselct='$i_sysselct' i_syssockio='$i_syssockio' i_sysstat='$i_sysstat' +i_sysstatvfs='$i_sysstatvfs' i_systime='$i_systime' i_systimek='$i_systimek' i_systimes='$i_systimes' @@ -11774,6 +12096,7 @@ i_values='$i_values' i_varargs='$i_varargs' i_varhdr='$i_varhdr' i_vfork='$i_vfork' +ignore_versioned_solibs='$ignore_versioned_solibs' incpath='$incpath' inews='$inews' installarchlib='$installarchlib' @@ -11784,6 +12107,7 @@ installprivlib='$installprivlib' installscript='$installscript' installsitearch='$installsitearch' installsitelib='$installsitelib' +installusrbinperl='$installusrbinperl' intsize='$intsize' known_extensions='$known_extensions' ksh='$ksh' @@ -11882,6 +12206,7 @@ runnm='$runnm' scriptdir='$scriptdir' scriptdirexp='$scriptdirexp' sed='$sed' +selectminbits='$selectminbits' selecttype='$selecttype' sendmail='$sendmail' sh='$sh' @@ -11894,6 +12219,7 @@ shsharp='$shsharp' sig_name='$sig_name' sig_name_init='$sig_name_init' sig_num='$sig_num' +sig_num_init='$sig_num_init' signal_t='$signal_t' sitearch='$sitearch' sitearchexp='$sitearchexp' @@ -12023,51 +12349,6 @@ esac : if this fails, just run all the .SH files by hand . ./config.sh -case "$ebcdic" in -$define) - xxx='' - echo "This is an EBCDIC system, checking if any parser files need regenerating." >&4 - rm -f y.tab.c y.tab.h - yacc -d perly.y >/dev/null 2>&1 - if cmp -s y.tab.c perly.c; then - rm -f y.tab.c - else - echo "perly.y -> perly.c" >&4 - mv -f y.tab.c perly.c - chmod u+w perly.c - sed -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' \ - -e 's/y\.tab/perly/g' perly.c >perly.tmp && mv perly.tmp perly.c - xxx="$xxx perly.c" - fi - if cmp -s y.tab.h perly.h; then - rm -f y.tab.h - else - echo "perly.y -> perly.h" >&4 - mv -f y.tab.h perly.h - xxx="$xxx perly.h" - fi - echo "x2p/a2p.y" >&4 - cd x2p - rm -f y.tab.c - yacc a2p.y >/dev/null 2>&1 - if cmp -s y.tab.c a2p.c - then - rm -f y.tab.c - else - echo "a2p.y -> a2p.c" >&4 - mv -f y.tab.c a2p.c - chmod u+w a2p.c - sed -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' \ - -e 's/y\.tab/a2p/g' a2p.c >a2p.tmp && mv a2p.tmp a2p.c - xxx="$xxx a2p.c" - fi - cd .. - case "$xxx" in - '') echo "No parser files were regenerated. That's okay." >&4 ;; - esac - ;; -esac - echo " " exec 1>&4 . ./UU/extract diff --git a/contrib/perl5/Copying b/contrib/perl5/Copying index 3c68f02..43cd72c 100644 --- a/contrib/perl5/Copying +++ b/contrib/perl5/Copying @@ -2,7 +2,7 @@ Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. - 675 Mass Ave, Cambridge, MA 02139, USA + 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. @@ -215,8 +215,8 @@ the exclusion of warranty; and each file should have at least the GNU General Public License for more details. You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + along with this program; if not, write to the Free Software Foundation, + Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA. Also add information on how to contact you by electronic and paper mail. diff --git a/contrib/perl5/EXTERN.h b/contrib/perl5/EXTERN.h index 19f6db8..66aeb9f 100644 --- a/contrib/perl5/EXTERN.h +++ b/contrib/perl5/EXTERN.h @@ -1,6 +1,6 @@ /* EXTERN.h * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. diff --git a/contrib/perl5/INSTALL b/contrib/perl5/INSTALL index a892e7d..c5e04cb 100644 --- a/contrib/perl5/INSTALL +++ b/contrib/perl5/INSTALL @@ -64,6 +64,23 @@ In a related issue, old extensions may possibly be affected by the changes in the Perl language in the current release. Please see pod/perldelta.pod for a description of what's changed. +=head1 WARNING: This version requires a compiler that supports ANSI C. + +If you find that your C compiler is not ANSI-capable, try obtaining +GCC, available from GNU mirrors worldwide (e.g. ftp://ftp.gnu.org/pub/gnu). +Another alternative may be to use a tool like C<ansi2knr> to convert the +sources back to K&R style, but there is no guarantee this route will get +you anywhere, since the prototypes are not the only ANSI features used +in the Perl sources. C<ansi2knr> is usually found as part of the freely +available C<Ghostscript> distribution. Another similar tool is +C<unprotoize>, distributed with GCC. Since C<unprotoize> requires GCC to +run, you may have to run it on a platform where GCC is available, and move +the sources back to the platform without GCC. + +If you succeed in automatically converting the sources to a K&R compatible +form, be sure to email perlbug@perl.com to let us know the steps you +followed. This will enable us to officially support this option. + =head1 Space Requirements The complete perl5 source tree takes up about 10 MB of disk space. The @@ -167,6 +184,9 @@ put (symlinks to) perl and its accompanying utilities, such as perldoc, into a directory typically found along a user's PATH, or in another obvious and convenient place. +You can use "Configure -Uinstallusrbinperl" which causes installperl +to skip installing perl also as /usr/bin/perl. + By default, Configure will compile perl to use dynamic loading if your system supports it. If you want to force perl to be compiled statically, you can either choose this when Configure prompts you or @@ -472,23 +492,26 @@ that problem. If you need to install perl on many identical systems, it is convenient to compile it once and create an archive that can be -installed on multiple systems. Here's one way to do that: +installed on multiple systems. Suppose, for example, that you want to +create an archive that can be installed in /opt/perl. +Here's one way to do that: # Set up config.over to install perl into a different directory, # e.g. /tmp/perl5 (see previous part). - sh Configure -des + sh Configure -Dprefix=/opt/perl -des make make test - make install + make install # This will install everything into /tmp/perl5. cd /tmp/perl5 - # Edit $archlib/Config.pm to change all the + # Edit $archlib/Config.pm and $archlib/.packlist to change all the # install* variables back to reflect where everything will - # really be installed. - # Edit any of the scripts in $scriptdir to have the correct + # really be installed. (That is, change /tmp/perl5 to /opt/perl + # everywhere in those files.) + # Check the scripts in $scriptdir to make sure they have the correct # #!/wherever/perl line. tar cvf ../perl5-archive.tar . # Then, on each machine where you want to install perl, - cd /usr/local # Or wherever you specified as $prefix + cd /opt/perl # Or wherever you specified as $prefix tar xvf perl5-archive.tar =head2 Site-wide Policy settings @@ -518,8 +541,9 @@ some of the main things you can change. =head2 Threads -On some platforms, perl5.005 can be compiled to use threads. To -enable this, read the file README.threads, and then try +On some platforms, perl5.005 can be compiled with experimental support +for threads. To enable this, read the file README.threads, and then +try: sh Configure -Dusethreads @@ -653,9 +677,24 @@ You can elect to build a shared libperl by sh Configure -Duseshrplib -To actually build perl, you must add the current working directory to your -LD_LIBRARY_PATH environment variable before running make. You can do -this with +To build a shared libperl, the environment variable controlling shared +library search (LD_LIBRARY_PATH in most systems, DYLD_LIBRARY_PATH for +NeXTSTEP/OPENSTEP, LIBRARY_PATH for BeOS) 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. + +However, there are some special cases where manually setting the +shared library path might be required. For example, if you want to run +something like the following with the newly-built but not-yet-installed +./perl: + + cd t; ./perl misc/failing_test.t +or + ./perl -Ilib ~/my_mission_critical_test + +then you need to set up the shared library path explicitly. +You can do this with LD_LIBRARY_PATH=`pwd`:$LD_LIBRARY_PATH; export LD_LIBRARY_PATH @@ -663,9 +702,13 @@ for Bourne-style shells, or setenv LD_LIBRARY_PATH `pwd` -for Csh-style shells. You *MUST* do this before running make. -Folks running NeXT OPENSTEP must substitute DYLD_LIBRARY_PATH for -LD_LIBRARY_PATH above. +for Csh-style shells. (This procedure may also be needed if for some +unexpected reason Configure fails to set up Makefile correctly.) + +You can often recognize failures to build/use a shared libperl from error +messages complaining about a missing libperl.so (or libperl.sl in HP-UX), +for example: +18126:./miniperl: /sbin/loader: Fatal Error: cannot map libperl.so There is also an potential problem with the shared perl library if you want to have more than one "flavor" of the same version of perl (e.g. @@ -771,21 +814,6 @@ you can change a number of factors in the way perl is built by adding appropriate -D directives to your ccflags variable in config.sh. -For example, you can replace the rand() and srand() functions in the -perl source by any other random number generator by a trick such as the -following (this should all be on one line): - - sh Configure -Dccflags='-Dmy_rand=random -Dmy_srand=srandom' \ - -Drandbits=31 - -or you can use the drand48 family of functions with - - sh Configure -Dccflags='-Dmy_rand=lrand48 -Dmy_srand=srand48' \ - -Drandbits=31 - -or by adding the -D flags to your ccflags at the appropriate Configure -prompt. (Read pp.c to see how this works.) - You should also run Configure interactively to verify that a hint file doesn't inadvertently override your ccflags setting. (Hints files shouldn't do that, but some might.) @@ -920,6 +948,42 @@ to config.h and edit the config.h to reflect your system's peculiarities. You'll probably also have to extensively modify the extension building mechanism. +=item Environment variable clashes + +Configure uses a CONFIG variable that is reported to cause trouble on +ReliantUnix 5.44. If your system sets this variable, you can try +unsetting it before you run Configure. Configure should eventually +be fixed to avoid polluting the namespace of the environment. + +=item Digital UNIX/Tru64 UNIX and BIN_SH + +In Digital UNIX/Tru64 UNIX Configure might abort with + +Build a threading Perl? [n] +Configure[2437]: Syntax error at line 1 : `config.sh' is not expected. + +This indicates that Configure is being run with a broken Korn shell +(even though you think you are using a Bourne shell by using +"sh Configure" or "./Configure"). The Korn shell bug has been reported +to Compaq as of February 1999 but in the meanwhile, the reason ksh is +being used is that you have the environment variable BIN_SH set to +'xpg4'. This causes /bin/sh to delegate its duties to /bin/posix/sh +(a ksh). Unset the environment variable and rerun Configure. + +=item HP-UX 11, pthreads, and libgdbm + +If you are running Configure with -Dusethreads in HP-UX 11, be warned +that POSIX threads and libgdbm (the GNU dbm library) compiled before +HP-UX 11 do not mix. This will cause a basic test run by Configure to +fail + +Pthread internal error: message: __libc_reinit() failed, file: ../pthreads/pthread.c, line: 1096 +Return Pointer is 0xc082bf33 +sh: 5345 Quit(coredump) + +and Configure will give up. The cure is to recompile and install +libgdbm under HP-UX 11. + =item Porting information Specific information for the OS/2, Plan9, VMS and Win32 ports is in the @@ -1218,6 +1282,17 @@ ones (which ones these are depends on your system and applications) with "ipcrm -s SEMAPHORE_ID_HERE" or configure more semaphores to your system. +=item GNU binutils + +If you mix GNU binutils (nm, ld, ar) with equivalent vendor-supplied +tools you may be in for some trouble. For example creating archives +with an old GNU 'ar' and then using a new current vendor-supplied 'ld' +may lead into linking problems. Either recompile your GNU binutils +under your current operating system release, or modify your PATH not +to include the GNU utils before running Configure, or specify the +vendor-supplied utilities explicitly to Configure, for example by +Configure -Dar=/bin/ar. + =item Miscellaneous Some additional things that have been reported for either perl4 or perl5: @@ -1236,6 +1311,12 @@ If you get syntax errors on '(', try -DCRIPPLED_CC. Machines with half-implemented dbm routines will need to #undef I_ODBM +HP-UX 11 Y2K patch "Y2K-1100 B.11.00.B0125 HP-UX Core OS Year 2000 +Patch Bundle" has been reported to break the io/fs test #18 which +tests whether utime() can change timestamps. The Y2K patch seems to +break utime() so that over NFS the timestamps do not get changed +(on local filesystems utime() still works). + =back =head1 make test diff --git a/contrib/perl5/INTERN.h b/contrib/perl5/INTERN.h index 6ce0367..118e47c 100644 --- a/contrib/perl5/INTERN.h +++ b/contrib/perl5/INTERN.h @@ -1,6 +1,6 @@ /* INTERN.h * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. diff --git a/contrib/perl5/MANIFEST b/contrib/perl5/MANIFEST index 1d6b3a8..f42a832 100644 --- a/contrib/perl5/MANIFEST +++ b/contrib/perl5/MANIFEST @@ -29,9 +29,13 @@ Porting/patchls Flexible patch file listing utility Porting/pumpkin.pod Guidelines and hints for Perl maintainers README The Instructions README.amiga Notes about AmigaOS port +README.apollo Notes about Apollo DomainOS port README.beos Notes about BeOS port README.cygwin32 Notes about Cygwin32 port README.dos Notes about dos/djgpp port +README.hpux Notes about HP-UX port +README.hurd Notes about GNU/Hurd port +README.mint Notes about Atari MiNT port README.mpeix Notes about MPE/iX port README.os2 Notes about OS/2 port README.os390 Notes about OS/390 (nee MVS) port @@ -39,11 +43,13 @@ README.plan9 Notes about Plan9 port README.qnx Notes about QNX port README.threads Notes about multithreading README.vms Notes about VMS port +README.vos Notes about Stratus VOS port README.win32 Notes about Win32 port Todo The Wishlist Todo-5.005 What needs doing before 5.005 release XSlock.h Include file for extensions built with PERL_OBJECT defined XSUB.h Include file for extension subroutines +apollo/netinet/in.h Apollo DomainOS port: C header file frontend av.c Array value code av.h Array value header beos/nm.c BeOS port @@ -65,8 +71,8 @@ cygwin32/ld2 Cygwin32 port cygwin32/perlgcc Cygwin32 port cygwin32/perlld Cygwin32 port deb.c Debugging routines -djgpp/config.over DOS/DJGPP port -djgpp/configure.bat DOS/DJGPP port +djgpp/config.over DOS/DJGPP port +djgpp/configure.bat DOS/DJGPP port djgpp/djgpp.c DOS/DJGPP port djgpp/djgppsed.sh DOS/DJGPP port djgpp/fixpmain DOS/DJGPP port @@ -185,6 +191,7 @@ ext/DB_File/DB_File.xs Berkeley DB extension external subroutines ext/DB_File/DB_File_BS Berkeley DB extension mkbootstrap fodder ext/DB_File/Makefile.PL Berkeley DB extension makefile writer ext/DB_File/dbinfo Berkeley DB database version checker +ext/DB_File/hints/dynixptx.pl Hints for DB_File for named architecture ext/DB_File/typemap Berkeley DB extension interface types ext/Data/Dumper/Changes Data pretty printer, changelog ext/Data/Dumper/Dumper.pm Data pretty printer, module @@ -195,6 +202,7 @@ 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/dl_aix.xs AIX implementation +ext/DynaLoader/dl_beos.xs BeOS implementation ext/DynaLoader/dl_cygwin32.xs Cygwin32 implementation ext/DynaLoader/dl_dld.xs GNU dld style implementation ext/DynaLoader/dl_dlopen.xs BSD/SunOS4&5 dlopen() style implementation @@ -213,6 +221,7 @@ ext/Fcntl/Makefile.PL Fcntl extension makefile writer ext/GDBM_File/GDBM_File.pm GDBM extension Perl module ext/GDBM_File/GDBM_File.xs GDBM extension external subroutines ext/GDBM_File/Makefile.PL GDBM extension makefile writer +ext/GDBM_File/hints/sco.pl Hint for GDBM_File for named architecture ext/GDBM_File/typemap GDBM extension interface types ext/IO/IO.pm Top-level interface to IO::* classes ext/IO/IO.xs IO extension external subroutines @@ -262,8 +271,10 @@ ext/POSIX/POSIX.pm POSIX extension Perl module ext/POSIX/POSIX.pod POSIX extension documentation ext/POSIX/POSIX.xs POSIX extension external subroutines ext/POSIX/hints/bsdos.pl Hint for POSIX for named architecture +ext/POSIX/hints/dynixptx.pl Hint for POSIX for named architecture ext/POSIX/hints/freebsd.pl Hint for POSIX for named architecture ext/POSIX/hints/linux.pl Hint for POSIX for named architecture +ext/POSIX/hints/mint.pl Hint for POSIX for named architecture ext/POSIX/hints/netbsd.pl Hint for POSIX for named architecture ext/POSIX/hints/next_3.pl Hint for POSIX for named architecture ext/POSIX/hints/openbsd.pl Hint for POSIX for named architecture @@ -380,6 +391,7 @@ hints/esix4.sh Hints for named architecture hints/fps.sh Hints for named architecture hints/freebsd.sh Hints for named architecture hints/genix.sh Hints for named architecture +hints/gnu.sh Hints for named architecture hints/greenhills.sh Hints for named architecture hints/hpux.sh Hints for named architecture hints/i386.sh Hints for named architecture @@ -394,6 +406,7 @@ hints/linux.sh Hints for named architecture hints/lynxos.sh Hints for named architecture hints/machten.sh Hints for named architecture hints/machten_2.sh Hints for named architecture +hints/mint.sh Hints for named architecture hints/mips.sh Hints for named architecture hints/mpc.sh Hints for named architecture hints/mpeix.sh Hints for named architecture @@ -429,12 +442,12 @@ hints/unicosmk.sh Hints for named architecture hints/unisysdynix.sh Hints for named architecture hints/utekv.sh Hints for named architecture hints/uts.sh Hints for named architecture +hints/uwin.sh Hints for named architecture hv.c Hash value code hv.h Hash value header installhtml Perl script to install html files for pods installman Perl script to install man pages for pods installperl Perl script to do "make install" dirty work -interp.sym Interpreter specific symbols to hide in a struct intrpvar.h Variables held in each interpreter instance iperlsys.h Perl's interface to the system keywords.h The keyword numbers @@ -456,8 +469,9 @@ lib/CPAN/Nox.pm Runs CPAN while avoiding compiled extensions lib/Carp.pm Error message base class lib/Class/Struct.pm Declare struct-like datatypes as Perl classes lib/Cwd.pm Various cwd routines (getcwd, fastcwd, chdir) -lib/Devel/SelfStubber.pm Generate stubs for SelfLoader.pm +lib/Devel/SelfStubber.pm Generate stubs for SelfLoader.pm lib/DirHandle.pm like FileHandle only for directories +lib/Dumpvalue.pm Screen dump of perl values lib/English.pm Readable aliases for short variables lib/Env.pm Map environment into ordinary variables lib/Exporter.pm Exporter base class @@ -553,7 +567,7 @@ lib/bigint.pl An arbitrary precision integer arithmetic package lib/bigrat.pl An arbitrary precision rational arithmetic package lib/blib.pm For "use blib" lib/cacheout.pl Manages output filehandles when you need too many -lib/chat2.pl Obsolete ipc library (use Comm.pm etc instead) +lib/chat2.pl Obsolete ipc library (use Comm.pm etc instead) lib/complete.pl A command completion subroutine lib/constant.pm For "use constant" lib/ctime.pl A ctime workalike @@ -602,6 +616,13 @@ mg.c Magic code mg.h Magic header minimod.pl Writes lib/ExtUtils/Miniperl.pm miniperlmain.c Basic perl w/o dynamic loading or extensions +mint/errno.h MiNT port +mint/Makefile MiNT port +mint/pwd.c MiNT port +mint/README MiNT port +mint/stdio.h MiNT port +mint/sys/time.h MiNT port +mint/time.h MiNT port mpeix/mpeixish.h MPE/iX port mpeix/nm MPE/iX port mpeix/relink MPE/iX port @@ -725,15 +746,18 @@ pod/perlmodinstall.pod Installing CPAN Modules pod/perlmodlib.pod Module policy info pod/perlobj.pod Object info pod/perlop.pod Operator info +pod/perlopentut.pod open() tutorial pod/perlpod.pod Pod info pod/perlport.pod Portability guide pod/perlre.pod Regular expression info pod/perlref.pod References info +pod/perlreftut.pod References tutorial pod/perlrun.pod Execution info pod/perlsec.pod Security info pod/perlstyle.pod Style info pod/perlsub.pod Subroutine info pod/perlsyn.pod Syntax info +pod/perlthrtut.pod Threads tutorial pod/perltie.pod Tieing an object class into a simple variable pod/perltoc.pod Table of Contents info pod/perltoot.pod Tom's object-oriented tutorial @@ -829,6 +853,7 @@ t/lib/dumper.t See if Data::Dumper works t/lib/english.t See if English works t/lib/env.t See if Env works t/lib/errno.t See if Errno works +t/lib/fatal.t See if Fatal works t/lib/fields.t See if base/fields works t/lib/filecache.t See if FileCache works t/lib/filecopy.t See if File::Copy works @@ -870,7 +895,8 @@ t/lib/socket.t See if Socket works t/lib/soundex.t See if Soundex works t/lib/symbol.t See if Symbol works t/lib/texttabs.t See if Text::Tabs works -t/lib/textwrap.t See if Text::Wrap works +t/lib/textfill.t See if Text::Wrap::fill works +t/lib/textwrap.t See if Text::Wrap::wrap works t/lib/thread.t Basic test of threading (skipped if no threads) t/lib/tie-push.t Test for Tie::Array t/lib/tie-stdarray.t Test for Tie::StdArray @@ -903,6 +929,7 @@ t/op/fork.t See if fork works t/op/glob.t See if <*> works t/op/goto.t See if goto works t/op/goto_xs.t See if "goto &sub" works on XSUBs +t/op/grep.t See if grep() and map() work t/op/groups.t See if $( works t/op/gv.t See if typeglobs work t/op/hashwarn.t See if warnings for bad hash assignments work @@ -938,7 +965,7 @@ t/op/repeat.t See if x operator works t/op/runlevel.t See if die() works from perl_call_*() t/op/sleep.t See if sleep works t/op/sort.t See if sort works -t/op/splice.t See if splice works +t/op/splice.t See if splice works t/op/split.t See if split works t/op/sprintf.t See if sprintf works t/op/stat.t See if stat works @@ -951,6 +978,7 @@ t/op/tie.t See if tie/untie functions work t/op/tiearray.t See if tie for arrays works t/op/tiehandle.t See if tie for handles works t/op/time.t See if time functions work +t/op/tr.t See if tr works t/op/undef.t See if undef works t/op/universal.t See if UNIVERSAL class works t/op/unshift.t See if unshift works @@ -1006,19 +1034,29 @@ vms/genconfig.pl retcon config.sh from config.h vms/genopt.com hack to write options files in case of broken makes vms/make_command.com record MM[SK] command used to build Perl vms/mms2make.pl convert descrip.mms to make syntax -vms/munchconfig.c performs shell $var substitution for VMS +vms/munchconfig.c performs shell $var substitution for VMS vms/myconfig.com record local configuration info for bug report vms/perlvms.pod VMS-specific additions to Perl documentation vms/perly_c.vms perly.c with fixed declarations for global syms vms/perly_h.vms perly.h with fixed declarations for global syms vms/sockadapt.c glue for SockshShr socket support vms/sockadapt.h glue for SockshShr socket support -vms/subconfigure.com performs compiler checks and writes config.sh, config.h, and descrip.mms +vms/subconfigure.com performs compiler checks and writes config.sh, config.h, and descrip.mms vms/test.com DCL driver for regression tests vms/vms.c VMS-specific C code for Perl core vms/vms_yfix.pl convert Unix perly.[ch] to VMS perly_[ch].vms vms/vmsish.h VMS-specific C header for Perl core vms/writemain.pl Generate perlmain.c from miniperlmain.c+extensions +vos/build.cm VOS command macro to build Perl +vos/Changes Changes made to port Perl to the VOS operating system +vos/compile_perl.cm VOS commnad macro to build multiple version of Perl +vos/config.h config.h for VOS +vos/config_h.SH_orig config_h.SH at the time config.h was created +vos/perl.bind VOS bind control file +vos/test_vos_dummies.c Test program for "vos_dummies.c" +vos/vos_accept.c Wrapper to fixup nonstandard VOS _accept function +vos/vos_dummies.c Wrappers to soak up undefined functions +vos/vosish.h VOS-specific header file win32/GenCAPI.pl Win32 port for C API with PERL_OBJECT win32/Makefile Win32 makefile for NMAKE (Visual C++ build) win32/TEST Win32 port diff --git a/contrib/perl5/Makefile.SH b/contrib/perl5/Makefile.SH index 050e471..61f01b5 100755 --- a/contrib/perl5/Makefile.SH +++ b/contrib/perl5/Makefile.SH @@ -43,12 +43,17 @@ true) # NeXT uses a different name. ldlibpth="DYLD_LIBRARY_PATH=`pwd`:$DYLD_LIBRARY_PATH" ;; + beos*) ldlibpth="LIBRARY_PATH=`pwd`:$LIBRARY_PATH" + ;; os2*) # OS/2 doesn't need anything special for LD_LIBRARY_PATH. ldlibpth='' ;; - sunos*|freebsd[23]*|netbsd*) + sunos*) linklibperl="-lperl" ;; + netbsd*|freebsd[234]*) + linklibperl="-L. -lperl" + ;; aix*) shrpldflags="-H512 -T512 -bhalt:4 -bM:SRE -bE:perl.exp" case "$osvers" in @@ -161,7 +166,7 @@ shellflags = $shellflags $make_set_make # These variables may need to be manually set for non-Unix systems. -AR = $ar +AR = $full_ar EXE_EXT = $_exe LIB_EXT = $_a OBJ_EXT = $_o @@ -450,14 +455,15 @@ perly.h: perly.y -@sh -c true # No compat3.sym here since and including the 5.004_50. -SYM = global.sym interp.sym perlio.sym thread.sym +# No interp.sym since 5.005_03. +SYM = global.sym perlio.sym thread.sym SYMH = perlvars.h thrdvar.h # The following files are generated automatically # keywords.h: keywords.pl # opcode.h: opcode.pl -# embed.h: embed.pl global.sym interp.sym +# embed.h: embed.pl global.sym # byterun.h: bytecode.pl # byterun.c: bytecode.pl # lib/B/Asmdata.pm: bytecode.pl @@ -598,13 +604,13 @@ minitest: miniperl lib/re.pm # Please *don't* use this unless all tests pass. # If you want to report test failures, use "make nok" instead. ok: utilities - $(LBLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)' + $(LDLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)' okfile: utilities - $(LBLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)' -F perl.ok + $(LDLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)' -F perl.ok nok: utilities - $(LBLIBPTH) ./perl -Ilib utils/perlbug -nok -s '(UNINSTALLED)' + $(LDLIBPTH) ./perl -Ilib utils/perlbug -nok -s '(UNINSTALLED)' clist: $(c) echo $(c) | tr ' ' $(TRNL) >.clist @@ -644,3 +650,70 @@ case `pwd` in ;; esac $rm -f $firstmakefile + +# Now do any special processing required before building. + +case "$ebcdic" in +$define) + xxx='' + echo "This is an EBCDIC system, checking if any parser files need regenerating." >&4 +case "$osname" in +os390) + rm -f y.tab.c y.tab.h + yacc -d perly.y >/dev/null 2>&1 + if cmp -s y.tab.c perly.c; then + rm -f y.tab.c + else + echo "perly.y -> perly.c" >&2 + mv -f y.tab.c perly.c + chmod u+w perly.c + sed -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' \ + -e 's/y\.tab/perly/g' perly.c >perly.tmp && mv perly.tmp perly.c + xxx="$xxx perly.c" + fi + if cmp -s y.tab.h perly.h; then + rm -f y.tab.h + else + echo "perly.y -> perly.h" >&2 + mv -f y.tab.h perly.h + xxx="$xxx perly.h" + fi + if cd x2p + then + rm -f y.tab.c y.tab.h + yacc a2p.y >/dev/null 2>&1 + if cmp -s y.tab.c a2p.c + then + rm -f y.tab.c + else + echo "a2p.y -> a2p.c" >&2 + mv -f y.tab.c a2p.c + chmod u+w a2p.c + sed -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' \ + -e 's/y\.tab/a2p/g' a2p.c >a2p.tmp && mv a2p.tmp a2p.c + xxx="$xxx a2p.c" + fi + # In case somebody yacc -d:ed the a2p.y. + if test -f y.tab.h + then + if cmp -s y.tab.h a2p.h + then + rm -f y.tab.h + else + echo "a2p.h -> a2p.h" >&2 + mv -f y.tab.h a2p.h + xxx="$xxx a2p.h" + fi + fi + cd .. + fi + ;; +*) + echo "'$osname' is an EBCDIC system I don't know that well." >&4 + ;; +esac + case "$xxx" in + '') echo "No parser files were regenerated. That's okay." >&2 ;; + esac + ;; +esac diff --git a/contrib/perl5/Porting/Glossary b/contrib/perl5/Porting/Glossary index f681679..52b560e 100644 --- a/contrib/perl5/Porting/Glossary +++ b/contrib/perl5/Porting/Glossary @@ -5,7 +5,7 @@ generates pod documentation for Config.pm from this file--please try to keep the formatting regular.] Mcc (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the Mcc program. After Configure runs, the value is reset to a plain "Mcc" and is not useful. @@ -52,7 +52,7 @@ apiversion (patchlevel.U): will retain binary compatibility. ar (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the ar program. After Configure runs, the value is reset to a plain "ar" and is not useful. @@ -79,7 +79,7 @@ archobjs (Unix.U): include os2/os2.obj. awk (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the awk program. After Configure runs, the value is reset to a plain "awk" and is not useful. @@ -105,7 +105,7 @@ bison (Loc.U): The value is a plain '' and is not useful. byacc (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the byacc program. After Configure runs, the value is reset to a plain "byacc" and is not useful. @@ -129,7 +129,7 @@ castflags (d_castneg.U): 4 = couldn't cast in argument expression list cat (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the cat program. After Configure runs, the value is reset to a plain "cat" and is not useful. @@ -154,6 +154,12 @@ ccflags (ccflags.U): This variable contains any additional C compiler flags desired by the user. It is up to the Makefile to use this. +ccsymbols (Cppsym.U): + The variable contains the symbols defined by the C compiler alone. + The symbols defined by cpp or by cc when it calls cpp are not in + this list, see cppsymbols and cppccsymbols. + The list is a space-separated list of symbol=value tokens. + cf_by (cf_who.U): Login name of the person who ran the Configure script and answered the questions. This is used to tag both config.sh and config_h.SH. @@ -184,7 +190,7 @@ clocktype (d_times.U): included). comm (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the comm program. After Configure runs, the value is reset to a plain "comm" and is not useful. @@ -199,7 +205,7 @@ contains (contains.U): is primarily for the use of other Configure units. cp (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the cp program. After Configure runs, the value is reset to a plain "cp" and is not useful. @@ -208,7 +214,7 @@ cpio (Loc.U): The value is a plain '' and is not useful. cpp (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the cpp program. After Configure runs, the value is reset to a plain "cpp" and is not useful. @@ -244,13 +250,25 @@ cppstdin (cppstdin.U): It is primarily used by other Configure units that ask about preprocessor symbols. +cppsymbols (Cppsym.U): + The variable contains the symbols defined by the C preprocessor + alone. The symbols defined by cc or by cc when it calls cpp are + not in this list, see ccsymbols and cppccsymbols. + The list is a space-separated list of symbol=value tokens. + +cppccsymbols (Cppsym.U): + The variable contains the symbols defined by the C compiler when + when it calls cpp. The symbols defined by the cc alone or cpp + alone are not in this list, see ccsymbols and cppsymbols. + The list is a space-separated list of symbol=value tokens. + cryptlib (d_crypt.U): This variable holds -lcrypt or the path to a libcrypt.a archive if the crypt() function is not defined in the standard C library. It is up to the Makefile to use this. csh (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the csh program. After Configure runs, the value is reset to a plain "csh" and is not useful. @@ -477,6 +495,14 @@ d_fsetpos (d_fsetpos.U): This variable conditionally defines HAS_FSETPOS if fsetpos() is available to set the file position indicator. +d_fstatfs (d_statfs.U): + This variable conditionally defines the HAS_FSTATFS symbol, which + indicates to the C program that the fstatfs() routine is available. + +d_fstatvfs (d_statvfs.U): + This variable conditionally defines the HAS_FSTATVFS symbol, which + indicates to the C program that the fstatvfs() routine is available. + d_ftime (d_ftime.U): This variable conditionally defines the HAS_FTIME symbol, which indicates that the ftime() routine exists. The ftime() routine is basically @@ -522,6 +548,11 @@ d_getlogin (d_getlogin.U): indicates to the C program that the getlogin() routine is available to get the login name. +d_getmntent (d_getmntent.U): + This variable conditionally defines the HAS_GETMNTENT symbol, which + indicates to the C program that the getmntent() routine is available + to iterate through mounted files. + d_getnbyaddr (d_getnbyad.U): This variable conditionally defines the HAS_GETNETBYADDR symbol, which indicates to the C program that the getnetbyaddr() routine is available @@ -626,6 +657,11 @@ d_grpasswd (i_grp.U): This variable conditionally defines GRPASSWD, which indicates that struct group in <grp.h> contains gr_passwd. +d_hasmntopt (d_hasmntopt.U): + This variable conditionally defines the HAS_HASMNTOPT symbol, which + indicates to the C program that the hasmntopt() routine is available + to query the mount options of file systems. + d_htonl (d_htonl.U): This variable conditionally defines HAS_HTONL if htonl() and its friends are available to do network order byte swapping. @@ -1072,6 +1108,16 @@ d_statblks (d_statblks.U): This variable conditionally defines USE_STAT_BLOCKS if this system has a stat structure declaring st_blksize and st_blocks. +d_statfsflags (d_statfs.U): + This variable conditionally defines the HAS_STRUCT_STATFS_FLAGS + symbol, which indicates to struct statfs from has f_flags member. + This kind of struct statfs is coming from sys/mount.h (BSD), + not from sys/statfs.h (SYSV). + +d_statvfs (d_statvfs.U): + This variable conditionally defines the HAS_STATVFS symbol, which + indicates to the C program that the statvfs() routine is available. + d_stdio_cnt_lval (d_stdstdio.U): This variable conditionally defines STDIO_CNT_LVALUE if the FILE_cnt macro can be used as an lvalue. @@ -1260,7 +1306,7 @@ d_xenix (Guess.U): the C program that it runs under Xenix. date (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the date program. After Configure runs, the value is reset to a plain "date" and is not useful. @@ -1307,12 +1353,12 @@ ebcdic (ebcdic.U): See trnl.U echo (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the echo program. After Configure runs, the value is reset to a plain "echo" and is not useful. egrep (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the egrep program. After Configure runs, the value is reset to a plain "egrep" and is not useful. @@ -1329,7 +1375,7 @@ exe_ext (Unix.U): This is an old synonym for _exe. expr (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the expr program. After Configure runs, the value is reset to a plain "expr" and is not useful. @@ -1340,7 +1386,7 @@ extensions (Extensions.U): is available. find (Loc.U): - This variable is be used internally by Configure to determine the + 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. @@ -1362,6 +1408,11 @@ freetype (mallocsrc.U): This variable contains the return type of free(). It is usually void, but occasionally int. +full_ar (Loc_ar.U): + This variable contains the full pathname to 'ar', whether or + not the user has specified 'portability'. This is only used + in the Makefile.SH. + full_csh (d_csh.U): This variable contains the full pathname to 'csh', whether or not the user has specified 'portability'. This is only used @@ -1387,7 +1438,7 @@ gidtype (gidtype.U): of getgid(). Typically, it is the type of group ids in the kernel. grep (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the grep program. After Configure runs, the value is reset to a plain "grep" and is not useful. @@ -1403,7 +1454,7 @@ groupstype (groupstype.U): gidtype (gid_t), but sometimes it isn't. gzip (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the gzip program. After Configure runs, the value is reset to a plain "gzip" and is not useful. @@ -1489,6 +1540,10 @@ i_locale (i_locale.U): This variable conditionally defines the I_LOCALE symbol, and indicates whether a C program should include <locale.h>. +i_machcthr (i_machcthr.U): + This variable conditionally defines the I_MACH_CTHREADS symbol, + and indicates whether a C program should include <mach/cthreads.h>. + i_malloc (i_malloc.U): This variable conditionally defines the I_MALLOC symbol, and indicates whether a C program should include <malloc.h>. @@ -1501,6 +1556,10 @@ i_memory (i_memory.U): This variable conditionally defines the I_MEMORY symbol, and indicates whether a C program should include <memory.h>. +i_mntent (i_mntent.U): + This variable conditionally defines the I_MNTENT symbol, and indicates + whether a C program should include <mntent.h>. + i_ndbm (i_ndbm.U): This variable conditionally defines the I_NDBM symbol, which indicates to the C program that <ndbm.h> exists and should @@ -1580,6 +1639,10 @@ i_sysioctl (i_sysioctl.U): indicates to the C program that <sys/ioctl.h> exists and should be included. +i_sysmount (i_sysmount.U): + This variable conditionally defines the I_SYSMOUNT symbol, + and indicates whether a C program should include <sys/mount.h>. + i_sysndir (i_sysndir.U): This variable conditionally defines the I_SYS_NDIR symbol, and indicates whether a C program should include <sys/ndir.h>. @@ -1606,6 +1669,14 @@ i_sysstat (i_sysstat.U): This variable conditionally defines the I_SYS_STAT symbol, and indicates whether a C program should include <sys/stat.h>. +i_sysstatfs (i_sysstatfs.U): + This variable conditionally defines the I_SYSSTATFS symbol, + and indicates whether a C program should include <sys/statfs.h>. + +i_sysstatvfs (i_sysstatvfs.U): + This variable conditionally defines the I_SYSSTATVFS symbol, + and indicates whether a C program should include <sys/statvfs.h>. + i_systime (i_time.U): This variable conditionally defines I_SYS_TIME, which indicates to the C program that it should include <sys/time.h>. @@ -1671,6 +1742,11 @@ i_vfork (i_vfork.U): This variable conditionally defines the I_VFORK symbol, and indicates whether a C program should include vfork.h. +ignore_versioned_solibs (libs.U): + This variable should be non-empty if non-versioned shared + libraries (libfoo.so.x.y) are to be ignored (because they + cannot be linked against). + incpath (usrinc.U): This variable must preceed the normal include path to get hte right one, as in "$incpath/usr/include" or "$incpath/usr/lib". @@ -1722,6 +1798,11 @@ installsitelib (sitelib.U): those systems using AFS. For extra portability, only this variable should be used in makefiles. +installusrbinperl (instubperl.U): + This variable tells whether Perl should be installed also as + /usr/bin/perl in addition to + $installbin/perl + intsize (intsize.U): This variable contains the value of the INTSIZE symbol, which indicates to the C program how many bytes there are in an int. @@ -1756,7 +1837,7 @@ ldflags (ccflags.U): the user. It is up to the Makefile to use this. less (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the less program. After Configure runs, the value is reset to a plain "less" and is not useful. @@ -1788,7 +1869,7 @@ libswanted (Myinit.U): ahead of ucb or bsd libraries for SVR4. line (Loc.U): - This variable is be used internally by Configure to determine the + 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. @@ -1801,7 +1882,7 @@ lkflags (ccflags.U): the user. It is up to the Makefile to use this. ln (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the ln program. After Configure runs, the value is reset to a plain "ln" and is not useful. @@ -1845,7 +1926,7 @@ lpr (Loc.U): The value is a plain '' and is not useful. ls (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the ls program. After Configure runs, the value is reset to a plain "ls" and is not useful. @@ -1863,7 +1944,7 @@ mailx (Loc.U): The value is a plain '' and is not useful. make (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the make program. After Configure runs, the value is reset to a plain "make" and is not useful. @@ -1934,7 +2015,7 @@ mips_type (usrinc.U): Possible values are "BSD 4.3" and "System V". mkdir (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the mkdir program. After Configure runs, the value is reset to a plain "mkdir" and is not useful. @@ -1949,7 +2030,7 @@ modetype (modetype.U): modes for system calls. more (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the more program. After Configure runs, the value is reset to a plain "more" and is not useful. @@ -2006,7 +2087,7 @@ netdb_net_type (netdbtype.U): This is only useful if you have getnetbyaddr(), naturally. nm (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the nm program. After Configure runs, the value is reset to a plain "nm" and is not useful. @@ -2026,7 +2107,7 @@ nonxs_ext (Extensions.U): in the package. All of them will be built. nroff (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the nroff program. After Configure runs, the value is reset to a plain "nroff" and is not useful. @@ -2086,7 +2167,7 @@ path_sep (Unix.U): used to separate elements in the command shell search PATH. perl (Loc.U): - This variable is be used internally by Configure to determine the + 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. @@ -2099,7 +2180,7 @@ perlpath (perlpath.U): shell scripts and in the "eval 'exec'" idiom. pg (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the pg program. After Configure runs, the value is reset to a plain "pg" and is not useful. @@ -2172,7 +2253,7 @@ rd_nodata (nblock_io.U): no data and an EOF.. Sigh! rm (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the rm program. After Configure runs, the value is reset to a plain "rm" and is not useful. @@ -2197,10 +2278,17 @@ scriptdirexp (scriptdir.U): at configuration time, for programs not wanting to bother with it. sed (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the sed program. After Configure runs, the value is reset to a plain "sed" and is not useful. +selectminbits (selectminbits.U): + This variable 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. + selecttype (selecttype.U): This variable holds the type used for the 2nd, 3rd, and 4th arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET @@ -2208,7 +2296,7 @@ selecttype (selecttype.U): have select(), naturally. sendmail (Loc.U): - This variable is be used internally by Configure to determine the + 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. @@ -2277,6 +2365,12 @@ sig_num (sig_name.U): the value of the signal listed in the same place within the sig_name list. +sig_num_init (sig_name.U): + This variable holds the signal numbers, enclosed in double quotes and + separated by commas, suitable for use in the SIG_NUM definition + below. A "ZERO" is prepended to the list, and the list is + terminated with a plain 0. + signal_t (d_voidsig.U): This variable holds the type of the signal handler (void or int). @@ -2329,7 +2423,7 @@ socketlib (d_socket.U): This variable has the names of any libraries needed for socket support. sort (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the sort program. After Configure runs, the value is reset to a plain "sort" and is not useful. @@ -2440,12 +2534,12 @@ tbl (Loc.U): The value is a plain '' and is not useful. tee (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the tee program. After Configure runs, the value is reset to a plain "tee" and is not useful. test (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the test program. After Configure runs, the value is reset to a plain "test" and is not useful. @@ -2458,12 +2552,12 @@ timetype (d_time.U): included). Anyway, the type Time_t should be used. touch (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the touch program. After Configure runs, the value is reset to a plain "touch" and is not useful. tr (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the tr program. After Configure runs, the value is reset to a plain "tr" and is not useful. @@ -2482,12 +2576,12 @@ uidtype (uidtype.U): ushort, or whatever type is used to declare user ids in the kernel. uname (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the uname program. After Configure runs, the value is reset to a plain "uname" and is not useful. uniq (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the uniq program. After Configure runs, the value is reset to a plain "uniq" and is not useful. @@ -2574,7 +2668,7 @@ zcat (Loc.U): The value is a plain '' and is not useful. zip (Loc.U): - This variable is be used internally by Configure to determine the + This variable is used internally by Configure to determine the full pathname (if any) of the zip program. After Configure runs, the value is reset to a plain "zip" and is not useful. diff --git a/contrib/perl5/Porting/patching.pod b/contrib/perl5/Porting/patching.pod index e3b6188..caada0c 100644 --- a/contrib/perl5/Porting/patching.pod +++ b/contrib/perl5/Porting/patching.pod @@ -10,7 +10,7 @@ The latest version of this document is available from =head2 How to contribute to this document You may mail corrections, additions, and suggestions to me -at dgris@tdrenterprises.com but the preferred method would be +at dgris@dimensional.com but the preferred method would be to follow the instructions set forth in this document and submit a patch 8-). @@ -36,6 +36,12 @@ and patches not produced using standard utilities (such as diff). =head1 Proper Patch Guidelines +=head2 What to patch + +Generally speaking you should patch the latest development release +of perl. The maintainers of the individual branches will see to it +that patches are picked up and applied as appropriate. + =head2 How to prepare your patch =over 4 @@ -159,18 +165,19 @@ guidelines (courtesy of Gurusamy Sarathy (gsar@engin.umich.edu))- Interpret results strictly. Use unrelated features (this will flush out bizarre interactions). Use non-standard idioms (otherwise you are not testing TIMTOWTDI). - Avoid using hardcoded test umbers whenever possible (the EXPECTED/GOT style - found in t/op/tie.t is much more maintainable, and gives better failure - reports). + Avoid using hardcoded test numbers whenever possible (the + EXPECTED/GOT found in t/op/tie.t is much more maintainable, + and gives better failure reports). Give meaningful error messages when a test fails. Avoid using qx// and system() unless you are testing for them. If you do use them, make sure that you cover _all_ perl platforms. Unlink any temporary files you create. Promote unforeseen warnings to errors with $SIG{__WARN__}. - Be sure to use the libraries and modules shipped with version being tested, - not those that were already installed. + Be sure to use the libraries and modules shipped with version + being tested, not those that were already installed. Add comments to the code explaining what you are testing for. - Make updating the '1..42' string unnecessary. Or make sure that you update it. + Make updating the '1..42' string unnecessary. Or make sure that + you update it. Test _all_ behaviors of a given operator, library, or function- All optional arguments Return values in various contexts (boolean, scalar, list, lvalue) @@ -289,23 +296,25 @@ others will have an easy time using your work, and it should be easier for the maintainers to coordinate the occasionally large numbers of patches received. -Also, just because you're not a brilliant coder doesn't mean that you can't -contribute. As valuable as code patches are there is always a need for better -documentation (especially considering the general level of joy that most -programmers feel when forced to sit down and write docs). If all you do -is patch the documentation you have still contributed more than the person -who sent in an amazing new feature that noone can use because noone understands -the code (what I'm getting at is that documentation is both the hardest part to -do (because everyone hates doing it) and the most valuable). - -Mostly, when contributing patches, imagine that it is B<you> receiving hundreds -of patches and that it is B<your> responsibility to integrate them into the source. -Obviously you'd want the patches to be as easy to apply as possible. Keep that in -mind. 8-) +Also, just because you're not a brilliant coder doesn't mean that you +can't contribute. As valuable as code patches are there is always a +need for better documentation (especially considering the general +level of joy that most programmers feel when forced to sit down and +write docs). If all you do is patch the documentation you have still +contributed more than the person who sent in an amazing new feature +that no one can use because no one understands the code (what I'm +getting at is that documentation is both the hardest part to do +(because everyone hates doing it) and the most valuable). + +Mostly, when contributing patches, imagine that it is B<you> receiving +hundreds of patches and that it is B<your> responsibility to integrate +them into the source. Obviously you'd want the patches to be as easy +to apply as possible. Keep that in mind. 8-) =head1 Last Modified -Last modified 21 May 1998 by Daniel Grisinger <dgris@perrin.dimensional.com> +Last modified 21 January 1999 +Daniel Grisinger <dgris@dimensional.com> =head1 Author and Copyright Information @@ -314,6 +323,3 @@ Copyright (c) 1998 Daniel Grisinger Adapted from a posting to perl5-porters by Tim Bunce (Tim.Bunce@ig.co.uk). I'd like to thank the perl5-porters for their suggestions. - - - diff --git a/contrib/perl5/Porting/pumpkin.pod b/contrib/perl5/Porting/pumpkin.pod index f41dfac..335e49f 100644 --- a/contrib/perl5/Porting/pumpkin.pod +++ b/contrib/perl5/Porting/pumpkin.pod @@ -1178,6 +1178,16 @@ the dist-users mailing list along these lines. They have been folded back into the main distribution, but various parts of the perl Configure/build/install process still assume src='.'. +=item Directory for vendor-supplied modules? + +If a vendor supplies perl, but wants to leave $siteperl and $sitearch +for the local user to use, where should the vendor put vendor-supplied +modules (such as Tk.so?) If the vendor puts them in $archlib, then +they need to be updated each time the perl version is updated. +Perhaps we need a set of libries $vendorperl and $vendorarch that +track $apiversion (like the $sitexxx directories do) rather than +just $version (like the main perl directory). + =item Hint file fixes Various hint files work around Configure problems. We ought to fix diff --git a/contrib/perl5/README b/contrib/perl5/README index 7cc8021..e3ccad4 100644 --- a/contrib/perl5/README +++ b/contrib/perl5/README @@ -1,7 +1,7 @@ Perl Kit, Version 5.0 - Copyright 1989-1997, Larry Wall + Copyright 1989-1999, Larry Wall All rights reserved. This program is free software; you can redistribute it and/or modify @@ -22,8 +22,8 @@ Kit, in the file named "Artistic". If not, I'll be glad to provide one. You should also have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + along with this program; if not, write to the Free Software Foundation, + Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA. For those of you that choose to use the GNU General Public License, my interpretation of the GNU General Public License is that no Perl diff --git a/contrib/perl5/README.threads b/contrib/perl5/README.threads index 952623f..136b156 100644 --- a/contrib/perl5/README.threads +++ b/contrib/perl5/README.threads @@ -1,3 +1,10 @@ +NOTE + +Threading is a highly experimental feature. There are still a +few race conditions that show up under high contention on SMP +machines. Internal implementation is still subject to changes. +It is not recommended for production use at this time. + Building If you want to build with multi-threading support and you are @@ -27,7 +34,8 @@ work or you are using another platform which you believe supports POSIX.1c threads then read on. Additional information may be in a platform-specific "hints" file in the hints/ subdirectory. -Omit the -d from your ./Configure arguments. For example, use +On other platforms that use Configure to build perl, omit the -d +from your ./Configure arguments. For example, use: ./Configure -Dusethreads @@ -92,6 +100,10 @@ For AIX: Add -lc_r to libswanted Change -lc in lddflags to be -lpthread -lc_r -lc +For Win32: + See README.win32, and the notes at the beginning of win32/Makefile + or win32/makefile.mk. + Now you can do a make @@ -147,11 +159,8 @@ libraries were not compiled to be thread-aware). Bugs * FAKE_THREADS should produce a working perl but the Thread -extension won't build with it yet. - -* There's a known memory leak (curstack isn't freed at the end -of each thread because it causes refcount problems that I -haven't tracked down yet) and there are very probably others too. +extension won't build with it yet. (FAKE_THREADS has not been +tested at all in recent times.) * There may still be races where bugs show up under contention. @@ -275,3 +284,6 @@ Last updated: 27 November 1997 Configure-related info updated 16 July 1998 by Andy Dougherty <doughera@lafayette.edu> + +Other minor updates 10 Feb 1999 by +Gurusamy Sarathy diff --git a/contrib/perl5/Todo b/contrib/perl5/Todo index 3340e4f..5867c40 100644 --- a/contrib/perl5/Todo +++ b/contrib/perl5/Todo @@ -10,9 +10,8 @@ Would be nice to have lexperl Bundled perl preprocessor Use posix calls internally where possible - gettimeofday + gettimeofday (possibly best left for a module?) format BOTTOM - -iprefix. -i rename file only when successfully changed All ARGV input should act like <> report HANDLE [formats]. @@ -23,6 +22,8 @@ Would be nice to have lvalue functions regression/sanity tests for suidperl Full 64 bit support (i.e. "long long") + Generalise Errno way of extracting cpp symbols and use that in + Errno and Fcntl (ExtUtils::CppSymbol?) Possible pragmas debugger diff --git a/contrib/perl5/Todo-5.005 b/contrib/perl5/Todo-5.005 index 404e5ec..7f2dbc9 100644 --- a/contrib/perl5/Todo-5.005 +++ b/contrib/perl5/Todo-5.005 @@ -1,26 +1,21 @@ Multi-threading $AUTOLOAD. Hmm. - without USE_THREADS, change extern variable for dTHR consistent semantics for exit/die in threads SvREFCNT_dec(curstack) in threadstart() in Thread.xs better support for externally created threads Thread::Pool - more Configure support spot-check globals like statcache and global GVs for thread-safety Compiler auto-produce executable typed lexicals should affect B::CC::load_pad workarounds to help Win32 - $^C to track compiler/checker status END blocks need saving in compiled output _AUTOLOAD prodding fix comppadlist (names in comppad_name can have fake SvCUR from where newASSIGNOP steals the field) Namespace cleanup - symbol-space: "pl_" prefix for all global vars - "Perl_" prefix for all functions CPP-space: restrict what we export from headers stop malloc()/free() pollution unless asked header-space: move into CORE/perl/ @@ -28,9 +23,7 @@ Namespace cleanup MULTIPLICITY support complete work on safe recursive interpreters, C<Perl->new()> - -Configure - installation layout changes to avoid overwriting old versions + revisit extra implicit arg that provides curthread/curinterp context Reliable Signals alternate runops() for signal despatch @@ -38,31 +31,31 @@ Reliable Signals add tests for Thread::Signal Win32 stuff - automate maintenance of most PERL_OBJECT code get PERL_OBJECT building under gcc + get PERL_OBJECT building on non-win32 + automate generation of 'protected' prototypes for CPerlObj rename new headers to be consistent with the rest sort out the spawnvp() mess work out DLL versioning - put perlobject in $ARCHNAME so it can coexist with rest - get PERL_OBJECT building on non-win32? style-check Miscellaneous rename and alter ISA.pm magic_setisa should be made to update %FIELDS [???] - be generous in accepting foreign line terminations - make filenames 8.3 friendly, where feasible - upgrade to newer versions of all independently maintained modules - add new modules (Data-Dumper, Storable?) - test it with large parts of CPAN + add new modules (Archive::Tar, Compress::Zlib, CPAN::FTP?) fix pod2html to generate relative URLs + automate testing with large parts of CPAN -Documentation +Ongoing + keep filenames 8.3 friendly, where feasible + upgrade to newer versions of all independently maintained modules comprehensive perldelta.pod + +Documentation describe new age patterns update perl{guts,call,embed,xs} with additions, changes to API document Win32 choices - rework INSTALL to reflect changes in installation structure spot-check all new modules for completeness better docs for pack()/unpack() - add perlport.pod + reorg tutorials vs. reference sections + diff --git a/contrib/perl5/XSUB.h b/contrib/perl5/XSUB.h index dc805d8..a6577d8 100644 --- a/contrib/perl5/XSUB.h +++ b/contrib/perl5/XSUB.h @@ -57,8 +57,8 @@ #ifdef XS_VERSION # define XS_VERSION_BOOTCHECK \ STMT_START { \ - SV *tmpsv; \ - char *vn = Nullch, *module = SvPV(ST(0),PL_na); \ + SV *tmpsv; STRLEN n_a; \ + char *vn = Nullch, *module = SvPV(ST(0),n_a); \ if (items >= 2) /* version supplied as bootstrap arg */ \ tmpsv = ST(1); \ else { \ @@ -69,7 +69,7 @@ tmpsv = perl_get_sv(form("%s::%s", module, \ vn = "VERSION"), FALSE); \ } \ - if (tmpsv && (!SvOK(tmpsv) || strNE(XS_VERSION, SvPV(tmpsv, PL_na)))) \ + if (tmpsv && (!SvOK(tmpsv) || strNE(XS_VERSION, SvPV(tmpsv, n_a)))) \ croak("%s object version %s does not match %s%s%s%s %_", \ module, XS_VERSION, \ vn ? "$" : "", vn ? module : "", vn ? "::" : "", \ @@ -79,6 +79,70 @@ # define XS_VERSION_BOOTCHECK #endif +#ifdef PERL_CAPI +# define VTBL_sv get_vtbl(want_vtbl_sv) +# define VTBL_env get_vtbl(want_vtbl_env) +# define VTBL_envelem get_vtbl(want_vtbl_envelem) +# define VTBL_sig get_vtbl(want_vtbl_sig) +# define VTBL_sigelem get_vtbl(want_vtbl_sigelem) +# define VTBL_pack get_vtbl(want_vtbl_pack) +# define VTBL_packelem get_vtbl(want_vtbl_packelem) +# define VTBL_dbline get_vtbl(want_vtbl_dbline) +# define VTBL_isa get_vtbl(want_vtbl_isa) +# define VTBL_isaelem get_vtbl(want_vtbl_isaelem) +# define VTBL_arylen get_vtbl(want_vtbl_arylen) +# define VTBL_glob get_vtbl(want_vtbl_glob) +# define VTBL_mglob get_vtbl(want_vtbl_mglob) +# define VTBL_nkeys get_vtbl(want_vtbl_nkeys) +# define VTBL_taint get_vtbl(want_vtbl_taint) +# define VTBL_substr get_vtbl(want_vtbl_substr) +# define VTBL_vec get_vtbl(want_vtbl_vec) +# define VTBL_pos get_vtbl(want_vtbl_pos) +# define VTBL_bm get_vtbl(want_vtbl_bm) +# define VTBL_fm get_vtbl(want_vtbl_fm) +# define VTBL_uvar get_vtbl(want_vtbl_uvar) +# define VTBL_defelem get_vtbl(want_vtbl_defelem) +# define VTBL_regexp get_vtbl(want_vtbl_regexp) +# ifdef USE_LOCALE_COLLATE +# define VTBL_collxfrm get_vtbl(want_vtbl_collxfrm) +# endif +# ifdef OVERLOAD +# define VTBL_amagic get_vtbl(want_vtbl_amagic) +# define VTBL_amagicelem get_vtbl(want_vtbl_amagicelem) +# endif +#else +# define VTBL_sv &vtbl_sv +# define VTBL_env &vtbl_env +# define VTBL_envelem &vtbl_envelem +# define VTBL_sig &vtbl_sig +# define VTBL_sigelem &vtbl_sigelem +# define VTBL_pack &vtbl_pack +# define VTBL_packelem &vtbl_packelem +# define VTBL_dbline &vtbl_dbline +# define VTBL_isa &vtbl_isa +# define VTBL_isaelem &vtbl_isaelem +# define VTBL_arylen &vtbl_arylen +# define VTBL_glob &vtbl_glob +# define VTBL_mglob &vtbl_mglob +# define VTBL_nkeys &vtbl_nkeys +# define VTBL_taint &vtbl_taint +# define VTBL_substr &vtbl_substr +# define VTBL_vec &vtbl_vec +# define VTBL_pos &vtbl_pos +# define VTBL_bm &vtbl_bm +# define VTBL_fm &vtbl_fm +# define VTBL_uvar &vtbl_uvar +# define VTBL_defelem &vtbl_defelem +# define VTBL_regexp &vtbl_regexp +# ifdef USE_LOCALE_COLLATE +# define VTBL_collxfrm &vtbl_collxfrm +# endif +# ifdef OVERLOAD +# define VTBL_amagic &vtbl_amagic +# define VTBL_amagicelem &vtbl_amagicelem +# endif +#endif + #ifdef PERL_OBJECT #include "objXSUB.h" #ifndef NO_XSLOCKS diff --git a/contrib/perl5/XSlock.h b/contrib/perl5/XSlock.h index 8fb0ce4..0b2c829 100644 --- a/contrib/perl5/XSlock.h +++ b/contrib/perl5/XSlock.h @@ -13,23 +13,26 @@ protected: }; XSLockManager g_XSLock; +CPerlObj* pPerl; class XSLock { public: - XSLock() { g_XSLock.Enter(); }; + XSLock(CPerlObj *p) { + g_XSLock.Enter(); + ::pPerl = p; + }; ~XSLock() { g_XSLock.Leave(); }; }; -CPerlObj* pPerl; - +/* PERL_CAPI does its own locking in xs_handler() */ +#if defined(PERL_OBJECT) && !defined(PERL_CAPI) #undef dXSARGS #define dXSARGS \ - dSP; dMARK; \ - I32 ax = mark - PL_stack_base + 1; \ - I32 items = sp - mark; \ - XSLock localLock; \ - ::pPerl = pPerl - + XSLock localLock(pPerl); \ + dSP; dMARK; \ + I32 ax = mark - PL_stack_base + 1; \ + I32 items = sp - mark +#endif /* PERL_OBJECT && !PERL_CAPI */ #endif diff --git a/contrib/perl5/av.c b/contrib/perl5/av.c index b5c9bc2..7652757 100644 --- a/contrib/perl5/av.c +++ b/contrib/perl5/av.c @@ -1,6 +1,6 @@ /* av.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -24,7 +24,7 @@ av_reify(AV *av) if (AvREAL(av)) return; #ifdef DEBUGGING - if (SvRMAGICAL(av) && mg_find((SV*)av,'P')) + if (SvTIED_mg((SV*)av, 'P')) warn("av_reify called on tied array"); #endif key = AvMAX(av) + 1; @@ -41,6 +41,7 @@ av_reify(AV *av) key = AvARRAY(av) - AvALLOC(av); while (key) AvALLOC(av)[--key] = &PL_sv_undef; + AvREIFY_off(av); AvREAL_on(av); } @@ -49,14 +50,14 @@ av_extend(AV *av, I32 key) { dTHR; /* only necessary if we have to extend stack */ MAGIC *mg; - if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) { + if (mg = SvTIED_mg((SV*)av, 'P')) { dSP; ENTER; SAVETMPS; PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); EXTEND(SP,2); - PUSHs(mg->mg_obj); + PUSHs(SvTIED_obj((SV*)av, mg)); PUSHs(sv_2mortal(newSViv(key+1))); PUTBACK; perl_call_method("EXTEND", G_SCALAR|G_DISCARD); @@ -174,10 +175,7 @@ av_fetch(register AV *av, I32 key, I32 lval) if (key > AvFILLp(av)) { if (!lval) return 0; - if (AvREALISH(av)) - sv = NEWSV(5,0); - else - sv = sv_newmortal(); + sv = NEWSV(5,0); return av_store(av,key,sv); } if (AvARRAY(av)[key] == &PL_sv_undef) { @@ -370,7 +368,7 @@ av_undef(register AV *av) /*SUPPRESS 560*/ /* Give any tie a chance to cleanup first */ - if (SvRMAGICAL(av) && mg_find((SV*)av,'P')) + if (SvTIED_mg((SV*)av, 'P')) av_fill(av, -1); /* mg_clear() ? */ if (AvREAL(av)) { @@ -397,12 +395,12 @@ av_push(register AV *av, SV *val) if (SvREADONLY(av)) croak(no_modify); - if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) { + if (mg = SvTIED_mg((SV*)av, 'P')) { dSP; PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); EXTEND(SP,2); - PUSHs(mg->mg_obj); + PUSHs(SvTIED_obj((SV*)av, mg)); PUSHs(val); PUTBACK; ENTER; @@ -424,11 +422,11 @@ av_pop(register AV *av) return &PL_sv_undef; if (SvREADONLY(av)) croak(no_modify); - if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) { + if (mg = SvTIED_mg((SV*)av, 'P')) { dSP; PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); - XPUSHs(mg->mg_obj); + XPUSHs(SvTIED_obj((SV*)av, mg)); PUTBACK; ENTER; if (perl_call_method("POP", G_SCALAR)) { @@ -459,12 +457,12 @@ av_unshift(register AV *av, register I32 num) if (SvREADONLY(av)) croak(no_modify); - if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) { + if (mg = SvTIED_mg((SV*)av, 'P')) { dSP; PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); EXTEND(SP,1+num); - PUSHs(mg->mg_obj); + PUSHs(SvTIED_obj((SV*)av, mg)); while (num-- > 0) { PUSHs(&PL_sv_undef); } @@ -510,11 +508,11 @@ av_shift(register AV *av) return &PL_sv_undef; if (SvREADONLY(av)) croak(no_modify); - if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) { + if (mg = SvTIED_mg((SV*)av, 'P')) { dSP; PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); - XPUSHs(mg->mg_obj); + XPUSHs(SvTIED_obj((SV*)av, mg)); PUTBACK; ENTER; if (perl_call_method("SHIFT", G_SCALAR)) { @@ -551,14 +549,14 @@ av_fill(register AV *av, I32 fill) croak("panic: null array"); if (fill < 0) fill = -1; - if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) { + if (mg = SvTIED_mg((SV*)av, 'P')) { dSP; ENTER; SAVETMPS; PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); EXTEND(SP,2); - PUSHs(mg->mg_obj); + PUSHs(SvTIED_obj((SV*)av, mg)); PUSHs(sv_2mortal(newSViv(fill+1))); PUTBACK; perl_call_method("STORESIZE", G_SCALAR|G_DISCARD); diff --git a/contrib/perl5/av.h b/contrib/perl5/av.h index 8de81f4..bef763d 100644 --- a/contrib/perl5/av.h +++ b/contrib/perl5/av.h @@ -1,6 +1,6 @@ /* av.h * - * Copyright (c) 1991-1998, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. diff --git a/contrib/perl5/bytecode.h b/contrib/perl5/bytecode.h index e28dd43..7f0ab13 100644 --- a/contrib/perl5/bytecode.h +++ b/contrib/perl5/bytecode.h @@ -64,7 +64,7 @@ typedef IV IV64; BGET_U32(hi); \ BGET_U32(lo); \ if (sizeof(IV) == 8) \ - arg = (IV) (hi << (sizeof(IV)*4) | lo); \ + arg = ((IV)hi << (sizeof(IV)*4) | lo); \ else if (((I32)hi == -1 && (I32)lo < 0) \ || ((I32)hi == 0 && (I32)lo >= 0)) { \ arg = (I32)lo; \ diff --git a/contrib/perl5/cc_runtime.h b/contrib/perl5/cc_runtime.h index 18e3ba2..9a01ff8 100644 --- a/contrib/perl5/cc_runtime.h +++ b/contrib/perl5/cc_runtime.h @@ -45,7 +45,7 @@ case 0: \ PL_op = ppaddr(ARGS); \ PL_retstack[PL_retstack_ix - 1] = Nullop; \ - if (PL_op != nxt) runops(); \ + if (PL_op != nxt) CALLRUNOPS(); \ JMPENV_POP; \ break; \ case 1: JMPENV_POP; JMPENV_JUMP(1); \ diff --git a/contrib/perl5/config_h.SH b/contrib/perl5/config_h.SH index 49f86c7..0b42d29 100755 --- a/contrib/perl5/config_h.SH +++ b/contrib/perl5/config_h.SH @@ -239,6 +239,54 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$d_fsetpos HAS_FSETPOS /**/ +/* I_SYS_MOUNT: + * This symbol, if defined, indicates to the C program that it should + * include <sys/mount.h>. + */ +#$i_sysmount I_SYS_MOUNT /**/ + +/* HAS_FSTATFS: + * This symbol, if defined, indicates that the fstatfs routine is + * available to stat the filesystem of a file descriptor. + */ +#$d_fstatfs HAS_FSTATFS /**/ + +/* HAS_STRUCT_STATFS_FLAGS: + * This symbol, if defined, indicates that the struct statfs has + * the f_flags member for mount flags. + */ +#$d_statfsflags HAS_STRUCT_STATFS_FLAGS /**/ + +/* I_SYS_STATVFS: + * This symbol, if defined, indicates to the C program that it should + * include <sys/statvfs.h>. + */ +#$i_sysstatvfs I_SYS_STATVFS /**/ + +/* HAS_FSTATVFS: + * This symbol, if defined, indicates that the fstatvfs routine is + * available to stat the filesystem of a file descriptor. + */ +#$d_fstatvfs HAS_FSTATVFS /**/ + +/* I_MNTENT: + * This symbol, if defined, indicates to the C program that it should + * include <mntent.h>. + */ +#$i_mntent I_MNTENT /**/ + +/* HAS_GETMNTENT: + * This symbol, if defined, indicates that the getmntent routine is + * available to lookup mount entries in some data base or other. + */ +#$d_getmntent HAS_GETMNTENT /**/ + +/* HAS_HASMNTOPT: + * This symbol, if defined, indicates that the hasmntopt routine is + * available to query mount entries returned by getmntent. + */ +#$d_hasmntopt HAS_HASMNTOPT /**/ + /* HAS_GETTIMEOFDAY: * This symbol, if defined, indicates that the gettimeofday() system * call is available for a sub-second accuracy clock. Usually, the file @@ -1813,7 +1861,7 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- * the sig_name list. */ #define SIG_NAME $sig_name_init /**/ -#define SIG_NUM $sig_num /**/ +#define SIG_NUM $sig_num_init /**/ /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this @@ -1902,6 +1950,15 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- #define PRIVLIB "$privlib" /**/ #define PRIVLIB_EXP "$privlibexp" /**/ +/* 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 $selectminbits /**/ + /* 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 @@ -2017,6 +2074,18 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #define ARCHNAME "$archname" /**/ +/* I_MACH_CTHREADS: + * This symbol, if defined, indicates to the C program that it should + * include <mach/cthreads.h>. + */ +#$i_machcthreads I_MACH_CTHREADS /**/ + +/* I_PTHREAD: + * This symbol, if defined, indicates to the C program that it should + * include <pthread.h>. + */ +#$i_pthread I_PTHREAD /**/ + /* HAS_PTHREAD_YIELD: * This symbol, if defined, indicates that the pthread_yield * routine is available to yield the execution of the current diff --git a/contrib/perl5/configure.com b/contrib/perl5/configure.com index 5212219..d51793a 100644 --- a/contrib/perl5/configure.com +++ b/contrib/perl5/configure.com @@ -974,7 +974,7 @@ $ line = F$EDIT(line,"COMPRESS, TRIM") $ patchlevel = F$EXTRACT(18,F$LENGTH(line)-18,line) $ got_patch = "true" $ ENDIF -$ IF ((F$LOCATE("SUBVERSION",line).NE.F$LENGTH(line)).AND.(.NOT.got_sub)) +$ IF ((F$LOCATE("#define SUBVERSION",line).NE.F$LENGTH(line)).AND.(.NOT.got_sub)) $ THEN $ line = F$EDIT(line,"COMPRESS, TRIM") $ subversion = F$EXTRACT(18,F$LENGTH(line)-18,line) diff --git a/contrib/perl5/cop.h b/contrib/perl5/cop.h index 9c8eae6..7d6730f 100644 --- a/contrib/perl5/cop.h +++ b/contrib/perl5/cop.h @@ -1,6 +1,6 @@ /* cop.h * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -142,7 +142,7 @@ struct block_loop { #define POPLOOP2() \ SvREFCNT_dec(cxloop.iterlval); \ if (cxloop.itervar) { \ - SvREFCNT_dec(*cxloop.itervar); \ + sv_2mortal(*cxloop.itervar); \ *cxloop.itervar = cxloop.itersave; \ } \ if (cxloop.iterary && cxloop.iterary != PL_curstack) \ @@ -180,17 +180,17 @@ struct block { cx->cx_type = t, \ cx->blk_oldsp = sp - PL_stack_base, \ cx->blk_oldcop = PL_curcop, \ - cx->blk_oldmarksp = PL_markstack_ptr - PL_markstack, \ + cx->blk_oldmarksp = PL_markstack_ptr - PL_markstack, \ cx->blk_oldscopesp = PL_scopestack_ix, \ - cx->blk_oldretsp = PL_retstack_ix, \ + cx->blk_oldretsp = PL_retstack_ix, \ cx->blk_oldpm = PL_curpm, \ cx->blk_gimme = gimme; \ DEBUG_l( PerlIO_printf(PerlIO_stderr(), "Entering block %ld, type %s\n", \ - (long)cxstack_ix, block_type[t]); ) + (long)cxstack_ix, block_type[CxTYPE(cx)]); ) /* Exit a block (RETURN and LAST). */ #define POPBLOCK(cx,pm) cx = &cxstack[cxstack_ix--], \ - newsp = PL_stack_base + cx->blk_oldsp, \ + newsp = PL_stack_base + cx->blk_oldsp, \ PL_curcop = cx->blk_oldcop, \ PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \ PL_scopestack_ix = cx->blk_oldscopesp, \ @@ -198,14 +198,15 @@ struct block { pm = cx->blk_oldpm, \ gimme = cx->blk_gimme; \ DEBUG_l( PerlIO_printf(PerlIO_stderr(), "Leaving block %ld, type %s\n", \ - (long)cxstack_ix+1,block_type[cx->cx_type]); ) + (long)cxstack_ix+1,block_type[CxTYPE(cx)]); ) /* Continue a block elsewhere (NEXT and REDO). */ #define TOPBLOCK(cx) cx = &cxstack[cxstack_ix], \ - PL_stack_sp = PL_stack_base + cx->blk_oldsp, \ + PL_stack_sp = PL_stack_base + cx->blk_oldsp, \ PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \ PL_scopestack_ix = cx->blk_oldscopesp, \ - PL_retstack_ix = cx->blk_oldretsp + PL_retstack_ix = cx->blk_oldretsp, \ + PL_curpm = cx->blk_oldpm /* substitution context */ struct subst { @@ -261,12 +262,14 @@ struct subst { rxres_free(&cx->sb_rxres) struct context { - I32 cx_type; /* what kind of context this is */ + U32 cx_type; /* what kind of context this is */ union { struct block cx_blk; struct subst cx_subst; } cx_u; }; + +#define CXTYPEMASK 0xff #define CXt_NULL 0 #define CXt_SUB 1 #define CXt_EVAL 2 @@ -274,6 +277,12 @@ struct context { #define CXt_SUBST 4 #define CXt_BLOCK 5 +/* private flags for CXt_EVAL */ +#define CXp_REAL 0x00000100 /* truly eval'', not a lookalike */ + +#define CxTYPE(c) ((c)->cx_type & CXTYPEMASK) +#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())) /* "gimme" values */ diff --git a/contrib/perl5/cv.h b/contrib/perl5/cv.h index c7c7a73..9605135 100644 --- a/contrib/perl5/cv.h +++ b/contrib/perl5/cv.h @@ -1,6 +1,6 @@ /* cv.h * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -94,3 +94,12 @@ struct xpvcv { #define CvLOCKED(cv) (CvFLAGS(cv) & CVf_LOCKED) #define CvLOCKED_on(cv) (CvFLAGS(cv) |= CVf_LOCKED) #define CvLOCKED_off(cv) (CvFLAGS(cv) &= ~CVf_LOCKED) + +#define CvEVAL(cv) (CvUNIQUE(cv) && !SvFAKE(cv)) +#define CvEVAL_on(cv) (CvUNIQUE_on(cv),SvFAKE_off(cv)) +#define CvEVAL_off(cv) CvUNIQUE_off(cv) + +/* BEGIN|INIT|END */ +#define CvSPECIAL(cv) (CvUNIQUE(cv) && SvFAKE(cv)) +#define CvSPECIAL_on(cv) (CvUNIQUE_on(cv),SvFAKE_on(cv)) +#define CvSPECIAL_off(cv) (CvUNIQUE_off(cv),SvFAKE_off(cv)) diff --git a/contrib/perl5/deb.c b/contrib/perl5/deb.c index 0c25225..ad26cd6 100644 --- a/contrib/perl5/deb.c +++ b/contrib/perl5/deb.c @@ -1,6 +1,6 @@ /* deb.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. diff --git a/contrib/perl5/doio.c b/contrib/perl5/doio.c index 85d604b..74544c9 100644 --- a/contrib/perl5/doio.c +++ b/contrib/perl5/doio.c @@ -1,6 +1,6 @@ /* doio.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -18,13 +18,12 @@ #include "perl.h" #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) +#ifndef HAS_SEM #include <sys/ipc.h> +#endif #ifdef HAS_MSG #include <sys/msg.h> #endif -#ifdef HAS_SEM -#include <sys/sem.h> -#endif #ifdef HAS_SHM #include <sys/shm.h> # ifndef HAS_SHMAT_PROTOTYPE @@ -359,8 +358,12 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe PerlIO_clearerr(fp); } #if defined(HAS_FCNTL) && defined(F_SETFD) - fd = PerlIO_fileno(fp); - fcntl(fd,F_SETFD,fd > PL_maxsysfd); + { + int save_errno = errno; + fd = PerlIO_fileno(fp); + fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */ + errno = save_errno; + } #endif IoIFP(io) = fp; if (writing) { @@ -545,7 +548,7 @@ nextargv(register GV *gv) } else PerlIO_printf(PerlIO_stderr(), "Can't open %s: %s\n", - SvPV(sv, PL_na), Strerror(errno)); + SvPV(sv, oldlen), Strerror(errno)); } if (PL_inplace) { (void)do_close(PL_argvoutgv,FALSE); @@ -759,7 +762,7 @@ do_binmode(PerlIO *fp, int iotype, int flag) if (flag != TRUE) croak("panic: unsetting binmode"); /* Not implemented yet */ #ifdef DOSISH -#ifdef atarist +#if defined(atarist) || defined(__MINT__) if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN)) return 1; else @@ -920,6 +923,7 @@ my_stat(ARGSproto) else { SV* sv = POPs; char *s; + STRLEN n_a; PUTBACK; if (SvTYPE(sv) == SVt_PVGV) { tmpgv = (GV*)sv; @@ -930,7 +934,7 @@ my_stat(ARGSproto) goto do_fstat; } - s = SvPV(sv, PL_na); + s = SvPV(sv, n_a); PL_statgv = Nullgv; sv_setpv(PL_statname, s); PL_laststype = OP_STAT; @@ -946,6 +950,7 @@ my_lstat(ARGSproto) { djSP; SV *sv; + STRLEN n_a; if (PL_op->op_flags & OPf_REF) { EXTEND(SP,1); if (cGVOP->op_gv == PL_defgv) { @@ -960,13 +965,13 @@ my_lstat(ARGSproto) PL_statgv = Nullgv; sv = POPs; PUTBACK; - sv_setpv(PL_statname,SvPV(sv, PL_na)); + sv_setpv(PL_statname,SvPV(sv, n_a)); #ifdef HAS_LSTAT - PL_laststatval = PerlLIO_lstat(SvPV(sv, PL_na),&PL_statcache); + PL_laststatval = PerlLIO_lstat(SvPV(sv, n_a),&PL_statcache); #else - PL_laststatval = PerlLIO_stat(SvPV(sv, PL_na),&PL_statcache); + PL_laststatval = PerlLIO_stat(SvPV(sv, n_a),&PL_statcache); #endif - if (PL_laststatval < 0 && PL_dowarn && strchr(SvPV(sv, PL_na), '\n')) + if (PL_laststatval < 0 && PL_dowarn && strchr(SvPV(sv, n_a), '\n')) warn(warn_nl, "lstat"); return PL_laststatval; } @@ -976,6 +981,7 @@ do_aexec(SV *really, register SV **mark, register SV **sp) { register char **a; char *tmps; + STRLEN n_a; if (sp > mark) { dTHR; @@ -983,14 +989,14 @@ do_aexec(SV *really, register SV **mark, register SV **sp) a = PL_Argv; while (++mark <= sp) { if (*mark) - *a++ = SvPVx(*mark, PL_na); + *a++ = SvPVx(*mark, n_a); else *a++ = ""; } *a = Nullch; if (*PL_Argv[0] != '/') /* will execvp use PATH? */ TAINT_ENV(); /* testing IFS here is overkill, probably */ - if (really && *(tmps = SvPV(really, PL_na))) + if (really && *(tmps = SvPV(really, n_a))) PerlProc_execvp(tmps,PL_Argv); else PerlProc_execvp(PL_Argv[0],PL_Argv); @@ -1116,10 +1122,11 @@ apply(I32 type, register SV **mark, register SV **sp) char *what; char *s; SV **oldmark = mark; + STRLEN n_a; #define APPLY_TAINT_PROPER() \ STMT_START { \ - if (PL_tainting && PL_tainted) { goto taint_proper_label; } \ + if (PL_tainted) { TAINT_PROPER(what); } \ } STMT_END /* This is a first heuristic; it doesn't catch tainting magic. */ @@ -1141,7 +1148,7 @@ apply(I32 type, register SV **mark, register SV **sp) APPLY_TAINT_PROPER(); tot = sp - mark; while (++mark <= sp) { - char *name = SvPVx(*mark, PL_na); + char *name = SvPVx(*mark, n_a); APPLY_TAINT_PROPER(); if (PerlLIO_chmod(name, val)) tot--; @@ -1158,7 +1165,7 @@ apply(I32 type, register SV **mark, register SV **sp) APPLY_TAINT_PROPER(); tot = sp - mark; while (++mark <= sp) { - char *name = SvPVx(*mark, PL_na); + char *name = SvPVx(*mark, n_a); APPLY_TAINT_PROPER(); if (PerlLIO_chown(name, val, val2)) tot--; @@ -1178,7 +1185,7 @@ nothing in the core. APPLY_TAINT_PROPER(); if (mark == sp) break; - s = SvPVx(*++mark, PL_na); + s = SvPVx(*++mark, n_a); if (isUPPER(*s)) { if (*s == 'S' && s[1] == 'I' && s[2] == 'G') s += 3; @@ -1248,7 +1255,7 @@ nothing in the core. APPLY_TAINT_PROPER(); tot = sp - mark; while (++mark <= sp) { - s = SvPVx(*mark, PL_na); + s = SvPVx(*mark, n_a); APPLY_TAINT_PROPER(); if (PL_euid || PL_unsafe) { if (UNLINK(s)) @@ -1277,23 +1284,23 @@ nothing in the core. struct utimbuf utbuf; #else struct { - long actime; - long modtime; + Time_t actime; + Time_t modtime; } utbuf; #endif Zero(&utbuf, sizeof utbuf, char); #ifdef BIG_TIME - utbuf.actime = (Time_t)SvNVx(*++mark); /* time accessed */ - utbuf.modtime = (Time_t)SvNVx(*++mark); /* time modified */ + utbuf.actime = (Time_t)SvNVx(*++mark); /* time accessed */ + utbuf.modtime = (Time_t)SvNVx(*++mark); /* time modified */ #else - utbuf.actime = SvIVx(*++mark); /* time accessed */ - utbuf.modtime = SvIVx(*++mark); /* time modified */ + utbuf.actime = (Time_t)SvIVx(*++mark); /* time accessed */ + utbuf.modtime = (Time_t)SvIVx(*++mark); /* time modified */ #endif APPLY_TAINT_PROPER(); tot = sp - mark; while (++mark <= sp) { - char *name = SvPVx(*mark, PL_na); + char *name = SvPVx(*mark, n_a); APPLY_TAINT_PROPER(); if (PerlLIO_utime(name, &utbuf)) tot--; @@ -1306,10 +1313,6 @@ nothing in the core. } return tot; - taint_proper_label: - TAINT_PROPER(what); - return 0; /* this should never happen */ - #undef APPLY_TAINT_PROPER } diff --git a/contrib/perl5/doop.c b/contrib/perl5/doop.c index e80fa48..85d7b9e 100644 --- a/contrib/perl5/doop.c +++ b/contrib/perl5/doop.c @@ -1,6 +1,6 @@ /* doop.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -352,7 +352,8 @@ do_vop(I32 optype, SV *sv, SV *left, SV *right) len = leftlen < rightlen ? leftlen : rightlen; lensave = len; if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) { - dc = SvPV_force(sv, PL_na); + STRLEN n_a; + dc = SvPV_force(sv, n_a); if (SvCUR(sv) < len) { dc = SvGROW(sv, len + 1); (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1); @@ -491,7 +492,7 @@ do_kv(ARGSproto) RETURN; } - if (!SvRMAGICAL(keys) || !mg_find((SV*)keys,'P')) + if (! SvTIED_mg((SV*)keys, 'P')) i = HvKEYS(keys); else { i = 0; diff --git a/contrib/perl5/dump.c b/contrib/perl5/dump.c index b1e984b..782c62d 100644 --- a/contrib/perl5/dump.c +++ b/contrib/perl5/dump.c @@ -1,6 +1,6 @@ /* dump.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -239,11 +239,12 @@ dump_op(OP *o) case OP_GVSV: case OP_GV: if (cGVOPo->op_gv) { + STRLEN n_a; SV *tmpsv = NEWSV(0,0); ENTER; SAVEFREESV(tmpsv); gv_fullname3(tmpsv, cGVOPo->op_gv, Nullch); - dump("GV = %s\n", SvPV(tmpsv, PL_na)); + dump("GV = %s\n", SvPV(tmpsv, n_a)); LEAVE; } else diff --git a/contrib/perl5/eg/ADB b/contrib/perl5/eg/ADB new file mode 100644 index 0000000..e8130e1 --- /dev/null +++ b/contrib/perl5/eg/ADB @@ -0,0 +1,8 @@ +#!/usr/bin/perl + +# $RCSfile: ADB,v $$Revision: 4.1 $$Date: 92/08/07 17:20:06 $ + +# This script is only useful when used in your crash directory. + +$num = shift; +exec 'adb', '-k', "vmunix.$num", "vmcore.$num"; diff --git a/contrib/perl5/eg/README b/contrib/perl5/eg/README new file mode 100644 index 0000000..15eb655 --- /dev/null +++ b/contrib/perl5/eg/README @@ -0,0 +1,22 @@ +Although supplied with the perl package, the perl scripts in this eg +directory and its subdirectories are placed in the public domain, and +you may do anything with them that you wish. + +This stuff is supplied on an as-is basis--little attempt has been made to make +any of it portable. It's mostly here to give you an idea of what perl code +looks like, and what tricks and idioms are used. + +System administrators responsible for many computers will enjoy the items +down in the g directory very much. The scan directory contains the beginnings +of a system to check on and report various kinds of anomalies. + +If you machine doesn't support #!, the first thing you'll want to do is +replace the #! with a couple of lines that look like this: + + eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' + if $running_under_some_shell; + +being sure to include any flags that were on the #! line. A supplied script +called "nih" will translate perl scripts in place for you: + + nih g/g?? diff --git a/contrib/perl5/eg/cgi/RunMeFirst b/contrib/perl5/eg/cgi/RunMeFirst new file mode 100755 index 0000000..018b11b --- /dev/null +++ b/contrib/perl5/eg/cgi/RunMeFirst @@ -0,0 +1,36 @@ +#!/usr/local/bin/perl + +# Make a world-writeable directory for saving state. +$ww = 'WORLD_WRITABLE'; +unless (-w $ww) { + $u = umask 0; + mkdir $ww, 0777; + umask $u; +} + +# Decode the sample image. +for $uu (<*.uu>) { + unless (open UU, "<$uu") { warn "Can't open $uu: $!\n"; next } + while (<UU>) { + chomp; + if (/^begin\s+\d+\s+(.+)$/) { + $bin = $1; + last; + } + } + unless (open BIN, "> $bin") { warn "Can't create $bin: $!\n"; next } + binmode BIN; + while (<UU>) { + chomp; + last if /^end/; + print BIN unpack "u", $_; + } + close BIN; + close UU; +} + +# Create symlinks from *.txt to *.cgi for documentation purposes. +foreach (<*.cgi>) { + ($target = $_) =~ s/cgi$/txt/i; + symlink $_, $target unless -e $target; +} diff --git a/contrib/perl5/eg/cgi/caution.xbm b/contrib/perl5/eg/cgi/caution.xbm new file mode 100644 index 0000000..87fcdbe --- /dev/null +++ b/contrib/perl5/eg/cgi/caution.xbm @@ -0,0 +1,12 @@ +#define caution_width 32 +#define caution_height 32 +static char caution_bits[] = { + 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0x00,0x00,0x00,0x10,0x01, + 0x00,0x00,0x08,0x07,0x00,0x00,0x08,0x0e,0x00,0x00,0x04,0x0e,0x00,0x00,0x04, + 0x1c,0x00,0x00,0x02,0x1c,0x00,0x00,0xe2,0x38,0x00,0x00,0xf1,0x39,0x00,0x00, + 0xf1,0x71,0x00,0x80,0xf0,0x71,0x00,0x80,0xf0,0xe1,0x00,0x40,0xf0,0xe1,0x00, + 0x40,0xf0,0xc1,0x01,0x20,0xf0,0xc1,0x01,0x20,0xf0,0x81,0x03,0x10,0xe0,0x80, + 0x03,0x10,0xe0,0x00,0x07,0x08,0xe0,0x00,0x07,0x08,0xe0,0x00,0x0e,0x04,0x00, + 0x00,0x0e,0x04,0xe0,0x00,0x1c,0x02,0xf0,0x01,0x1c,0x02,0xf0,0x01,0x38,0x01, + 0xe0,0x00,0x38,0x01,0x00,0x00,0x70,0x01,0x00,0x00,0x70,0xff,0xff,0xff,0x7f, + 0xf8,0xff,0xff,0x3f,0x00,0x00,0x00,0x00}; diff --git a/contrib/perl5/eg/cgi/clickable_image.cgi b/contrib/perl5/eg/cgi/clickable_image.cgi new file mode 100644 index 0000000..81daf09 --- /dev/null +++ b/contrib/perl5/eg/cgi/clickable_image.cgi @@ -0,0 +1,26 @@ +#!/usr/local/bin/perl + +use CGI; +$query = new CGI; +print $query->header; +print $query->start_html("A Clickable Image"); +print <<END; +<H1>A Clickable Image</H1> +</A> +END +print "Sorry, this isn't very exciting!\n"; + +print $query->startform; +print $query->image_button('picture',"./wilogo.gif"); +print "Give me a: ",$query->popup_menu('letter',['A','B','C','D','E','W']),"\n"; # +print "<P>Magnification: ",$query->radio_group('magnification',['1X','2X','4X','20X']),"\n"; +print "<HR>\n"; + +if ($query->param) { + print "<P>Magnification, <EM>",$query->param('magnification'),"</EM>\n"; + print "<P>Selected Letter, <EM>",$query->param('letter'),"</EM>\n"; + ($x,$y) = ($query->param('picture.x'),$query->param('picture.y')); + print "<P>Selected Position <EM>($x,$y)</EM>\n"; +} + +print $query->end_html; diff --git a/contrib/perl5/eg/cgi/cookie.cgi b/contrib/perl5/eg/cgi/cookie.cgi new file mode 100644 index 0000000..98adda1 --- /dev/null +++ b/contrib/perl5/eg/cgi/cookie.cgi @@ -0,0 +1,88 @@ +#!/usr/local/bin/perl + +use CGI qw(:standard); + +@ANIMALS=sort qw/lion tiger bear pig porcupine ferret zebra gnu ostrich + emu moa goat weasel yak chicken sheep hyena dodo lounge-lizard + squirrel rat mouse hedgehog racoon baboon kangaroo hippopotamus + giraffe/; + +# Recover the previous animals from the magic cookie. +# The cookie has been formatted as an associative array +# mapping animal name to the number of animals. +%zoo = cookie('animals'); + +# Recover the new animal(s) from the parameter 'new_animal' +@new = param('new_animals'); + +# If the action is 'add', then add new animals to the zoo. Otherwise +# delete them. +foreach (@new) { + if (param('action') eq 'Add') { + $zoo{$_}++; + } elsif (param('action') eq 'Delete') { + $zoo{$_}-- if $zoo{$_}; + delete $zoo{$_} unless $zoo{$_}; + } +} + +# Add new animals to old, and put them in a cookie +$the_cookie = cookie(-name=>'animals', + -value=>\%zoo, + -expires=>'+1h'); + +# Print the header, incorporating the cookie and the expiration date... +print header(-cookie=>$the_cookie); + +# Now we're ready to create our HTML page. +print start_html('Animal crackers'); + +print <<EOF; +<h1>Animal Crackers</h1> +Choose the animals you want to add to the zoo, and click "add". +Come back to this page any time within the next hour and the list of +animals in the zoo will be resurrected. You can even quit Netscape +completely! +<p> +Try adding the same animal several times to the list. Does this +remind you vaguely of a shopping cart? +<p> +<em>This script only works with Netscape browsers</em> +<p> +<center> +<table border> +<tr><th>Add/Delete<th>Current Contents +EOF + ; + +print "<tr><td>",start_form; +print scrolling_list(-name=>'new_animals', + -values=>[@ANIMALS], + -multiple=>1, + -override=>1, + -size=>10),"<br>"; +print submit(-name=>'action',-value=>'Delete'), + submit(-name=>'action',-value=>'Add'); +print end_form; + +print "<td>"; +if (%zoo) { # make a table + print "<ul>\n"; + foreach (sort keys %zoo) { + print "<li>$zoo{$_} $_\n"; + } + print "</ul>\n"; +} else { + print "<strong>The zoo is empty.</strong>\n"; +} +print "</table></center>"; + +print <<EOF; +<hr> +<ADDRESS>Lincoln D. Stein</ADDRESS><BR> +<A HREF="./">More Examples</A> +EOF + ; +print end_html; + + diff --git a/contrib/perl5/eg/cgi/crash.cgi b/contrib/perl5/eg/cgi/crash.cgi new file mode 100644 index 0000000..64f03c7 --- /dev/null +++ b/contrib/perl5/eg/cgi/crash.cgi @@ -0,0 +1,6 @@ +#!/usr/local/bin/perl + +use CGI::Carp qw(fatalsToBrowser); + +# This line invokes a fatal error message at compile time. +foo bar baz; diff --git a/contrib/perl5/eg/cgi/customize.cgi b/contrib/perl5/eg/cgi/customize.cgi new file mode 100644 index 0000000..c1c8187 --- /dev/null +++ b/contrib/perl5/eg/cgi/customize.cgi @@ -0,0 +1,92 @@ +#!/usr/local/bin/perl + +use CGI qw(:standard :html3); + +# Some constants to use in our form. +@colors=qw/aqua black blue fuschia gray green lime maroon navy olive + purple red silver teal white yellow/; +@sizes=("<default>",1..7); + +# recover the "preferences" cookie. +%preferences = cookie('preferences'); + +# If the user wants to change the background color or her +# name, they will appear among our CGI parameters. +foreach ('text','background','name','size') { + $preferences{$_} = param($_) || $preferences{$_}; +} + +# Set some defaults +$preferences{'background'} = $preferences{'background'} || 'silver'; +$preferences{'text'} = $preferences{'text'} || 'black'; + +# Refresh the cookie so that it doesn't expire. This also +# makes any changes the user made permanent. +$the_cookie = cookie(-name=>'preferences', + -value=>\%preferences, + -expires=>'+30d'); +print header(-cookie=>$the_cookie); + +# Adjust the title to incorporate the user's name, if provided. +$title = $preferences{'name'} ? + "Welcome back, $preferences{name}!" : "Customizable Page"; + +# Create the HTML page. We use several of Netscape's +# extended tags to control the background color and the +# font size. It's safe to use Netscape features here because +# cookies don't work anywhere else anyway. +print start_html(-title=>$title, + -bgcolor=>$preferences{'background'}, + -text=>$preferences{'text'} + ); + +print basefont({SIZE=>$preferences{size}}) if $preferences{'size'} > 0; + +print h1($title),<<END; +You can change the appearance of this page by submitting +the fill-out form below. If you return to this page any time +within 30 days, your preferences will be restored. +END + ; + +# Create the form +print hr(), + start_form, + + "Your first name: ", + textfield(-name=>'name', + -default=>$preferences{'name'}, + -size=>30),br, + + table( + TR( + td("Preferred"), + td("Page color:"), + td(popup_menu(-name=>'background', + -values=>\@colors, + -default=>$preferences{'background'}) + ), + ), + TR( + td(''), + td("Text color:"), + td(popup_menu(-name=>'text', + -values=>\@colors, + -default=>$preferences{'text'}) + ) + ), + TR( + td(''), + td("Font size:"), + td(popup_menu(-name=>'size', + -values=>\@sizes, + -default=>$preferences{'size'}) + ) + ) + ), + + submit(-label=>'Set preferences'), + hr; + +print a({HREF=>"/"},'Go to the home page'); +print end_html; diff --git a/contrib/perl5/eg/cgi/diff_upload.cgi b/contrib/perl5/eg/cgi/diff_upload.cgi new file mode 100644 index 0000000..913f9ca --- /dev/null +++ b/contrib/perl5/eg/cgi/diff_upload.cgi @@ -0,0 +1,68 @@ +#!/usr/local/bin/perl + +$DIFF = "/usr/bin/diff"; +$PERL = "/usr/bin/perl"; + +use CGI qw(:standard); +use CGI::Carp; + +print header; +print start_html("File Diff Example"); +print "<strong>Version </strong>$CGI::VERSION<p>"; + +print <<EOF; +<H1>File Diff Example</H1> +Enter two files. When you press "submit" their diff will be +produced. +EOF + ; + +# Start a multipart form. +print start_multipart_form; +print "File #1:",filefield(-name=>'file1',-size=>45),"<BR>\n"; +print "File #2:",filefield(-name=>'file2',-size=>45),"<BR>\n"; +print "Diff type: ",radio_group(-name=>'type', + -value=>['context','normal']),"<br>\n"; +print reset,submit(-name=>'submit',-value=>'Do Diff'); +print endform; + +# Process the form if there is a file name entered +$file1 = param('file1'); +$file2 = param('file2'); + +$|=1; # for buffering +if ($file1 && $file2) { + $realfile1 = tmpFileName($file1); + $realfile2 = tmpFileName($file2); + print "<HR>\n"; + print "<H2>$file1 vs $file2</H2>\n"; + + print "<PRE>\n"; + $options = "-c" if param('type') eq 'context'; + system "$DIFF $options $realfile1 $realfile2 | $PERL -pe 's/>/>/g; s/</</g;'"; + close $file1; + close $file2; + print "</PRE>\n"; +} + +print <<EOF; +<HR> +<A HREF="../cgi_docs.html">CGI documentation</A> +<HR> +<ADDRESS> +<A HREF="/~lstein">Lincoln D. Stein</A> +</ADDRESS><BR> +Last modified 17 July 1996 +EOF + ; +print end_html; + +sub sanitize { + my $name = shift; + my($safe) = $name=~/([a-zA-Z0-9._~#,]+)/; + unless ($safe) { + print "<strong>$name is not a valid Unix filename -- sorry</strong>"; + exit 0; + } + return $safe; +} diff --git a/contrib/perl5/eg/cgi/dna.small.gif.uu b/contrib/perl5/eg/cgi/dna.small.gif.uu new file mode 100644 index 0000000..d3ce24c --- /dev/null +++ b/contrib/perl5/eg/cgi/dna.small.gif.uu @@ -0,0 +1,63 @@ +begin 444 dna.small.gif +M1TE&.#=A)0`J`.<``+9%&Y<R0M<F'ID\,!<07%<G1:P<0Q`A2Q`P;"L9/L$: +M,"480N5"&RL7:4LD0T,G144[7BHL2B4?3\0I+"</)BQ.9KD0/S878\96$Z\@ +M(:\1*RL:3L0W&QL?2#4?9>@_&A$_5<I"&C`A3*,3-A`//9X<)\@Q(L`@.#\E +M7K,R*R\T6)H++1L72T8=4207:T`G=JX..MD^&!$_;^)2$#T=7S`79AL7.A$3 +M1-=%#^,Q&QT_:C8=1!L86]\R#4M":4H76R,515HZ4"477G@T,J\;(X(@/$\7 +M."4A2N9;$"DZ6RL34-8I$34A73P86I84/\87%1`0/V,B2"0<0N!(%QPH91<6 +M2=!5$3(=73(E23`/,!L4.=$Z'-MH%>`Y#3$=2"=#59M((H88,GP\/]X^&+$R +M$"(79"DF33(93"$86=%;&"T4/=Y"&\\A$Q4Z4!`62*T4-Q4B9+X1*BH96SP? +M1<0D/3(F<-TM$!`=5:H.(!<64C$W?#8J3*`S(S<@3=8V%K$](QT.6Q`43AL4 +M1:$D,;<0,\X9&,8])\@=$A(U244S5U,D6Q<V;]\I&&<K/8!*.R044>=/#YH> +M08$I1B,09S$35R(:4C0?<19$7<D^#Q`>5!()-;4702M`=;56)A`25,0K%"X< +M83`N>K`H'HDS*1`40,M&%!<@7M,_$A<N2L)%%18E4^<M$A@=5=0Q$Q`E311* +M2L8E&2D<7Q\A7P\80B48,%E/8[1-'J4/-"H<3"PA1$,T?Q<15R44,R,A4AL/ +M,^M4%2,07!L+,[\[&!P4520I:C(9.=54$[,2/M-)&RP?7M=(%1$J8<-,%2H@ +M4B,=51436^]2"!X<1A<44RD</>E+#%0>0S0/:4PJ9I,F-6DG420Y<"@09R,0 +M-V$R/R4M<:\H0!(H410Z:AT27&4Q9"L@;=1%(MA-$M5+#RL4+M8Z&AT<7[<: +M(-QA&2,36R$++B(84!0:5ALO:K$A.]X?&!$84V@;/SX<6Q`;2$(B2QD21W4J +M1=TW&@```````````````"P`````)0`J```(_@!]:(N'18\W%15T$1N'C)V? +M0_HH,<$G9YBX!C6<3;+T@AZ-)K@\O*"!KP^$>"KVA`L3*8P3)^5ZA)@B:AH+ +M9];F7.$Q+!`!0=*<E3'5K(:EHS2N%"AP*Y(\&##H6(!A:!XU99B*H?%4IDF? +M!8'<"-F%9I*TH8A83:*TXYD!J83D$0ICI-NE(:O8I6&FJ$64$M5$M%!3PU,F +M2UJD"9I41E824WT2G?BV-!$(!`=,+<IF!P>.%",&P7J"9XB82L5,48F5K,:" +M'94FU='6;!*R3T->E"%&95DR"`/6P,I0PDF)0SG8($$RJN0R`FI(H7$A2]VD +M*^^L_6(T3U*V%XH"_AB:HDS8H$AO5@R:P,8.I%^.:*AC(>Z!'":6RC`1L@W- +M%1Q/,%(.'5+1`<D^74R@P2#?T*'/$"%@\(L5Y?RAB!SO3#*,-6CL44\4]C1# +MR0Q3C&&"!AH08@(#:Y2C@`&1---,.#)\T84=R##`0",H++8#)34,@X80R:"` +M0A<]?'#.!";`TDH.8QBB0354A!,*)WI0\<D\YJRQ3PE[V",(.D#48$T9GO22 +MA0.BC,)'*]3TP,`^\_#QA0P@>`/"*]=<HX\3"C!BAQV%5",$+Z0,0X,UL3SB +M#B[NN$'/,A&,$L,Y[-BASR(@<**("E^,0(<&;[QA0@^,3%",#2S8H,01_LX0 +M`(0:W%`@13#TN+'#&LK@0$T0VER##50*Q/%-%%&H$`0#K7"`!B^X/`),()F0 +M0PNT[K#BRBS1-!("`^=,$8`D="B`QRW?1**+-I?(X$@(L(R2AQ8+Y,*#-*YX +MH(00'1Q!CSI,U'!%)^_%4(X&FUB@01$.@*!#$I?4D48I&1BA!2*HD%))(.+T +MYTEOT3B#PB/U4(,$%QD0(<\QX^CRBC=)@%`!&+:<<TH&M*C1"RJX'-'.'`YX +M<H0@<)#"0CX+I%`*-%:4L@XFS`#[11M?U-))"&RP84LWZL!A1A^YH.*)!)3< +MHXX6L]P3"!I`H/!`*>90`PD.F'3SR@-AG)`&_A=3'"**#[J(P<<I@YCA2@32 +M!,*+Q9H`(XT2'O2RS"CGS.U9!K>0^C0&S/#1""(ZI)'&*6,,$842N%Q!@3NK +M"R'%%4KP0D(Q?"`S!3)<I#!!".68$T(IMHP#>BVE(/$+)#-80<PTLBRP^@$> +M<+,`-[QH$LP+0_P!1C>=S("!,N>8XP<8H6131!B;3`#&#)"DTH(L5#P0S#W+ +MQ)*`$K1HHD4^;E!2QP%:B``&4H$,/Y2C$Y*(1%0(00A)@```77B"*$0@#3>P +MP&PU4`,^H!","P!!$')0P^H6((I5L"$'.;``';[Q!@-\PP"<B$<]EG"(#*C" +M%-(@0":\L0U?D&`#_L50@33.(`4M4``=&4@'+-9!!P9JP`#9T$4H=*$+!#1B +M'3A(`SYH`81'B.,(XJ@"":0(CDRPH@/<"$88V+"%$N#A&)MPX0N2H`L]C&,< +MEW"$%6:0BCV@XPIH>$0?)M$`<92!%OG8Q3#@(`U2C*)%9-!`&`K`!!EP0@80 +M2,0M;I$.:"C#"D.@P#UJ``]GT"*,K%B&*0+!@TFH8VV*0$(:_/`)?7@#'.'0 +M@R[H8``\:&`,=NC"*"B@!2TTHP5]N((TEH&`<)B"!PU`0RQ(P8MNS``9K6@% +M'W31AG%$(BZ2&((PA-&#'I"A&`F8!DD\\`H6-,.,X'B'%,+R#FX4`PS&_L!$ +M.4R0#7W<0@%O2,07$($#9@C3"%C8P!5H88\]J$,"-E!;(.X@C5T<`!65V,40 +M,'&(0C!"`1JP@"3TH`T9=&,5JRC$-]+1`U%TP@@[^,$>Z$&*0%1A%XFK`BFD +MX0L6Y"(#A_A$#[JPC@%\@1@02`(SJ#&&.`A@'\&$!AALX(4Y="`/TA"",UA! +M@%W<8!*\$`$@C%""+G1A"9AP!"<>9@ME*)$0F\C!$I8`B3\TP@%'@$(QH$`" +M)8@#'(B0ACB`P`,@%&,'9"##)S`1!&)\`0)^&,,^+$`("QC"#D\X!":HX0!< +ML(`&-O!%,&H@BS#F0AI'`!LO^"`,/OS!%KJ0_H0HEA`E27Q#%T%X0"%"@`1E +M2,`!:F!%+Q#A!G)40A!HP`4OFK`#-13#`?I(QCW38(Q/9&``%0#!);01BE>$ +M@!TZNL81$G`!-]2!&&5@A1N&T0Q<,$$$%*!``BR1A5$PPPH<74$%]*`#$.RA +M`(VP@#`X$(`7``(%T=@`.5Q`C@:0`P[)D$4'$H`."MB#"908Q=X@,01B9$(7 +MG'A%`#8!"QSL@PUAL,0==M"")CQCP4)0QQUDP806H&,!T]A!`EH@AC2P`P,^ +MT`,*NN%-&&T!&L@X!!Y^<(4.D(,%E>A`,T20C#IXL`6-:,`5F+"#!W"@'%OH +MA`IJ$5(#;`(;AV/'FA103(EV+(,>GHB&&ZJ`!D'<X0[-N$(N@)$+4$C@`<(` +M$(&/<8Q;7$,1UT"``+>P!57`X1F9D`4<W$`"4MP@$ZYX\B-"004Y2$`.HT@% +M)@IAB#><0!]FB(<I.(&`(7P"%GPPQ3)F`0YB0"$0@8"")L!Q!RH`8A&AL,8L +BR!$$,@@#&5OX!1V.\85XA.,.,A##!T2!AP@LXP#;"`@`.P`` +end diff --git a/contrib/perl5/eg/cgi/file_upload.cgi b/contrib/perl5/eg/cgi/file_upload.cgi new file mode 100644 index 0000000..f6bbbe0 --- /dev/null +++ b/contrib/perl5/eg/cgi/file_upload.cgi @@ -0,0 +1,69 @@ +#!/usr/local/bin/perl -w + +use lib '..'; +use CGI qw(:standard); +use CGI::Carp qw/fatalsToBrowser/; + +print header(); +print start_html("File Upload Example"); +print strong("Version "),$CGI::VERSION,p; + +print h1("File Upload Example"), + 'This example demonstrates how to prompt the remote user to + select a remote file for uploading. ', + strong("This feature only works with Netscape 2.0 browsers."), + p, + 'Select the ',cite('browser'),' button to choose a text file + to upload. When you press the submit button, this script + will count the number of lines, words, and characters in + the file.'; + +@types = ('count lines','count words','count characters'); + +# Start a multipart form. +print start_multipart_form(), + "Enter the file to process:", + filefield('filename','',45), + br, + checkbox_group('count',\@types,\@types), + p, + reset,submit('submit','Process File'), + endform; + +# Process the form if there is a file name entered +if ($file = param('filename')) { + $tmpfile=tmpFileName($file); + $mimetype = uploadInfo($file)->{'Content-Type'} || ''; + print hr(), + h2($file), + h3($tmpfile), + h4("MIME Type:",em($mimetype)); + + my($lines,$words,$characters,@words) = (0,0,0,0); + while (<$file>) { + $lines++; + $words += @words=split(/\s+/); + $characters += length($_); + } + close $file; + grep($stats{$_}++,param('count')); + if (%stats) { + print strong("Lines: "),$lines,br if $stats{'count lines'}; + print strong("Words: "),$words,br if $stats{'count words'}; + print strong("Characters: "),$characters,br if $stats{'count characters'}; + } else { + print strong("No statistics selected."); + } +} + +# print cite("URL parameters: "),url_param(); + +print hr(), + a({href=>"../cgi_docs.html"},"CGI documentation"), + hr, + address( + a({href=>'/~lstein'},"Lincoln D. Stein")), + br, + 'Last modified July 17, 1996', + end_html; + diff --git a/contrib/perl5/eg/cgi/frameset.cgi b/contrib/perl5/eg/cgi/frameset.cgi new file mode 100644 index 0000000..fc86e92 --- /dev/null +++ b/contrib/perl5/eg/cgi/frameset.cgi @@ -0,0 +1,81 @@ +#!/usr/local/bin/perl + +use CGI; +$query = new CGI; +print $query->header; +$TITLE="Frameset Example"; + +# We use the path information to distinguish between calls +# to the script to: +# (1) create the frameset +# (2) create the query form +# (3) create the query response + +$path_info = $query->path_info; + +# If no path information is provided, then we create +# a side-by-side frame set +if (!$path_info) { + &print_frameset; + exit 0; +} + +# If we get here, then we either create the query form +# or we create the response. +&print_html_header; +&print_query if $path_info=~/query/; +&print_response if $path_info=~/response/; +&print_end; + + +# Create the frameset +sub print_frameset { + $script_name = $query->script_name; + print <<EOF; +<html><head><title>$TITLE</title></head> +<frameset cols="50,50"> +<frame src="$script_name/query" name="query"> +<frame src="$script_name/response" name="response"> +</frameset> +EOF + ; + exit 0; +} + +sub print_html_header { + print $query->start_html($TITLE); +} + +sub print_end { + print qq{<P><hr><A HREF="../index.html" TARGET="_top">More Examples</A>}; + print $query->end_html; +} + +sub print_query { + $script_name = $query->script_name; + print "<H1>Frameset Query</H1>\n"; + print $query->startform(-action=>"$script_name/response",-TARGET=>"response"); + print "What's your name? ",$query->textfield('name'); + print "<P>What's the combination?<P>", + $query->checkbox_group(-name=>'words', + -values=>['eenie','meenie','minie','moe']); + + print "<P>What's your favorite color? ", + $query->popup_menu(-name=>'color', + -values=>['red','green','blue','chartreuse']), + "<P>"; + print $query->submit; + print $query->endform; +} + +sub print_response { + print "<H1>Frameset Result</H1>\n"; + unless ($query->param) { + print "<b>No query submitted yet.</b>"; + return; + } + print "Your name is <EM>",$query->param(name),"</EM>\n"; + print "<P>The keywords are: <EM>",join(", ",$query->param(words)),"</EM>\n"; + print "<P>Your favorite color is <EM>",$query->param(color),"</EM>\n"; +} + diff --git a/contrib/perl5/eg/cgi/index.html b/contrib/perl5/eg/cgi/index.html new file mode 100644 index 0000000..75e2d30 --- /dev/null +++ b/contrib/perl5/eg/cgi/index.html @@ -0,0 +1,118 @@ +<HTML> <HEAD> +<TITLE>More Examples of Scripts Created with CGI.pm</TITLE> +</HEAD> + +<BODY> +<H1>More Examples of Scripts Created with CGI.pm</H1> + +<H2> Basic Non Sequitur Questionnaire</H2> +<UL> + <LI> <A HREF="tryit.cgi">Try the script</A> + <LI> <A HREF="tryit.txt">Look at its source code</A> +</UL> + +<H2> Advanced Non Sequitur Questionnaire</H2> +<UL> + <LI> <A HREF="monty.cgi">Try the script</A> + <LI> <A HREF="monty.txt">Look at its source code</A> +</UL> + +<H2> Save and restore the state of a form to a file</H2> +<UL> + <LI> <A HREF="save_state.cgi">Try the script</A> + <LI> <A HREF="save_state.txt">Look at its source code</A> +</UL> + +<H2> Server Push</H2> +<ul> + <li><a href="nph-multipart.cgi">Try the script</a> + <li><a href="nph-multipart.txt">Look at its source code</a> +</ul> + +<H2> Read the coordinates from a clickable image map</H2> +<UL> + <LI> <A HREF="clickable_image.cgi">Try the script</A> + <LI> <A HREF="clickable_image.txt">Look at its source code</A> +</UL> + +<H2> Multiple independent forms on the same page</H2> +<UL> + <LI> <A HREF="multiple_forms.cgi">Try the script</A> + <LI> <A HREF="multiple_forms.txt">Look at its source code</A> +</UL> + +<H2> How to maintain state on a page with internal links</H2> +<UL> + <LI> <A HREF="internal_links.cgi">Try the script</A> + <LI> <A HREF="internal_links.txt">Look at its source code</A> +</UL> + +<h2>Echo fatal script errors to the browser</h2> +<em>This script deliberately generates a compile-time error.</em> +<ul> + <li><a href="crash.cgi">Try the script</a> + <li><a href="crash.txt">Look at its source code</a> +</ul> + +<EM>The Following Scripts only Work with Netscape 2.0 & Internet Explorer only!</EM> + +<H2> Prompt for a file to upload and process it</H2> +<UL> + <LI> <A HREF="file_upload.cgi">Try the script</A> + <LI> <A HREF="file_upload.txt">Look at its source code</A> +</UL> + +<h2> A Continuously-Updated Page using Server Push</h2> +<ul> + <li><a href="nph-clock.cgi">Try the script</a> + <li><a href="nph-clock.txt">Look at its source code</a> +</ul> + +<h2>Compute the "diff" between two uploaded files</h2> +<ul> + <li><a href="diff_upload.cgi">Try the script</a> + <li><a href="diff_upload.txt">Look at its source code</a> +</ul> + +<h2>Maintain state over a long period with a cookie</h2> +<ul> + <li><a href="cookie.cgi">Try the script</a> + <li><a href="cookie.txt">Look at its source code</a> +</ul> + +<h2>Permanently customize the appearance of a page with a cookie</h2> +<ul> + <li><a href="customize.cgi">Try the script</a> + <li><a href="customize.txt">Look at its source code</a> +</ul> + +<h2> Popup the response in a new window</h2> +<ul> + <li><a href="popup.cgi">Try the script</a> + <li><a href="popup.txt">Look at its source code</a> +</ul> + +<h2> Side-by-side form and response using frames</h2> +<ul> + <li><a href="frameset.cgi">Try the script</a> + <li><a href="frameset.txt">Look at its source code</a> +</ul> + +<h2>Verify the Contents of a fill-out form with JavaScript</h2> +<ul> + <li><a href="javascript.cgi">Try the script</a> + <li><a href="javascript.txt">Look at its source code</a> +</ul> + +<HR> +<MENU> + <LI> <A HREF="../cgi_docs.html">CGI.pm documentation</A> + <LI> <A HREF="../../CGI.pm.tar.gz">Download the CGI.pm distribution</A> +</MENU> +<HR> +<ADDRESS>Lincoln D. Stein, lstein@genome.wi.mit.edu<br> +<a href="/">Whitehead Institute/MIT Center for Genome Research</a></ADDRESS> +<!-- hhmts start --> +Last modified: Tue May 19 22:16:43 EDT 1998 +<!-- hhmts end --> +</BODY> </HTML> diff --git a/contrib/perl5/eg/cgi/internal_links.cgi b/contrib/perl5/eg/cgi/internal_links.cgi new file mode 100644 index 0000000..4806966 --- /dev/null +++ b/contrib/perl5/eg/cgi/internal_links.cgi @@ -0,0 +1,33 @@ +#!/usr/local/bin/perl + +use CGI; +$query = new CGI; + +# We generate a regular HTML file containing a very long list +# and a popup menu that does nothing except to show that we +# don't lose the state information. +print $query->header; +print $query->start_html("Internal Links Example"); +print "<H1>Internal Links Example</H1>\n"; +print "Click <cite>Submit Query</cite> to create a state. Then scroll down and", + " click on any of the <cite>Jump to top</cite> links. This is not very exciting."; + +print "<A NAME=\"start\"></A>\n"; # an anchor point at the top + +# pick a default starting value; +$query->param('amenu','FOO1') unless $query->param('amenu'); + +print $query->startform; +print $query->popup_menu('amenu',[('FOO1'..'FOO9')]); +print $query->submit,$query->endform; + +# We create a long boring list for the purposes of illustration. +$myself = $query->self_url; +print "<OL>\n"; +for (1..100) { + print qq{<LI>List item #$_ <A HREF="$myself#start">Jump to top</A>\n}; +} +print "</OL>\n"; + +print $query->end_html; + diff --git a/contrib/perl5/eg/cgi/javascript.cgi b/contrib/perl5/eg/cgi/javascript.cgi new file mode 100644 index 0000000..91c2b9e --- /dev/null +++ b/contrib/perl5/eg/cgi/javascript.cgi @@ -0,0 +1,105 @@ +#!/usr/local/bin/perl + +# This script illustrates how to use JavaScript to validate fill-out +# forms. +use CGI qw(:standard); + +# Here's the javascript code that we include in the document. +$JSCRIPT=<<EOF; + // validate that the user is the right age. Return + // false to prevent the form from being submitted. + function validateForm() { + var today = new Date(); + var birthday = validateDate(document.form1.birthdate); + if (birthday == 0) { + document.form1.birthdate.focus() + document.form1.birthdate.select(); + return false; + } + var milliseconds = today.getTime()-birthday; + var years = milliseconds/(1000 * 60 * 60 * 24 * 365.25); + if ((years > 20) || (years < 5)) { + alert("You must be between the ages of 5 and 20 to submit this form"); + document.form1.birthdate.focus(); + document.form1.birthdate.select(); + return false; + } + // Since we've calculated the age in years already, + // we might as well send it up to our CGI script. + document.form1.age.value=Math.floor(years); + return true; + } + + // make sure that the contents of the supplied + // field contain a valid date. + function validateDate(element) { + var date = Date.parse(element.value); + if (0 == date) { + alert("Please enter date in format MMM DD, YY"); + element.focus(); + element.select(); + } + return date; + } + + // Compliments, compliments + function doPraise(element) { + if (element.checked) { + self.status=element.value + " is an excellent choice!"; + return true; + } else { + return false; + } + } + + function checkColor(element) { + var color = element.options[element.selectedIndex].text; + if (color == "blonde") { + if (confirm("Is it true that blondes have more fun?")) + alert("Darn. That leaves me out."); + } else + alert(color + " is a fine choice!"); + } +EOF + ; + +# here's where the execution begins +print header; +print start_html(-title=>'Personal Profile',-script=>$JSCRIPT); + +print h1("Big Brother Wants to Know All About You"), + strong("Note: "),"This page uses JavaScript and requires ", + "Netscape 2.0 or higher to do anything special."; + +&print_prompt(); +print hr; +&print_response() if param; +print end_html; + +sub print_prompt { + print start_form(-name=>'form1', + -onSubmit=>"return validateForm()"),"\n"; + print "Birthdate (e.g. Jan 3, 1972): ", + textfield(-name=>'birthdate', + -onBlur=>"validateDate(this)"),"<p>\n"; + print "Sex: ",radio_group(-name=>'gender', + -value=>[qw/male female/], + -onClick=>"doPraise(this)"),"<p>\n"; + print "Hair color: ",popup_menu(-name=>'color', + -value=>[qw/brunette blonde red gray/], + -default=>'red', + -onChange=>"checkColor(this)"),"<p>\n"; + print hidden(-name=>'age',-value=>0); + print submit(); + print end_form; +} + +sub print_response { + import_names('Q'); + print h2("Your profile"), + "You claim to be a ",b($Q::age)," year old ",b($Q::color,$Q::gender),".", + "You should be ashamed of yourself for lying so ", + "blatantly to big brother!", + hr; +} + diff --git a/contrib/perl5/eg/cgi/monty.cgi b/contrib/perl5/eg/cgi/monty.cgi new file mode 100644 index 0000000..693c258 --- /dev/null +++ b/contrib/perl5/eg/cgi/monty.cgi @@ -0,0 +1,84 @@ +#!/usr/local/bin/perl + +use CGI; +use CGI::Carp qw/fatalsToBrowser/; + +$query = new CGI; + +print $query->header; +print $query->start_html("Example CGI.pm Form"); +print "<H1> Example CGI.pm Form</H1>\n"; +&print_prompt($query); +&do_work($query); +&print_tail; +print $query->end_html; + +sub print_prompt { + my($query) = @_; + + print $query->start_form; + print "<EM>What's your name?</EM><BR>"; + print $query->textfield('name'); + print $query->checkbox('Not my real name'); + + print "<P><EM>Where can you find English Sparrows?</EM><BR>"; + print $query->checkbox_group( + -name=>'Sparrow locations', + -Values=>[England,France,Spain,Asia,Hoboken], + -linebreak=>'yes', + -defaults=>[England,Asia]); + + print "<P><EM>How far can they fly?</EM><BR>", + $query->radio_group( + -name=>'how far', + -Values=>['10 ft','1 mile','10 miles','real far'], + -default=>'1 mile'); + + print "<P><EM>What's your favorite color?</EM> "; + print $query->popup_menu(-name=>'Color', + -Values=>['black','brown','red','yellow'], + -default=>'red'); + + print $query->hidden('Reference','Monty Python and the Holy Grail'); + + print "<P><EM>What have you got there?</EM><BR>"; + print $query->scrolling_list( + -name=>'possessions', + -Values=>['A Coconut','A Grail','An Icon', + 'A Sword','A Ticket'], + -size=>5, + -multiple=>'true'); + + print "<P><EM>Any parting comments?</EM><BR>"; + print $query->textarea(-name=>'Comments', + -rows=>10, + -columns=>50); + + print "<P>",$query->reset; + print $query->submit('Action','Shout'); + print $query->submit('Action','Scream'); + print $query->endform; + print "<HR>\n"; + } + +sub do_work { + my($query) = @_; + my(@values,$key); + + print "<H2>Here are the current settings in this form</H2>"; + + foreach $key ($query->param) { + print "<STRONG>$key</STRONG> -> "; + @values = $query->param($key); + print join(", ",@values),"<BR>\n"; + } +} + +sub print_tail { + print <<END; +<HR> +<ADDRESS>Lincoln D. Stein</ADDRESS><BR> +<A HREF="/">Home Page</A> +END + ; +} diff --git a/contrib/perl5/eg/cgi/multiple_forms.cgi b/contrib/perl5/eg/cgi/multiple_forms.cgi new file mode 100644 index 0000000..b38bf93 --- /dev/null +++ b/contrib/perl5/eg/cgi/multiple_forms.cgi @@ -0,0 +1,54 @@ +#!/usr/local/bin/perl + +use CGI; + +$query = new CGI; +print $query->header; +print $query->start_html('Multiple Forms'); +print "<H1>Multiple Forms</H1>\n"; + +# Print the first form +print $query->startform; +$name = $query->remote_user || 'anonymous@' . $query->remote_host; + +print "What's your name? ",$query->textfield('name',$name,50); +print "<P>What's the combination?<P>", + $query->checkbox_group('words',['eenie','meenie','minie','moe']); +print "<P>What's your favorite color? ", + $query->popup_menu('color',['red','green','blue','chartreuse']), + "<P>"; +print $query->submit('form_1','Send Form 1'); +print $query->endform; + +# Print the second form +print "<HR>\n"; +print $query->startform; +print "Some radio buttons: ",$query->radio_group('radio buttons', + [qw{one two three four five}],'three'),"\n"; +print "<P>What's the password? ",$query->password_field('pass','secret'); +print $query->defaults,$query->submit('form_2','Send Form 2'),"\n"; +print $query->endform; + +print "<HR>\n"; + +$query->import_names('Q'); +if ($Q::form_1) { + print "<H2>Form 1 Submitted</H2>\n"; + print "Your name is <EM>$Q::name</EM>\n"; + print "<P>The combination is: <EM>{",join(",",@Q::words),"}</EM>\n"; + print "<P>Your favorite color is <EM>$Q::color</EM>\n"; +} elsif ($Q::form_2) { + print <<EOF; +<H2>Form 2 Submitted</H2> +<P>The value of the radio buttons is <EM>$Q::radio_buttons</EM> +<P>The secret password is <EM>$Q::pass</EM> +EOF + ; +} +print qq{<P><A HREF="./">Other examples</A>}; +print qq{<P><A HREF="../cgi_docs.html">Go to the documentation</A>}; + +print $query->end_html; + + + diff --git a/contrib/perl5/eg/cgi/nph-clock.cgi b/contrib/perl5/eg/cgi/nph-clock.cgi new file mode 100644 index 0000000..55a2fbe --- /dev/null +++ b/contrib/perl5/eg/cgi/nph-clock.cgi @@ -0,0 +1,18 @@ +#!/usr/local/bin/perl -w + +use CGI::Push qw(:standard :html3); + +do_push(-next_page=>\&draw_time,-delay=>1); + +sub draw_time { + my $time = `/bin/date`; + return start_html('Tick Tock'), + div({-align=>CENTER}, + h1('Virtual Clock'), + h2($time) + ), + hr, + a({-href=>'index.html'},'More examples'), + end_html(); +} + diff --git a/contrib/perl5/eg/cgi/nph-multipart.cgi b/contrib/perl5/eg/cgi/nph-multipart.cgi new file mode 100755 index 0000000..f8cea59 --- /dev/null +++ b/contrib/perl5/eg/cgi/nph-multipart.cgi @@ -0,0 +1,10 @@ +#!/usr/local/bin/perl +use CGI qw/:push -nph/; +$| = 1; +print multipart_init(-boundary=>'----------------here we go!'); +while (1) { + print multipart_start(-type=>'text/plain'), + "The current time is ",scalar(localtime),"\n", + multipart_end; + sleep 1; +} diff --git a/contrib/perl5/eg/cgi/popup.cgi b/contrib/perl5/eg/cgi/popup.cgi new file mode 100644 index 0000000..88cea1d --- /dev/null +++ b/contrib/perl5/eg/cgi/popup.cgi @@ -0,0 +1,32 @@ +#!/usr/local/bin/perl + +use CGI; +$query = new CGI; +print $query->header; +print $query->start_html('Popup Window'); + + +if (!$query->param) { + print "<H1>Ask your Question</H1>\n"; + print $query->startform(-target=>'_new'); + print "What's your name? ",$query->textfield('name'); + print "<P>What's the combination?<P>", + $query->checkbox_group(-name=>'words', + -values=>['eenie','meenie','minie','moe'], + -defaults=>['eenie','moe']); + + print "<P>What's your favorite color? ", + $query->popup_menu(-name=>'color', + -values=>['red','green','blue','chartreuse']), + "<P>"; + print $query->submit; + print $query->endform; + +} else { + print "<H1>And the Answer is...</H1>\n"; + print "Your name is <EM>",$query->param(name),"</EM>\n"; + print "<P>The keywords are: <EM>",join(", ",$query->param(words)),"</EM>\n"; + print "<P>Your favorite color is <EM>",$query->param(color),"</EM>\n"; +} +print qq{<P><A HREF="cgi_docs.html">Go to the documentation</A>}; +print $query->end_html; diff --git a/contrib/perl5/eg/cgi/save_state.cgi b/contrib/perl5/eg/cgi/save_state.cgi new file mode 100644 index 0000000..85bacaf --- /dev/null +++ b/contrib/perl5/eg/cgi/save_state.cgi @@ -0,0 +1,67 @@ +#!/usr/local/bin/perl + +use CGI; +$query = new CGI; + +print $query->header; +print $query->start_html("Save and Restore Example"); +print "<H1>Save and Restore Example</H1>\n"; + +# Here's where we take action on the previous request +&save_parameters($query) if $query->param('action') eq 'SAVE'; +$query = &restore_parameters($query) if $query->param('action') eq 'RESTORE'; + +# Here's where we create the form +print $query->start_multipart_form; +print "Popup 1: ",$query->popup_menu('popup1',[qw{red green purple magenta orange chartreuse brown}]),"\n"; +print "Popup 2: ",$query->popup_menu('popup2',[qw{lion tiger bear zebra potto wildebeest frog emu gazelle}]),"\n"; +print "<P>"; +$default_name = $query->remote_addr . '.sav'; +print "Save/restore state from file: ",$query->textfield('savefile',$default_name),"\n"; +print "<P>"; +print $query->submit('action','SAVE'),$query->submit('action','RESTORE'); +print "<P>",$query->defaults; +print $query->endform; + +# Here we print out a bit at the end +print $query->end_html; + +sub save_parameters { + local($query) = @_; + local($filename) = &clean_name($query->param('savefile')); + if (open(FILE,">$filename")) { + $query->save(FILE); + close FILE; + print "<STRONG>State has been saved to file $filename</STRONG>\n"; + print "<P>If you remember this name you can restore the state later.\n"; + } else { + print "<STRONG>Error:</STRONG> couldn't write to file $filename: $!\n"; + } +} + +sub restore_parameters { + local($query) = @_; + local($filename) = &clean_name($query->param('savefile')); + if (open(FILE,$filename)) { + $query = new CGI(FILE); # Throw out the old query, replace it with a new one + close FILE; + print "<STRONG>State has been restored from file $filename</STRONG>\n"; + } else { + print "<STRONG>Error:</STRONG> couldn't restore file $filename: $!\n"; + } + return $query; +} + + +# Very important subroutine -- get rid of all the naughty +# metacharacters from the file name. If there are, we +# complain bitterly and die. +sub clean_name { + local($name) = @_; + unless ($name=~/^[\w\._\-]+$/) { + print "<STRONG>$name has naughty characters. Only "; + print "alphanumerics are allowed. You can't use absolute names.</STRONG>"; + die "Attempt to use naughty characters"; + } + return "WORLD_WRITABLE/$name"; +} diff --git a/contrib/perl5/eg/cgi/tryit.cgi b/contrib/perl5/eg/cgi/tryit.cgi new file mode 100644 index 0000000..83c620c --- /dev/null +++ b/contrib/perl5/eg/cgi/tryit.cgi @@ -0,0 +1,37 @@ +#!/usr/local/bin/perl + +use CGI ':standard'; + +print header; +print start_html('A Simple Example'), + h1('A Simple Example'), + start_form, + "What's your name? ",textfield('name'), + p, + "What's the combination?", + p, + checkbox_group(-name=>'words', + -values=>['eenie','meenie','minie','moe'], + -defaults=>['eenie','minie']), + p, + "What's your favorite color? ", + popup_menu(-name=>'color', + -values=>['red','green','blue','chartreuse']), + p, + submit, + end_form, + hr; + +if (param()) { + print + "Your name is: ",em(param('name')), + p, + "The keywords are: ",em(join(", ",param('words'))), + p, + "Your favorite color is: ",em(param('color')), + hr; +} +print a({href=>'../cgi_docs.html'},'Go to the documentation'); +print end_html; + + diff --git a/contrib/perl5/eg/cgi/wilogo.gif.uu b/contrib/perl5/eg/cgi/wilogo.gif.uu new file mode 100644 index 0000000..c5d1042 --- /dev/null +++ b/contrib/perl5/eg/cgi/wilogo.gif.uu @@ -0,0 +1,13 @@ +begin 444 wilogo.gif +M1TE&.#=A7@!$`(```'X2F?___RP`````7@!$```"_D2.J<#MKF)ZU,A3,[OO +M(IUY']A%9"6AW$F)+#2]Y:BNLF6_\;WMH<?#I72^VP+D"@*)F&"O25KRDM&B +M[%C-7;4_J)*6'4ZE&O`W8"1OQ5UGPWRBIKDPM!MW9J]-[;LUKL;$5W.'YQ3( +M(O<&-^>F*(A55\BX%UEI^;<VB0BH1RFX2=<IELE4^*0'N?-I>OJ8N%(*Z^4G +M.OJJ>8HZ.(>;JRMD><E[!KQHB^3;:APL6Z8\RKPK/)O:*-WLW&7]*\UYR]J) +M?<P=1MR-_6VN76,WGAV^32W^3CZ_SCY3;W__C-R^CU^\%M#T!9PVL(ZZ&>X" +M%A1XSM]!A?T8/C0T$1XMJG\B&G+,"-&C/(VS0(842;`)M'S>_OE8F#"=2S#* +M8LHLAS'D1Y,42UGY9O,F-T:X@@JEE@D1RW>/D@8R.DZ-+*E0CQ:9JJ5JU!SQ +MR&BU2D.;E*4'ER0TNY%G2A/Y.G[=VG%81+5K_UG$21<A6;=YP9'5B++O7:@7 +M\]J5]]?DX7:)%<]5%=B/55>-GQW55;$8L\RW6J8-9>QM7<^A/SMZK!ESY$,+ +(KPA.EJ```#L` +end diff --git a/contrib/perl5/eg/changes b/contrib/perl5/eg/changes new file mode 100644 index 0000000..901e1ed --- /dev/null +++ b/contrib/perl5/eg/changes @@ -0,0 +1,34 @@ +#!/usr/bin/perl -P + +# $RCSfile: changes,v $$Revision: 4.1 $$Date: 92/08/07 17:20:08 $ + +($dir, $days) = @ARGV; +$dir = '/' if $dir eq ''; +$days = '14' if $days eq ''; + +# Masscomps do things differently from Suns + +#if defined(mc300) || defined(mc500) || defined(mc700) +open(Find, "find $dir -mtime -$days -print |") || + die "changes: can't run find"; +#else +open(Find, "find $dir \\( -fstype nfs -prune \\) -o -mtime -$days -ls |") || + die "changes: can't run find"; +#endif + +while (<Find>) { + +#if defined(mc300) || defined(mc500) || defined(mc700) + $x = `/bin/ls -ild $_`; + $_ = $x; + ($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) + = split(' '); +#else + ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) + = split(' '); +#endif + + printf("%10s%3s %-8s %-8s%9s %3s %2s %s\n", + $perm,$links,$owner,$group,$size,$month,$day,$name); +} + diff --git a/contrib/perl5/eg/client b/contrib/perl5/eg/client new file mode 100755 index 0000000..5900c90 --- /dev/null +++ b/contrib/perl5/eg/client @@ -0,0 +1,34 @@ +#!./perl + +$pat = 'S n C4 x8'; +$inet = 2; +$echo = 7; +$smtp = 25; +$nntp = 119; +$test = 2345; + +$SIG{'INT'} = 'dokill'; + +$this = pack($pat,$inet,0, 128,149,13,43); +$that = pack($pat,$inet,$test,127,0,0,1); + +if (socket(S,2,1,6)) { print "socket ok\n"; } else { die $!; } +if (bind(S,$this)) { print "bind ok\n"; } else { die $!; } +if (connect(S,$that)) { print "connect ok\n"; } else { die $!; } + +select(S); $| = 1; select(stdout); + +if ($child = fork) { + while (<STDIN>) { + print S; + } + sleep 3; + do dokill(); +} +else { + while (<S>) { + print; + } +} + +sub dokill { kill 9,$child if $child; } diff --git a/contrib/perl5/eg/down b/contrib/perl5/eg/down new file mode 100755 index 0000000..bbb0d06 --- /dev/null +++ b/contrib/perl5/eg/down @@ -0,0 +1,30 @@ +#!/usr/bin/perl + +$| = 1; +if ($#ARGV >= 0) { + $cmd = join(' ',@ARGV); +} +else { + print "Command: "; + $cmd = <stdin>; + chop($cmd); + while ($cmd =~ s/\\$//) { + print "+ "; + $cmd .= <stdin>; + chop($cmd); + } +} +$cwd = `pwd`; chop($cwd); + +open(FIND,'find . -type d -print|') || die "Can't run find"; + +while (<FIND>) { + chop; + unless (chdir $_) { + print stderr "Can't cd to $_\n"; + next; + } + print "\t--> ",$_,"\n"; + system $cmd; + chdir $cwd; +} diff --git a/contrib/perl5/eg/dus b/contrib/perl5/eg/dus new file mode 100644 index 0000000..3025e2b --- /dev/null +++ b/contrib/perl5/eg/dus @@ -0,0 +1,22 @@ +#!/usr/bin/perl + +# $RCSfile: dus,v $$Revision: 4.1 $$Date: 92/08/07 17:20:11 $ + +# This script does a du -s on any directories in the current directory that +# are not mount points for another filesystem. + +($mydev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('.'); + +open(ls,'ls -F1|'); + +while (<ls>) { + chop; + next unless s|/$||; + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($_); + next unless $dev == $mydev; + push(@ary,$_); +} + +exec 'du', '-s', @ary; diff --git a/contrib/perl5/eg/findcp b/contrib/perl5/eg/findcp new file mode 100644 index 0000000..5dba040 --- /dev/null +++ b/contrib/perl5/eg/findcp @@ -0,0 +1,53 @@ +#!/usr/bin/perl + +# $RCSfile: findcp,v $$Revision: 4.1 $$Date: 92/08/07 17:20:12 $ + +# This is a wrapper around the find command that pretends find has a switch +# of the form -cp host:destination. It presumes your find implements -ls. +# It uses tar to do the actual copy. If your tar knows about the I switch +# you may prefer to use findtar, since this one has to do the tar in batches. + +sub copy { + `tar cf - $list | rsh $desthost cd $destdir '&&' tar xBpf -`; +} + +$sourcedir = $ARGV[0]; +if ($sourcedir =~ /^\//) { + $ARGV[0] = '.'; + unless (chdir($sourcedir)) { die "Can't find directory $sourcedir: $!"; } +} + +$args = join(' ',@ARGV); +if ($args =~ s/-cp *([^ ]+)/-ls/) { + $dest = $1; + if ($dest =~ /(.*):(.*)/) { + $desthost = $1; + $destdir = $2; + } + else { + die "Malformed destination--should be host:directory"; + } +} +else { + die("No destination specified"); +} + +open(find,"find $args |") || die "Can't run find for you: $!"; + +while (<find>) { + @x = split(' '); + if ($x[2] =~ /^d/) { next;} + chop($filename = $x[10]); + if (length($list) > 5000) { + do copy(); + $list = ''; + } + else { + $list .= ' '; + } + $list .= $filename; +} + +if ($list) { + do copy(); +} diff --git a/contrib/perl5/eg/findtar b/contrib/perl5/eg/findtar new file mode 100644 index 0000000..6462f66 --- /dev/null +++ b/contrib/perl5/eg/findtar @@ -0,0 +1,17 @@ +#!/usr/bin/perl + +# $RCSfile: findtar,v $$Revision: 4.1 $$Date: 92/08/07 17:20:13 $ + +# findtar takes find-style arguments and spits out a tarfile on stdout. +# It won't work unless your find supports -ls and your tar the I flag. + +$args = join(' ',@ARGV); +open(find,"/usr/bin/find $args -ls |") || die "Can't run find for you."; + +open(tar,"| /bin/tar cIf - -") || die "Can't run tar for you: $!"; + +while (<find>) { + @x = split(' '); + if ($x[2] =~ /^d/) { print tar '-d ';} + print tar $x[10],"\n"; +} diff --git a/contrib/perl5/eg/g/gcp b/contrib/perl5/eg/g/gcp new file mode 100644 index 0000000..d18b6f6 --- /dev/null +++ b/contrib/perl5/eg/g/gcp @@ -0,0 +1,114 @@ +#!/usr/bin/perl + +# $RCSfile: gcp,v $$Revision: 4.1 $$Date: 92/08/07 17:20:15 $ + +# Here is a script to do global rcps. See man page. + +$#ARGV >= 1 || die "Not enough arguments.\n"; + +if ($ARGV[0] eq '-r') { + $rcp = 'rcp -r'; + shift; +} else { + $rcp = 'rcp'; +} +$args = $rcp; +$dest = $ARGV[$#ARGV]; + +$SIG{'QUIT'} = 'CLEANUP'; +$SIG{'INT'} = 'CONT'; + +while ($arg = shift) { + if ($arg =~ /^([-a-zA-Z0-9_+]+):/) { + if ($systype && $systype ne $1) { + die "Can't mix system type specifers ($systype vs $1).\n"; + } + $#ARGV < 0 || $arg !~ /:$/ || die "No source file specified.\n"; + $systype = $1; + $args .= " $arg"; + } else { + if ($#ARGV >= 0) { + if ($arg =~ /^[\/~]/) { + $arg =~ /^(.*)\// && ($dir = $1); + } else { + if (!$pwd) { + chop($pwd = `pwd`); + } + $dir = $pwd; + } + } + if ($olddir && $dir ne $olddir && $dest =~ /:$/) { + $args .= " $dest$olddir; $rcp"; + } + $olddir = $dir; + $args .= " $arg"; + } +} + +die "No system type specified.\n" unless $systype; + +$args =~ s/:$/:$olddir/; + +chop($thishost = `hostname`); + +$one_of_these = ":$systype:"; +if ($systype =~ s/\+/[+]/g) { + $one_of_these =~ s/\+/:/g; +} +$one_of_these =~ s/-/:-/g; + +@ARGV = (); +push(@ARGV,'.grem') if -f '.grem'; +push(@ARGV,'.ghosts') if -f '.ghosts'; +push(@ARGV,'/etc/ghosts'); + +$remainder = ''; + +line: while (<>) { + s/[ \t]*\n//; + if (!$_ || /^#/) { + next line; + } + if (/^([a-zA-Z_0-9]+)=(.+)/) { + $name = $1; $repl = $2; + $repl =~ s/\+/:/g; + $repl =~ s/-/:-/g; + $one_of_these =~ s/:$name:/:$repl:/; + $repl =~ s/:/:-/g; + $one_of_these =~ s/:-$name:/:-$repl:/g; + next line; + } + @gh = split(' '); + $host = $gh[0]; + next line if $host eq $thishost; # should handle aliases too + $wanted = 0; + foreach $class (@gh) { + $wanted++ if index($one_of_these,":$class:") >= 0; + $wanted = -9999 if index($one_of_these,":-$class:") >= 0; + } + if ($wanted > 0) { + ($cmd = $args) =~ s/[ \t]$systype:/ $host:/g; + print "$cmd\n"; + $result = `$cmd 2>&1`; + $remainder .= "$host+" if + $result =~ /Connection timed out|Permission denied/; + print $result; + } +} + +if ($remainder) { + chop($remainder); + open(grem,">.grem") || (printf stderr "Can't create .grem: $!\n"); + print grem 'rem=', $remainder, "\n"; + close(grem); + print 'rem=', $remainder, "\n"; +} + +sub CLEANUP { + exit; +} + +sub CONT { + print "Continuing...\n"; # Just ignore the signal that kills rcp + $remainder .= "$host+"; +} diff --git a/contrib/perl5/eg/g/gcp.man b/contrib/perl5/eg/g/gcp.man new file mode 100644 index 0000000..1198554 --- /dev/null +++ b/contrib/perl5/eg/g/gcp.man @@ -0,0 +1,77 @@ +.\" $RCSfile: gcp.man,v $$Revision: 4.1 $$Date: 92/08/07 17:20:17 $ +.TH GCP 1C "13 May 1988" +.SH NAME +gcp \- global file copy +.SH SYNOPSIS +.B gcp +file1 file2 +.br +.B gcp +[ +.B \-r +] file ... directory +.SH DESCRIPTION +.I gcp +works just like rcp(1C) except that you may specify a set of hosts to copy files +from or to. +The host sets are defined in the file /etc/ghosts. +(An individual host name can be used as a set containing one member.) +You can give a command like + + gcp /etc/motd sun: + +to copy your /etc/motd file to /etc/motd on all the Suns. +If, on the other hand, you say + + gcp /a/foo /b/bar sun:/tmp + +then your files will be copied to /tmp on all the Suns. +The general rule is that if you don't specify the destination directory, +files go to the same directory they are in currently. +.P +You may specify the union of two or more sets by using + as follows: + + gcp /a/foo /b/bar 750+mc: + +which will copy /a/foo to /a/foo on all 750's and Masscomps, and then copy +/b/bar to /b/bar on all 750's and Masscomps. +.P +Commonly used sets should be defined in /etc/ghosts. +For example, you could add a line that says + + pep=manny+moe+jack + +Another way to do that would be to add the word "pep" after each of the host +entries: + + manny sun3 pep +.br + moe sun3 pep +.br + jack sun3 pep + +Hosts and sets of host can also be excluded: + + foo=sun-sun2 + +Any host so excluded will never be included, even if a subsequent set on the +line includes it: + + foo=abc+def +.br + bar=xyz-abc+foo + +comes out to xyz+def. + +You can define private host sets by creating .ghosts in your current directory +with entries just like /etc/ghosts. +Also, if there is a file .grem, it defines "rem" to be the remaining hosts +from the last gsh or gcp that didn't succeed everywhere. +.PP +Interrupting with a SIGINT will cause the rcp to the current host to be skipped +and execution resumed with the next host. +To stop completely, send a SIGQUIT. +.SH SEE ALSO +rcp(1C) +.SH BUGS +All the bugs of rcp, since it calls rcp. diff --git a/contrib/perl5/eg/g/ged b/contrib/perl5/eg/g/ged new file mode 100644 index 0000000..07ac88f --- /dev/null +++ b/contrib/perl5/eg/g/ged @@ -0,0 +1,21 @@ +#!/usr/bin/perl + +# $RCSfile: ged,v $$Revision: 4.1 $$Date: 92/08/07 17:20:18 $ + +# Does inplace edits on a set of files on a set of machines. +# +# Typical invokation: +# +# ged vax+sun /etc/passwd +# s/Freddy/Freddie/; +# ^D +# + +$class = shift; +$files = join(' ',@ARGV); + +die "Usage: ged class files <perlcmds\n" unless $files; + +exec "gsh", $class, "-d", "perl -pi.bak - $files"; + +die "Couldn't execute gsh for some reason, stopped"; diff --git a/contrib/perl5/eg/g/ghosts b/contrib/perl5/eg/g/ghosts new file mode 100644 index 0000000..96ec771 --- /dev/null +++ b/contrib/perl5/eg/g/ghosts @@ -0,0 +1,33 @@ +# This first section gives alternate sets defined in terms of the sets given +# by the second section. The order is important--all references must be +# forward references. + +Nnd=sun-nd +all=sun+mc+vax +baseline=sun+mc +sun=sun2+sun3 +vax=750+8600 +pep=manny+moe+jack + +# This second section defines the basic sets. Each host should have a line +# that specifies which sets it is a member of. Extra sets should be separated +# by white space. (The first section isn't strictly necessary, since all sets +# could be defined in the second section, but then it wouldn't be so readable.) + +basvax 8600 src +cdb0 sun3 sys +cdb1 sun3 sys +cdb2 sun3 sys +chief sun3 src +tis0 sun3 +manny sun3 sys +moe sun3 sys +jack sun3 sys +disney sun3 sys +huey sun3 nd +dewey sun3 nd +louie sun3 nd +bizet sun2 src sys +gif0 mc src +mc0 mc +dtv0 mc diff --git a/contrib/perl5/eg/g/gsh b/contrib/perl5/eg/g/gsh new file mode 100644 index 0000000..4bc5d87 --- /dev/null +++ b/contrib/perl5/eg/g/gsh @@ -0,0 +1,117 @@ +#! /usr/bin/perl + +# $RCSfile: gsh,v $$Revision: 4.1 $$Date: 92/08/07 17:20:20 $ + +# Do rsh globally--see man page + +$SIG{'QUIT'} = 'quit'; # install signal handler for SIGQUIT + +sub getswitches { + while ($ARGV[0] =~ /^-/) { # parse switches + $ARGV[0] =~ /^-h/ && ($showhost++,$silent++,shift(@ARGV),next); + $ARGV[0] =~ /^-s/ && ($silent++,shift(@ARGV),next); + $ARGV[0] =~ /^-d/ && ($dodist++,shift(@ARGV),next); + $ARGV[0] =~ /^-n/ && ($n=' -n',shift(@ARGV),next); + $ARGV[0] =~ /^-l/ && ($l=' -l ' . $ARGV[1],shift(@ARGV),shift(@ARGV), + next); + last; + } +} + +do getswitches(); # get any switches before class +$systype = shift; # get name representing set of hosts +do getswitches(); # same switches allowed after class + +if ($dodist) { # distribute input over all rshes? + `cat >/tmp/gsh$$`; # get input into a handy place + $dist = " </tmp/gsh$$"; # each rsh takes input from there +} + +$cmd = join(' ',@ARGV); # remaining args constitute the command +$cmd =~ s/'/'"'"'/g; # quote any embedded single quotes + +$one_of_these = ":$systype:"; # prepare to expand "macros" +$one_of_these =~ s/\+/:/g; # we hope to end up with list of +$one_of_these =~ s/-/:-/g; # colon separated attributes + +@ARGV = (); +push(@ARGV,'.grem') if -f '.grem'; +push(@ARGV,'.ghosts') if -f '.ghosts'; +push(@ARGV,'/etc/ghosts'); + +$remainder = ''; + +line: while (<>) { # for each line of ghosts + + s/[ \t]*\n//; # trim trailing whitespace + if (!$_ || /^#/) { # skip blank line or comment + next line; + } + + if (/^(\w+)=(.+)/) { # a macro line? + $name = $1; $repl = $2; + $repl =~ s/\+/:/g; + $repl =~ s/-/:-/g; + $one_of_these =~ s/:$name:/:$repl:/; # do expansion in "wanted" list + $repl =~ s/:/:-/g; + $one_of_these =~ s/:-$name:/:-$repl:/; + next line; + } + + # we have a normal line + + @attr = split(' '); # a list of attributes to match against + # which we put into an array + $host = $attr[0]; # the first attribute is the host name + if ($showhost) { + $showhost = "$host:\t"; + } + + $wanted = 0; + foreach $attr (@attr) { # iterate over attribute array + $wanted++ if index($one_of_these,":$attr:") >= 0; + $wanted = -9999 if index($one_of_these,":-$attr:") >= 0; + } + if ($wanted > 0) { + print "rsh $host$l$n '$cmd'\n" unless $silent; + $SIG{'INT'} = 'DEFAULT'; + if (open(PIPE,"rsh $host$l$n '$cmd'$dist 2>&1|")) { # start an rsh + $SIG{'INT'} = 'cont'; + for ($iter=0; <PIPE>; $iter++) { + unless ($iter) { + $remainder .= "$host+" + if /Connection timed out|Permission denied/; + } + print $showhost,$_; + } + close(PIPE); + } else { + print "(Can't execute rsh: $!)\n"; + $SIG{'INT'} = 'cont'; + } + } +} + +unlink "/tmp/gsh$$" if $dodist; + +if ($remainder) { + chop($remainder); + open(grem,">.grem") || (printf stderr "Can't make a .grem file: $!\n"); + print grem 'rem=', $remainder, "\n"; + close(grem); + print 'rem=', $remainder, "\n"; +} + +# here are a couple of subroutines that serve as signal handlers + +sub cont { + print "\rContinuing...\n"; + $remainder .= "$host+"; +} + +sub quit { + $| = 1; + print "\r"; + $SIG{'INT'} = ''; + kill 2, $$; +} diff --git a/contrib/perl5/eg/g/gsh.man b/contrib/perl5/eg/g/gsh.man new file mode 100644 index 0000000..2958707 --- /dev/null +++ b/contrib/perl5/eg/g/gsh.man @@ -0,0 +1,80 @@ +.\" $RCSfile: gsh.man,v $$Revision: 4.1 $$Date: 92/08/07 17:20:22 $ +.TH GSH 8 "13 May 1988" +.SH NAME +gsh \- global shell +.SH SYNOPSIS +.B gsh +[options] +.I host +[options] +.I command +.SH DESCRIPTION +.I gsh +works just like rsh(1C) except that you may specify a set of hosts to execute +the command on. +The host sets are defined in the file /etc/ghosts. +(An individual host name can be used as a set containing one member.) +You can give a command like + + gsh sun /etc/mungmotd + +to run /etc/mungmotd on all your Suns. +.P +You may specify the union of two or more sets by using + as follows: + + gsh 750+mc /etc/mungmotd + +which will run mungmotd on all 750's and Masscomps. +.P +Commonly used sets should be defined in /etc/ghosts. +For example, you could add a line that says + + pep=manny+moe+jack + +Another way to do that would be to add the word "pep" after each of the host +entries: + + manny sun3 pep +.br + moe sun3 pep +.br + jack sun3 pep + +Hosts and sets of host can also be excluded: + + foo=sun-sun2 + +Any host so excluded will never be included, even if a subsequent set on the +line includes it: + + foo=abc+def + bar=xyz-abc+foo + +comes out to xyz+def. + +You can define private host sets by creating .ghosts in your current directory +with entries just like /etc/ghosts. +Also, if there is a file .grem, it defines "rem" to be the remaining hosts +from the last gsh or gcp that didn't succeed everywhere. + +Options include all those defined by rsh, as well as + +.IP "\-d" 8 +Causes gsh to collect input till end of file, and then distribute that input +to each invokation of rsh. +.IP "\-h" 8 +Rather than print out the command followed by the output, merely prepends the +host name to each line of output. +.IP "\-s" 8 +Do work silently. +.PP +Interrupting with a SIGINT will cause the rsh to the current host to be skipped +and execution resumed with the next host. +To stop completely, send a SIGQUIT. +.SH SEE ALSO +rsh(1C) +.SH BUGS +All the bugs of rsh, since it calls rsh. + +Also, will not properly return data from the remote execution that contains +null characters. diff --git a/contrib/perl5/eg/muck b/contrib/perl5/eg/muck new file mode 100644 index 0000000..873539b --- /dev/null +++ b/contrib/perl5/eg/muck @@ -0,0 +1,141 @@ +#!../perl + +$M = '-M'; +$M = '-m' if -d '/usr/uts' && -f '/etc/master'; + +do 'getopt.pl'; +do Getopt('f'); + +if ($opt_f) { + $makefile = $opt_f; +} +elsif (-f 'makefile') { + $makefile = 'makefile'; +} +elsif (-f 'Makefile') { + $makefile = 'Makefile'; +} +else { + die "No makefile\n"; +} + +$MF = 'mf00'; + +while(($key,$val) = each(ENV)) { + $mac{$key} = $val; +} + +do scan($makefile); + +$co = $action{'.c.o'}; +$co = ' ' unless $co; + +$missing = "Missing dependencies:\n"; +foreach $key (sort keys(o)) { + if ($oc{$key}) { + $src = $oc{$key}; + $action = $action{$key}; + } + else { + $action = ''; + } + if (!$action) { + if ($co && ($c = $key) =~ s/\.o$/.c/ && -f $c) { + $src = $c; + $action = $co; + } + else { + print "No source found for $key $c\n"; + next; + } + } + $I = ''; + $D = ''; + $I .= $1 while $action =~ s/(-I\S+\s*)//; + $D .= $1 . ' ' while $action =~ s/(-D\w+)//; + if ($opt_v) { + $cmd = "Checking $key: cc $M $D $I $src"; + $cmd =~ s/\s\s+/ /g; + print stderr $cmd,"\n"; + } + open(CPP,"cc $M $D $I $src|") || die "Can't run C preprocessor: $!"; + while (<CPP>) { + ($name,$dep) = split; + $dep =~ s|^\./||; + (print $missing,"$key: $dep\n"),($missing='') + unless ($dep{"$key: $dep"} += 2) > 2; + } +} + +$extra = "\nExtraneous dependencies:\n"; +foreach $key (sort keys(dep)) { + if ($key =~ /\.o: .*\.h$/ && $dep{$key} == 1) { + print $extra,$key,"\n"; + $extra = ''; + } +} + +sub scan { + local($makefile) = @_; + local($MF) = $MF; + print stderr "Analyzing $makefile.\n" if $opt_v; + $MF++; + open($MF,$makefile) || die "Can't open $makefile: $!"; + while (<$MF>) { + chop; + chop($_ = $_ . <$MF>) while s/\\$//; + next if /^#/; + next if /^$/; + s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg; + s/\$\((\w+)\)/$mac{$1}/eg; + $mac{$1} = $2, next if /^(\w+)\s*=\s*(.*)/; + if (/^include\s+(.*)/) { + do scan($1); + print stderr "Continuing $makefile.\n" if $opt_v; + next; + } + if (/^([^:]+):\s*(.*)/) { + $left = $1; + $right = $2; + if ($right =~ /^([^;]*);(.*)/) { + $right = $1; + $action = $2; + } + else { + $action = ''; + } + while (<$MF>) { + last unless /^\t/; + chop; + chop($_ = $_ . <$MF>) while s/\\$//; + next if /^#/; + last if /^$/; + s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg; + s/\$\((\w+)\)/$mac{$1}/eg; + $action .= $_; + } + foreach $targ (split(' ',$left)) { + $targ =~ s|^\./||; + foreach $src (split(' ',$right)) { + $src =~ s|^\./||; + $deplist{$targ} .= ' ' . $src; + $dep{"$targ: $src"} = 1; + $o{$src} = 1 if $src =~ /\.o$/; + $oc{$targ} = $src if $targ =~ /\.o$/ && $src =~ /\.[yc]$/; + } + $action{$targ} .= $action; + } + redo if $_; + } + } + close($MF); +} + +sub subst { + local($foo,$from,$to) = @_; + $foo = $mac{$foo}; + $from =~ s/\./[.]/; + y/a/a/; + $foo =~ s/\b$from\b/$to/g; + $foo; +} diff --git a/contrib/perl5/eg/muck.man b/contrib/perl5/eg/muck.man new file mode 100644 index 0000000..02ae428 --- /dev/null +++ b/contrib/perl5/eg/muck.man @@ -0,0 +1,21 @@ +.\" $RCSfile: muck.man,v $$Revision: 4.1 $$Date: 92/08/07 17:20:23 $ +.TH MUCK 1 "10 Jan 1989" +.SH NAME +muck \- make usage checker +.SH SYNOPSIS +.B muck +[options] +.SH DESCRIPTION +.I muck +looks at your current makefile and complains if you've left out any dependencies +between .o and .h files. +It also complains about extraneous dependencies. +.PP +You can use the -f FILENAME option to specify an alternate name for your +makefile. +The -v option is a little more verbose about what muck is mucking around +with at the moment. +.SH SEE ALSO +make(1) +.SH BUGS +Only knows about .h, .c and .o files. diff --git a/contrib/perl5/eg/myrup b/contrib/perl5/eg/myrup new file mode 100644 index 0000000..2cbdf75 --- /dev/null +++ b/contrib/perl5/eg/myrup @@ -0,0 +1,29 @@ +#!/usr/bin/perl + +# $RCSfile: myrup,v $$Revision: 4.1 $$Date: 92/08/07 17:20:26 $ + +# This was a customization of ruptime requested by someone here who wanted +# to be able to find the least loaded machine easily. It uses the +# /etc/ghosts file that's defined for gsh and gcp to prune down the +# number of entries to those hosts we have administrative control over. + +print "node load (u)\n------- --------\n"; + +open(ghosts,'/etc/ghosts') || die "Can't open /etc/ghosts: $!"; +line: while (<ghosts>) { + next line if /^#/; + next line if /^$/; + next line if /=/; + ($host) = split; + $wanted{$host} = 1; +} + +open(ruptime,'ruptime|') || die "Can't run ruptime: $!"; +open(sort,'|sort +1n'); + +while (<ruptime>) { + ($host,$upness,$foo,$users,$foo,$foo,$load) = split(/[\s,]+/); + if ($wanted{$host} && $upness eq 'up') { + printf sort "%s\t%s (%d)\n", $host, $load, $users; + } +} diff --git a/contrib/perl5/eg/nih b/contrib/perl5/eg/nih new file mode 100644 index 0000000..4475c49 --- /dev/null +++ b/contrib/perl5/eg/nih @@ -0,0 +1,11 @@ +eval 'exec /usr/bin/perl -Spi.bak $0 ${1+"$@"}' + if $running_under_some_shell; + +# $RCSfile: nih,v $$Revision: 4.1 $$Date: 92/08/07 17:20:27 $ + +# This script makes #! scripts directly executable on machines that don't +# support #!. It edits in place any scripts mentioned on the command line. + +s[^#!(.*)] + [#!$1\neval 'exec $1 -S \$0 \${1+"\$@"}'\n\tif \$running_under_some_shell;] + if $. == 1; diff --git a/contrib/perl5/eg/relink b/contrib/perl5/eg/relink new file mode 100644 index 0000000..2c5793f --- /dev/null +++ b/contrib/perl5/eg/relink @@ -0,0 +1,82 @@ +#!/usr/bin/perl +'di'; +'ig00'; +# +# $RCSfile: relink,v $$Revision: 4.1 $$Date: 92/08/07 17:20:29 $ +# +# $Log: relink,v $ + +($op = shift) || die "Usage: relink perlexpr [filenames]\n"; +if (!@ARGV) { + @ARGV = <STDIN>; + chop(@ARGV); +} +for (@ARGV) { + next unless -l; # symbolic link? + $name = $_; + $_ = readlink($_); + $was = $_; + eval $op; + die $@ if $@; + if ($was ne $_) { + unlink($name); + symlink($_, $name); + } +} +############################################################################## + + # These next few lines are legal in both Perl and nroff. + +.00; # finish .ig + +'di \" finish diversion--previous line must be blank +.nr nl 0-1 \" fake up transition to first page again +.nr % 0 \" start at page 1 +';<<'.ex'; #__END__ ############# From here on it's a standard manual page ############ +.TH RELINK 1 "July 30, 1990" +.AT 3 +.SH LINK +relink \- relinks multiple symbolic links +.SH SYNOPSIS +.B relink perlexpr [symlinknames] +.SH DESCRIPTION +.I Relink +relinks the symbolic links given according to the rule specified as the +first argument. +The argument is a Perl expression which is expected to modify the $_ +string in Perl for at least some of the names specified. +For each symbolic link named on the command line, the Perl expression +will be executed on the contents of the symbolic link with that name. +If a given symbolic link's contents is not modified by the expression, +it will not be changed. +If a name given on the command line is not a symbolic link, it will be ignored. +If no names are given on the command line, names will be read +via standard input. +.PP +For example, to relink all symbolic links in the current directory +pointing to somewhere in X11R3 so that they point to X11R4, you might say +.nf + + relink 's/X11R3/X11R4/' * + +.fi +To change all occurences of links in the system from /usr/spool to /var/spool, +you'd say +.nf + + find / -type l -print | relink 's#/usr/spool#/var/spool#' + +.fi +.SH ENVIRONMENT +No environment variables are used. +.SH FILES +.SH AUTHOR +Larry Wall +.SH "SEE ALSO" +ln(1) +.br +perl(1) +.SH DIAGNOSTICS +If you give an invalid Perl expression you'll get a syntax error. +.SH BUGS +.ex diff --git a/contrib/perl5/eg/rename b/contrib/perl5/eg/rename new file mode 100755 index 0000000..10e97f7 --- /dev/null +++ b/contrib/perl5/eg/rename @@ -0,0 +1,74 @@ +#!/usr/bin/perl +'di'; +'ig00'; +# +# $RCSfile: rename,v $$Revision: 4.1 $$Date: 92/08/07 17:20:30 $ +# +# $Log: rename,v $ + +($op = shift) || die "Usage: rename perlexpr [filenames]\n"; +if (!@ARGV) { + @ARGV = <STDIN>; + chop(@ARGV); +} +for (@ARGV) { + $was = $_; + eval $op; + die $@ if $@; + rename($was,$_) unless $was eq $_; +} +############################################################################## + + # These next few lines are legal in both Perl and nroff. + +.00; # finish .ig + +'di \" finish diversion--previous line must be blank +.nr nl 0-1 \" fake up transition to first page again +.nr % 0 \" start at page 1 +';<<'.ex'; #__END__ ############# From here on it's a standard manual page ############ +.TH RENAME 1 "July 30, 1990" +.AT 3 +.SH NAME +rename \- renames multiple files +.SH SYNOPSIS +.B rename perlexpr [files] +.SH DESCRIPTION +.I Rename +renames the filenames supplied according to the rule specified as the +first argument. +The argument is a Perl expression which is expected to modify the $_ +string in Perl for at least some of the filenames specified. +If a given filename is not modified by the expression, it will not be +renamed. +If no filenames are given on the command line, filenames will be read +via standard input. +.PP +For example, to rename all files matching *.bak to strip the extension, +you might say +.nf + + rename 's/\e.bak$//' *.bak + +.fi +To translate uppercase names to lower, you'd use +.nf + + rename 'y/A-Z/a-z/' * + +.fi +.SH ENVIRONMENT +No environment variables are used. +.SH FILES +.SH AUTHOR +Larry Wall +.SH "SEE ALSO" +mv(1) +.br +perl(1) +.SH DIAGNOSTICS +If you give an invalid Perl expression you'll get a syntax error. +.SH BUGS +.I Rename +does not check for the existence of target filenames, so use with care. +.ex diff --git a/contrib/perl5/eg/rmfrom b/contrib/perl5/eg/rmfrom new file mode 100644 index 0000000..7178e77 --- /dev/null +++ b/contrib/perl5/eg/rmfrom @@ -0,0 +1,7 @@ +#!/usr/bin/perl -n + +# $RCSfile: rmfrom,v $$Revision: 4.1 $$Date: 92/08/07 17:20:31 $ + +# A handy (but dangerous) script to put after a find ... -print. + +chop; unlink; diff --git a/contrib/perl5/eg/scan/scan_df b/contrib/perl5/eg/scan/scan_df new file mode 100644 index 0000000..c221cdc --- /dev/null +++ b/contrib/perl5/eg/scan/scan_df @@ -0,0 +1,51 @@ +#!/usr/bin/perl -P + +# $RCSfile: scan_df,v $$Revision: 4.1 $$Date: 92/08/07 17:20:33 $ + +# This report points out filesystems that are in danger of overflowing. + +(chdir '/usr/adm/private/memories') || die "Can't cd to memories: $!\n"; +`df >newdf`; +open(Df, 'olddf'); + +while (<Df>) { + ($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split; + next if $fs =~ /:/; + next if $fs eq ''; + $oldused{$fs} = $used; +} + +open(Df, 'newdf') || die "scan_df: can't open newdf"; + +while (<Df>) { + ($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split; + next if $fs =~ /:/; + next if $fs eq ''; + $oldused = $oldused{$fs}; + next if ($oldused == $used && $capacity < 99); # inactive filesystem + if ($capacity >= 90) { +#if defined(mc300) || defined(mc500) || defined(mc700) + $_ = substr($_,0,13) . ' ' . substr($_,13,1000); + $kbytes /= 2; # translate blocks to K + $used /= 2; + $oldused /= 2; + $avail /= 2; +#endif + $diff = int($used - $oldused); + if ($avail < $diff * 2) { # mark specially if in danger + $mounted_on .= ' *'; + } + next if $diff < 50 && $mounted_on eq '/'; + $fs =~ s|/dev/||; + if ($diff >= 0) { + $diff = '(+' . $diff . ')'; + } + else { + $diff = '(' . $diff . ')'; + } + printf "%-8s%8d%8d %-8s%8d%7s %s\n", + $fs,$kbytes,$used,$diff,$avail,$capacity,$mounted_on; + } +} + +rename('newdf','olddf'); diff --git a/contrib/perl5/eg/scan/scan_last b/contrib/perl5/eg/scan/scan_last new file mode 100644 index 0000000..4d15ca0 --- /dev/null +++ b/contrib/perl5/eg/scan/scan_last @@ -0,0 +1,57 @@ +#!/usr/bin/perl -P + +# $RCSfile: scan_last,v $$Revision: 4.1 $$Date: 92/08/07 17:20:35 $ + +# This reports who was logged on at weird hours + +($dy, $mo, $lastdt) = split(/ +/,`date`); + +open(Last, 'exec last 2>&1 |') || die "scan_last: can't run last"; + +while (<Last>) { +#if defined(mc300) || defined(mc500) || defined(mc700) + $_ = substr($_,0,19) . substr($_,23,100); +#endif + next if /^$/; + (print),next if m|^/|; + $login = substr($_,0,8); + $tty = substr($_,10,7); + $from = substr($_,19,15); + $day = substr($_,36,3); + $mo = substr($_,40,3); + $dt = substr($_,44,2); + $hr = substr($_,47,2); + $min = substr($_,50,2); + $dash = substr($_,53,1); + $tohr = substr($_,55,2); + $tomin = substr($_,58,2); + $durhr = substr($_,63,2); + $durmin = substr($_,66,2); + + next unless $hr; + next if $login eq 'reboot '; + next if $login eq 'shutdown'; + + if ($dt != $lastdt) { + if ($lastdt < $dt) { + $seen += $dt - $lastdt; + } + else { + $seen++; + } + $lastdt = $dt; + } + + $inat = $hr + $min / 60; + if ($tohr =~ /^[a-z]/) { + $outat = 12; # something innocuous + } else { + $outat = $tohr + $tomin / 60; + } + + last if $seen + ($inat < 8) > 1; + + if ($inat < 5 || $inat > 21 || $outat < 6 || $outat > 23) { + print; + } +} diff --git a/contrib/perl5/eg/scan/scan_messages b/contrib/perl5/eg/scan/scan_messages new file mode 100644 index 0000000..6cf0997 --- /dev/null +++ b/contrib/perl5/eg/scan/scan_messages @@ -0,0 +1,222 @@ +#!/usr/bin/perl -P + +# $RCSfile: scan_messages,v $$Revision: 4.1 $$Date: 92/08/07 17:20:37 $ + +# This prints out extraordinary console messages. You'll need to customize. + +chdir('/usr/adm/private/memories') || die "Can't cd to memories: $!\n"; + +$maxpos = `cat oldmsgs 2>&1`; + +#if defined(mc300) || defined(mc500) || defined(mc700) +open(Msgs, '/dev/null') || die "scan_messages: can't open messages"; +#else +open(Msgs, '/usr/adm/messages') || die "scan_messages: can't open messages"; +#endif + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat(Msgs); + +if ($size < $maxpos) { # Did somebody truncate messages file? + $maxpos = 0; +} + +seek(Msgs,$maxpos,0); # Start where we left off last time. + +while (<Msgs>) { + s/\[(\d+)\]/#/ && s/$1/#/g; +#ifdef vax + $_ =~ s/[A-Z][a-z][a-z] +\w+ +[0-9:]+ +\w+ +//; + next if /root@.*:/; + next if /^vmunix: 4.3 BSD UNIX/; + next if /^vmunix: Copyright/; + next if /^vmunix: avail mem =/; + next if /^vmunix: SBIA0 at /; + next if /^vmunix: disk ra81 is/; + next if /^vmunix: dmf. at uba/; + next if /^vmunix: dmf.:.*asynch/; + next if /^vmunix: ex. at uba/; + next if /^vmunix: ex.: HW/; + next if /^vmunix: il. at uba/; + next if /^vmunix: il.: hardware/; + next if /^vmunix: ra. at uba/; + next if /^vmunix: ra.: media/; + next if /^vmunix: real mem/; + next if /^vmunix: syncing disks/; + next if /^vmunix: tms/; + next if /^vmunix: tmscp. at uba/; + next if /^vmunix: uba. at /; + next if /^vmunix: uda. at /; + next if /^vmunix: uda.: unit . ONLIN/; + next if /^vmunix: .*buffers containing/; + next if /^syslogd: .*newslog/; +#endif + next if /unknown service/; + next if /^\.\.\.$/; + if (/^[A-Z][a-z][a-z] [ 0-9][0-9] [ 0-9][0-9]:[0-9][0-9]/) { + $pfx = ''; + next; + } + next if /^[ \t]*$/; + next if /^[ 0-9]*done$/; + if (/^A/) { + next if /^Accounting [sr]/; + } + elsif (/^C/) { + next if /^Called from/; + next if /^Copyright/; + } + elsif (/^E/) { + next if /^End traceback/; + next if /^Ethernet address =/; + } + elsif (/^K/) { + next if /^KERNEL MODE/; + } + elsif (/^R/) { + next if /^Rebooting Unix/; + } + elsif (/^S/) { + next if /^Sun UNIX 4\.2 Release/; + } + elsif (/^W/) { + next if /^WARNING: clock gained/; + } + elsif (/^a/) { + next if /^arg /; + next if /^avail mem =/; + } + elsif (/^b/) { + next if /^bwtwo[0-9] at /; + } + elsif (/^c/) { + next if /^cgone[0-9] at /; + next if /^cdp[0-9] at /; + next if /^csr /; + } + elsif (/^d/) { + next if /^dcpa: init/; + next if /^done$/; + next if /^dts/; + next if /^dump i\/o error/; + next if /^dumping to dev/; + next if /^dump succeeded/; + $pfx = '*' if /^dev = /; + } + elsif (/^e/) { + next if /^end \*\*/; + next if /^error in copy/; + } + elsif (/^f/) { + next if /^found /; + } + elsif (/^i/) { + next if /^ib[0-9] at /; + next if /^ie[0-9] at /; + } + elsif (/^l/) { + next if /^le[0-9] at /; + } + elsif (/^m/) { + next if /^mem = /; + next if /^mt[0-9] at /; + next if /^mti[0-9] at /; + $pfx = '*' if /^mode = /; + } + elsif (/^n/) { + next if /^not found /; + } + elsif (/^p/) { + next if /^page map /; + next if /^pi[0-9] at /; + $pfx = '*' if /^panic/; + } + elsif (/^q/) { + next if /^qqq /; + } + elsif (/^r/) { + next if /^read /; + next if /^revarp: Requesting/; + next if /^root [od]/; + } + elsif (/^s/) { + next if /^sc[0-9] at /; + next if /^sd[0-9] at /; + next if /^sd[0-9]: </; + next if /^si[0-9] at /; + next if /^si_getstatus/; + next if /^sk[0-9] at /; + next if /^skioctl/; + next if /^skopen/; + next if /^skprobe/; + next if /^skread/; + next if /^skwrite/; + next if /^sky[0-9] at /; + next if /^st[0-9] at /; + next if /^st0:.*load/; + next if /^stat1 = /; + next if /^syncing disks/; + next if /^syslogd: going down on signal 15/; + } + elsif (/^t/) { + next if /^timeout [0-9]/; + next if /^tm[0-9] at /; + next if /^tod[0-9] at /; + next if /^tv [0-9]/; + $pfx = '*' if /^trap address/; + } + elsif (/^u/) { + next if /^unit nsk/; + next if /^use one of/; + $pfx = '' if /^using/; + next if /^using [0-9]+ buffers/; + } + elsif (/^x/) { + next if /^xy[0-9] at /; + next if /^write [0-9]/; + next if /^xy[0-9]: </; + next if /^xyc[0-9] at /; + } + elsif (/^y/) { + next if /^yyy [0-9]/; + } + elsif (/^z/) { + next if /^zs[0-9] at /; + } + $pfx = '*' if /^[a-z]+:$/; + s/pid [0-9]+: //; + if (/last message repeated ([0-9]+) time/) { + $seen{$last} += $1; + next; + } + s/^/$pfx/ if $pfx; + unless ($seen{$_}++) { + push(@seen,$_); + } + $last = $_; +} +$max = tell(Msgs); + +open(tmp,'|sort >oldmsgs.tmp') || die "Can't create tmp file: $!\n"; +while ($_ = pop(@seen)) { + print tmp $_; +} +close(tmp); +open(tmp,'oldmsgs.tmp') || die "Can't reopen tmp file: $!\n"; +while (<tmp>) { + if (/^nd:/) { + next if $seen{$_} < 20; + } + if (/NFS/) { + next if $seen{$_} < 20; + } + if (/no carrier/) { + next if $seen{$_} < 20; + } + if (/silo overflow/) { + next if $seen{$_} < 20; + } + print $seen{$_},":\t",$_; +} + +print `rm -f oldmsgs.tmp 2>&1; echo $max > oldmsgs 2>&1`; diff --git a/contrib/perl5/eg/scan/scan_passwd b/contrib/perl5/eg/scan/scan_passwd new file mode 100644 index 0000000..50f6fc8 --- /dev/null +++ b/contrib/perl5/eg/scan/scan_passwd @@ -0,0 +1,30 @@ +#!/usr/bin/perl + +# $RCSfile: scan_passwd,v $$Revision: 4.1 $$Date: 92/08/07 17:20:38 $ + +# This scans passwd file for security holes. + +open(Pass,'/etc/passwd') || die "Can't open passwd file: $!\n"; +# $dotriv = (`date` =~ /^Mon/); +$dotriv = 1; + +while (<Pass>) { + ($login,$pass,$uid,$gid,$gcos,$home,$shell) = split(/:/); + if ($shell eq '') { + print "Short: $_"; + } + next if /^[+]/; + if ($pass eq '') { + if (index(":sync:lpq:+:", ":$login:") < 0) { + print "No pass: $login\t$gcos\n"; + } + } + elsif ($dotriv && crypt($login,substr($pass,0,2)) eq $pass) { + print "Trivial: $login\t$gcos\n"; + } + if ($uid == 0) { + if ($login !~ /^.?root$/ && $pass ne '*') { + print "Extra root: $_"; + } + } +} diff --git a/contrib/perl5/eg/scan/scan_ps b/contrib/perl5/eg/scan/scan_ps new file mode 100644 index 0000000..18b5cb2 --- /dev/null +++ b/contrib/perl5/eg/scan/scan_ps @@ -0,0 +1,32 @@ +#!/usr/bin/perl -P + +# $RCSfile: scan_ps,v $$Revision: 4.1 $$Date: 92/08/07 17:20:40 $ + +# This looks for looping processes. + +#if defined(mc300) || defined(mc500) || defined(mc700) +open(Ps, '/bin/ps -el|') || die "scan_ps: can't run ps"; + +while (<Ps>) { + next if /rwhod/; + print if index(' T', substr($_,62,1)) < 0; +} +#else +open(Ps, '/bin/ps auxww|') || die "scan_ps: can't run ps"; + +while (<Ps>) { + next if /dataserver/; + next if /nfsd/; + next if /update/; + next if /ypserv/; + next if /rwhod/; + next if /routed/; + next if /pagedaemon/; +#ifdef vax + ($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$start,$time) = split; +#else + ($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$time) = split; +#endif + print if length($time) > 4; +} +#endif diff --git a/contrib/perl5/eg/scan/scan_sudo b/contrib/perl5/eg/scan/scan_sudo new file mode 100644 index 0000000..5b143e9 --- /dev/null +++ b/contrib/perl5/eg/scan/scan_sudo @@ -0,0 +1,54 @@ +#!/usr/bin/perl -P + +# $RCSfile: scan_sudo,v $$Revision: 4.1 $$Date: 92/08/07 17:20:42 $ + +# Analyze the sudo log. + +chdir('/usr/adm/private/memories') || die "Can't cd to memories: $!\n"; + +if (open(Oldsudo,'oldsudo')) { + $maxpos = <Oldsudo>; + close Oldsudo; +} +else { + $maxpos = 0; + `echo 0 >oldsudo`; +} + +unless (open(Sudo, '/usr/adm/sudo.log')) { + print "Somebody removed sudo.log!!!\n" if $maxpos; + exit 0; +} + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat(Sudo); + +if ($size < $maxpos) { + $maxpos = 0; + print "Somebody reset sudo.log!!!\n"; +} + +seek(Sudo,$maxpos,0); + +while (<Sudo>) { + s/^.* :[ \t]+//; + s/ipcrm.*/ipcrm/; + s/kill.*/kill/; + unless ($seen{$_}++) { + push(@seen,$_); + } + $last = $_; +} +$max = tell(Sudo); + +open(tmp,'|sort >oldsudo.tmp') || die "Can't create tmp file: $!\n"; +while ($_ = pop(@seen)) { + print tmp $_; +} +close(tmp); +open(tmp,'oldsudo.tmp') || die "Can't reopen tmp file: $!\n"; +while (<tmp>) { + print $seen{$_},":\t",$_; +} + +print `(rm -f oldsudo.tmp; echo $max > oldsudo) 2>&1`; diff --git a/contrib/perl5/eg/scan/scan_suid b/contrib/perl5/eg/scan/scan_suid new file mode 100644 index 0000000..c10aa58 --- /dev/null +++ b/contrib/perl5/eg/scan/scan_suid @@ -0,0 +1,84 @@ +#!/usr/bin/perl -P + +# $RCSfile: scan_suid,v $$Revision: 4.1 $$Date: 92/08/07 17:20:43 $ + +# Look for new setuid root files. + +chdir '/usr/adm/private/memories' || die "Can't cd to memories: $!\n"; + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('oldsuid'); +if ($nlink) { + $lasttime = $mtime; + $tmp = $ctime - $atime; + if ($tmp <= 0 || $tmp >= 10) { + print "WARNING: somebody has read oldsuid!\n"; + } + $tmp = $ctime - $mtime; + if ($tmp <= 0 || $tmp >= 10) { + print "WARNING: somebody has modified oldsuid!!!\n"; + } +} else { + $lasttime = time - 60 * 60 * 24; # one day ago +} +$thistime = time; + +#if defined(mc300) || defined(mc500) || defined(mc700) +open(Find, 'find / -perm -04000 -print |') || + die "scan_find: can't run find"; +#else +open(Find, 'find / \( -fstype nfs -prune \) -o -perm -04000 -ls |') || + die "scan_find: can't run find"; +#endif + +open(suid, '>newsuid.tmp'); + +while (<Find>) { + +#if defined(mc300) || defined(mc500) || defined(mc700) + $x = `/bin/ls -il $_`; + $_ = $x; + s/^ *//; + ($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) + = split; +#else + s/^ *//; + ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) + = split; +#endif + + if ($perm =~ /[sS]/ && $owner eq 'root') { + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($name); + $foo = sprintf("%10s%3s %-8s %-8s%9s %3s %2s %s %s\n", + $perm,$links,$owner,$group,$size,$month,$day,$name,$inode); + print suid $foo; + if ($ctime > $lasttime) { + if ($ctime > $thistime) { + print "Future file: $foo"; + } + else { + $ct .= $foo; + } + } + } +} +close(suid); + +print `sort +7 -8 newsuid.tmp >newsuid 2>&1`; +$foo = `/bin/diff oldsuid newsuid 2>&1`; +print "Differences in suid info:\n",$foo if $foo; +print `mv oldsuid oldoldsuid 2>&1; mv newsuid oldsuid 2>&1`; +print `touch oldsuid 2>&1;sleep 2 2>&1;chmod o+w oldsuid 2>&1`; +print `rm -f newsuid.tmp 2>&1`; + +@ct = split(/\n/,$ct); +$ct = ''; +$* = 1; +while ($#ct >= 0) { + $tmp = shift(@ct); + unless ($foo =~ "^>.*$tmp\n") { $ct .= "$tmp\n"; } +} + +print "Inode changed since last time:\n",$ct if $ct; + diff --git a/contrib/perl5/eg/scan/scanner b/contrib/perl5/eg/scan/scanner new file mode 100644 index 0000000..e73cdc8 --- /dev/null +++ b/contrib/perl5/eg/scan/scanner @@ -0,0 +1,87 @@ +#!/usr/bin/perl + +# $RCSfile: scanner,v $$Revision: 4.1 $$Date: 92/08/07 17:20:44 $ + +# This runs all the scan_* routines on all the machines in /etc/ghosts. +# We run this every morning at about 6 am: + +# !/bin/sh +# cd /usr/adm/private +# decrypt scanner | perl >scan.out 2>&1 +# mail admin <scan.out + +# Note that the scan_* files should be encrypted with the key "-inquire", and +# scanner should be encrypted somehow so that people can't find that key. +# I leave it up to you to figure out how to unencrypt it before executing. + +$ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin:/usr/ucb:.'; + +$| = 1; # command buffering on stdout + +print "Subject: bizarre happenings\n\n"; + +(chdir '/usr/adm/private') || die "Can't cd to /usr/adm/private: $!\n"; + +if ($#ARGV >= 0) { + @scanlist = @ARGV; +} else { + @scanlist = split(/[ \t\n]+/,`echo scan_*`); +} + +scan: while ($scan = shift(@scanlist)) { + print "\n********** $scan **********\n"; + $showhost++; + + $systype = 'all'; + + open(ghosts, '/etc/ghosts') || die 'No /etc/ghosts file'; + + $one_of_these = ":$systype:"; + if ($systype =~ s/\+/[+]/g) { + $one_of_these =~ s/\+/:/g; + } + + line: while (<ghosts>) { + s/[ \t]*\n//; + if (!$_ || /^#/) { + next line; + } + if (/^([a-zA-Z_0-9]+)=(.+)/) { + $name = $1; $repl = $2; + $repl =~ s/\+/:/g; + $one_of_these =~ s/:$name:/:$repl:/; + next line; + } + @gh = split; + $host = $gh[0]; + if ($showhost) { $showhost = "$host:\t"; } + class: while ($class = pop(gh)) { + if (index($one_of_these,":$class:") >=0) { + $iter = 0; + `exec crypt -inquire <$scan >.x 2>/dev/null`; + unless (open(scan,'.x')) { + print "Can't run $scan: $!\n"; + next scan; + } + $cmd = <scan>; + unless ($cmd =~ s/#!(.*)\n/$1/) { + $cmd = '/usr/bin/perl'; + } + close(scan); + if (open(PIPE,"exec rsh $host '$cmd' <.x|")) { + sleep(5); + unlink '.x'; + while (<PIPE>) { + last if $iter++ > 1000; # must be looping + next if /^[0-9.]+u [0-9.]+s/; + print $showhost,$_; + } + close(PIPE); + } else { + print "(Can't execute rsh: $!)\n"; + } + last class; + } + } + } +} diff --git a/contrib/perl5/eg/server b/contrib/perl5/eg/server new file mode 100755 index 0000000..49a140a --- /dev/null +++ b/contrib/perl5/eg/server @@ -0,0 +1,27 @@ +#!./perl + +$pat = 'S n C4 x8'; +$inet = 2; +$echo = 7; +$smtp = 25; +$nntp = 119; + +$this = pack($pat,$inet,2345, 0,0,0,0); +select(NS); $| = 1; select(stdout); + +if (socket(S,2,1,6)) { print "socket ok\n"; } else { die $!; } +if (bind(S,$this)) { print "bind ok\n"; } else { die $!; } +if (listen(S,5)) { print "listen ok\n"; } else { die $!; } +for (;;) { + print "Listening again\n"; + if ($addr = accept(NS,S)) { print "accept ok\n"; } else { die $!; } + + @ary = unpack($pat,$addr); + $, = ' '; + print @ary; print "\n"; + + while (<NS>) { + print; + print NS; + } +} diff --git a/contrib/perl5/eg/shmkill b/contrib/perl5/eg/shmkill new file mode 100644 index 0000000..b91ee6f --- /dev/null +++ b/contrib/perl5/eg/shmkill @@ -0,0 +1,24 @@ +#!/usr/bin/perl + +# $RCSfile: shmkill,v $$Revision: 4.1 $$Date: 92/08/07 17:20:45 $ + +# A script to call from crontab periodically when people are leaving shared +# memory sitting around unattached. + +open(ipcs,'ipcs -m -o|') || die "Can't run ipcs: $!"; + +while (<ipcs>) { + $tmp = index($_,'NATTCH'); + $pos = $tmp if $tmp >= 0; + if (/^m/) { + ($m,$id,$key,$mode,$owner,$group,$attach) = split; + if ($attach != substr($_,$pos,6)) { + die "Different ipcs format--can't parse!\n"; + } + if ($attach == 0) { + push(@goners,'-m',$id); + } + } +} + +exec 'ipcrm', @goners if $#goners >= 0; diff --git a/contrib/perl5/eg/sysvipc/README b/contrib/perl5/eg/sysvipc/README new file mode 100644 index 0000000..54094f1 --- /dev/null +++ b/contrib/perl5/eg/sysvipc/README @@ -0,0 +1,9 @@ +FYEnjoyment, here are the test scripts I used while implementing SysV +IPC in Perl. Each of them must be run with the parameter "s" for +"send" or "r" for "receive"; in each case, the receiver is the server +and the sender is the client. + +-- +Chip Salzenberg at ComDev/TCT <chip@tct.uucp>, <uunet!ateng!tct!chip> + + diff --git a/contrib/perl5/eg/sysvipc/ipcmsg b/contrib/perl5/eg/sysvipc/ipcmsg new file mode 100644 index 0000000..646d8b6 --- /dev/null +++ b/contrib/perl5/eg/sysvipc/ipcmsg @@ -0,0 +1,47 @@ +#!/usr/bin/perl +eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' + if $running_under_some_shell; + +require 'sys/ipc.ph'; +require 'sys/msg.ph'; + +$| = 1; + +$mode = shift; +die "usage: ipcmsg {r|s}\n" unless $mode =~ /^[rs]$/; +$send = ($mode eq "s"); + +$id = msgget(0x1234, ($send ? 0 : &IPC_CREAT) | 0644); +die "Can't get message queue: $!\n" unless defined($id); +print "message queue id: $id\n"; + +if ($send) { + while (<STDIN>) { + chop; + unless (msgsnd($id, pack("LA*", $., $_), 0)) { + die "Can't send message: $!\n"; + } + } +} +else { + $SIG{'INT'} = $SIG{'QUIT'} = "leave"; + for (;;) { + unless (msgrcv($id, $_, 512, 0, 0)) { + die "Can't receive message: $!\n"; + } + ($type, $message) = unpack("La*", $_); + printf "[%d] %s\n", $type, $message; + } +} + +&leave; + +sub leave { + if (!$send) { + $x = msgctl($id, &IPC_RMID, 0); + if (!defined($x) || $x < 0) { + die "Can't remove message queue: $!\n"; + } + } + exit; +} diff --git a/contrib/perl5/eg/sysvipc/ipcsem b/contrib/perl5/eg/sysvipc/ipcsem new file mode 100644 index 0000000..e0dc551 --- /dev/null +++ b/contrib/perl5/eg/sysvipc/ipcsem @@ -0,0 +1,46 @@ +#!/usr/bin/perl +eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' + if $running_under_some_shell; + +require 'sys/ipc.ph'; +require 'sys/msg.ph'; + +$| = 1; + +$mode = shift; +die "usage: ipcmsg {r|s}\n" unless $mode =~ /^[rs]$/; +$signal = ($mode eq "s"); + +$id = semget(0x1234, 1, ($signal ? 0 : &IPC_CREAT) | 0644); +die "Can't get semaphore: $!\n" unless defined($id); +print "semaphore id: $id\n"; + +if ($signal) { + while (<STDIN>) { + print "Signalling\n"; + unless (semop($id, pack("sss", 0, 1, 0))) { + die "Can't signal semaphore: $!\n"; + } + } +} +else { + $SIG{'INT'} = $SIG{'QUIT'} = "leave"; + for (;;) { + unless (semop($id, pack("sss", 0, -1, 0))) { + die "Can't wait for semaphore: $!\n"; + } + print "Unblocked\n"; + } +} + +&leave; + +sub leave { + if (!$signal) { + $x = semctl($id, 0, &IPC_RMID, 0); + if (!defined($x) || $x < 0) { + die "Can't remove semaphore: $!\n"; + } + } + exit; +} diff --git a/contrib/perl5/eg/sysvipc/ipcshm b/contrib/perl5/eg/sysvipc/ipcshm new file mode 100644 index 0000000..ecc1ba4 --- /dev/null +++ b/contrib/perl5/eg/sysvipc/ipcshm @@ -0,0 +1,50 @@ +#!/usr/bin/perl +eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' + if $running_under_some_shell; + +require 'sys/ipc.ph'; +require 'sys/shm.ph'; + +$| = 1; + +$mode = shift; +die "usage: ipcshm {r|s}\n" unless $mode =~ /^[rs]$/; +$send = ($mode eq "s"); + +$SIZE = 32; +$id = shmget(0x1234, $SIZE, ($send ? 0 : &IPC_CREAT) | 0644); +die "Can't get shared memory: $!\n" unless defined($id); +print "shared memory id: $id\n"; + +if ($send) { + while (<STDIN>) { + chop; + unless (shmwrite($id, pack("La*", length($_), $_), 0, $SIZE)) { + die "Can't write to shared memory: $!\n"; + } + } +} +else { + $SIG{'INT'} = $SIG{'QUIT'} = "leave"; + for (;;) { + $_ = <STDIN>; + unless (shmread($id, $_, 0, $SIZE)) { + die "Can't read shared memory: $!\n"; + } + $len = unpack("L", $_); + $message = substr($_, length(pack("L",0)), $len); + printf "[%d] %s\n", $len, $message; + } +} + +&leave; + +sub leave { + if (!$send) { + $x = shmctl($id, &IPC_RMID, 0); + if (!defined($x) || $x < 0) { + die "Can't remove shared memory: $!\n"; + } + } + exit; +} diff --git a/contrib/perl5/eg/travesty b/contrib/perl5/eg/travesty new file mode 100644 index 0000000..7e6f983 --- /dev/null +++ b/contrib/perl5/eg/travesty @@ -0,0 +1,46 @@ +#!/usr/bin/perl + +while (<>) { + next if /^\./; + next if /^From / .. /^$/; + next if /^Path: / .. /^$/; + s/^\W+//; + push(@ary,split(' ')); + while ($#ary > 1) { + $a = $p; + $p = $n; + $w = shift(@ary); + $n = $num{$w}; + if ($n eq '') { + push(@word,$w); + $n = pack('S',$#word); + $num{$w} = $n; + } + $lookup{$a . $p} .= $n; + } +} + +for (;;) { + $n = $lookup{$a . $p}; + ($foo,$n) = each(lookup) if $n eq ''; + $n = substr($n,int(rand(length($n))) & 0177776,2); + $a = $p; + $p = $n; + ($w) = unpack('S',$n); + $w = $word[$w]; + $col += length($w) + 1; + if ($col >= 65) { + $col = 0; + print "\n"; + } + else { + print ' '; + } + print $w; + if ($w =~ /\.$/) { + if (rand() < .1) { + print "\n"; + $col = 80; + } + } +} diff --git a/contrib/perl5/eg/unuc b/contrib/perl5/eg/unuc new file mode 100755 index 0000000..ae5c652 --- /dev/null +++ b/contrib/perl5/eg/unuc @@ -0,0 +1,186 @@ +#!/usr/bin/perl + +print STDERR "Loading proper nouns...\n"; +open(DICT,"/usr/dict/words") || die "Can't find /usr/dict/words: $!\n"; +while (<DICT>) { + if (/^[A-Z]/) { + chop; + ($lower = $_) =~ y/A-Z/a-z/; + $proper{$lower} = $_; + } +} +close DICT; +print STDERR "Loading exceptions...\n"; + +$prog = <<'EOT'; +while (<>) { + next if /[a-z]/; + y/A-Z/a-z/; + s/(\w+)/$proper{$1} ? $proper{$1} : $1/eg; + s/^(\s*)([a-z])/$1 . (($tmp = $2) =~ y:a-z:A-Z:,$tmp)/e; + s/([-.?!]["']?(\n\s*| \s*)["']?)([a-z])/$1 . (($tmp = $3) =~ y:a-z:A-Z:,$tmp)/eg; + s/\b([b-df-hj-np-tv-xz]+)\b/(($tmp = $1) =~ y:a-z:A-Z:,$tmp)/eg; + s/([a-z])'([SDT])\b/$1 . "'" . (($tmp = $2) =~ y:A-Z:a-z:,$tmp)/eg; +EOT +while (<DATA>) { + chop; + next if /^$/; + next if /^#/; + if (! /;$/) { + $foo = $_; + $foo =~ y/A-Z/a-z/; + print STDERR "Dup $_\n" if $proper{$foo}; + $foo =~ s/([^\w ])/\\$1/g; + $foo =~ s/ /(\\s+)/g; + $foo = "\\b" . $foo if $foo =~ /^\w/; # XXX till patch 9 + $foo .= "\\b" if $foo =~ /\w$/; + $i = 0; + ($bar = $_) =~ s/ /'$' . ++$i/eg; + $_ = "s/$foo/$bar/gi;"; + } + $prog .= ' ' . $_ . "\n"; +} +$prog .= "}\ncontinue {\n print;\n}\n"; + +$/ = ''; +#print $prog; +eval $prog; die $@ if $@; +__END__ +A.M. +Air Force +Air Force Base +Air Force Station +American +Apr. +Ariane +Aug. +August +Bureau of Labor Statistics +CIT +Caltech +Cape Canaveral +Challenger +China +Corporation +Crippen +Daily News in Brief +Daniel Quayle +Dec. +Discovery +Edwards +Endeavour +Feb. +Ford Aerospace +Fri. +General Dynamics +George Bush +Headline News +HOTOL +I +II +III +IV +IX +Institute of Technology +JPL +Jan. +Jul. +Jun. +Kennedy Space Center +LDEF +Long Duration Exposure Facility +Long March +Mar. +March +Martin +Martin Marietta +Mercury +Mon. +in May +s/\bmay (\d)/May $1/g; +s/\boffice of (\w)/'Office of ' . (($tmp = $1) =~ y:a-z:A-Z:,$tmp)/eg; +National Science Foundation +NASA Select +New Mexico +Nov. +OMB +Oct. +Office of Management and Budget +President +President Bush +Richard Truly +Rocketdyne +Russian +Russians +Sat. +Sep. +Soviet +Soviet Union +Soviets +Space Shuttle +Sun. +Thu. +Tue. +U.S. +Union of Soviet Socialist Republics +United States +VI +VII +VIII +Vice President +Vice President Quayle +Wed. +White Sands +Kaman Aerospace +Aerospace Daily +Aviation Week +Space Technology +Washington Post +Los Angeles Times +New York Times +Aerospace Industries Association +president of +Johnson Space Center +Space Services +Inc. +Co. +Hughes Aircraft +Company +Orbital Sciences +Swedish Space +Arnauld +Nicogosian +Magellan +Galileo +Mir +Jet Propulsion Laboratory +University +Department of Defense +Orbital Science +OMS +United Press International +United Press +UPI +Associated Press +AP +Cable News Network +Cape York +Zenit +SYNCOM +Eastern +Western +Test Range +Jcsat +Japanese Satellite Communications +Defence Ministry +Defense Ministry +Skynet +Fixed Service Structure +Launch Processing System +Asiasat +Launch Control Center +Earth +CNES +Glavkosmos +Pacific +Atlantic diff --git a/contrib/perl5/eg/uudecode b/contrib/perl5/eg/uudecode new file mode 100644 index 0000000..3b3cb60 --- /dev/null +++ b/contrib/perl5/eg/uudecode @@ -0,0 +1,15 @@ +#!/usr/bin/perl +while (<>) { + next unless ($mode,$file) = /^begin\s*(\d*)\s*(\S*)/; + open(OUT,"> $file") || die "Can't create $file: $!\n"; + while (<>) { + last if /^end/; + next if /[a-z]/; + next unless int((((ord() - 32) & 077) + 2) / 3) == + int(length() / 4); + print OUT unpack("u", $_); + } + chmod oct($mode), $file; + eof() && die "Missing end: $file may be truncated.\n"; +} + diff --git a/contrib/perl5/eg/van/empty b/contrib/perl5/eg/van/empty new file mode 100644 index 0000000..d699319 --- /dev/null +++ b/contrib/perl5/eg/van/empty @@ -0,0 +1,45 @@ +#!/usr/bin/perl + +# $RCSfile: empty,v $$Revision: 4.1 $$Date: 92/08/07 17:20:50 $ + +# This script empties a trashcan. + +$recursive = shift if $ARGV[0] eq '-r'; + +@ARGV = '.' if $#ARGV < 0; + +chop($pwd = `pwd`); + +dir: foreach $dir (@ARGV) { + unless (chdir $dir) { + print stderr "Can't find directory $dir: $!\n"; + next dir; + } + if ($recursive) { + do cmd('find . -name .deleted -exec /bin/rm -rf {} ;'); + } + else { + if (-d '.deleted') { + do cmd('rm -rf .deleted'); + } + else { + if ($dir eq '.' && $pwd =~ m|/\.deleted$|) { + chdir '..'; + do cmd('rm -rf .deleted'); + } + else { + print stderr "No trashcan found in directory $dir\n"; + } + } + } +} +continue { + chdir $pwd; +} + +# force direct execution with no shell + +sub cmd { + system split(' ',join(' ',@_)); +} + diff --git a/contrib/perl5/eg/van/unvanish b/contrib/perl5/eg/van/unvanish new file mode 100644 index 0000000..acb1603 --- /dev/null +++ b/contrib/perl5/eg/van/unvanish @@ -0,0 +1,66 @@ +#!/usr/bin/perl + +# $RCSfile: unvanish,v $$Revision: 4.1 $$Date: 92/08/07 17:20:52 $ + +sub it { + if ($olddir ne '.') { + chop($pwd = `pwd`) if $pwd eq ''; + (chdir $olddir) || die "Directory $olddir is not accesible"; + } + unless ($olddir eq '.deleted') { + if (-d '.deleted') { + chdir '.deleted' || die "Directory .deleted is not accesible"; + } + else { + chop($pwd = `pwd`) if $pwd eq ''; + die "Directory .deleted does not exist" unless $pwd =~ /\.deleted$/; + } + } + print `mv $startfiles$filelist..$force`; + if ($olddir ne '.') { + (chdir $pwd) || die "Can't get back to original directory $pwd: $!\n"; + } +} + +if ($#ARGV < 0) { + open(lastcmd,'.deleted/.lastcmd') || + open(lastcmd,'.lastcmd') || + die "No previous vanish in this dir"; + $ARGV = <lastcmd>; + close(lastcmd); + @ARGV = split(/[\n ]+/,$ARGV); +} + +while ($ARGV[0] =~ /^-/) { + $_ = shift; + /^-f/ && ($force = ' >/dev/null 2>&1'); + /^-i/ && ($interactive = 1); + if (/^-+$/) { + $startfiles = '- '; + last; + } +} + +while ($file = shift) { + if ($file =~ s|^(.*)/||) { + $dir = $1; + } + else { + $dir = '.'; + } + + if ($dir ne $olddir) { + do it() if $olddir; + $olddir = $dir; + } + + if ($interactive) { + print "unvanish: restore $dir/$file? "; + next unless <stdin> =~ /^y/i; + } + + $filelist .= $file; $filelist .= ' '; + +} + +do it() if $olddir; diff --git a/contrib/perl5/eg/van/vanexp b/contrib/perl5/eg/van/vanexp new file mode 100644 index 0000000..415b73b --- /dev/null +++ b/contrib/perl5/eg/van/vanexp @@ -0,0 +1,21 @@ +#!/usr/bin/perl + +# $RCSfile: vanexp,v $$Revision: 4.1 $$Date: 92/08/07 17:20:53 $ + +# This is for running from a find at night to expire old .deleteds + +$can = $ARGV[0]; + +exit 1 unless $can =~ /.deleted$/; + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($can); + +exit 0 unless $size; + +if (time - $mtime > 2 * 24 * 60 * 60) { + `/bin/rm -rf $can`; +} +else { + `find $can -ctime +2 -exec rm -f {} \;`; +} diff --git a/contrib/perl5/eg/van/vanish b/contrib/perl5/eg/van/vanish new file mode 100644 index 0000000..09b9679 --- /dev/null +++ b/contrib/perl5/eg/van/vanish @@ -0,0 +1,65 @@ +#!/usr/bin/perl + +# $RCSfile: vanish,v $$Revision: 4.1 $$Date: 92/08/07 17:20:54 $ + +sub it { + if ($olddir ne '.') { + chop($pwd = `pwd`) if $pwd eq ''; + (chdir $olddir) || die "Directory $olddir is not accesible"; + } + if (!-d .deleted) { + print `mkdir .deleted; chmod 775 .deleted`; + die "You can't remove files from $olddir" if $?; + } + $filelist =~ s/ $//; + $filelist =~ s/#/\\#/g; + if ($filelist !~ /^[ \t]*$/) { + open(lastcmd,'>.deleted/.lastcmd'); + print lastcmd $filelist,"\n"; + close(lastcmd); + print `/bin/mv $startfiles$filelist .deleted$force`; + } + if ($olddir ne '.') { + (chdir $pwd) || die "Can't get back to original directory $pwd: $!\n"; + } +} + +while ($ARGV[0] =~ /^-/) { + $_ = shift; + /^-f/ && ($force = ' >/dev/null 2>&1'); + /^-i/ && ($interactive = 1); + if (/^-+$/) { + $startfiles = '- '; + last; + } +} + +chop($pwd = `pwd`); + +while ($file = shift) { + if ($file =~ s|^(.*)/||) { + $dir = $1; + } + else { + $dir = '.'; + } + + if ($interactive) { + print "vanish: remove $dir/$file? "; + next unless <stdin> =~ /^y/i; + } + + if ($file eq '.deleted') { + print stderr "To delete .deleted (the trashcan) use the 'empty' command.\n"; + next; + } + + if ($dir ne $olddir) { + do it() if $olddir; + $olddir = $dir; + } + + $filelist .= $file; $filelist .= ' '; +} + +do it() if $olddir; diff --git a/contrib/perl5/eg/who b/contrib/perl5/eg/who new file mode 100644 index 0000000..ac15246 --- /dev/null +++ b/contrib/perl5/eg/who @@ -0,0 +1,13 @@ +#!/usr/bin/perl +# This assumes your /etc/utmp file looks like ours +open(UTMP,'/etc/utmp'); +@mo = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec); +while (read(UTMP,$utmp,36)) { + ($line,$name,$host,$time) = unpack('A8A8A16l',$utmp); + if ($name) { + $host = "($host)" if ord($host); + ($sec,$min,$hour,$mday,$mon) = localtime($time); + printf "%-9s%-8s%s %2d %02d:%02d %s\n", + $name,$line,$mo[$mon],$mday,$hour,$min,$host; + } +} diff --git a/contrib/perl5/eg/wrapsuid b/contrib/perl5/eg/wrapsuid new file mode 100755 index 0000000..3b1fc6e --- /dev/null +++ b/contrib/perl5/eg/wrapsuid @@ -0,0 +1,104 @@ +#!/usr/bin/perl +'di'; +'ig00'; +# +# $Header: wrapsuid,v 1.1 90/08/11 13:51:29 lwall Locked $ +# +# $Log: wrapsuid,v $ +# Revision 1.1 90/08/11 13:51:29 lwall +# Initial revision +# + +$xdev = '-xdev' unless -d '/dev/iop'; + +if ($#ARGV >= 0) { + @list = @ARGV; + foreach $name (@ARGV) { + die "You must use absolute pathnames.\n" unless $name =~ m|^/|; + } +} +else { + open(DF,"/etc/mount|") || die "Can't run /etc/mount"; + + while (<DF>) { + chop; + $_ .= <DF> if length($_) < 50; + @ary = split; + push(@list,$ary[2]) if ($ary[0] =~ m|^/dev|); + } +} +$fslist = join(' ',@list); + +die "Can't find local filesystems" unless $fslist; + +open(FIND, + "find $fslist $xdev -type f \\( -perm -04000 -o -perm -02000 \\) -print|"); + +while (<FIND>) { + chop; + next unless -T; + print "Fixing ", $_, "\n"; + ($dir,$file) = m|(.*)/(.*)|; + chdir $dir || die "Can't chdir to $dir"; + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($file); + die "Can't stat $_" unless $ino; + chmod $mode & 01777, $file; # wipe out set[ug]id bits + rename($file,".$file"); + open(C,">.tmp$$.c") || die "Can't write C program for $_"; + $real = "$dir/.$file"; + print C ' +main(argc,argv) +int argc; +char **argv; +{ + execv("' . $real . '",argv); +} +'; + close C; + system '/bin/cc', ".tmp$$.c", '-o', $file; + die "Can't compile new $_" if $?; + chmod $mode, $file; + chown $uid, $gid, $file; + unlink ".tmp$$.c"; + chdir '/'; +} +############################################################################## + + # These next few lines are legal in both Perl and nroff. + +.00; # finish .ig + +'di \" finish diversion--previous line must be blank +.nr nl 0-1 \" fake up transition to first page again +.nr % 0 \" start at page 1 +'; __END__ ############# From here on it's a standard manual page ############ +.TH SUIDSCRIPT 1 "July 30, 1990" +.AT 3 +.SH NAME +wrapsuid \- puts a compiled C wrapper around a setuid or setgid script +.SH SYNOPSIS +.B wrapsuid [dirlist] +.SH DESCRIPTION +.I Wrapsuid +creates a small C program to execute a script with setuid or setgid privileges +without having to set the setuid or setgid bit on the script, which is +a security problem on many machines. +Specify the list of directories or files that you wish to process. +The names must be absolute pathnames. +With no arguments it will attempt to process all the local directories +for this machine. +The scripts to be processed must have the setuid or setgid bit set. +The wrapsuid program will delete the bits and set them on the wrapper. +.PP +Non-superusers may only process their own files. +.SH ENVIRONMENT +No environment variables are used. +.SH FILES +None. +.SH AUTHOR +Larry Wall +.SH "SEE ALSO" +.SH DIAGNOSTICS +.SH BUGS +.ex diff --git a/contrib/perl5/embed.h b/contrib/perl5/embed.h index 592f39b..e7deb32 100644 --- a/contrib/perl5/embed.h +++ b/contrib/perl5/embed.h @@ -159,6 +159,7 @@ #define do_trans Perl_do_trans #define do_vecset Perl_do_vecset #define do_vop Perl_do_vop +#define dofile Perl_dofile #define dofindlabel Perl_dofindlabel #define dopoptoeval Perl_dopoptoeval #define dounwind Perl_dounwind @@ -204,6 +205,7 @@ #define get_op_names Perl_get_op_names #define get_opargs Perl_get_opargs #define get_specialsv_list Perl_get_specialsv_list +#define get_vtbl Perl_get_vtbl #define gp_free Perl_gp_free #define gp_ref Perl_gp_ref #define gt_amg Perl_gt_amg @@ -859,6 +861,7 @@ #define save_freeop Perl_save_freeop #define save_freepv Perl_save_freepv #define save_freesv Perl_save_freesv +#define save_generic_svref Perl_save_generic_svref #define save_gp Perl_save_gp #define save_hash Perl_save_hash #define save_helem Perl_save_helem diff --git a/contrib/perl5/embed.pl b/contrib/perl5/embed.pl index a7fb0ed..497b97d 100755 --- a/contrib/perl5/embed.pl +++ b/contrib/perl5/embed.pl @@ -37,7 +37,6 @@ sub readsyms (\%$) { } readsyms %global, 'global.sym'; -readsyms %interp, 'interp.sym'; sub readvars(\%$$) { my ($syms, $file,$pre) = @_; @@ -63,11 +62,10 @@ readvars %globvar, 'perlvars.h','G'; foreach my $sym (sort keys %intrp) { - warn "$sym not in interp.sym\n" unless exists $interp{$sym}; if (exists $global{$sym}) { delete $global{$sym}; - warn "$sym in global.sym as well as interp\n"; + warn "$sym in global.sym as well as intrpvar.h\n"; } } @@ -80,19 +78,13 @@ foreach my $sym (sort keys %globvar) } } -foreach my $sym (keys %interp) - { - warn "extra $sym in interp.sym\n" - unless exists $intrp{$sym} || exists $thread{$sym}; - } - foreach my $sym (sort keys %thread) { - warn "$sym in intrpvar.h\n" if exists $intrp{$sym}; + warn "$sym in intrpvar.h as well as thrdvar.h\n" if exists $intrp{$sym}; if (exists $global{$sym}) { delete $global{$sym}; - warn "$sym in global.sym as well as thread\n"; + warn "$sym in global.sym as well as thrdvar.h\n"; } } diff --git a/contrib/perl5/embedvar.h b/contrib/perl5/embedvar.h index 7a258b0..25b31e0 100644 --- a/contrib/perl5/embedvar.h +++ b/contrib/perl5/embedvar.h @@ -250,6 +250,7 @@ #define PL_stdingv (PL_curinterp->Istdingv) #define PL_strchop (PL_curinterp->Istrchop) #define PL_strtab (PL_curinterp->Istrtab) +#define PL_strtab_mutex (PL_curinterp->Istrtab_mutex) #define PL_sub_generation (PL_curinterp->Isub_generation) #define PL_sublex_info (PL_curinterp->Isublex_info) #define PL_sv_arenaroot (PL_curinterp->Isv_arenaroot) @@ -384,6 +385,7 @@ #define PL_Istdingv PL_stdingv #define PL_Istrchop PL_strchop #define PL_Istrtab PL_strtab +#define PL_Istrtab_mutex PL_strtab_mutex #define PL_Isub_generation PL_sub_generation #define PL_Isublex_info PL_sublex_info #define PL_Isv_arenaroot PL_sv_arenaroot @@ -647,6 +649,7 @@ #define PL_collxfrm_base (PL_Vars.Gcollxfrm_base) #define PL_collxfrm_mult (PL_Vars.Gcollxfrm_mult) #define PL_cop_seqmax (PL_Vars.Gcop_seqmax) +#define PL_cred_mutex (PL_Vars.Gcred_mutex) #define PL_cryptseen (PL_Vars.Gcryptseen) #define PL_cshlen (PL_Vars.Gcshlen) #define PL_cshname (PL_Vars.Gcshname) @@ -757,6 +760,7 @@ #define PL_Gcollxfrm_base PL_collxfrm_base #define PL_Gcollxfrm_mult PL_collxfrm_mult #define PL_Gcop_seqmax PL_cop_seqmax +#define PL_Gcred_mutex PL_cred_mutex #define PL_Gcryptseen PL_cryptseen #define PL_Gcshlen PL_cshlen #define PL_Gcshname PL_cshname diff --git a/contrib/perl5/ext/B/B.pm b/contrib/perl5/ext/B/B.pm index d5137d4..75dcfb3 100644 --- a/contrib/perl5/ext/B/B.pm +++ b/contrib/perl5/ext/B/B.pm @@ -13,7 +13,7 @@ require Exporter; class peekop cast_I32 cstring cchar hash threadsv_names main_root main_start main_cv svref_2object walkoptree walkoptree_slow walkoptree_exec walksymtable - parents comppadlist sv_undef compile_stats timing_info); + parents comppadlist sv_undef compile_stats timing_info init_av); use strict; @B::SV::ISA = 'B::OBJECT'; @@ -530,6 +530,8 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>). =item XSUBANY +=item CvFLAGS + =back =head2 B::HV METHODS @@ -576,7 +578,7 @@ This returns the function name as a string (e.g. pp_add, pp_rv2av). =item desc -This returns the op description from the global C op_desc array +This returns the op description from the global C PL_op_desc array (e.g. "addition" "array deref"). =item targ @@ -720,6 +722,10 @@ get an initial "handle" on an internal object. Return the (faked) CV corresponding to the main part of the Perl program. +=item init_av + +Returns the AV object (i.e. in class B::AV) representing INIT blocks. + =item main_root Returns the root op (i.e. an object in the appropriate B::OP-derived diff --git a/contrib/perl5/ext/B/B.xs b/contrib/perl5/ext/B/B.xs index 8dbc915..6610ae8 100644 --- a/contrib/perl5/ext/B/B.xs +++ b/contrib/perl5/ext/B/B.xs @@ -267,7 +267,8 @@ static SV * cchar(SV *sv) { SV *sstr = newSVpv("'", 0); - char *s = SvPV(sv, PL_na); + STRLEN n_a; + char *s = SvPV(sv, n_a); if (*s == '\'') sv_catpv(sstr, "\\'"); @@ -437,6 +438,7 @@ BOOT: INIT_SPECIALSV_LIST; #define B_main_cv() PL_main_cv +#define B_init_av() PL_initav #define B_main_root() PL_main_root #define B_main_start() PL_main_start #define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv)) @@ -444,6 +446,9 @@ BOOT: #define B_sv_yes() &PL_sv_yes #define B_sv_no() &PL_sv_no +B::AV +B_init_av() + B::CV B_main_cv() @@ -1164,6 +1169,13 @@ CvXSUBANY(cv) CODE: ST(0) = sv_2mortal(newSViv(CvXSUBANY(cv).any_iv)); +MODULE = B PACKAGE = B::CV + +U8 +CvFLAGS(cv) + B::CV cv + + MODULE = B PACKAGE = B::HV PREFIX = Hv STRLEN diff --git a/contrib/perl5/ext/B/B/Assembler.pm b/contrib/perl5/ext/B/B/Assembler.pm index defcbdf..06e00ad 100644 --- a/contrib/perl5/ext/B/B/Assembler.pm +++ b/contrib/perl5/ext/B/B/Assembler.pm @@ -53,6 +53,8 @@ sub B::Asmdata::PUT_U16 { pack("n", $_[0]) } sub B::Asmdata::PUT_U32 { pack("N", $_[0]) } sub B::Asmdata::PUT_I32 { pack("N", $_[0]) } sub B::Asmdata::PUT_objindex { pack("N", $_[0]) } # could allow names here +sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex } +sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex } sub B::Asmdata::PUT_strconst { my $arg = shift; @@ -78,7 +80,7 @@ sub B::Asmdata::PUT_PV { error "bad string argument: $arg" unless defined($arg); return pack("N", length($arg)) . $arg; } -sub B::Asmdata::PUT_comment { +sub B::Asmdata::PUT_comment_t { my $arg = shift; $arg = uncstring($arg); error "bad string argument: $arg" unless defined($arg); diff --git a/contrib/perl5/ext/B/B/C.pm b/contrib/perl5/ext/B/B/C.pm index 0b7d6eb..e695cc2 100644 --- a/contrib/perl5/ext/B/B/C.pm +++ b/contrib/perl5/ext/B/B/C.pm @@ -13,7 +13,7 @@ use Exporter (); use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop class cstring cchar svref_2object compile_stats comppadlist hash - threadsv_names); + threadsv_names main_cv init_av); use B::Asmdata qw(@specialsv_name); use FileHandle; @@ -44,7 +44,7 @@ my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, $cvopsect, $gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect, $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect, - $xrvsect, $xpvbmsect, $xpviosect); + $xrvsect, $xpvbmsect, $xpviosect, $bootstrap); sub walk_and_save_optree; my $saveoptree_callback = \&walk_and_save_optree; @@ -596,10 +596,15 @@ sub B::CV::save { warn sprintf("No definition for sub %s::%s (unable to autoload)\n", $cvstashname, $cvname); # debug } - $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, 0", + $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", $xpvcv_ix, cstring($pv), length($pv), $cv->IVX, $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH, - $$padlist, ${$cv->OUTSIDE})); + $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS)); + + if (${$cv->OUTSIDE} == ${main_cv()}){ + $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv)); + } + if ($$gv) { $gv->save; $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv)); @@ -691,7 +696,7 @@ sub B::GV::save { } my $gvfilegv = $gv->FILEGV; if ($$gvfilegv) { - $init->add(sprintf("GvFILEGV($sym) = s\\_%x;",$$gvfilegv)); + $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv)); # warn "GV::save GvFILEGV(*$name)\n"; # debug $gvfilegv->save; } @@ -847,6 +852,7 @@ sub output_all { $cvopsect, $loopsect, $copsect, $svsect, $xpvsect, $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect); + $bootstrap->output(\*STDOUT, "/* bootstrap %s */\n"); $symsect->output(\*STDOUT, "#define %s\n"); print "\n"; output_declarations(); @@ -1046,30 +1052,61 @@ sub save_object { foreach $sv (@_) { svref_2object($sv)->save; } -} +} + +sub Dummy_BootStrap { } sub B::GV::savecv { my $gv = shift; my $cv = $gv->CV; my $name = $gv->NAME; - if ($$cv && !objsym($cv) && !($name eq "bootstrap" && $cv->XSUB)) { + if ($$cv) { + if ($name eq "bootstrap" && $cv->XSUB) { + my $file = $cv->FILEGV->SV->PV; + $bootstrap->add($file); + my $name = $gv->STASH->NAME.'::'.$name; + no strict 'refs'; + *{$name} = \&Dummy_BootStrap; + $cv = $gv->CV; + } if ($debug_cv) { warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n", $gv->STASH->NAME, $name, $$cv, $$gv); } + my $package=$gv->STASH->NAME; + # This seems to undo all the ->isa and prefix stuff we do below + # so disable again for now + if (0 && ! grep(/^$package$/,@unused_sub_packages)){ + warn sprintf("omitting cv in superclass %s", $gv->STASH->NAME) + if $debug_cv; + return ; + } $gv->save; } + elsif ($name eq 'ISA') + { + $gv->save; + } + } + + sub save_unused_subs { my %search_pack; map { $search_pack{$_} = 1 } @_; + @unused_sub_packages=@_; no strict qw(vars refs); walksymtable(\%{"main::"}, "savecv", sub { my $package = shift; $package =~ s/::$//; + return 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc. #warn "Considering $package\n";#debug return 1 if exists $search_pack{$package}; + #sub try for a partial match + if (grep(/^$package\:\:/,@unused_sub_packages)){ + return 1; + } #warn " (nothing explicit)\n";#debug # Omit the packages which we use (and which cause grief # because of fancy "goto &$AUTOLOAD" stuff). @@ -1079,10 +1116,21 @@ sub save_unused_subs { || $package eq "SelectSaver") { return 0; } - my $m; - foreach $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) { + foreach my $u (keys %search_pack) { + if ($package =~ /^${u}::/) { + warn "$package starts with $u\n"; + return 1 + } + if ($package->isa($u)) { + warn "$package isa $u\n"; + return 1 + } + return 1 if $package->isa($u); + } + foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) { if (defined(&{$package."::$m"})) { warn "$package has method $m: -u$package assumed\n";#debug + push @unused_sub_package, $package; return 1; } } @@ -1091,14 +1139,25 @@ sub save_unused_subs { } sub save_main { + warn "Walking tree\n"; + my $curpad_nam = (comppadlist->ARRAY)[0]->save; my $curpad_sym = (comppadlist->ARRAY)[1]->save; + my $init_av = init_av->save; + my $inc_hv = svref_2object(\%INC)->save; + my $inc_av = svref_2object(\@INC)->save; walkoptree(main_root, "save"); warn "done main optree, walking symtable for extras\n" if $debug_cv; save_unused_subs(@unused_sub_packages); $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), sprintf("PL_main_start = s\\_%x;", ${main_start()}), - "PL_curpad = AvARRAY($curpad_sym);"); + "PL_curpad = AvARRAY($curpad_sym);", + "PL_initav = $init_av;", + "GvHV(PL_incgv) = $inc_hv;", + "GvAV(PL_incgv) = $inc_av;", + "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", + "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));"); + warn "Writing output\n"; output_boilerplate(); print "\n"; output_all("perl_init"); @@ -1118,7 +1177,7 @@ sub init_sections { xpviv => \$xpvivsect, xpvnv => \$xpvnvsect, xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect, xrv => \$xrvsect, xpvbm => \$xpvbmsect, - xpvio => \$xpviosect); + xpvio => \$xpviosect, bootstrap => \$bootstrap); my ($name, $sectref); while (($name, $sectref) = splice(@sections, 0, 2)) { $$sectref = new B::Section $name, \%symtable, 0; diff --git a/contrib/perl5/ext/B/B/CC.pm b/contrib/perl5/ext/B/B/CC.pm index 9991d8e..d200d70 100644 --- a/contrib/perl5/ext/B/B/CC.pm +++ b/contrib/perl5/ext/B/B/CC.pm @@ -878,7 +878,7 @@ sub pp_sassign { } runtime("SvSETMAGIC(TOPs);"); } else { - my $dst = pop @stack; + my $dst = $stack[-1]; my $type = $dst->{type}; runtime("sv = POPs;"); runtime("MAYBE_TAINT_SASSIGN_SRC(sv);"); @@ -946,13 +946,25 @@ sub pp_entersub { write_back_lexicals(REGISTER|TEMPORARY); write_back_stack(); my $sym = doop($op); - runtime("if (PL_op != ($sym)->op_next) PL_op = (*PL_op->op_ppaddr)(ARGS);"); - runtime("SPAGAIN;"); + runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){"); + runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);"); + runtime("SPAGAIN;}"); $know_op = 0; invalidate_lexicals(REGISTER|TEMPORARY); return $op->next; } +sub pp_goto{ + + my $op = shift; + my $ppname = $op->ppaddr; + write_back_lexicals() unless $skip_lexicals{$ppname}; + write_back_stack() unless $skip_stack{$ppname}; + my $sym=doop($op); + runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}"); + invalidate_lexicals() unless $skip_invalidate{$ppname}; + return $op->next; +} sub pp_enterwrite { my $op = shift; pp_entersub($op); @@ -1051,7 +1063,7 @@ sub pp_return { write_back_lexicals(REGISTER|TEMPORARY); write_back_stack(); doop($op); - runtime("PUTBACK;", "return 0;"); + runtime("PUTBACK;", "return (PL_op)?PL_op->op_next:0;"); $know_op = 0; return $op->next; } @@ -1344,7 +1356,7 @@ sub cc { $need_freetmps = 0; } if (!$$op) { - runtime("PUTBACK;", "return 0;"); + runtime("PUTBACK;","return (PL_op)?PL_op->op_next:0;"); } elsif ($done{$$op}) { runtime(sprintf("goto %s;", label($op))); } @@ -1375,6 +1387,7 @@ sub cc_obj { sub cc_main { my @comppadlist = comppadlist->ARRAY; + my $curpad_nam = $comppadlist[0]->save; my $curpad_sym = $comppadlist[1]->save; my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist); save_unused_subs(@unused_sub_packages); @@ -1384,7 +1397,9 @@ sub cc_main { if (!defined($module)) { $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), "PL_main_start = $start;", - "PL_curpad = AvARRAY($curpad_sym);"); + "PL_curpad = AvARRAY($curpad_sym);", + "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", + "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));"); } output_boilerplate(); print "\n"; diff --git a/contrib/perl5/ext/B/B/Disassembler.pm b/contrib/perl5/ext/B/B/Disassembler.pm index f26441d..4a008a3 100644 --- a/contrib/perl5/ext/B/B/Disassembler.pm +++ b/contrib/perl5/ext/B/B/Disassembler.pm @@ -77,7 +77,7 @@ sub GET_PV { } } -sub GET_comment { +sub GET_comment_t { my $fh = shift; my ($str, $c); while (defined($c = $fh->getc) && $c ne "\n") { diff --git a/contrib/perl5/ext/B/Makefile.PL b/contrib/perl5/ext/B/Makefile.PL index cdcc4ed..80e5e1b 100644 --- a/contrib/perl5/ext/B/Makefile.PL +++ b/contrib/perl5/ext/B/Makefile.PL @@ -16,7 +16,7 @@ if ($^O eq 'MSWin32') { WriteMakefile( NAME => "B", VERSION => "a5", - MAN3PODS => ' ', + MAN3PODS => {}, clean => { FILES => "perl$e byteperl$e *$o B.c *~" } diff --git a/contrib/perl5/ext/B/README b/contrib/perl5/ext/B/README index 4e4ed25..fa3f085 100644 --- a/contrib/perl5/ext/B/README +++ b/contrib/perl5/ext/B/README @@ -20,8 +20,8 @@ in the file named "Artistic". If not, you can get one from the Perl distribution. You should also have received a copy of the GNU General Public License, in the file named "Copying". If not, you can get one - from the Perl distribution or else write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + from the Perl distribution or else write to the Free Software Foundation, + Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA. CHANGES diff --git a/contrib/perl5/ext/DB_File/Changes b/contrib/perl5/ext/DB_File/Changes index 993fe32..2fab919 100644 --- a/contrib/perl5/ext/DB_File/Changes +++ b/contrib/perl5/ext/DB_File/Changes @@ -203,3 +203,32 @@ 1.60 Changed the test to check for full tied array support + +1.61 19th November 1998 + + Added a note to README about how to build Berkeley DB 2.x when + using HP-UX. + Minor modifications to get the module to build with DB 2.5.x + Fixed a typo in the definition of O_RDONLY, courtesy of Mark Kettenis. + +1.62 30th November 1998 + + Added hints/dynixptx.pl. + Fixed typemap -- 1.61 used PL_na instead of na + +1.63 19th December 1998 + + * Fix to allow DB 2.6.x to build with DB_File + * Documentation updated to use push,pop etc in the RECNO example & + to include the find_dup & del_dup methods. + +1.64 21st February 1999 + + * Tidied the 1.x to 2.x flag mapping code. + * Added a patch from Mark Kettenis <kettenis@wins.uva.nl> to fix a flag + mapping problem with O_RDONLY on the Hurd + * Updated the message that db-recno.t prints when tests 51, 53 or 55 fail. + +1.65 6th March 1999 + * Fixed a bug in the recno PUSH logic. + * The BOOT version check now needs 2.3.4 when using Berkeley DB version 2 diff --git a/contrib/perl5/ext/DB_File/DB_File.pm b/contrib/perl5/ext/DB_File/DB_File.pm index fcd0746..e5759ff 100644 --- a/contrib/perl5/ext/DB_File/DB_File.pm +++ b/contrib/perl5/ext/DB_File/DB_File.pm @@ -1,10 +1,10 @@ # DB_File.pm -- Perl 5 interface to Berkeley DB # -# written by Paul Marquess (pmarquess@bfsec.bt.co.uk) -# last modified 16th May 1998 -# version 1.60 +# written by Paul Marquess (Paul.Marquess@btinternet.com) +# last modified 6th March 1999 +# version 1.65 # -# Copyright (c) 1995-8 Paul Marquess. All rights reserved. +# Copyright (c) 1995-9 Paul Marquess. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. @@ -145,7 +145,7 @@ use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO $db_ver use Carp; -$VERSION = "1.60" ; +$VERSION = "1.65" ; #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; $DB_BTREE = new DB_File::BTREEINFO ; @@ -300,6 +300,40 @@ sub STORESIZE } } +sub find_dup +{ + croak "Usage: \$db->find_dup(key,value)\n" + unless @_ == 3 ; + + my $db = shift ; + my ($origkey, $value_wanted) = @_ ; + my ($key, $value) = ($origkey, 0); + my ($status) = 0 ; + + for ($status = $db->seq($key, $value, R_CURSOR() ) ; + $status == 0 ; + $status = $db->seq($key, $value, R_NEXT() ) ) { + + return 0 if $key eq $origkey and $value eq $value_wanted ; + } + + return $status ; +} + +sub del_dup +{ + croak "Usage: \$db->del_dup(key,value)\n" + unless @_ == 3 ; + + my $db = shift ; + my ($key, $value) = @_ ; + my ($status) = $db->find_dup($key, $value) ; + return $status if $status != 0 ; + + $status = $db->del($key, R_CURSOR() ) ; + return $status ; +} + sub get_dup { croak "Usage: \$db->get_dup(key [,flag])\n" @@ -364,6 +398,8 @@ DB_File - Perl5 access to Berkeley DB version 1.x $count = $X->get_dup($key) ; @list = $X->get_dup($key) ; %list = $X->get_dup($key, 1) ; + $status = $X->find_dup($key, $value) ; + $status = $X->del_dup($key, $value) ; # RECNO only $a = $X->length; @@ -443,11 +479,11 @@ is considered stable enough for real work. B<Note:> The database file format has changed in Berkeley DB version 2. If you cannot recreate your databases, you must dump any existing databases with the C<db_dump185> utility that comes with Berkeley DB. -Once you have upgraded DB_File to use Berkeley DB version 2, your +Once you have rebuilt DB_File to use Berkeley DB version 2, your databases can be recreated using C<db_load>. Refer to the Berkeley DB documentation for further details. -Please read L<COPYRIGHT> before using version 2.x of Berkeley DB with +Please read L<"COPYRIGHT"> before using version 2.x of Berkeley DB with DB_File. =head2 Interface to Berkeley DB @@ -837,9 +873,12 @@ that prints: This time we have got all the key/value pairs, including the multiple values associated with the key C<Wall>. +To make life easier when dealing with duplicate keys, B<DB_File> comes with +a few utility methods. + =head2 The get_dup() Method -B<DB_File> comes with a utility method, called C<get_dup>, to assist in +The C<get_dup> method assists in reading duplicate values from BTREE databases. The method can take the following forms: @@ -888,6 +927,79 @@ and it will print: Smith => [John] Dog => [] +=head2 The find_dup() Method + + $status = $X->find_dup($key, $value) ; + +This method checks for the existance of a specific key/value pair. If the +pair exists, the cursor is left pointing to the pair and the method +returns 0. Otherwise the method returns a non-zero value. + +Assuming the database from the previous example: + + use strict ; + use DB_File ; + + use vars qw($filename $x %h $found) ; + + my $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; + print "Larry Wall is $found there\n" ; + + $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ; + print "Harry Wall is $found there\n" ; + + undef $x ; + untie %h ; + +prints this + + Larry Wall is there + Harry Wall is not there + + +=head2 The del_dup() Method + + $status = $X->del_dup($key, $value) ; + +This method deletes a specific key/value pair. It returns +0 if they exist and have been deleted successfully. +Otherwise the method returns a non-zero value. + +Again assuming the existance of the C<tree> database + + use strict ; + use DB_File ; + + use vars qw($filename $x %h $found) ; + + my $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + $x->del_dup("Wall", "Larry") ; + + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; + print "Larry Wall is $found there\n" ; + + undef $x ; + untie %h ; + +prints this + + Larry Wall is not there + =head2 Matching Partial Keys The BTREE interface has a feature which allows partial keys to be @@ -970,7 +1082,7 @@ Here is the output: DB_RECNO provides an interface to flat text files. Both variable and fixed length records are supported. -In order to make RECNO more compatible with Perl the array offset for +In order to make RECNO more compatible with Perl, the array offset for all RECNO arrays begins at 0 rather than 1 as in Berkeley DB. As with normal Perl arrays, a RECNO array can be accessed using @@ -999,7 +1111,7 @@ error will be fixed in the next release of Berkeley DB. That clarifies the situation with regards Berkeley DB itself. What about B<DB_File>? Well, the behavior defined in the quote above is -quite useful, so B<DB_File> conforms it. +quite useful, so B<DB_File> conforms to it. That means that you can specify other options (e.g. cachesize) and still have bval default to C<"\n"> for variable length records, and @@ -1007,7 +1119,9 @@ space for fixed length records. =head2 A Simple Example -Here is a simple example that uses RECNO. +Here is a simple example that uses RECNO (if you are using a version +of Perl earlier than 5.004_57 this example won't work -- see +L<Extra RECNO Methods> for a workaround). use strict ; use DB_File ; @@ -1021,6 +1135,18 @@ Here is a simple example that uses RECNO. $h[1] = "blue" ; $h[2] = "yellow" ; + push @h, "green", "black" ; + + my $elements = scalar @h ; + print "The array contains $elements entries\n" ; + + my $last = pop @h ; + print "popped $last\n" ; + + unshift @h, "white" ; + my $first = shift @h ; + print "shifted $first\n" ; + # Check for existence of a key print "Element 1 Exists with value $h[1]\n" if $h[1] ; @@ -1032,17 +1158,19 @@ Here is a simple example that uses RECNO. Here is the output from the script: - + The array contains 5 entries + popped black + unshifted white Element 1 Exists with value blue - The last element is yellow - The 2nd last element is blue + The last element is green + The 2nd last element is yellow -=head2 Extra Methods +=head2 Extra RECNO Methods If you are using a version of Perl earlier than 5.004_57, the tied -array interface is quite limited. The example script above will work, -but you won't be able to use C<push>, C<pop>, C<shift>, C<unshift> -etc. with the tied array. +array interface is quite limited. In the example script above +C<push>, C<pop>, C<shift>, C<unshift> +or determining the array length will not work with a tied array. To make the interface more useful for older versions of Perl, a number of methods are supplied with B<DB_File> to simulate the missing array @@ -1657,7 +1785,7 @@ compile properly on IRIX 5.3. =head1 COPYRIGHT -Copyright (c) 1995-8 Paul Marquess. All rights reserved. This program +Copyright (c) 1995-9 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. @@ -1688,7 +1816,7 @@ L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)> =head1 AUTHOR The DB_File interface was written by Paul Marquess -E<lt>pmarquess@bfsec.bt.co.ukE<gt>. +E<lt>Paul.Marquess@btinternet.comE<gt>. Questions about the DB system itself may be addressed to E<lt>db@sleepycat.com<gt>. diff --git a/contrib/perl5/ext/DB_File/DB_File.xs b/contrib/perl5/ext/DB_File/DB_File.xs index c661023..94113eb 100644 --- a/contrib/perl5/ext/DB_File/DB_File.xs +++ b/contrib/perl5/ext/DB_File/DB_File.xs @@ -2,13 +2,13 @@ DB_File.xs -- Perl 5 interface to Berkeley DB - written by Paul Marquess (pmarquess@bfsec.bt.co.uk) - last modified 16th May 1998 - version 1.60 + written by Paul Marquess <Paul.Marquess@btinternet.com> + last modified 6th March 1999 + version 1.65 All comments/suggestions/problems are welcome - Copyright (c) 1995, 1996, 1997, 1998 Paul Marquess. All rights reserved. + Copyright (c) 1995-9 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. @@ -56,6 +56,15 @@ This was ok for DB 1.x, but isn't for DB 2.x. 1.59 - No change to DB_File.xs 1.60 - Some code tidy up + 1.61 - added flagSet macro for DB 2.5.x + fixed typo in O_RDONLY test. + 1.62 - No change to DB_File.xs + 1.63 - Fix to alllow DB 2.6.x to build. + 1.64 - Tidied up the 1.x to 2.x flags mapping code. + Added a patch from Mark Kettenis <kettenis@wins.uva.nl> + to fix a flag mapping problem with O_RDONLY on the Hurd + 1.65 - Fixed a bug in the PUSH logic. + Added BOOT check that using 2.3.4 or greater @@ -65,6 +74,20 @@ #include "perl.h" #include "XSUB.h" +#ifndef PERL_VERSION +#include "patchlevel.h" +#define PERL_REVISION 5 +#define PERL_VERSION PATCHLEVEL +#define PERL_SUBVERSION SUBVERSION +#endif + +#if PERL_REVISION == 5 && (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION <= 75 )) + +# define PL_sv_undef sv_undef +# define PL_na na + +#endif + /* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be * shortly #included by the <db.h>) __attribute__ to the possibly * already defined __attribute__, for example by GNUC or by Perl. */ @@ -153,6 +176,12 @@ typedef db_recno_t recno_t; #define DBT_flags(x) x.flags = 0 #define DB_flags(x, v) x |= v +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 +#define flagSet(flags, bitmask) ((flags) & (bitmask)) +#else +#define flagSet(flags, bitmask) (((flags) & DB_OPFLAGS_MASK) == (bitmask)) +#endif + #else /* db version 1.x */ typedef union INFO { @@ -205,6 +234,7 @@ typedef union INFO { #define do_SEQ(db, key, value, flag) (db->dbp->seq)(db->dbp, &key, &value, flag) #define DBT_flags(x) #define DB_flags(x, v) +#define flagSet(flags, bitmask) ((flags) & (bitmask)) #endif /* db version 1 */ @@ -216,10 +246,11 @@ typedef union INFO { #define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags) #define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) + #ifdef DB_VERSION_MAJOR #define db_DESTROY(db) ((db->dbp)->close)(db->dbp, 0) #define db_close(db) ((db->dbp)->close)(db->dbp, 0) -#define db_del(db, key, flags) ((flags & R_CURSOR) \ +#define db_del(db, key, flags) (flagSet(flags, R_CURSOR) \ ? ((db->cursor)->c_del)(db->cursor, 0) \ : ((db->dbp)->del)(db->dbp, NULL, &key, flags) ) @@ -232,6 +263,7 @@ typedef union INFO { #endif + #define db_seq(db, key, value, flags) do_SEQ(db, key, value, flags) typedef struct { @@ -288,12 +320,17 @@ u_int flags ; { int status ; - if (flags & R_CURSOR) { + if (flagSet(flags, R_CURSOR)) { status = ((db->cursor)->c_del)(db->cursor, 0); if (status != 0) return status ; +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 flags &= ~R_CURSOR ; +#else + flags &= ~DB_OPFLAGS_MASK ; +#endif + } return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ; @@ -311,12 +348,12 @@ GetVersionInfo() (void)db_version(&Major, &Minor, &Patch) ; - /* check that libdb is recent enough */ - if (Major == 2 && Minor == 0 && Patch < 5) - croak("DB_File needs Berkeley DB 2.0.5 or greater, you have %d.%d.%d\n", + /* check that libdb is recent enough -- we need 2.3.4 or greater */ + if (Major == 2 && (Minor < 3 || (Minor == 3 && Patch < 4))) + croak("DB_File needs Berkeley DB 2.3.4 or greater, you have %d.%d.%d\n", Major, Minor, Patch) ; -#if PATCHLEVEL > 3 +#if PERL_VERSION > 3 sv_setpvf(ver_sv, "%d.%d", Major, Minor) ; #else { @@ -577,6 +614,7 @@ SV * sv ; DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; void * openinfo = NULL ; INFO * info = &RETVAL->info ; + STRLEN n_a; /* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */ Zero(RETVAL, 1, DB_File_type) ; @@ -718,11 +756,11 @@ SV * sv ; #endif svp = hv_fetch(action, "bfname", 6, FALSE); if (svp && SvOK(*svp)) { - char * ptr = SvPV(*svp,PL_na) ; + char * ptr = SvPV(*svp,n_a) ; #ifdef DB_VERSION_MAJOR - name = (char*) PL_na ? ptr : NULL ; + name = (char*) n_a ? ptr : NULL ; #else - info->db_RE_bfname = (char*) (PL_na ? ptr : NULL) ; + info->db_RE_bfname = (char*) (n_a ? ptr : NULL) ; #endif } else @@ -738,7 +776,7 @@ SV * sv ; { int value ; if (SvPOK(*svp)) - value = (int)*SvPV(*svp, PL_na) ; + value = (int)*SvPV(*svp, n_a) ; else value = SvIV(*svp) ; @@ -756,7 +794,7 @@ SV * sv ; if (svp && SvOK(*svp)) { if (SvPOK(*svp)) - info->db_RE_bval = (u_char)*SvPV(*svp, PL_na) ; + info->db_RE_bval = (u_char)*SvPV(*svp, n_a) ; else info->db_RE_bval = (u_char)(unsigned long) SvIV(*svp) ; DB_flags(info->flags, DB_DELIMITER) ; @@ -800,26 +838,26 @@ SV * sv ; if ((flags & O_CREAT) == O_CREAT) Flags |= DB_CREATE ; -#ifdef O_NONBLOCK - if ((flags & O_NONBLOCK) == O_NONBLOCK) - Flags |= DB_EXCL ; -#endif - #if O_RDONLY == 0 if (flags == O_RDONLY) #else - if (flags & O_RDONLY) == O_RDONLY) + if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR) #endif Flags |= DB_RDONLY ; -#ifdef O_NONBLOCK +#ifdef O_TRUNC if ((flags & O_TRUNC) == O_TRUNC) Flags |= DB_TRUNCATE ; #endif status = db_open(name, RETVAL->type, Flags, mode, NULL, openinfo, &RETVAL->dbp) ; if (status == 0) +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6 status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ; +#else + status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor, + 0) ; +#endif if (status) RETVAL->dbp = NULL ; @@ -1100,9 +1138,10 @@ db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_H { char * name = (char *) NULL ; SV * sv = (SV *) NULL ; + STRLEN n_a; if (items >= 3 && SvOK(ST(2))) - name = (char*) SvPV(ST(2), PL_na) ; + name = (char*) SvPV(ST(2), n_a) ; if (items == 6) sv = ST(5) ; @@ -1191,7 +1230,6 @@ db_FIRSTKEY(db) { DBTKEY key ; DBT value ; - DB * Db = db->dbp ; DBT_flags(key) ; DBT_flags(value) ; @@ -1208,7 +1246,6 @@ db_NEXTKEY(db, key) CODE: { DBT value ; - DB * Db = db->dbp ; DBT_flags(value) ; CurrentDB = db ; @@ -1232,6 +1269,7 @@ unshift(db, ...) int i ; int One ; DB * Db = db->dbp ; + STRLEN n_a; DBT_flags(key) ; DBT_flags(value) ; @@ -1245,8 +1283,8 @@ unshift(db, ...) #endif for (i = items-1 ; i > 0 ; --i) { - value.data = SvPV(ST(i), PL_na) ; - value.size = PL_na ; + value.data = SvPV(ST(i), n_a) ; + value.size = n_a ; One = 1 ; key.data = &One ; key.size = sizeof(int) ; @@ -1270,7 +1308,6 @@ pop(db) { DBTKEY key ; DBT value ; - DB * Db = db->dbp ; DBT_flags(key) ; DBT_flags(value) ; @@ -1298,7 +1335,6 @@ shift(db) { DBT value ; DBTKEY key ; - DB * Db = db->dbp ; DBT_flags(key) ; DBT_flags(value) ; @@ -1325,42 +1361,42 @@ push(db, ...) CODE: { DBTKEY key ; - DBTKEY * keyptr = &key ; DBT value ; DB * Db = db->dbp ; int i ; + STRLEN n_a; DBT_flags(key) ; DBT_flags(value) ; CurrentDB = db ; - /* Set the Cursor to the Last element */ - RETVAL = do_SEQ(db, key, value, R_LAST) ; - if (RETVAL >= 0) - { - if (RETVAL == 1) - keyptr = &empty ; #ifdef DB_VERSION_MAJOR + RETVAL = 0 ; + key = empty ; for (i = 1 ; i < items ; ++i) { - - ++ (* (int*)key.data) ; - value.data = SvPV(ST(i), PL_na) ; - value.size = PL_na ; - RETVAL = (Db->put)(Db, NULL, &key, &value, 0) ; + value.data = SvPV(ST(i), n_a) ; + value.size = n_a ; + RETVAL = (Db->put)(Db, NULL, &key, &value, DB_APPEND) ; if (RETVAL != 0) break; } #else + /* Set the Cursor to the Last element */ + RETVAL = do_SEQ(db, key, value, R_LAST) ; + if (RETVAL >= 0) + { + if (RETVAL == 1) + key = empty ; for (i = items - 1 ; i > 0 ; --i) { - value.data = SvPV(ST(i), PL_na) ; - value.size = PL_na ; - RETVAL = (Db->put)(Db, keyptr, &value, R_IAFTER) ; + value.data = SvPV(ST(i), n_a) ; + value.size = n_a ; + RETVAL = (Db->put)(Db, &key, &value, R_IAFTER) ; if (RETVAL != 0) break; } -#endif } +#endif } OUTPUT: RETVAL @@ -1436,7 +1472,7 @@ db_put(db, key, value, flags=0) #endif OUTPUT: RETVAL - key if (flags & (R_IAFTER|R_IBEFORE)) OutputKey(ST(1), key); + key if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) OutputKey(ST(1), key); int db_fd(db) diff --git a/contrib/perl5/ext/DB_File/Makefile.PL b/contrib/perl5/ext/DB_File/Makefile.PL index dbe19f1..1a13e0b 100644 --- a/contrib/perl5/ext/DB_File/Makefile.PL +++ b/contrib/perl5/ext/DB_File/Makefile.PL @@ -11,7 +11,7 @@ $LIB = "-llibdb" if $^O eq 'MSWin32' ; WriteMakefile( NAME => 'DB_File', LIBS => ["-L/usr/local/lib $LIB"], - MAN3PODS => ' ', # Pods will be built by installman. + MAN3PODS => {}, # Pods will be built by installman. #INC => '-I/usr/local/include', VERSION_FROM => 'DB_File.pm', XSPROTOARG => '-noprototypes', diff --git a/contrib/perl5/ext/DB_File/dbinfo b/contrib/perl5/ext/DB_File/dbinfo index 9640ba4..24a7944 100644 --- a/contrib/perl5/ext/DB_File/dbinfo +++ b/contrib/perl5/ext/DB_File/dbinfo @@ -3,7 +3,7 @@ # Name: dbinfo -- identify berkeley DB version used to create # a database file # -# Author: Paul Marquess +# Author: Paul Marquess <Paul.Marquess@btinternet.com> # Version: 1.01 # Date 16th April 1998 # diff --git a/contrib/perl5/ext/DB_File/hints/dynixptx.pl b/contrib/perl5/ext/DB_File/hints/dynixptx.pl new file mode 100644 index 0000000..bb5ffa5 --- /dev/null +++ b/contrib/perl5/ext/DB_File/hints/dynixptx.pl @@ -0,0 +1,3 @@ +# Need to add an extra '-lc' to the end to work around a DYNIX/ptx bug + +$self->{LIBS} = ['-lm -lc']; diff --git a/contrib/perl5/ext/DB_File/typemap b/contrib/perl5/ext/DB_File/typemap index 7af55ae..994ba27 100644 --- a/contrib/perl5/ext/DB_File/typemap +++ b/contrib/perl5/ext/DB_File/typemap @@ -1,8 +1,8 @@ # typemap for Perl 5 interface to Berkeley # -# written by Paul Marquess (pmarquess@bfsec.bt.co.uk) -# last modified 13th May 1998 -# version 1.59 +# written by Paul Marquess <Paul.Marquess@btinternet.com> +# last modified 21st February 1999 +# version 1.65 # #################################### DB SECTION # diff --git a/contrib/perl5/ext/Data/Dumper/Changes b/contrib/perl5/ext/Data/Dumper/Changes index a164958..9a96eda 100644 --- a/contrib/perl5/ext/Data/Dumper/Changes +++ b/contrib/perl5/ext/Data/Dumper/Changes @@ -6,6 +6,24 @@ HISTORY - public release history for Data::Dumper =over 8 +=item 2.10 (31 Oct 1998) + +Bugfixes for dumping related undef values, globs, and better double +quoting: three patches suggested by Gisle Aas <gisle@aas.no>. + +Escaping of single quotes in the XS version could get tripped up +by the presence of nulls in the string. Fix suggested by +Slaven Rezic <eserte@cs.tu-berlin.de>. + +Rather large scale reworking of the logic in how seen values +are stashed. Anonymous scalars that may be encountered while +traversing the structure are properly tracked, in case they become +used in data dumped in a later pass. There used to be a problem +with the previous logic that prevented such structures from being +dumped correctly. + +Various additions to the testsuite. + =item 2.09 (9 July 1998) Implement $Data::Dumper::Bless, suggested by Mark Daku <daku@nortel.ca>. diff --git a/contrib/perl5/ext/Data/Dumper/Dumper.pm b/contrib/perl5/ext/Data/Dumper/Dumper.pm index e3c361f..b1fd2b7 100644 --- a/contrib/perl5/ext/Data/Dumper/Dumper.pm +++ b/contrib/perl5/ext/Data/Dumper/Dumper.pm @@ -9,7 +9,7 @@ package Data::Dumper; -$VERSION = $VERSION = '2.09'; +$VERSION = $VERSION = '2.101'; #$| = 1; @@ -208,8 +208,6 @@ sub _dump { my($sname); my($out, $realpack, $realtype, $type, $ipad, $id, $blesspad); - return "undef" unless defined $val; - $type = ref $val; $out = ""; @@ -218,47 +216,47 @@ sub _dump { # prep it, if it looks like an object if ($type =~ /[a-z_:]/) { my $freezer = $s->{freezer}; - # UNIVERSAL::can should be used here, when we can require 5.004 - if ($freezer) { - eval { $val->$freezer() }; - carp "WARNING(Freezer method call failed): $@" if $@; - } + $val->$freezer() if $freezer && UNIVERSAL::can($val, $freezer); } ($realpack, $realtype, $id) = (overload::StrVal($val) =~ /^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$/); - # keep a tab on it so that we dont fall into recursive pit - if (exists $s->{seen}{$id}) { -# if ($s->{expdepth} < $s->{level}) { - if ($s->{purity} and $s->{level} > 0) { - $out = ($realtype eq 'HASH') ? '{}' : - ($realtype eq 'ARRAY') ? '[]' : - "''" ; - push @post, $name . " = " . $s->{seen}{$id}[0]; - } - else { - $out = $s->{seen}{$id}[0]; - if ($name =~ /^([\@\%])/) { - my $start = $1; - if ($out =~ /^\\$start/) { - $out = substr($out, 1); + # if it has a name, we need to either look it up, or keep a tab + # on it so we know when we hit it later + if (defined($name) and length($name)) { + # keep a tab on it so that we dont fall into recursive pit + if (exists $s->{seen}{$id}) { +# if ($s->{expdepth} < $s->{level}) { + if ($s->{purity} and $s->{level} > 0) { + $out = ($realtype eq 'HASH') ? '{}' : + ($realtype eq 'ARRAY') ? '[]' : + "''" ; + push @post, $name . " = " . $s->{seen}{$id}[0]; } else { - $out = $start . '{' . $out . '}'; - } - } + $out = $s->{seen}{$id}[0]; + if ($name =~ /^([\@\%])/) { + my $start = $1; + if ($out =~ /^\\$start/) { + $out = substr($out, 1); + } + else { + $out = $start . '{' . $out . '}'; + } + } + } + return $out; +# } + } + else { + # store our name + $s->{seen}{$id} = [ (($name =~ /^[@%]/) ? ('\\' . $name ) : + ($realtype eq 'CODE' and + $name =~ /^[*](.*)$/) ? ('\\&' . $1 ) : + $name ), + $val ]; } - return $out; -# } - } - else { - # store our name - $s->{seen}{$id} = [ (($name =~ /^[@%]/) ? ('\\' . $name ) : - ($realtype eq 'CODE' and - $name =~ /^[*](.*)$/) ? ('\\&' . $1 ) : - $name ), - $val ]; } $s->{level}++; @@ -272,14 +270,14 @@ sub _dump { if ($realtype eq 'SCALAR') { if ($realpack) { - $out .= 'do{\\(my $o = ' . $s->_dump($$val, "") . ')}'; + $out .= 'do{\\(my $o = ' . $s->_dump($$val, "\${$name}") . ')}'; } else { - $out .= '\\' . $s->_dump($$val, ""); + $out .= '\\' . $s->_dump($$val, "\${$name}"); } } elsif ($realtype eq 'GLOB') { - $out .= '\\' . $s->_dump($$val, ""); + $out .= '\\' . $s->_dump($$val, "*{$name}"); } elsif ($realtype eq 'ARRAY') { my($v, $pad, $mname); @@ -287,7 +285,9 @@ sub _dump { $out .= ($name =~ /^\@/) ? '(' : '['; $pad = $s->{sep} . $s->{pad} . $s->{apad}; ($name =~ /^\@(.*)$/) ? ($mname = "\$" . $1) : - ($name =~ /[]}]$/) ? ($mname = $name) : ($mname = $name . '->'); + # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar} + ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) : + ($mname = $name . '->'); $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/; for $v (@$val) { $sname = $mname . '[' . $i . ']'; @@ -303,8 +303,10 @@ sub _dump { $out .= ($name =~ /^\%/) ? '(' : '{'; $pad = $s->{sep} . $s->{pad} . $s->{apad}; $lpad = $s->{apad}; - ($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) : - ($name =~ /[]}]$/) ? ($mname = $name) : ($mname = $name . '->'); + ($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) : + # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar} + ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) : + ($mname = $name . '->'); $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/; while (($k, $v) = each %$val) { my $nk = $s->_dump($k, ""); @@ -324,8 +326,7 @@ sub _dump { $out .= ($name =~ /^\%/) ? ')' : '}'; } elsif ($realtype eq 'CODE') { - $out .= '"DUMMY"'; - $out = 'sub { ' . $out . ' }'; + $out .= 'sub { "DUMMY" }'; carp "Encountered CODE ref, using dummy placeholder" if $s->{purity}; } else { @@ -347,11 +348,15 @@ sub _dump { if ($name ne '') { ($id) = ("$ref" =~ /\(([^\(]*)\)$/); if (exists $s->{seen}{$id}) { - $out = $s->{seen}{$id}[0]; - return $out; + if ($s->{seen}{$id}[2]) { + $out = $s->{seen}{$id}[0]; + #warn "[<$out]\n"; + return "\${$out}"; + } } else { - $s->{seen}{$id} = ["\\$name", $val]; + #warn "[>\\$name]\n"; + $s->{seen}{$id} = ["\\$name", $ref]; } } if (ref($ref) eq 'GLOB' or "$ref" =~ /=GLOB\([^()]+\)$/) { # glob @@ -368,21 +373,28 @@ sub _dump { my $k; local ($s->{level}) = 0; for $k (qw(SCALAR ARRAY HASH)) { + my $gval = *$val{$k}; + next unless defined $gval; + next if $k eq "SCALAR" && ! defined $$gval; # always there + # _dump can push into @post, so we hold our place using $postlen my $postlen = scalar @post; $post[$postlen] = "\*$sname = "; local ($s->{apad}) = " " x length($post[$postlen]) if $s->{indent} >= 2; - $post[$postlen] .= $s->_dump(*{$name}{$k}, "\*$sname\{$k\}"); + $post[$postlen] .= $s->_dump($gval, "\*$sname\{$k\}"); } } $out .= '*' . $sname; } + elsif (!defined($val)) { + $out .= "undef"; + } elsif ($val =~ /^-?[1-9]\d{0,8}$/) { # safe decimal number $out .= $val; } else { # string if ($s->{useqq}) { - $out .= qquote($val); + $out .= qquote($val, $s->{useqq}); } else { $val =~ s/([\\\'])/\\$1/g; @@ -390,10 +402,16 @@ sub _dump { } } } - - # if we made it this far, $id was added to seen list at current - # level, so remove it to get deep copies - delete($s->{seen}{$id}) if $id and $s->{deepcopy}; + if ($id) { + # if we made it this far, $id was added to seen list at current + # level, so remove it to get deep copies + if ($s->{deepcopy}) { + delete($s->{seen}{$id}); + } + elsif ($name) { + $s->{seen}{$id}[2] = 1; + } + } return $out; } @@ -493,22 +511,41 @@ sub Bless { defined($v) ? (($s->{'bless'} = $v), return $s) : $s->{'bless'}; } +# used by qquote below +my %esc = ( + "\a" => "\\a", + "\b" => "\\b", + "\t" => "\\t", + "\n" => "\\n", + "\f" => "\\f", + "\r" => "\\r", + "\e" => "\\e", +); + # put a string value in double quotes sub qquote { local($_) = shift; - s/([\\\"\@\$\%])/\\$1/g; - s/\a/\\a/g; - s/[\b]/\\b/g; - s/\t/\\t/g; - s/\n/\\n/g; - s/\f/\\f/g; - s/\r/\\r/g; - s/\e/\\e/g; - -# this won't work! -# s/([^\a\b\t\n\f\r\e\038-\176])/'\\'.sprintf('%03o',ord($1))/eg; - s/([\000-\006\013\016-\032\034-\037\177\200-\377])/'\\'.sprintf('%03o',ord($1))/eg; - return "\"$_\""; + s/([\\\"\@\$])/\\$1/g; + return qq("$_") unless /[^\040-\176]/; # 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; + } + return qq("$_"); } 1; @@ -954,7 +991,7 @@ modify it under the same terms as Perl itself. =head1 VERSION -Version 2.09 (9 July 1998) +Version 2.10 (31 Oct 1998) =head1 SEE ALSO diff --git a/contrib/perl5/ext/Data/Dumper/Dumper.xs b/contrib/perl5/ext/Data/Dumper/Dumper.xs index d8012ee..a3da110 100644 --- a/contrib/perl5/ext/Data/Dumper/Dumper.xs +++ b/contrib/perl5/ext/Data/Dumper/Dumper.xs @@ -2,8 +2,19 @@ #include "perl.h" #include "XSUB.h" -static SV *freezer; -static SV *toaster; +#include "patchlevel.h" + +#if PATCHLEVEL < 5 +# ifndef PL_sv_undef +# define PL_sv_undef sv_undef +# endif +# ifndef ERRSV +# define ERRSV GvSV(errgv) +# endif +# ifndef newSVpvn +# define newSVpvn newSVpv +# endif +#endif static I32 num_q _((char *s, STRLEN slen)); static I32 esc_q _((char *dest, char *src, STRLEN slen)); @@ -84,7 +95,7 @@ static SV * sv_x(SV *sv, register char *str, STRLEN len, I32 n) { if (sv == Nullsv) - sv = newSVpv("", 0); + sv = newSVpvn("", 0); else assert(SvTYPE(sv) >= SVt_PV); @@ -121,11 +132,9 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, U32 i; char *c, *r, *realpack, id[128]; SV **svp; - SV *sv; + SV *sv, *ipad, *ival; SV *blesspad = Nullsv; - SV *ipad; - SV *ival; - AV *seenentry; + AV *seenentry = Nullav; char *iname; STRLEN inamelen, idlen = 0; U32 flags; @@ -139,10 +148,6 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, if (SvGMAGICAL(val)) mg_get(val); - if (val == &PL_sv_undef || !SvOK(val)) { - sv_catpvn(retval, "undef", 5); - return 1; - } if (SvROK(val)) { if (SvOBJECT(SvRV(val)) && freezer && @@ -152,9 +157,9 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, XPUSHs(val); PUTBACK; i = perl_call_method(SvPVX(freezer), G_EVAL|G_SCALAR); SPAGAIN; - if (SvTRUE(GvSV(PL_errgv))) + if (SvTRUE(ERRSV)) warn("WARNING(Freezer method call failed): %s", - SvPVX(GvSV(PL_errgv))); + SvPVX(ERRSV)); else if (i) val = newSVsv(POPs); PUTBACK; FREETMPS; LEAVE; @@ -171,67 +176,77 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, realpack = HvNAME(SvSTASH(ival)); else realpack = Nullch; - if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) && - (sv = *svp) && SvROK(sv) && - (seenentry = (AV*)SvRV(sv))) { - SV *othername; - if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)) { - if (purity && *levelp > 0) { - SV *postentry; - - if (realtype == SVt_PVHV) - sv_catpvn(retval, "{}", 2); - else if (realtype == SVt_PVAV) - sv_catpvn(retval, "[]", 2); - else - sv_catpvn(retval, "''", 2); - postentry = newSVpv(name, namelen); - sv_catpvn(postentry, " = ", 3); - sv_catsv(postentry, othername); - av_push(postav, postentry); - } - else { - if (name[0] == '@' || name[0] == '%') { - if ((SvPVX(othername))[0] == '\\' && - (SvPVX(othername))[1] == name[0]) { - sv_catpvn(retval, SvPVX(othername)+1, SvCUR(othername)-1); + + /* if it has a name, we need to either look it up, or keep a tab + * on it so we know when we hit it later + */ + if (namelen) { + if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) + && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv))) + { + SV *othername; + if ((svp = av_fetch(seenentry, 0, FALSE)) + && (othername = *svp)) + { + if (purity && *levelp > 0) { + SV *postentry; + + if (realtype == SVt_PVHV) + sv_catpvn(retval, "{}", 2); + else if (realtype == SVt_PVAV) + sv_catpvn(retval, "[]", 2); + else + sv_catpvn(retval, "''", 2); + postentry = newSVpvn(name, namelen); + sv_catpvn(postentry, " = ", 3); + sv_catsv(postentry, othername); + av_push(postav, postentry); + } + else { + if (name[0] == '@' || name[0] == '%') { + if ((SvPVX(othername))[0] == '\\' && + (SvPVX(othername))[1] == name[0]) { + sv_catpvn(retval, SvPVX(othername)+1, + SvCUR(othername)-1); + } + else { + sv_catpvn(retval, name, 1); + sv_catpvn(retval, "{", 1); + sv_catsv(retval, othername); + sv_catpvn(retval, "}", 1); + } } - else { - sv_catpvn(retval, name, 1); - sv_catpvn(retval, "{", 1); + else sv_catsv(retval, othername); - sv_catpvn(retval, "}", 1); - } } - else - sv_catsv(retval, othername); + return 1; + } + else { + warn("ref name not found for %s", id); + return 0; } - return 1; - } - else { - warn("ref name not found for %s", id); - return 0; - } - } - else { /* store our name and continue */ - SV *namesv; - if (name[0] == '@' || name[0] == '%') { - namesv = newSVpv("\\", 1); - sv_catpvn(namesv, name, namelen); } - else if (realtype == SVt_PVCV && name[0] == '*') { - namesv = newSVpv("\\", 2); - sv_catpvn(namesv, name, namelen); - (SvPVX(namesv))[1] = '&'; + else { /* store our name and continue */ + SV *namesv; + if (name[0] == '@' || name[0] == '%') { + namesv = newSVpvn("\\", 1); + sv_catpvn(namesv, name, namelen); + } + else if (realtype == SVt_PVCV && name[0] == '*') { + namesv = newSVpvn("\\", 2); + sv_catpvn(namesv, name, namelen); + (SvPVX(namesv))[1] = '&'; + } + else + namesv = newSVpvn(name, namelen); + seenentry = newAV(); + av_push(seenentry, namesv); + (void)SvREFCNT_inc(val); + av_push(seenentry, val); + (void)hv_store(seenhv, id, strlen(id), + newRV((SV*)seenentry), 0); + SvREFCNT_dec(seenentry); } - else - namesv = newSVpv(name, namelen); - seenentry = newAV(); - av_push(seenentry, namesv); - (void)SvREFCNT_inc(val); - av_push(seenentry, val); - (void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0); - SvREFCNT_dec(seenentry); } (*levelp)++; @@ -249,20 +264,34 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, } } - if (realtype <= SVt_PVBM || realtype == SVt_PVGV) { /* scalars */ - if (realpack && realtype != SVt_PVGV) { /* blessed */ + if (realtype <= SVt_PVBM) { /* scalar ref */ + SV *namesv = newSVpvn("${", 2); + sv_catpvn(namesv, name, namelen); + sv_catpvn(namesv, "}", 1); + if (realpack) { /* blessed */ sv_catpvn(retval, "do{\\(my $o = ", 13); - DD_dump(ival, "", 0, retval, seenhv, postav, - levelp, indent, pad, xpad, apad, sep, + DD_dump(ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv, + postav, levelp, indent, pad, xpad, apad, sep, freezer, toaster, purity, deepcopy, quotekeys, bless); sv_catpvn(retval, ")}", 2); - } + } /* plain */ else { sv_catpvn(retval, "\\", 1); - DD_dump(ival, "", 0, retval, seenhv, postav, - levelp, indent, pad, xpad, apad, sep, + DD_dump(ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv, + postav, levelp, indent, pad, xpad, apad, sep, freezer, toaster, purity, deepcopy, quotekeys, bless); } + SvREFCNT_dec(namesv); + } + else if (realtype == SVt_PVGV) { /* glob ref */ + SV *namesv = newSVpvn("*{", 2); + sv_catpvn(namesv, name, namelen); + sv_catpvn(namesv, "}", 1); + sv_catpvn(retval, "\\", 1); + DD_dump(ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv, + postav, levelp, indent, pad, xpad, apad, sep, + freezer, toaster, purity, deepcopy, quotekeys, bless); + SvREFCNT_dec(namesv); } else if (realtype == SVt_PVAV) { SV *totpad; @@ -280,7 +309,16 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, } else { sv_catpvn(retval, "[", 1); - if (namelen > 0 && name[namelen-1] != ']' && name[namelen-1] != '}') { + /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */ + /*if (namelen > 0 + && name[namelen-1] != ']' && name[namelen-1] != '}' + && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/ + if ((namelen > 0 + && name[namelen-1] != ']' && name[namelen-1] != '}') + || (namelen > 4 + && (name[1] == '{' + || (name[0] == '\\' && name[2] == '{')))) + { iname[inamelen++] = '-'; iname[inamelen++] = '>'; iname[inamelen] = '\0'; } @@ -346,14 +384,20 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, I32 klen; SV *hval; - iname = newSVpv(name, namelen); + iname = newSVpvn(name, namelen); if (name[0] == '%') { sv_catpvn(retval, "(", 1); (SvPVX(iname))[0] = '$'; } else { sv_catpvn(retval, "{", 1); - if (namelen > 0 && name[namelen-1] != ']' && name[namelen-1] != '}') { + /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */ + if ((namelen > 0 + && name[namelen-1] != ']' && name[namelen-1] != '}') + || (namelen > 4 + && (name[1] == '{' + || (name[0] == '\\' && name[2] == '{')))) + { sv_catpvn(iname, "->", 2); } } @@ -472,33 +516,36 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, (void) sprintf(id, "0x%lx", (unsigned long)val); if ((svp = hv_fetch(seenhv, id, (idlen = strlen(id)), FALSE)) && (sv = *svp) && SvROK(sv) && - (seenentry = (AV*)SvRV(sv))) { + (seenentry = (AV*)SvRV(sv))) + { SV *othername; - if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)) { + if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp) + && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0) + { + sv_catpvn(retval, "${", 2); sv_catsv(retval, othername); + sv_catpvn(retval, "}", 1); return 1; } } else { SV *namesv; - namesv = newSVpv("\\", 1); + namesv = newSVpvn("\\", 1); sv_catpvn(namesv, name, namelen); seenentry = newAV(); av_push(seenentry, namesv); - (void)SvREFCNT_inc(val); - av_push(seenentry, val); + av_push(seenentry, newRV(val)); (void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0); SvREFCNT_dec(seenentry); } } - + if (SvIOK(val)) { STRLEN len; i = SvIV(val); (void) sprintf(tmpbuf, "%d", i); len = strlen(tmpbuf); sv_catpvn(retval, tmpbuf, len); - return 1; } else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */ c = SvPV(val, i); @@ -522,21 +569,27 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, r[0] = '*'; strcpy(r+1, c); i++; } + SvCUR_set(retval, SvCUR(retval)+i); if (purity) { static char *entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" }; static STRLEN sizes[] = { 8, 7, 6 }; SV *e; - SV *nname = newSVpv("", 0); - SV *newapad = newSVpv("", 0); + SV *nname = newSVpvn("", 0); + SV *newapad = newSVpvn("", 0); GV *gv = (GV*)val; I32 j; for (j=0; j<3; j++) { e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv)); - if (e) { + if (!e) + continue; + if (j == 0 && !SvOK(e)) + continue; + + { I32 nlevel = 0; - SV *postentry = newSVpv(r,i); + SV *postentry = newSVpvn(r,i); sv_setsv(nname, postentry); sv_catpvn(nname, entries[j], sizes[j]); @@ -560,6 +613,9 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, SvREFCNT_dec(nname); } } + else if (val == &PL_sv_undef || !SvOK(val)) { + sv_catpvn(retval, "undef", 5); + } else { c = SvPV(val, i); sv_grow(retval, SvCUR(retval)+3+2*i); @@ -569,13 +625,18 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, ++i; r[i++] = '\''; r[i] = '\0'; + SvCUR_set(retval, SvCUR(retval)+i); } - SvCUR_set(retval, SvCUR(retval)+i); } - if (deepcopy && idlen) - (void)hv_delete(seenhv, id, idlen, G_DISCARD); - + if (idlen) { + if (deepcopy) + (void)hv_delete(seenhv, id, idlen, G_DISCARD); + else if (namelen && seenentry) { + SV *mark = *av_fetch(seenentry, 2, TRUE); + sv_setiv(mark,1); + } + } return 1; } @@ -647,7 +708,7 @@ Data_Dumper_Dumpxs(href, ...) terse = useqq = purity = deepcopy = 0; quotekeys = 1; - retval = newSVpv("", 0); + retval = newSVpvn("", 0); if (SvROK(href) && (hv = (HV*)SvRV((SV*)href)) && SvTYPE(hv) == SVt_PVHV) { @@ -692,7 +753,7 @@ Data_Dumper_Dumpxs(href, ...) imax = av_len(todumpav); else imax = -1; - valstr = newSVpv("",0); + valstr = newSVpvn("",0); for (i = 0; i <= imax; ++i) { SV *newapad; @@ -787,7 +848,7 @@ Data_Dumper_Dumpxs(href, ...) if (gimme == G_ARRAY) { XPUSHs(sv_2mortal(retval)); if (i < imax) /* not the last time thro ? */ - retval = newSVpv("",0); + retval = newSVpvn("",0); } } SvREFCNT_dec(postav); diff --git a/contrib/perl5/ext/Data/Dumper/Makefile.PL b/contrib/perl5/ext/Data/Dumper/Makefile.PL index 6c94e95d..12930c5 100644 --- a/contrib/perl5/ext/Data/Dumper/Makefile.PL +++ b/contrib/perl5/ext/Data/Dumper/Makefile.PL @@ -7,5 +7,5 @@ WriteMakefile( SUFFIX => 'gz', DIST_DEFAULT => 'all tardist', }, - MAN3PODS => ' ', + MAN3PODS => {}, ); diff --git a/contrib/perl5/ext/Data/Dumper/Todo b/contrib/perl5/ext/Data/Dumper/Todo index 4a41f97..7dcd40b 100644 --- a/contrib/perl5/ext/Data/Dumper/Todo +++ b/contrib/perl5/ext/Data/Dumper/Todo @@ -29,4 +29,6 @@ where we don't care so much for cross-references). =item Implement redesign that allows various backends (Perl, Lisp, some-binary-data-format, graph-description-languages, etc.) +=item Dump traversal in breadth-first order + =back diff --git a/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL b/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL index 4c41559..cf7d708 100644 --- a/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL +++ b/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL @@ -101,7 +101,8 @@ push(@dl_library_path, split(/:/, $ENV{LD_LIBRARY_PATH})) # No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. -boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader); +boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) && + !defined(&dl_load_file); if ($dl_debug) { diff --git a/contrib/perl5/ext/DynaLoader/Makefile.PL b/contrib/perl5/ext/DynaLoader/Makefile.PL index 7a75115..2141fde 100644 --- a/contrib/perl5/ext/DynaLoader/Makefile.PL +++ b/contrib/perl5/ext/DynaLoader/Makefile.PL @@ -4,7 +4,7 @@ WriteMakefile( NAME => 'DynaLoader', LINKTYPE => 'static', DEFINE => '-DPERL_CORE -DLIBC="$(LIBC)"', - MAN3PODS => ' ', # Pods will be built by installman. + MAN3PODS => {}, # Pods will be built by installman. SKIP => [qw(dynamic dynamic_lib dynamic_bs)], XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'DynaLoader_pm.PL', diff --git a/contrib/perl5/ext/DynaLoader/dl_beos.xs b/contrib/perl5/ext/DynaLoader/dl_beos.xs new file mode 100644 index 0000000..42a27cb --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_beos.xs @@ -0,0 +1,115 @@ +/* + * dl_beos.xs, by Tom Spindler + * based on dl_dlopen.xs, by Paul Marquess + * $Id:$ + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include <be/kernel/image.h> +#include <OS.h> +#include <stdlib.h> +#include <limits.h> + +#define dlerror() strerror(errno) + +#include "dlutils.c" /* SaveError() etc */ + +static void +dl_private_init() +{ + (void)dl_generic_private_init(); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + + +void * +dl_load_file(filename, flags=0) + char * filename + int flags + CODE: +{ image_id bogo; + char *path; + path = malloc(PATH_MAX); + if (*filename != '/') { + getcwd(path, PATH_MAX); + strcat(path, "/"); + strcat(path, filename); + } else { + strcpy(path, filename); + } + + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", path, flags)); + bogo = load_add_on(path); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%lx\n", (unsigned long) RETVAL)); + ST(0) = sv_newmortal() ; + if (bogo < 0) { + SaveError("%s", strerror(bogo)); + PerlIO_printf(PerlIO_stderr(), "load_add_on(%s) : %d (%s)\n", path, bogo, strerror(bogo)); + } else { + RETVAL = (void *) bogo; + sv_setiv( ST(0), (IV)RETVAL); + } + free(path); +} + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: + status_t retcode; + void *adr = 0; +#ifdef DLSYM_NEEDS_UNDERSCORE + symbolname = form("_%s", symbolname); +#endif + RETVAL = NULL; + DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + "dl_find_symbol(handle=%lx, symbol=%s)\n", + (unsigned long) libhandle, symbolname)); + retcode = get_image_symbol((image_id) libhandle, symbolname, + B_SYMBOL_TYPE_TEXT, (void **) &adr); + RETVAL = adr; + DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + " symbolref = %lx\n", (unsigned long) RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) { + SaveError("%s", strerror(retcode)) ; + PerlIO_printf(PerlIO_stderr(), "retcode = %p (%s)\n", retcode, strerror(retcode)); + } else + sv_setiv( ST(0), (IV)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(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%lx)\n", + perl_name, (unsigned long) symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)_((CV *)))symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_cygwin32.xs b/contrib/perl5/ext/DynaLoader/dl_cygwin32.xs index 2b75637..b64ab3e 100644 --- a/contrib/perl5/ext/DynaLoader/dl_cygwin32.xs +++ b/contrib/perl5/ext/DynaLoader/dl_cygwin32.xs @@ -82,11 +82,11 @@ dl_load_file(filename,flags=0) int flags PREINIT: CODE: - DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(),"dl_load_file(%s):\n", filename)); RETVAL = (void*) LoadLibraryExA(filename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH ) ; - DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL){ SaveError("%d",GetLastError()) ; @@ -113,10 +113,10 @@ dl_find_symbol(libhandle, symbolname) void * libhandle char * symbolname CODE: - DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname); - DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%d",GetLastError()) ; @@ -138,7 +138,7 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); diff --git a/contrib/perl5/ext/DynaLoader/dl_mpeix.xs b/contrib/perl5/ext/DynaLoader/dl_mpeix.xs index 808c3b0..4cc07ec 100644 --- a/contrib/perl5/ext/DynaLoader/dl_mpeix.xs +++ b/contrib/perl5/ext/DynaLoader/dl_mpeix.xs @@ -2,6 +2,7 @@ * Author: Mark Klein (mklein@dis.com) * Version: 2.1, 1996/07/25 * Version: 2.2, 1997/09/25 Mark Bixby (markb@cccd.edu) + * Version: 2.3, 1998/11/19 Mark Bixby (markb@cccd.edu) */ #include "EXTERN.h" @@ -59,13 +60,13 @@ flags)); ",filename); obj = (p_mpe_dld) safemalloc(sizeof(t_mpe_dld)); memzero(obj, sizeof(t_mpe_dld)); - if (filename[0] == '.') + if (filename[0] != '/') { getcwd(buf,sizeof(buf)); - sprintf(obj->filename,"$%s/%s$",buf,filename); + sprintf(obj->filename," %s/%s ",buf,filename); } else - sprintf(obj->filename,"$%s$",filename); + sprintf(obj->filename," %s ",filename); DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," libref=%x\n", obj)); @@ -90,11 +91,11 @@ dl_find_symbol(libhandle, symbolname) ST(0) = sv_newmortal() ; errno = 0; - sprintf(symname, "$%s$", symbolname); + sprintf(symname, " %s ", symbolname); HPGETPROCPLABEL(8, symname, &symaddr, &status, obj->filename, 1, 0, &datalen, 1, 0, 0); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," symbolref(PROCEDURE) = %x\n", symaddr)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," symbolref(PROCEDURE) = %x, status=%x\n", symaddr, status)); if (status != 0) { SaveError("%s",(errno) ? Strerror(errno) : "Symbol not found") ; diff --git a/contrib/perl5/ext/DynaLoader/dl_next.xs b/contrib/perl5/ext/DynaLoader/dl_next.xs index 2b547f0..dfa8a3e 100644 --- a/contrib/perl5/ext/DynaLoader/dl_next.xs +++ b/contrib/perl5/ext/DynaLoader/dl_next.xs @@ -172,6 +172,7 @@ static char *dlopen(char *path, int mode /* mode is ignored */) I32 i, psize; char *result; char **p; + STRLEN n_a; /* Do not load what is already loaded into this process */ if (hv_fetch(dl_loaded_files, path, strlen(path), 0)) @@ -182,7 +183,7 @@ static char *dlopen(char *path, int mode /* mode is ignored */) p = (char **) safemalloc(psize * sizeof(char*)); p[0] = path; for(i=1; i<psize-1; i++) { - p[i] = SvPVx(*av_fetch(dl_resolve_using, i-1, TRUE), PL_na); + p[i] = SvPVx(*av_fetch(dl_resolve_using, i-1, TRUE), n_a); } p[psize-1] = 0; rld_success = rld_load(nxerr, (struct mach_header **)0, p, diff --git a/contrib/perl5/ext/DynaLoader/dl_vms.xs b/contrib/perl5/ext/DynaLoader/dl_vms.xs index 974fd58..08fd2f3 100644 --- a/contrib/perl5/ext/DynaLoader/dl_vms.xs +++ b/contrib/perl5/ext/DynaLoader/dl_vms.xs @@ -1,7 +1,7 @@ /* dl_vms.xs * * Platform: OpenVMS, VAX or AXP - * Author: Charles Bailey bailey@genetics.upenn.edu + * Author: Charles Bailey bailey@newman.upenn.edu * Revised: 12-Dec-1994 * * Implementation Note diff --git a/contrib/perl5/ext/Errno/Errno_pm.PL b/contrib/perl5/ext/Errno/Errno_pm.PL index f4d5020..c1f26fc 100644 --- a/contrib/perl5/ext/Errno/Errno_pm.PL +++ b/contrib/perl5/ext/Errno/Errno_pm.PL @@ -4,7 +4,7 @@ use strict; use vars qw($VERSION); -$VERSION = "1.09"; +$VERSION = "1.111"; my %err = (); @@ -21,7 +21,7 @@ unlink "errno.c" if -f "errno.c"; sub process_file { my($file) = @_; - return unless defined $file; + return unless defined $file and -f $file; local *FH; if (($^O eq 'VMS') && ($Config{vms_cc_type} ne 'gnuc')) { @@ -31,7 +31,9 @@ sub process_file { } } else { unless(open(FH,"< $file")) { - warn "Cannot open '$file'"; + # This file could be a temporary file created by cppstdin + # so only warn under -w, and return + warn "Cannot open '$file'" if $^W; return; } } @@ -42,6 +44,24 @@ sub process_file { close(FH); } +my $cppstdin; + +sub default_cpp { + unless (defined $cppstdin) { + use File::Spec; + $cppstdin = $Config{cppstdin}; + my $upup_cppstdin = File::Spec->catfile(File::Spec->updir, + File::Spec->updir, + "cppstdin"); + my $cppstdin_is_wrapper = + ($cppstdin eq 'cppstdin' + and -f $upup_cppstdin + and -x $upup_cppstdin); + $cppstdin = $upup_cppstdin if $cppstdin_is_wrapper; + } + return "$cppstdin $Config{cppflags} $Config{cppminus}"; +} + sub get_files { my %file = (); # VMS keeps its include files in system libraries (well, except for Gcc) @@ -56,6 +76,9 @@ sub get_files { } elsif ($^O eq 'os390') { # OS/390 C compiler doesn't generate #file or #line directives $file{'/usr/include/errno.h'} = 1; + } elsif ($^O eq 'vmesa') { + # OS/390 C compiler doesn't generate #file or #line directives + $file{'../../vmesa/errno.h'} = 1; } else { open(CPPI,"> errno.c") or die "Cannot open errno.c"; @@ -65,9 +88,14 @@ sub get_files { close(CPPI); # invoke CPP and read the output - - open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or - die "Cannot exec $Config{cpprun}"; + if ($^O eq 'MSWin32') { + open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or + die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'"; + } else { + my $cpp = default_cpp(); + open(CPPO,"$cpp < errno.c |") or + die "Cannot exec $cpp"; + } my $pat; if ($^O eq 'MSWin32' and $Config{cc} =~ /^bcc/i) { @@ -77,7 +105,16 @@ sub get_files { $pat = '^#(?:line)?\s*\d+\s+"([^"]+)"'; } while(<CPPO>) { - $file{$1} = 1 if /$pat/o; + if ($^O eq 'os2' or $^O eq 'MSWin32') { + if (/$pat/o) { + my $f = $1; + $f =~ s,\\\\,/,g; + $file{$f} = 1; + } + } + else { + $file{$1} = 1 if /$pat/o; + } } close(CPPO); } @@ -87,6 +124,10 @@ sub get_files { sub write_errno_pm { my $err; + # quick sanity check + + die "No error definitions found" unless keys %err; + # create the CPP input open(CPPI,"> errno.c") or @@ -107,14 +148,13 @@ sub write_errno_pm { $cpp =~ s/sys\$input//i; open(CPPO,"$cpp errno.c |") or die "Cannot exec $Config{cppstdin}"; - } elsif(!$Config{'cpprun'} or $^O eq 'next') { - # NeXT will do syntax checking unless it is reading from stdin - my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}"; + } elsif ($^O eq 'MSWin32') { + open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or + die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'"; + } else { + my $cpp = default_cpp(); open(CPPO,"$cpp < errno.c |") or die "Cannot exec $cpp"; - } else { - open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or - die "Cannot exec $Config{cpprun}"; } %err = (); diff --git a/contrib/perl5/ext/Errno/Makefile.PL b/contrib/perl5/ext/Errno/Makefile.PL index ffc8c4b..604d4fb 100644 --- a/contrib/perl5/ext/Errno/Makefile.PL +++ b/contrib/perl5/ext/Errno/Makefile.PL @@ -1,10 +1,11 @@ use ExtUtils::MakeMaker; -@VMS = ($^O eq 'VMS') ? (MAN3PODS => ' ') : (); +@VMS = ($^O eq 'VMS') ? (MAN3PODS => {}) : (); WriteMakefile( NAME => 'Errno', VERSION_FROM => 'Errno_pm.PL', + MAN3PODS => {}, # Pods will be built by installman. PL_FILES => {'Errno_pm.PL'=>'Errno.pm'}, PM => {'Errno.pm' => '$(INST_LIBDIR)/Errno.pm'}, 'clean' => {FILES => 'Errno.pm'}, diff --git a/contrib/perl5/ext/Fcntl/Makefile.PL b/contrib/perl5/ext/Fcntl/Makefile.PL index 66a6df6..0346373 100644 --- a/contrib/perl5/ext/Fcntl/Makefile.PL +++ b/contrib/perl5/ext/Fcntl/Makefile.PL @@ -1,7 +1,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Fcntl', - MAN3PODS => ' ', # Pods will be built by installman. + MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'Fcntl.pm', ); diff --git a/contrib/perl5/ext/GDBM_File/Makefile.PL b/contrib/perl5/ext/GDBM_File/Makefile.PL index d244613..2a7256f 100644 --- a/contrib/perl5/ext/GDBM_File/Makefile.PL +++ b/contrib/perl5/ext/GDBM_File/Makefile.PL @@ -2,7 +2,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'GDBM_File', LIBS => ["-L/usr/local/lib -lgdbm", "-ldbm"], - MAN3PODS => ' ', # Pods will be built by installman. + MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'GDBM_File.pm', ); diff --git a/contrib/perl5/ext/GDBM_File/hints/sco.pl b/contrib/perl5/ext/GDBM_File/hints/sco.pl new file mode 100644 index 0000000..5c74a77 --- /dev/null +++ b/contrib/perl5/ext/GDBM_File/hints/sco.pl @@ -0,0 +1,2 @@ +# SCO OSR5 needs to link with libc.so again to have C<fsync> defined +$self->{LIBS} = ['-lgdbm -lc']; diff --git a/contrib/perl5/ext/IO/IO.xs b/contrib/perl5/ext/IO/IO.xs index a434cca..300581e 100644 --- a/contrib/perl5/ext/IO/IO.xs +++ b/contrib/perl5/ext/IO/IO.xs @@ -111,7 +111,8 @@ fsetpos(handle, pos) SV * pos CODE: char *p; - if (handle && (p = SvPVx(pos, PL_na)) && PL_na == sizeof(Fpos_t)) + STRLEN n_a; + if (handle && (p = SvPVx(pos, n_a)) && n_a == sizeof(Fpos_t)) #ifdef PerlIO RETVAL = PerlIO_setpos(handle, (Fpos_t*)p); #else diff --git a/contrib/perl5/ext/IO/Makefile.PL b/contrib/perl5/ext/IO/Makefile.PL index 4a34be6..6a2d50d 100644 --- a/contrib/perl5/ext/IO/Makefile.PL +++ b/contrib/perl5/ext/IO/Makefile.PL @@ -1,7 +1,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'IO', - MAN3PODS => ' ', # Pods will be built by installman. + MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'lib/IO/Handle.pm', XS_VERSION => 1.15 diff --git a/contrib/perl5/ext/IO/lib/IO/Pipe.pm b/contrib/perl5/ext/IO/lib/IO/Pipe.pm index ae6d9a5..23c51b0 100644 --- a/contrib/perl5/ext/IO/lib/IO/Pipe.pm +++ b/contrib/perl5/ext/IO/lib/IO/Pipe.pm @@ -14,7 +14,7 @@ use vars qw($VERSION); use Carp; use Symbol; -$VERSION = "1.0901"; +$VERSION = "1.0902"; sub new { my $type = shift; @@ -96,7 +96,7 @@ sub reader { close ${*$me}[1]; bless $me, ref($fh); - *{*$me} = *{*$fh}; # Alias self to handle + *$me = *$fh; # Alias self to handle bless $fh; # Really wan't un-bless here ${*$me}{'io_pipe_pid'} = $pid if defined $pid; @@ -113,7 +113,7 @@ sub writer { close ${*$me}[0]; bless $me, ref($fh); - *{*$me} = *{*$fh}; # Alias self to handle + *$me = *$fh; # Alias self to handle bless $fh; # Really wan't un-bless here ${*$me}{'io_pipe_pid'} = $pid if defined $pid; @@ -177,10 +177,10 @@ IO::pipe - supply object methods for pipes =head1 DESCRIPTION -C<IO::Pipe> provides an interface to createing pipes between +C<IO::Pipe> provides an interface to creating pipes between processes. -=head1 CONSTRCUTOR +=head1 CONSTRUCTOR =over 4 diff --git a/contrib/perl5/ext/IO/lib/IO/Seekable.pm b/contrib/perl5/ext/IO/lib/IO/Seekable.pm index 91c381a..86154c5 100644 --- a/contrib/perl5/ext/IO/lib/IO/Seekable.pm +++ b/contrib/perl5/ext/IO/lib/IO/Seekable.pm @@ -14,7 +14,7 @@ IO::Seekable - supply seek based methods for I/O objects =head1 DESCRIPTION -C<IO::Seekable> does not have a constuctor of its own as is intended to +C<IO::Seekable> does not have a constructor of its own as it is intended to be inherited by other C<IO::Handle> based objects. It provides methods which allow seeking of the file descriptors. diff --git a/contrib/perl5/ext/IO/lib/IO/Socket.pm b/contrib/perl5/ext/IO/lib/IO/Socket.pm index 406f74d..2b4bc49 100644 --- a/contrib/perl5/ext/IO/lib/IO/Socket.pm +++ b/contrib/perl5/ext/IO/lib/IO/Socket.pm @@ -664,7 +664,7 @@ Returns the pathname to the fifo at the local end =item peerpath() -Returns the pathanme to the fifo at the peer end +Returns the pathname to the fifo at the peer end =back diff --git a/contrib/perl5/ext/IPC/SysV/Makefile.PL b/contrib/perl5/ext/IPC/SysV/Makefile.PL index c8e320f..60dd74d 100644 --- a/contrib/perl5/ext/IPC/SysV/Makefile.PL +++ b/contrib/perl5/ext/IPC/SysV/Makefile.PL @@ -22,6 +22,7 @@ sub MY::libscan WriteMakefile( VERSION_FROM => "SysV.pm", NAME => "IPC::SysV", + MAN3PODS => {}, # Pods will be built by installman. 'dist' => {COMPRESS => 'gzip -9f', SUFFIX => 'gz', diff --git a/contrib/perl5/ext/IPC/SysV/Msg.pm b/contrib/perl5/ext/IPC/SysV/Msg.pm index 93d2ae1..a739ca2 100644 --- a/contrib/perl5/ext/IPC/SysV/Msg.pm +++ b/contrib/perl5/ext/IPC/SysV/Msg.pm @@ -84,7 +84,7 @@ sub remove { } sub rcv { - @_ == 5 || croak '$msg->rcv( BUF, LEN, TYPE, FLAGS )'; + @_ <= 5 && @_ >= 3 or croak '$msg->rcv( BUF, LEN, TYPE, FLAGS )'; my $self = shift; my $buf = ""; msgrcv($$self,$buf,$_[1],$_[2] || 0, $_[3] || 0) or @@ -95,7 +95,7 @@ sub rcv { } sub snd { - @_ == 4 || croak '$msg->snd( TYPE, BUF, FLAGS )'; + @_ <= 4 && @_ >= 3 or croak '$msg->snd( TYPE, BUF, FLAGS )'; my $self = shift; msgsnd($$self,pack("L a*",$_[0],$_[1]), $_[2] || 0); } diff --git a/contrib/perl5/ext/IPC/SysV/SysV.xs b/contrib/perl5/ext/IPC/SysV/SysV.xs index 0fbf783..ecd5270 100644 --- a/contrib/perl5/ext/IPC/SysV/SysV.xs +++ b/contrib/perl5/ext/IPC/SysV/SysV.xs @@ -4,32 +4,52 @@ #include <sys/types.h> #ifdef __linux__ -#include <asm/page.h> +# include <asm/page.h> #endif #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) -#include <sys/ipc.h> -#ifdef HAS_MSG -#include <sys/msg.h> -#endif -#ifdef HAS_SEM -#include <sys/sem.h> -#endif -#ifdef HAS_SHM -#if defined(PERL_SCO5) || defined(PERL_ISC) -#include <sys/sysmacros.h> -#endif -#include <sys/shm.h> -# ifndef HAS_SHMAT_PROTOTYPE - extern Shmat_t shmat _((int, char *, int)); -# endif +#ifndef HAS_SEM +# include <sys/ipc.h> +#endif +# ifdef HAS_MSG +# include <sys/msg.h> +# endif +# ifdef HAS_SHM +# if defined(PERL_SCO) || defined(PERL_ISC) +# include <sys/sysmacros.h> /* SHMLBA */ +# endif +# include <sys/shm.h> +# ifndef HAS_SHMAT_PROTOTYPE + extern Shmat_t shmat _((int, char *, int)); +# endif +# if defined(__sparc__) && (defined(__NetBSD__) || defined(__OpenBSD__)) +# undef SHMLBA /* not static: determined at boot time */ +# define SHMLBA getpagesize() +# endif +# endif #endif + +/* Required to get 'struct pte' for SHMLBA on ULTRIX. */ +#if defined(__ultrix) || defined(__ultrix__) || defined(ultrix) +# include <machine/pte.h> #endif /* Required in BSDI to get PAGE_SIZE definition for SHMLBA. * Ugly. More beautiful solutions welcome. * Shouting at BSDI sounds quite beautiful. */ #ifdef __bsdi__ -# include <vm/vm_param.h> +# include <vm/vm_param.h> /* move upwards under HAS_SHM? */ +#endif + +#ifndef S_IRWXU +# ifdef S_IRUSR +# define S_IRWXU (S_IRUSR|S_IWUSR|S_IWUSR) +# define S_IRWXG (S_IRGRP|S_IWGRP|S_IWGRP) +# define S_IRWXO (S_IROTH|S_IWOTH|S_IWOTH) +# else +# define S_IRWXU 0700 +# define S_IRWXG 0070 +# define S_IRWXO 0007 +# endif #endif MODULE=IPC::SysV PACKAGE=IPC::Msg::stat diff --git a/contrib/perl5/ext/NDBM_File/Makefile.PL b/contrib/perl5/ext/NDBM_File/Makefile.PL index ca4c107..6ceab55 100644 --- a/contrib/perl5/ext/NDBM_File/Makefile.PL +++ b/contrib/perl5/ext/NDBM_File/Makefile.PL @@ -2,7 +2,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'NDBM_File', LIBS => ["-L/usr/local/lib -lndbm", "-ldbm -lucb"], - MAN3PODS => ' ', # Pods will be built by installman. + MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'NDBM_File.pm', ); diff --git a/contrib/perl5/ext/ODBM_File/Makefile.PL b/contrib/perl5/ext/ODBM_File/Makefile.PL index 76a5d19..2732a32 100644 --- a/contrib/perl5/ext/ODBM_File/Makefile.PL +++ b/contrib/perl5/ext/ODBM_File/Makefile.PL @@ -2,7 +2,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'ODBM_File', LIBS => ["-ldbm -lucb"], - MAN3PODS => ' ', # Pods will be built by installman. + MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'ODBM_File.pm', ); diff --git a/contrib/perl5/ext/Opcode/Makefile.PL b/contrib/perl5/ext/Opcode/Makefile.PL index 48a6ed8..d7e781f 100644 --- a/contrib/perl5/ext/Opcode/Makefile.PL +++ b/contrib/perl5/ext/Opcode/Makefile.PL @@ -1,7 +1,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Opcode', - MAN3PODS => ' ', + MAN3PODS => {}, VERSION_FROM => 'Opcode.pm', XS_VERSION => '1.03' ); diff --git a/contrib/perl5/ext/Opcode/Opcode.xs b/contrib/perl5/ext/Opcode/Opcode.xs index e853cf1..e93b900 100644 --- a/contrib/perl5/ext/Opcode/Opcode.xs +++ b/contrib/perl5/ext/Opcode/Opcode.xs @@ -400,7 +400,8 @@ PPCODE: } else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) { int b, j; - char *bitmap = SvPV(bitspec,PL_na); + STRLEN n_a; + char *bitmap = SvPV(bitspec,n_a); myopcode = 0; for (b=0; b < opset_len; b++) { U16 bits = bitmap[b]; diff --git a/contrib/perl5/ext/Opcode/Safe.pm b/contrib/perl5/ext/Opcode/Safe.pm index 940a972..2d09c2e 100644 --- a/contrib/perl5/ext/Opcode/Safe.pm +++ b/contrib/perl5/ext/Opcode/Safe.pm @@ -283,8 +283,8 @@ perl code is compiled into an internal format before execution. Evaluating perl code (e.g. via "eval" or "do 'file'") causes the code to be compiled into an internal format and then, provided there was no error in the compilation, executed. -Code evaulated in a compartment compiles subject to the -compartment's operator mask. Attempting to evaulate code in a +Code evaluated in a compartment compiles subject to the +compartment's operator mask. Attempting to evaluate code in a compartment which contains a masked operator will cause the compilation to fail with an error. The code will not be executed. diff --git a/contrib/perl5/ext/Opcode/ops.pm b/contrib/perl5/ext/Opcode/ops.pm index b9ea36c..9b553b7 100644 --- a/contrib/perl5/ext/Opcode/ops.pm +++ b/contrib/perl5/ext/Opcode/ops.pm @@ -31,7 +31,7 @@ ops - Perl pragma to restrict unsafe operations when compiling =head1 DESCRIPTION -Since the ops pragma currently has an irreversable global effect, it is +Since the ops pragma currently has an irreversible global effect, it is only of significant practical use with the C<-M> option on the command line. See the L<Opcode> module for information about opcodes, optags, opmasks diff --git a/contrib/perl5/ext/POSIX/Makefile.PL b/contrib/perl5/ext/POSIX/Makefile.PL index bc1dda9..d379fdb 100644 --- a/contrib/perl5/ext/POSIX/Makefile.PL +++ b/contrib/perl5/ext/POSIX/Makefile.PL @@ -2,7 +2,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'POSIX', ($^O eq 'MSWin32' ? () : (LIBS => ["-lm -lposix -lcposix"])), - MAN3PODS => ' ', # Pods will be built by installman. + MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'POSIX.pm', ); diff --git a/contrib/perl5/ext/POSIX/POSIX.pm b/contrib/perl5/ext/POSIX/POSIX.pm index 5d3ef5c..84298cb 100644 --- a/contrib/perl5/ext/POSIX/POSIX.pm +++ b/contrib/perl5/ext/POSIX/POSIX.pm @@ -268,25 +268,25 @@ sub toupper { sub closedir { usage "closedir(dirhandle)" if @_ != 1; - closedir($_[0]); + CORE::closedir($_[0]); } sub opendir { usage "opendir(directory)" if @_ != 1; my $dirhandle = gensym; - opendir($dirhandle, $_[0]) + CORE::opendir($dirhandle, $_[0]) ? $dirhandle : undef; } sub readdir { usage "readdir(dirhandle)" if @_ != 1; - readdir($_[0]); + CORE::readdir($_[0]); } sub rewinddir { usage "rewinddir(dirhandle)" if @_ != 1; - rewinddir($_[0]); + CORE::rewinddir($_[0]); } sub errno { @@ -301,42 +301,42 @@ sub creat { sub fcntl { usage "fcntl(filehandle, cmd, arg)" if @_ != 3; - fcntl($_[0], $_[1], $_[2]); + CORE::fcntl($_[0], $_[1], $_[2]); } sub getgrgid { usage "getgrgid(gid)" if @_ != 1; - getgrgid($_[0]); + CORE::getgrgid($_[0]); } sub getgrnam { usage "getgrnam(name)" if @_ != 1; - getgrnam($_[0]); + CORE::getgrnam($_[0]); } sub atan2 { usage "atan2(x,y)" if @_ != 2; - atan2($_[0], $_[1]); + CORE::atan2($_[0], $_[1]); } sub cos { usage "cos(x)" if @_ != 1; - cos($_[0]); + CORE::cos($_[0]); } sub exp { usage "exp(x)" if @_ != 1; - exp($_[0]); + CORE::exp($_[0]); } sub fabs { usage "fabs(x)" if @_ != 1; - abs($_[0]); + CORE::abs($_[0]); } sub log { usage "log(x)" if @_ != 1; - log($_[0]); + CORE::log($_[0]); } sub pow { @@ -346,22 +346,22 @@ sub pow { sub sin { usage "sin(x)" if @_ != 1; - sin($_[0]); + CORE::sin($_[0]); } sub sqrt { usage "sqrt(x)" if @_ != 1; - sqrt($_[0]); + CORE::sqrt($_[0]); } sub getpwnam { usage "getpwnam(name)" if @_ != 1; - getpwnam($_[0]); + CORE::getpwnam($_[0]); } sub getpwuid { usage "getpwuid(uid)" if @_ != 1; - getpwuid($_[0]); + CORE::getpwuid($_[0]); } sub longjmp { @@ -382,12 +382,12 @@ sub sigsetjmp { sub kill { usage "kill(pid, sig)" if @_ != 2; - kill $_[1], $_[0]; + CORE::kill $_[1], $_[0]; } sub raise { usage "raise(sig)" if @_ != 1; - kill $_[0], $$; # Is this good enough? + CORE::kill $_[0], $$; # Is this good enough? } sub offsetof { @@ -480,12 +480,12 @@ sub fwrite { sub getc { usage "getc(handle)" if @_ != 1; - getc($_[0]); + CORE::getc($_[0]); } sub getchar { usage "getchar()" if @_ != 0; - getc(STDIN); + CORE::getc(STDIN); } sub gets { @@ -500,7 +500,7 @@ sub perror { sub printf { usage "printf(pattern, args...)" if @_ < 1; - printf STDOUT @_; + CORE::printf STDOUT @_; } sub putc { @@ -517,17 +517,17 @@ sub puts { sub remove { usage "remove(filename)" if @_ != 1; - unlink($_[0]); + CORE::unlink($_[0]); } sub rename { usage "rename(oldfilename, newfilename)" if @_ != 2; - rename($_[0], $_[1]); + CORE::rename($_[0], $_[1]); } sub rewind { usage "rewind(filehandle)" if @_ != 1; - seek($_[0],0,0); + CORE::seek($_[0],0,0); } sub scanf { @@ -536,7 +536,7 @@ sub scanf { sub sprintf { usage "sprintf(pattern,args)" if @_ == 0; - sprintf(shift,@_); + CORE::sprintf(shift,@_); } sub sscanf { @@ -565,7 +565,7 @@ sub vsprintf { sub abs { usage "abs(x)" if @_ != 1; - abs($_[0]); + CORE::abs($_[0]); } sub atexit { @@ -598,7 +598,7 @@ sub div { sub exit { usage "exit(status)" if @_ != 1; - exit($_[0]); + CORE::exit($_[0]); } sub free { @@ -640,7 +640,7 @@ sub srand { sub system { usage "system(command)" if @_ != 1; - system($_[0]); + CORE::system($_[0]); } sub memchr { @@ -719,7 +719,7 @@ sub strspn { sub strstr { usage "strstr(big, little)" if @_ != 2; - index($_[0], $_[1]); + CORE::index($_[0], $_[1]); } sub strtok { @@ -728,71 +728,71 @@ sub strtok { sub chmod { usage "chmod(mode, filename)" if @_ != 2; - chmod($_[0], $_[1]); + CORE::chmod($_[0], $_[1]); } sub fstat { usage "fstat(fd)" if @_ != 1; local *TMP; open(TMP, "<&$_[0]"); # Gross. - my @l = stat(TMP); + my @l = CORE::stat(TMP); close(TMP); @l; } sub mkdir { usage "mkdir(directoryname, mode)" if @_ != 2; - mkdir($_[0], $_[1]); + CORE::mkdir($_[0], $_[1]); } sub stat { usage "stat(filename)" if @_ != 1; - stat($_[0]); + CORE::stat($_[0]); } sub umask { usage "umask(mask)" if @_ != 1; - umask($_[0]); + CORE::umask($_[0]); } sub wait { usage "wait()" if @_ != 0; - wait(); + CORE::wait(); } sub waitpid { usage "waitpid(pid, options)" if @_ != 2; - waitpid($_[0], $_[1]); + CORE::waitpid($_[0], $_[1]); } sub gmtime { usage "gmtime(time)" if @_ != 1; - gmtime($_[0]); + CORE::gmtime($_[0]); } sub localtime { usage "localtime(time)" if @_ != 1; - localtime($_[0]); + CORE::localtime($_[0]); } sub time { usage "time()" if @_ != 0; - time; + CORE::time; } sub alarm { usage "alarm(seconds)" if @_ != 1; - alarm($_[0]); + CORE::alarm($_[0]); } sub chdir { usage "chdir(directory)" if @_ != 1; - chdir($_[0]); + CORE::chdir($_[0]); } sub chown { usage "chown(filename, uid, gid)" if @_ != 3; - chown($_[0], $_[1], $_[2]); + CORE::chown($_[0], $_[1], $_[2]); } sub execl { @@ -821,7 +821,7 @@ sub execvp { sub fork { usage "fork()" if @_ != 0; - fork; + CORE::fork; } sub getcwd @@ -861,12 +861,12 @@ sub getgroups { sub getlogin { usage "getlogin()" if @_ != 0; - getlogin(); + CORE::getlogin(); } sub getpgrp { usage "getpgrp()" if @_ != 0; - getpgrp($_[0]); + CORE::getpgrp; } sub getpid { @@ -876,7 +876,7 @@ sub getpid { sub getppid { usage "getppid()" if @_ != 0; - getppid; + CORE::getppid; } sub getuid { @@ -891,12 +891,16 @@ sub isatty { sub link { usage "link(oldfilename, newfilename)" if @_ != 2; - link($_[0], $_[1]); + CORE::link($_[0], $_[1]); } sub rmdir { usage "rmdir(directoryname)" if @_ != 1; - rmdir($_[0]); + CORE::rmdir($_[0]); +} + +sub setbuf { + redef "IO::Handle::setbuf()"; } sub setgid { @@ -909,18 +913,22 @@ sub setuid { $< = $_[0]; } +sub setvbuf { + redef "IO::Handle::setvbuf()"; +} + sub sleep { usage "sleep(seconds)" if @_ != 1; - sleep($_[0]); + CORE::sleep($_[0]); } sub unlink { usage "unlink(filename)" if @_ != 1; - unlink($_[0]); + CORE::unlink($_[0]); } sub utime { usage "utime(filename, atime, mtime)" if @_ != 3; - utime($_[1], $_[2], $_[0]); + CORE::utime($_[1], $_[2], $_[0]); } diff --git a/contrib/perl5/ext/POSIX/POSIX.pod b/contrib/perl5/ext/POSIX/POSIX.pod index 4726487..6a4a61a 100644 --- a/contrib/perl5/ext/POSIX/POSIX.pod +++ b/contrib/perl5/ext/POSIX/POSIX.pod @@ -1009,13 +1009,14 @@ Convert date and time information to string. Returns the string. Synopsis: - strftime(fmt, sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) + strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1) The month (C<mon>), weekday (C<wday>), and yearday (C<yday>) begin at zero. I.e. January is 0, not 1; Sunday is 0, not 1; January 1st is 0, not 1. The -year (C<year>) is given in years since 1900. I.e. The year 1995 is 95; the +year (C<year>) is given in years since 1900. I.e., the year 1995 is 95; the year 2001 is 101. Consult your system's C<strftime()> manpage for details -about these and the other arguments. +about these and the other arguments. The given arguments are made consistent +by calling C<mktime()> before calling your system's C<strftime()> function. The string for Tuesday, December 12, 1995. diff --git a/contrib/perl5/ext/POSIX/POSIX.xs b/contrib/perl5/ext/POSIX/POSIX.xs index 6958c00..15e026e 100644 --- a/contrib/perl5/ext/POSIX/POSIX.xs +++ b/contrib/perl5/ext/POSIX/POSIX.xs @@ -10,8 +10,6 @@ # undef open # undef setmode # define open PerlLIO_open3 -# undef TAINT_PROPER -# define TAINT_PROPER(a) #endif #include <ctype.h> #ifdef I_DIRENT /* XXX maybe better to just rely on perl.h? */ @@ -2569,7 +2567,7 @@ new(packname = "POSIX::SigSet", ...) CODE: { int i; - RETVAL = (sigset_t*)safemalloc(sizeof(sigset_t)); + New(0, RETVAL, 1, sigset_t); sigemptyset(RETVAL); for (i = 1; i < items; i++) sigaddset(RETVAL, SvIV(ST(i))); @@ -2581,7 +2579,7 @@ void DESTROY(sigset) POSIX::SigSet sigset CODE: - safefree((char *)sigset); + Safefree(sigset); SysRet sigaddset(sigset, sig) @@ -2615,7 +2613,7 @@ new(packname = "POSIX::Termios", ...) CODE: { #ifdef I_TERMIOS - RETVAL = (struct termios*)safemalloc(sizeof(struct termios)); + New(0, RETVAL, 1, struct termios); #else not_here("termios"); RETVAL = 0; @@ -2629,7 +2627,7 @@ DESTROY(termios_ref) POSIX::Termios termios_ref CODE: #ifdef I_TERMIOS - safefree((char *)termios_ref); + Safefree(termios_ref); #else not_here("termios"); #endif @@ -3181,10 +3179,11 @@ sigaction(sig, action, oldaction = 0) sig_name[sig], strlen(sig_name[sig]), TRUE); + STRLEN n_a; /* Remember old handler name if desired. */ if (oldaction) { - char *hand = SvPVx(*sigsvp, PL_na); + char *hand = SvPVx(*sigsvp, n_a); svp = hv_fetch(oldaction, "HANDLER", 7, TRUE); sv_setpv(*svp, *hand ? hand : "DEFAULT"); } @@ -3195,7 +3194,7 @@ sigaction(sig, action, oldaction = 0) svp = hv_fetch(action, "HANDLER", 7, FALSE); if (!svp) croak("Can't supply an action without a HANDLER"); - sv_setpv(*sigsvp, SvPV(*svp, PL_na)); + sv_setpv(*sigsvp, SvPV(*svp, n_a)); mg_set(*sigsvp); /* handles DEFAULT and IGNORE */ act.sa_handler = sighandler; @@ -3234,7 +3233,7 @@ sigaction(sig, action, oldaction = 0) sigset = (sigset_t*) tmp; } else { - sigset = (sigset_t*)safemalloc(sizeof(sigset_t)); + New(0, sigset, 1, sigset_t); sv_setptrobj(*svp, sigset, "POSIX::SigSet"); } *sigset = oact.sa_mask; @@ -3256,7 +3255,20 @@ SysRet sigprocmask(how, sigset, oldsigset = 0) int how POSIX::SigSet sigset - POSIX::SigSet oldsigset + POSIX::SigSet oldsigset = NO_INIT +INIT: + if ( items < 3 ) { + oldsigset = 0; + } + else if (sv_derived_from(ST(2), "POSIX::SigSet")) { + IV tmp = SvIV((SV*)SvRV(ST(2))); + oldsigset = (POSIX__SigSet) tmp; + } + else { + New(0, oldsigset, 1, sigset_t); + sigemptyset(oldsigset); + sv_setref_pv(ST(2), "POSIX::SigSet", (void*)oldsigset); + } SysRet sigsuspend(signal_mask) @@ -3591,7 +3603,7 @@ mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) RETVAL char * -strftime(fmt, sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) +strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1) char * fmt int sec int min @@ -3617,8 +3629,45 @@ strftime(fmt, sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) mytm.tm_wday = wday; mytm.tm_yday = yday; mytm.tm_isdst = isdst; + (void) mktime(&mytm); len = strftime(tmpbuf, sizeof tmpbuf, fmt, &mytm); - ST(0) = sv_2mortal(newSVpv(tmpbuf, len)); + /* + ** The following is needed to handle to the situation where + ** tmpbuf overflows. Basically we want to allocate a buffer + ** and try repeatedly. The reason why it is so complicated + ** is that getting a return value of 0 from strftime can indicate + ** one of the following: + ** 1. buffer overflowed, + ** 2. illegal conversion specifier, or + ** 3. the format string specifies nothing to be returned(not + ** an error). This could be because format is an empty string + ** or it specifies %p that yields an empty string in some locale. + ** If there is a better way to make it portable, go ahead by + ** all means. + */ + if ( ( len > 0 && len < sizeof(tmpbuf) ) + || ( len == 0 && strlen(fmt) == 0 ) ) { + ST(0) = sv_2mortal(newSVpv(tmpbuf, len)); + } else { + /* Possibly buf overflowed - try again with a bigger buf */ + int bufsize = strlen(fmt) + sizeof(tmpbuf); + char* buf; + int buflen; + + New(0, buf, bufsize, char); + while( buf ) { + buflen = strftime(buf, bufsize, fmt, &mytm); + if ( buflen > 0 && buflen < bufsize ) break; + bufsize *= 2; + Renew(buf, bufsize, char); + } + if ( buf ) { + ST(0) = sv_2mortal(newSVpv(buf, buflen)); + Safefree(buf); + } else { + ST(0) = sv_2mortal(newSVpv(tmpbuf, len)); + } + } } void diff --git a/contrib/perl5/ext/POSIX/hints/dynixptx.pl b/contrib/perl5/ext/POSIX/hints/dynixptx.pl new file mode 100644 index 0000000..9b63684 --- /dev/null +++ b/contrib/perl5/ext/POSIX/hints/dynixptx.pl @@ -0,0 +1,4 @@ +# Need to add an extra '-lc' to the end to work around a DYNIX/ptx bug +# PR#227670 - linker error on fpgetround() + +$self->{LIBS} = ['-ldb -lm -lc']; diff --git a/contrib/perl5/ext/POSIX/hints/mint.pl b/contrib/perl5/ext/POSIX/hints/mint.pl new file mode 100644 index 0000000..b975cbb --- /dev/null +++ b/contrib/perl5/ext/POSIX/hints/mint.pl @@ -0,0 +1,2 @@ +$self->{CCFLAGS} = $Config{ccflags} . ' -DNO_LOCALECONV_GROUPING -DNO_LOCALECONV_MON_GROUPING'; + diff --git a/contrib/perl5/ext/SDBM_File/Makefile.PL b/contrib/perl5/ext/SDBM_File/Makefile.PL index b639b29..7494785 100644 --- a/contrib/perl5/ext/SDBM_File/Makefile.PL +++ b/contrib/perl5/ext/SDBM_File/Makefile.PL @@ -12,7 +12,7 @@ else { $myextlib = 'sdbm/libsdbm$(LIB_EXT)'; } WriteMakefile( NAME => 'SDBM_File', MYEXTLIB => $myextlib, - MAN3PODS => ' ', # Pods will be built by installman. + MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'SDBM_File.pm', DEFINE => $define, diff --git a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c index 637fbe9..c147e45 100644 --- a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c +++ b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c @@ -437,6 +437,7 @@ setdbit(register DBM *db, register long int dbit) dirb = c / DBLKSIZ; if (dirb != db->dirbno) { + (void) memset(db->dirbuf, 0, DBLKSIZ); if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 || read(db->dirf, db->dirbuf, DBLKSIZ) < 0) return 0; diff --git a/contrib/perl5/ext/Socket/Makefile.PL b/contrib/perl5/ext/Socket/Makefile.PL index 7b9469a..3819143 100644 --- a/contrib/perl5/ext/Socket/Makefile.PL +++ b/contrib/perl5/ext/Socket/Makefile.PL @@ -2,6 +2,6 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Socket', VERSION_FROM => 'Socket.pm', - MAN3PODS => ' ', # Pods will be built by installman. + MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? ); diff --git a/contrib/perl5/ext/Socket/Socket.pm b/contrib/perl5/ext/Socket/Socket.pm index 5a4870f..1ed19f7 100644 --- a/contrib/perl5/ext/Socket/Socket.pm +++ b/contrib/perl5/ext/Socket/Socket.pm @@ -193,10 +193,25 @@ require DynaLoader; AF_UNIX AF_UNSPEC AF_X25 + MSG_CTLFLAGS + MSG_CTLIGNORE + MSG_CTRUNC MSG_DONTROUTE + MSG_DONTWAIT + MSG_EOF + MSG_EOR + MSG_ERRQUEUE + MSG_FIN MSG_MAXIOVLEN + MSG_NOSIGNAL MSG_OOB MSG_PEEK + MSG_PROXY + MSG_RST + MSG_SYN + MSG_TRUNC + MSG_URG + MSG_WAITALL PF_802 PF_APPLETALK PF_CCITT @@ -221,6 +236,11 @@ require DynaLoader; PF_UNIX PF_UNSPEC PF_X25 + SCM_CONNECT + SCM_CREDENTIALS + SCM_CREDS + SCM_RIGHTS + SCM_TIMESTAMP SOCK_DGRAM SOCK_RAW SOCK_RDM diff --git a/contrib/perl5/ext/Socket/Socket.xs b/contrib/perl5/ext/Socket/Socket.xs index de0217b..0bd6e59 100644 --- a/contrib/perl5/ext/Socket/Socket.xs +++ b/contrib/perl5/ext/Socket/Socket.xs @@ -330,42 +330,114 @@ constant(char *name, int arg) case 'L': break; case 'M': + if (strEQ(name, "MSG_CTLFLAGS")) +#ifdef MSG_CTLFLAGS + return MSG_CTLFLAGS; +#else + goto not_there; +#endif + if (strEQ(name, "MSG_CTLIGNORE")) +#ifdef MSG_CTLIGNORE + return MSG_CTLIGNORE; +#else + goto not_there; +#endif if (strEQ(name, "MSG_CTRUNC")) -#if defined(MSG_CTRUNC) || defined(HAS_GNULIBC) /* XXX it's an enum */ +#if defined(MSG_TRUNC) || defined(HAS_MSG_CTRUNC) /* might be an enum */ return MSG_CTRUNC; #else goto not_there; #endif if (strEQ(name, "MSG_DONTROUTE")) -#if defined(MSG_DONTROUTE) || defined(HAS_GNULIBC) /* XXX it's an enum */ +#if defined(MSG_DONTROUTE) || defined(HAS_MSG_DONTROUTE) /* might be an enum */ return MSG_DONTROUTE; #else goto not_there; #endif + if (strEQ(name, "MSG_DONTWAIT")) +#ifdef MSG_DONTWAIT + return MSG_DONTWAIT; +#else + goto not_there; +#endif + if (strEQ(name, "MSG_EOF")) +#ifdef MSG_EOF + return MSG_EOF; +#else + goto not_there; +#endif + if (strEQ(name, "MSG_EOR")) +#ifdef MSG_EOR + return MSG_EOR; +#else + goto not_there; +#endif + if (strEQ(name, "MSG_ERRQUEUE")) +#ifdef MSG_ERRQUEUE + return MSG_ERRQUEUE; +#else + goto not_there; +#endif + if (strEQ(name, "MSG_FIN")) +#ifdef MSG_FIN + return MSG_FIN; +#else + goto not_there; +#endif if (strEQ(name, "MSG_MAXIOVLEN")) #ifdef MSG_MAXIOVLEN return MSG_MAXIOVLEN; #else goto not_there; #endif + if (strEQ(name, "MSG_NOSIGNAL")) +#ifdef MSG_NOSIGNAL + return MSG_NOSIGNAL; +#else + goto not_there; +#endif if (strEQ(name, "MSG_OOB")) -#if defined(MSG_OOB) || defined(HAS_GNULIBC) /* XXX it's an enum */ +#if defined(MSG_OOB) || defined(HAS_MSG_OOB) /* might be an enum */ return MSG_OOB; #else goto not_there; #endif if (strEQ(name, "MSG_PEEK")) -#if defined(MSG_PEEK) || defined(HAS_GNULIBC) /* XXX it's an enum */ +#if defined(MSG_PEEK) || defined(HAS_MSG_PEEK) /* might be an enum */ return MSG_PEEK; #else goto not_there; #endif if (strEQ(name, "MSG_PROXY")) -#if defined(MSG_PROXY) || defined(HAS_GNULIBC) /* XXX it's an enum */ +#if defined(MSG_PROXY) || defined(HAS_MSG_PROXY) /* might be an enum */ return MSG_PROXY; #else goto not_there; #endif + if (strEQ(name, "MSG_RST")) +#ifdef MSG_RST + return MSG_RST; +#else + goto not_there; +#endif + if (strEQ(name, "MSG_SYN")) +#ifdef MSG_SYN + return MSG_SYN; +#else + goto not_there; +#endif + if (strEQ(name, "MSG_TRUNC")) +#ifdef MSG_TRUNC + return MSG_TRUNC; +#else + goto not_there; +#endif + if (strEQ(name, "MSG_WAITALL")) +#ifdef MSG_WAITALL + return MSG_WAITALL; +#else + goto not_there; +#endif break; case 'N': break; @@ -522,6 +594,36 @@ constant(char *name, int arg) case 'R': break; case 'S': + if (strEQ(name, "SCM_CONNECT")) +#ifdef SCM_CONNECT + return SCM_CONNECT; +#else + goto not_there; +#endif + if (strEQ(name, "SCM_CREDENTIALS")) +#ifdef SCM_CREDENTIALS + return SCM_CREDENTIALS; +#else + goto not_there; +#endif + if (strEQ(name, "SCM_CREDS")) +#ifdef SCM_CREDS + return SCM_CREDS; +#else + goto not_there; +#endif + if (strEQ(name, "SCM_RIGHTS")) +#if defined(SCM_RIGHTS) || defined(HAS_SCM_RIGHTS) /* might be an enum */ + return SCM_RIGHTS; +#else + goto not_there; +#endif + if (strEQ(name, "SCM_TIMESTAMP")) +#ifdef SCM_TIMESTAMP + return SCM_TIMESTAMP; +#else + goto not_there; +#endif if (strEQ(name, "SOCK_DGRAM")) #ifdef SOCK_DGRAM return SOCK_DGRAM; diff --git a/contrib/perl5/ext/Thread/Makefile.PL b/contrib/perl5/ext/Thread/Makefile.PL index e252d4e..e67fbb7 100644 --- a/contrib/perl5/ext/Thread/Makefile.PL +++ b/contrib/perl5/ext/Thread/Makefile.PL @@ -2,6 +2,6 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Thread', VERSION_FROM => 'Thread.pm', - MAN3PODS => ' ' + MAN3PODS => {} ); diff --git a/contrib/perl5/ext/Thread/Thread.xs b/contrib/perl5/ext/Thread/Thread.xs index 48f8aa0..2337e8c 100644 --- a/contrib/perl5/ext/Thread/Thread.xs +++ b/contrib/perl5/ext/Thread/Thread.xs @@ -115,18 +115,21 @@ threadstart(void *arg) sv = POPs; PUTBACK; + ENTER; + SAVETMPS; perl_call_sv(sv, G_ARRAY|G_EVAL); SPAGAIN; retval = SP - (PL_stack_base + oldmark); SP = PL_stack_base + oldmark + 1; if (SvCUR(thr->errsv)) { + STRLEN n_a; MUTEX_LOCK(&thr->mutex); thr->flags |= THRf_DID_DIE; MUTEX_UNLOCK(&thr->mutex); av_store(av, 0, &PL_sv_no); av_store(av, 1, newSVsv(thr->errsv)); DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p died: %s\n", - thr, SvPV(thr->errsv, PL_na))); + thr, SvPV(thr->errsv, n_a))); } else { DEBUG_S(STMT_START { for (i = 1; i <= retval; i++) { @@ -138,6 +141,8 @@ threadstart(void *arg) for (i = 1; i <= retval; i++, SP++) sv_setsv(*av_fetch(av, i, TRUE), SvREFCNT_inc(*SP)); } + FREETMPS; + LEAVE; finishoff: #if 0 @@ -174,7 +179,7 @@ threadstart(void *arg) Safefree(PL_screamnext); Safefree(PL_reg_start_tmp); SvREFCNT_dec(PL_lastscream); - /*SvREFCNT_dec(PL_defoutgv);*/ + SvREFCNT_dec(PL_defoutgv); MUTEX_LOCK(&thr->mutex); DEBUG_S(PerlIO_printf(PerlIO_stderr(), @@ -233,6 +238,11 @@ newthread (SV *startsv, AV *initargs, char *classname) savethread = thr; thr = new_struct_thread(thr); + /* temporarily pretend to be the child thread in case the + * XPUSHs() below want to grow the child's stack. This is + * safe, since the other thread is not yet created, and we + * are the only ones who know about it */ + SET_THR(thr); SPAGAIN; DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: newthread (%p), tid is %u, preparing stack\n", @@ -244,11 +254,14 @@ newthread (SV *startsv, AV *initargs, char *classname) XPUSHs(SvREFCNT_inc(*av_fetch(initargs, i, FALSE))); XPUSHs(SvREFCNT_inc(startsv)); PUTBACK; + + /* On your marks... */ + SET_THR(savethread); + MUTEX_LOCK(&thr->mutex); + #ifdef THREAD_CREATE err = THREAD_CREATE(thr, threadstart); #else - /* On your marks... */ - MUTEX_LOCK(&thr->mutex); /* Get set... */ sigfillset(&fullmask); if (sigprocmask(SIG_SETMASK, &fullmask, &oldmask) == -1) @@ -279,10 +292,9 @@ newthread (SV *startsv, AV *initargs, char *classname) #else err = pthread_create(&thr->self, &attr, threadstart, (void*) thr); #endif - /* Go */ - MUTEX_UNLOCK(&thr->mutex); #endif if (err) { + MUTEX_UNLOCK(&thr->mutex); DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: create of %p failed %d\n", savethread, thr, err)); @@ -295,16 +307,23 @@ newthread (SV *startsv, AV *initargs, char *classname) SvREFCNT_dec(startsv); return NULL; } + #ifdef THREAD_POST_CREATE THREAD_POST_CREATE(thr); #else if (sigprocmask(SIG_SETMASK, &oldmask, 0)) croak("panic: sigprocmask"); #endif + sv = newSViv(thr->tid); sv_magic(sv, thr->oursv, '~', 0, 0); SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE; - return sv_bless(newRV_noinc(sv), gv_stashpv(classname, TRUE)); + sv = sv_bless(newRV_noinc(sv), gv_stashpv(classname, TRUE)); + + /* Go */ + MUTEX_UNLOCK(&thr->mutex); + + return sv; #else croak("No threads in this perl"); return &PL_sv_undef; @@ -371,7 +390,8 @@ join(t) for (i = 1; i <= AvFILL(av); i++) XPUSHs(sv_2mortal(*av_fetch(av, i, FALSE))); } else { - char *mess = SvPV(*av_fetch(av, 1, FALSE), PL_na); + STRLEN n_a; + char *mess = SvPV(*av_fetch(av, 1, FALSE), n_a); DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: join propagating die message: %s\n", thr, mess)); @@ -483,6 +503,7 @@ CODE: croak("cond_wait for lock that we don't own\n"); } MgOWNER(mg) = 0; + COND_SIGNAL(MgOWNERCONDP(mg)); COND_WAIT(MgCONDP(mg), MgMUTEXP(mg)); while (MgOWNER(mg)) COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); diff --git a/contrib/perl5/ext/Thread/create.t b/contrib/perl5/ext/Thread/create.t index 7d6d189..df8fc77 100644 --- a/contrib/perl5/ext/Thread/create.t +++ b/contrib/perl5/ext/Thread/create.t @@ -1,4 +1,7 @@ -use Thread; +use Thread 'async'; +use Config; +use Tie::Hash; + sub start_here { my $i; print "In start_here with args: @_\n"; @@ -8,6 +11,12 @@ sub start_here { } } +async { + tie my(%h), 'Tie::StdHash'; + %h = %Config; + print "running on $h{archname}\n"; +}; + print "Starting new thread now\n"; $t = new Thread \&start_here, qw(foo bar baz); print "Started thread $t\n"; diff --git a/contrib/perl5/ext/attrs/Makefile.PL b/contrib/perl5/ext/attrs/Makefile.PL index c421757..86ed3f3 100644 --- a/contrib/perl5/ext/attrs/Makefile.PL +++ b/contrib/perl5/ext/attrs/Makefile.PL @@ -2,6 +2,6 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'attrs', VERSION_FROM => 'attrs.pm', - MAN3PODS => ' ', # Pods will be built by installman. + MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes' ); diff --git a/contrib/perl5/ext/attrs/attrs.xs b/contrib/perl5/ext/attrs/attrs.xs index da952d5..7f7970d 100644 --- a/contrib/perl5/ext/attrs/attrs.xs +++ b/contrib/perl5/ext/attrs/attrs.xs @@ -27,7 +27,8 @@ char * Class if (!PL_compcv || !(cv = CvOUTSIDE(PL_compcv))) croak("can't set attributes outside a subroutine scope"); for (i = 1; i < items; i++) { - char *attr = SvPV(ST(i), PL_na); + STRLEN n_a; + char *attr = SvPV(ST(i), n_a); cv_flags_t flag = get_flag(attr); if (!flag) croak("invalid attribute name %s", attr); @@ -47,7 +48,8 @@ SV * sub sub = Nullsv; } else { - char *name = SvPV(sub, PL_na); + STRLEN n_a; + char *name = SvPV(sub, n_a); sub = (SV*)perl_get_cv(name, FALSE); } if (!sub) diff --git a/contrib/perl5/ext/re/Makefile.PL b/contrib/perl5/ext/re/Makefile.PL index 9ed83d1..040b085 100644 --- a/contrib/perl5/ext/re/Makefile.PL +++ b/contrib/perl5/ext/re/Makefile.PL @@ -2,7 +2,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 're', VERSION_FROM => 're.pm', - MAN3PODS => ' ', # Pods will be built by installman. + MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', OBJECT => 're_exec$(OBJ_EXT) re_comp$(OBJ_EXT) re$(OBJ_EXT)', DEFINE => '-DPERL_EXT_RE_BUILD', diff --git a/contrib/perl5/ext/re/re.pm b/contrib/perl5/ext/re/re.pm index 7cea77d..83e7dba 100644 --- a/contrib/perl5/ext/re/re.pm +++ b/contrib/perl5/ext/re/re.pm @@ -41,11 +41,11 @@ on tainted data aren't meant to extract safe substrings, but to perform other transformations. When C<use re 'eval'> is in effect, a regex is allowed to contain -C<(?{ ... })> zero-width assertions even if regular expression contains -variable interpolation. That is normally disallowed, since it is a +C<(?{ ... })> zero-width assertions even if the regex contains +variable interpolation. This is normally disallowed, since it is a potential security risk. Note that this pragma is ignored when the regular expression is obtained from tainted data, i.e. evaluation is always -disallowed with tainted regular expresssions. See L<perlre/(?{ code })>. +disallowed with tainted regular expressions. See L<perlre/(?{ code })>. For the purpose of this pragma, interpolation of precompiled regular expressions (i.e., the result of C<qr//>) is I<not> considered variable diff --git a/contrib/perl5/form.h b/contrib/perl5/form.h index 5e74c61..0d3053d 100644 --- a/contrib/perl5/form.h +++ b/contrib/perl5/form.h @@ -1,6 +1,6 @@ /* form.h * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. diff --git a/contrib/perl5/global.sym b/contrib/perl5/global.sym index f3c73fe..99edf17 100644 --- a/contrib/perl5/global.sym +++ b/contrib/perl5/global.sym @@ -276,6 +276,7 @@ do_tell do_trans do_vecset do_vop +dofile dofindlabel dopoptoeval dounwind @@ -312,6 +313,7 @@ get_op_names get_no_modify get_opargs get_specialsv_list +get_vtbl gp_free gp_ref gv_AVadd @@ -914,6 +916,7 @@ save_destructor save_freeop save_freepv save_freesv +save_generic_svref save_gp save_hash save_helem diff --git a/contrib/perl5/gv.c b/contrib/perl5/gv.c index 0d96ffa..1845058 100644 --- a/contrib/perl5/gv.c +++ b/contrib/perl5/gv.c @@ -1,6 +1,6 @@ /* gv.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -107,11 +107,12 @@ gv_init(GV *gv, HV *stash, char *name, STRLEN len, int multi) GvSTASH(gv) = (HV*)SvREFCNT_inc(stash); GvNAME(gv) = savepvn(name, len); GvNAMELEN(gv) = len; - if (multi) + if (multi || doproto) /* doproto means it _was_ mentioned */ GvMULTI_on(gv); if (doproto) { /* Replicate part of newSUB here. */ SvIOK_off(gv); ENTER; + /* XXX unsafe for threads if eval_owner isn't held */ start_subparse(0,0); /* Create CV in compcv. */ GvCV(gv) = PL_compcv; LEAVE; @@ -122,9 +123,10 @@ gv_init(GV *gv, HV *stash, char *name, STRLEN len, int multi) CvSTASH(GvCV(gv)) = PL_curstash; #ifdef USE_THREADS CvOWNER(GvCV(gv)) = 0; - if (!CvMUTEXP(GvCV(gv))) + if (!CvMUTEXP(GvCV(gv))) { New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex); - MUTEX_INIT(CvMUTEXP(GvCV(gv))); + MUTEX_INIT(CvMUTEXP(GvCV(gv))); + } #endif /* USE_THREADS */ if (proto) { sv_setpv((SV*)GvCV(gv), proto); @@ -614,12 +616,6 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; } break; - - case 'a': - case 'b': - if (len == 1) - GvMULTI_on(gv); - break; case 'E': if (strnEQ(name, "EXPORT", 6)) GvMULTI_on(gv); @@ -747,6 +743,7 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) case '/': case '|': case '\001': + case '\003': case '\004': case '\005': case '\006': @@ -850,7 +847,8 @@ newIO(void) SvREFCNT(io) = 1; SvOBJECT_on(io); iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV); - if (!iogv) + /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */ + if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv)))) iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV); SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv)); return io; @@ -991,6 +989,7 @@ Gv_AMupdate(HV *stash) MAGIC* mg=mg_find((SV*)stash,'c'); AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL; AMT amt; + STRLEN n_a; if (mg && amtp->was_ok_am == PL_amagic_generation && amtp->was_ok_sub == PL_sub_generation) @@ -1038,7 +1037,7 @@ Gv_AMupdate(HV *stash) default: if (!SvROK(sv)) { if (!SvOK(sv)) break; - gv = gv_fetchmethod(stash, SvPV(sv, PL_na)); + gv = gv_fetchmethod(stash, SvPV(sv, n_a)); if (gv) cv = GvCV(gv); break; } @@ -1099,7 +1098,7 @@ Gv_AMupdate(HV *stash) GV *ngv; DEBUG_o( deb("Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n", - SvPV(GvSV(gv), PL_na), cp, HvNAME(stash)) ); + SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) ); if (!SvPOK(GvSV(gv)) || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)), FALSE))) diff --git a/contrib/perl5/gv.h b/contrib/perl5/gv.h index 8d987ed..0226513 100644 --- a/contrib/perl5/gv.h +++ b/contrib/perl5/gv.h @@ -1,6 +1,6 @@ /* gv.h * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. diff --git a/contrib/perl5/handy.h b/contrib/perl5/handy.h index eb26ed8..7744c31 100644 --- a/contrib/perl5/handy.h +++ b/contrib/perl5/handy.h @@ -1,6 +1,6 @@ /* handy.h * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. diff --git a/contrib/perl5/hints/aix.sh b/contrib/perl5/hints/aix.sh index 25e2048..d2c45c0 100644 --- a/contrib/perl5/hints/aix.sh +++ b/contrib/perl5/hints/aix.sh @@ -19,6 +19,10 @@ alignbytes=8 usemymalloc='n' +# Intuiting the existence of system calls under AIX is difficult, +# at best; the safest technique is to find them empirically. +usenm='undef' + so="a" dlext="so" @@ -63,40 +67,51 @@ esac # symbol: boot_$(EXP) can it be auto-generated? case "$osvers" in 3*) -lddlflags='-H512 -T512 -bhalt:4 -bM:SRE -bI:$(PERL_INC)/perl.exp -bE:$(BASEEXT).exp -e _nostart -lc' + lddlflags='-H512 -T512 -bhalt:4 -bM:SRE -bI:$(PERL_INC)/perl.exp -bE:$(BASEEXT).exp -e _nostart -lc' ;; *) -lddlflags='-bhalt:4 -bM:SRE -bI:$(PERL_INC)/perl.exp -bE:$(BASEEXT).exp -b noentry -lc' - -;; + lddlflags='-bhalt:4 -bM:SRE -bI:$(PERL_INC)/perl.exp -bE:$(BASEEXT).exp -b noentry -lc' + ;; esac -if [ "X$usethreads" = "X$define" ]; then - ccflags="$ccflags -DNEED_PTHREAD_INIT" - case "$cc" in - xlc_r | cc_r) - ;; - cc | '') - cc=xlc_r # Let us be stricter. - ;; - *) - cat >&4 <<EOM -Unknown C compiler '$cc'. -For pthreads you should use the AIX C compilers xlc_r or cc_r. +# This script UU/usethreads.cbu will get 'called-back' by Configure +# after it has prompted the user for whether to use threads. +cat > UU/usethreads.cbu <<'EOCBU' +case "$usethreads" in +$define|true|[yY]*) + ccflags="$ccflags -DNEED_PTHREAD_INIT" + case "$cc" in + cc_r) ;; + cc|xlc_r) + echo >&4 "Switching cc to cc_r because of POSIX threads." + # xlc_r has been known to produce buggy code in AIX 4.3.2. + # (e.g. pragma/overload core dumps) + # --jhi@iki.fi + cc=cc_r + ;; + '') + cc=cc_r + ;; + *) + cat >&4 <<EOM +For pthreads you should use the AIX C compiler cc_r. +(now your compiler was '$cc') Cannot continue, aborting. EOM - exit 1 - ;; - esac + exit 1 + ;; + esac - # Add the POSIX threads library and the re-entrant libc. + # Add the POSIX threads library and the re-entrant libc. - lddlflags=`echo $lddlflags | sed 's/ -lc$/ -lpthreads -lc_r -lc/'` + lddlflags=`echo $lddlflags | sed 's/ -lc$/ -lpthreads -lc_r -lc/'` - # Add the c_r library to the list of libraries wanted - # Make sure the c_r library is before the c library or - # make will fail. - set `echo X "$libswanted "| sed -e 's/ c / c_r c /'` - shift - libswanted="$*" -fi + # Add the c_r library to the list of wanted libraries. + # Make sure the c_r library is before the c library or + # make will fail. + set `echo X "$libswanted "| sed -e 's/ c / c_r c /'` + shift + libswanted="$*" + ;; +esac +EOCBU diff --git a/contrib/perl5/hints/apollo.sh b/contrib/perl5/hints/apollo.sh index 8c361aa..05f433d 100644 --- a/contrib/perl5/hints/apollo.sh +++ b/contrib/perl5/hints/apollo.sh @@ -1,13 +1,17 @@ # Info from Johann Klasek <jk@auto.tuwien.ac.at> # Merged by Andy Dougherty <doughera@lafcol.lafayette.edu> -# Last revised Fri Jun 2 11:21:27 EDT 1995 +# Last revised Tue Mar 16 19:12:22 EET 1999 by +# Jarkko Hietaniemi <jhi@iki.fi> # uname -a looks like # DomainOS newton 10.4.1 bsd4.3 425t # We want to use both BSD includes and some of the features from the # /sys5 includes. -ccflags="$ccflags -A cpu,mathchip -I/usr/include -I/sys5/usr/include" +ccflags="$ccflags -A cpu,mathchip -I`pwd`/apollo -I/usr/include -I/sys5/usr/include" + +# When Apollo runs a script with "#!", it sets argv[0] to the script name. +toke_cflags='ccflags="$ccflags -DARG_ZERO_IS_SCRIPT"' # These adjustments are necessary (why?) to compile malloc.c. freetype='void' diff --git a/contrib/perl5/hints/beos.sh b/contrib/perl5/hints/beos.sh index ab75276..8d76bc5 100644 --- a/contrib/perl5/hints/beos.sh +++ b/contrib/perl5/hints/beos.sh @@ -1,11 +1,12 @@ # BeOS hints file # $Id: beos.sh,v 1.1 1998/02/16 03:51:45 dogcow Exp $ -if [ ! -f beos/nm ]; then mwcc -w all -o beos/nm beos/nm.c; fi +if [ ! -f beos/nm ]; then mwcc -w all -o beos/nm beos/nm.c 2>/dev/null; fi +# If this fails, that's all right - it's only for PPC. prefix="/boot/home/config" -cpp="mwcc -e" +#cpp="mwcc -e" libpth='/boot/beos/system/lib /boot/home/config/lib' usrinc='/boot/develop/headers/posix' @@ -37,9 +38,16 @@ d_syserrlst='undef' # the array syserrlst[] is useless for the most part. # large negative numbers really kind of suck in arrays. -#d_socket='undef' +d_socket='undef' +d_gethbyaddr='undef' +d_gethbyname='undef' +d_getsbyname='undef' + +ld='gcc' + # Sockets really don't work with the current version of perl and the # current BeOS sockets; I suspect that a new module a la GSAR's WIN32 port # will be required. +# Of course, this may also change with R5. export PATH="$PATH:$PWD/beos" diff --git a/contrib/perl5/hints/dec_osf.sh b/contrib/perl5/hints/dec_osf.sh index a531ea8..8758cbb 100644 --- a/contrib/perl5/hints/dec_osf.sh +++ b/contrib/perl5/hints/dec_osf.sh @@ -177,30 +177,37 @@ case "$optimize" in ;; esac -if [ "X$usethreads" = "X$define" ]; then - # Threads interfaces changed with V4.0. - case "$_DEC_uname_r" in - *[123].*) libswanted="$libswanted pthreads mach exc c_r" - ccflags="-threads $ccflags" - ;; - *) libswanted="$libswanted pthread exc" - ccflags="-pthread $ccflags" - ;; - esac - usemymalloc='n' -fi - # # Make embedding in things like INN and Apache more memory friendly. # Keep it overridable on the Configure command line, though, so that # "-Uuseshrplib" prevents this default. # -# This or the glibpth change above breaks the build. Commented out -# for this snapshot. -#case "$_DEC_cc_style.$useshrplib" in -# new.) useshrplib="$define" ;; -#esac +case "$_DEC_cc_style.$useshrplib" in + new.) useshrplib="$define" ;; +esac + +# This script UU/usethreads.cbu will get 'called-back' by Configure +# after it has prompted the user for whether to use threads. +cat > UU/usethreads.cbu <<'EOCBU' +case "$usethreads" in +$define|true|[yY]*) + # Threads interfaces changed with V4.0. + case "`uname -r`" in + *[123].*) + libswanted="$libswanted pthreads mach exc c_r" + ccflags="-threads $ccflags" + ;; + *) + libswanted="$libswanted pthread exc" + ccflags="-pthread $ccflags" + ;; + esac + + usemymalloc='n' + ;; +esac +EOCBU # # Unset temporary variables no more needed. @@ -216,7 +223,7 @@ unset _DEC_uname_r # # 19-Dec-1997 Spider Boardman <spider@Orb.Nashua.NH.US> # -# * Newer Digial UNIX compilers enforce signaling for NaN without +# * Newer Digital UNIX compilers enforce signaling for NaN without # -ieee. Added -fprm d at the same time since it's friendlier for # embedding. # diff --git a/contrib/perl5/hints/dos_djgpp.sh b/contrib/perl5/hints/dos_djgpp.sh index 73bae63..7c59428 100644 --- a/contrib/perl5/hints/dos_djgpp.sh +++ b/contrib/perl5/hints/dos_djgpp.sh @@ -52,8 +52,14 @@ sitearch=$sitelib eagain='EAGAIN' rd_nodata='-1' -if [ "X$usethreads" = "X$define" ]; then - set `echo X "$libswanted "| sed -e 's/ c / gthreads c /'` - shift - libswanted="$*" -fi +# This script UU/usethreads.cbu will get 'called-back' by Configure +# after it has prompted the user for whether to use threads. +cat > UU/usethreads.cbu <<'EOCBU' +case "$usethreads" in +$define|true|[yY]*) + set `echo X "$libswanted "| sed -e 's/ c / gthreads c /'` + shift + libswanted="$*" + ;; +esac +EOCBU diff --git a/contrib/perl5/hints/dynixptx.sh b/contrib/perl5/hints/dynixptx.sh index 78a45e4..2edf026 100644 --- a/contrib/perl5/hints/dynixptx.sh +++ b/contrib/perl5/hints/dynixptx.sh @@ -1,5 +1,9 @@ # Sequent Dynix/Ptx v. 4 hints # Created 1996/03/15 by Brad Howerter, bhower@wgc.woodward.com + +# Modified 1998/11/10 by Martin J. Bligh, mbligh@sequent.com +# to incorporate work done by Kurtis D. Rader & myself. + # Use Configure -Dcc=gcc to use gcc. # cc wants -G for dynamic loading @@ -15,10 +19,41 @@ libswanted=`echo $libswanted | sed -e 's/ inet / /'` # Configure defaults to usenm='y', which doesn't work very well usenm='n' -# Reported by bruce@aps.org ("Bruce P. Schuck") as needed for -# DYNIX/ptx 4.0 V4.2.1 to get socket i/o to work -# Not defined by default in case they break other versions. -# These probably need to be worked into a piece of code that -# checks for the need for this setting. -# cppflags='-Wc,+abi-socket -I/usr/local/include' -# ccflags='-Wc,+abi-socket -I/usr/local/include' +# for performance, apparently this makes a huge difference (~krader) + +d_vfork='define' +optimize='-Wc,-O3 -W0,-xstring' + +# We override d_socket because it's very hard for Configure to get it right +# in Dynix/Ptx, for several reasons. +# (1) the socket interface is in libsocket.so -- this wouldn't be so hard +# for Configure to fathom...but it gets more tangled. +# (2) if the system has been patched there can be libsocket.so.1.FOO.BAR, +# the FOO.BAR being the old version of the system before the patching. +# Configure picks up the old broken version. +# (3) libsocket.so points to either libsocket.so.1 (v4.2) +# or libsocket.so.1.1 (v4.4) The socket call in libsocket.so.1.1 +# (BSD socket library) is called bsd_socket(), and has a macro wrapper +# to hide this. +# This information kindly provided by Martin J. Bligh of Sequent. +# As he puts it: +# "Sequent has unusual capabilities, taking it above and beyond +# the complexity of any other vendor" :-) +# +# Jarkko Hietaniemi November 1998 + +case "$osvers" in +4.4*) # configure doesn't find sockets, as they're in libsocket, not libc + d_socket='define' + d_oldsock='undef' + d_sockpair='define' + ;; +4.2*) # on ptx/TCP 4.2, we can use BSD sockets, but they're not the default. + cppflags='-Wc,+bsd-socket' + ccflags='-Wc,+bsd-socket' + ldflags='-Wc,+bsd-socket' + d_socket='define' + d_oldsock='undef' + d_sockpair='define' + ;; +esac diff --git a/contrib/perl5/hints/freebsd.sh b/contrib/perl5/hints/freebsd.sh index 0f2a5a5..66f6ca0 100644 --- a/contrib/perl5/hints/freebsd.sh +++ b/contrib/perl5/hints/freebsd.sh @@ -23,6 +23,10 @@ # Andy Dougherty <doughera@lafcol.lafayette.edu> # Date: Tue Mar 10 16:07:00 EST 1998 # +# Support for FreeBSD/ELF +# Ollivier Robert <roberto@keltia.freenix.fr> +# Date: Wed Sep 2 16:22:12 CEST 1998 +# # The two flags "-fpic -DPIC" are used to indicate a # will-be-shared object. Configure will guess the -fpic, (and the # -DPIC is not used by perl proper) but the full define is included to @@ -95,12 +99,21 @@ esac case "$osvers" in 0.*|1.0*) ;; -3.0*) if [ -e /usr/lib/aout ]; then +3.*|4.0*) + objformat=`/usr/bin/objformat` + if [ x$objformat = xelf ]; then + libpth="/usr/lib /usr/local/lib" + glibpth="/usr/lib /usr/local/lib" + ldflags="-Wl,-E " + lddlflags="-shared " + else + if [ -e /usr/lib/aout ]; then libpth="/usr/lib/aout /usr/local/lib /usr/lib" glibpth="/usr/lib/aout /usr/local/lib /usr/lib" fi - cccdlflags='-DPIC -fpic' lddlflags='-Bshareable' + fi + cccdlflags='-DPIC -fpic' ;; *) cccdlflags='-DPIC -fpic' @@ -118,38 +131,91 @@ problem. Try EOM -# XXX EXPERIMENTAL A.D. 03/09/1998 -# XXX This script UU/usethreads.cbu will get 'called-back' by Configure -# XXX after it has prompted the user for whether to use threads. -cat > UU/usethreads.cbu <<'EOSH' +# From: Anton Berezin <tobez@plab.ku.dk> +# To: perl5-porters@perl.org +# Subject: [PATCH 5.005_54] Configure - hints/freebsd.sh signal handler type +# Date: 30 Nov 1998 19:46:24 +0100 +# Message-ID: <864srhhvcv.fsf@lion.plab.ku.dk> + +signal_t='void' +d_voidsig='define' + +# set libperl.so.X.X for 2.2.X +case "$osvers" in +2.2*) + # unfortunately this code gets executed before + # the equivalent in the main Configure so we copy a little + # from Configure XXX Configure should be fixed. + if $test -r $src/patchlevel.h;then + patchlevel=`awk '/define[ ]+PATCHLEVEL/ {print $3}' $src/patchlevel.h` + subversion=`awk '/define[ ]+SUBVERSION/ {print $3}' $src/patchlevel.h` + else + patchlevel=0 + subversion=0 + fi + libperl="libperl.so.$patchlevel.$subversion" + unset patchlevel + unset subversion + ;; +esac + +# This script UU/usethreads.cbu will get 'called-back' by Configure +# after it has prompted the user for whether to use threads. +cat > UU/usethreads.cbu <<'EOCBU' case "$usethreads" in -$define) - case "$osvers" in - 3.0*) ldflags="-pthread $ldflags" - ;; - 2.2*) if [ ! -r /usr/lib/libc_r ]; then - cat <<'EOM' >&4 -POSIX threads are not supported by default on FreeBSD $uname_r. Follow the -instructions in 'man pthread' to build and install the needed libraries. +$define|true|[yY]*) + lc_r=`/sbin/ldconfig -r|grep ':-lc_r'|awk '{print $NF}'` + case "$osvers" in + 2.2.8*|3.*|4.*) + if [ ! -r "$lc_r" ]; then + cat <<EOM >&4 +POSIX threads should be supported by FreeBSD $osvers -- +but your system is missing the shared libc_r. +(/sbin/ldconfig -r doesn't find any). + +Consider using the latest STABLE release. EOM - exit 1 - fi - set `echo X "$libswanted "| sed -e 's/ c / c_r /'` - shift - libswanted="$*" - # Configure will probably pick the wrong libc to use for nm - # scan. - # The safest quick-fix is just to not use nm at all. - usenm=false - ;; - *) cat <<'EOM' >&4 -It is not known if FreeBSD $uname_r supports POSIX threads or not. Consider -upgrading to the latest STABLE release. + exit 1 + fi + ldflags="-pthread $ldflags" + ;; + 2.2*) + cat <<EOM >&4 +POSIX threads are not supported well by FreeBSD $osvers. + +Please consider upgrading to at least FreeBSD 2.2.8, +or preferably to 3.something. + +(While 2.2.7 does have pthreads, it has some problems + with the combination of threads and pipes and therefore + many Perl tests will either hang or fail.) EOM - exit 1 - ;; - esac - ;; + exit 1 + ;; + *) cat <<EOM >&4 +I did not know that FreeBSD $osvers supports POSIX threads. + +Feel free to tell perlbug@perl.com otherwise. +EOM + exit 1 + ;; + esac + + set `echo X "$libswanted "| sed -e 's/ c / c_r /'` + shift + libswanted="$*" + # Configure will probably pick the wrong libc to use for nm scan. + # The safest quick-fix is just to not use nm at all... + usenm=false + + case "$osvers" in + 2.2.8*) + # ... but this does not apply for 2.2.8 - we know it's safe + libc="$lc_r" + usenm=true + ;; + esac + + unset lc_r esac -EOSH -# XXX EXPERIMENTAL --end of call-back +EOCBU diff --git a/contrib/perl5/hints/gnu.sh b/contrib/perl5/hints/gnu.sh new file mode 100644 index 0000000..927bcea --- /dev/null +++ b/contrib/perl5/hints/gnu.sh @@ -0,0 +1,33 @@ +# hints/gnu.sh +# Last modified: Thu Dec 10 20:47:28 CET 1998 +# Mark Kettenis <kettenis@phys.uva.nl> + +# libnsl is unusable on the Hurd. +# XXX remove this once SUNRPC is implemented. +set `echo X "$libswanted "| sed -e 's/ nsl / /'` +shift +libswanted="$*" + +case "$optimize" in +'') optimize='-O2' ;; +esac + +# Flags needed to produce shared libraries. +lddlflags='-shared' + +# Flags needed by programs that use dynamic linking. +ccdlflags='-Wl,-E' + +# The following routines are only available as stubs in GNU libc. +# XXX remove this once metaconf detects the GNU libc stubs. +d_msgctl='undef' +d_msgget='undef' +d_msgrcv='undef' +d_msgsnd='undef' +d_semctl='undef' +d_semget='undef' +d_semop='undef' +d_shmat='undef' +d_shmctl='undef' +d_shmdt='undef' +d_shmget='undef' diff --git a/contrib/perl5/hints/hpux.sh b/contrib/perl5/hints/hpux.sh index 281f289..8a9e3cb 100644 --- a/contrib/perl5/hints/hpux.sh +++ b/contrib/perl5/hints/hpux.sh @@ -20,6 +20,7 @@ # Distinguish between MC68020, MC68030, MC68040 # Don't assume every OS != 10 is < 10, (e.g., 11). # From: Chuck Phillips <cdp@fc.hp.com> +# HP-UX 10 pthreads hints: Matthew T Harden <mthard@mthard1.monsanto.com> # This version: August 15, 1997 # Current maintainer: Jeff Okamoto <okamoto@corp.hp.com> @@ -80,6 +81,16 @@ EOM esac else ccflags="$ccflags -Aa" # The add-on compiler supports ANSI C + # cppstdin and cpprun need the -Aa option if you use the unbundled + # ANSI C compiler (*not* the bundled K&R compiler or gcc) + # [XXX this should be set automatically by Configure, but isn't yet.] + # [XXX This is reported not to work. You may have to edit config.sh. + # After running Configure, set cpprun and cppstdin in config.sh, + # run "Configure -S" and then "make".] + cpprun="${cc:-cc} -E -Aa" + cppstdin="$cpprun" + cppminus='-' + cpplast='-' fi # For HP's ANSI C compiler, up to "+O3" is safe for everything # except shared libraries (PIC code). Max safe for PIC is "+O2". @@ -128,6 +139,60 @@ else selecttype='int *' fi +# This script UU/usethreads.cbu will get 'called-back' by Configure +# after it has prompted the user for whether to use threads. +cat > UU/usethreads.cbu <<'EOCBU' +case "$usethreads" in +$define|true|[yY]*) + if [ "$xxOsRevMajor" -lt 10 ]; then + cat <<EOM >&4 +HP-UX $xxOsRevMajor cannot support POSIX threads. +Consider upgrading to at least HP-UX 11. +Cannot continue, aborting. +EOM + exit 1 + fi + case "$xxOsRevMajor" in + 10) + # Under 10.X, a threaded perl can be built, but it needs + # libcma and OLD_PTHREADS_API. Also <pthread.h> needs to + # be #included before any other includes (in perl.h) + if [ ! -f /usr/include/pthread.h -o ! -f /usr/lib/libcma.sl ]; then + cat <<EOM >&4 +In HP-UX 10.X for POSIX threads you need both of the files +/usr/include/pthread.h and /usr/lib/libcma.sl. +Either you must install the CMA package or you must upgrade to HP-UX 11. +Cannot continue, aborting. +EOM + exit 1 + fi + + # HP-UX 10.X uses the old pthreads API + case "$d_oldpthreads" in + '') d_oldpthreads="$define" ;; + esac + + # include libcma before all the others + libswanted="cma $libswanted" + + # tell perl.h to include <pthread.h> before other include files + ccflags="$ccflags -DPTHREAD_H_FIRST" + + # CMA redefines select to cma_select, and cma_select expects int * + # instead of fd_set * (just like 9.X) + selecttype='int *' + ;; + 11 | 12) # 12 may want upping the _POSIX_C_SOURCE datestamp... + ccflags=" -D_POSIX_C_SOURCE=199506L $ccflags" + set `echo X "$libswanted "| sed -e 's/ c / pthread c /'` + shift + libswanted="$*" + ;; + esac + usemymalloc='n' + ;; +esac +EOCBU # Remove bad libraries that will cause problems # (This doesn't remove libraries that don't actually exist) @@ -183,24 +248,3 @@ esac # assembler of the form: # (warning) Use of GR3 when frame >= 8192 may cause conflict. # These warnings are harmless and can be safely ignored. - -# -# cppstdin and cpprun need the -Aa option if you use the unbundled -# ANSI C compiler (*not* the bundled K&R compiler or gcc) -# [XXX this should be enabled automatically by Configure, but isn't yet.] -# [XXX This is reported not to work. You may have to edit config.sh. -# After running Configure, set cpprun and cppstdin in config.sh, -# run "Configure -S" and then "make".] -# -case "$cppstdin" in -'') - case "$ccflags" in - *-Aa*) - cpprun="${cc:-cc} -E -Aa" - cppstdin="$cpprun" - cppminus='-' - cpplast='-' - ;; - esac - ;; -esac diff --git a/contrib/perl5/hints/irix_4.sh b/contrib/perl5/hints/irix_4.sh index f5883f3..8013c8a 100644 --- a/contrib/perl5/hints/irix_4.sh +++ b/contrib/perl5/hints/irix_4.sh @@ -22,3 +22,14 @@ If you have problems, you might have try including -DSTANDARD_C -cckr in ccflags. EOM + +case "$usethreads" in +$define|true|[yY]*) + cat >&4 <<EOM +IRIX `uname -r` does not support POSIX threads. +You should upgrade to at least IRIX 6.2 with pthread patches. +EOM + exit 1 + ;; +esac + diff --git a/contrib/perl5/hints/irix_5.sh b/contrib/perl5/hints/irix_5.sh index 9d6e802..757ffff 100644 --- a/contrib/perl5/hints/irix_5.sh +++ b/contrib/perl5/hints/irix_5.sh @@ -32,3 +32,14 @@ libswanted="$*" # patchSG0000596. The patch can be downloaded from Advantage OnLine (SGI's # WWW server) or from the Support Advantage 9/95 Patch CDROM. Thanks to Tom # Christiansen and others who provided assistance. + +case "$usethreads" in +$define|true|[yY]*) + cat >&4 <<EOM +IRIX `uname -r` does not support POSIX threads. +You should upgrade to at least IRIX 6.2 with pthread patches. +EOM + exit 1 + ;; +esac + diff --git a/contrib/perl5/hints/irix_6.sh b/contrib/perl5/hints/irix_6.sh index 384701f..3250fc7 100644 --- a/contrib/perl5/hints/irix_6.sh +++ b/contrib/perl5/hints/irix_6.sh @@ -53,11 +53,11 @@ case "$cc" in case "`$cc -version 2>&1`" in *7.0*) # Mongoose 7.0 ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -woff 1009,1042,1048,1110,1116,1184 -OPT:Olimit=0" - optimize='none' + optimize='none' ;; *7.1*|*7.2|*7.20) # Mongoose 7.1+ ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -woff 1009,1110,1184 -OPT:Olimit=0" - optimize='-O3' + optimize='-O3' # This is a temporary fix for 5.005. # Leave pp_ctl_cflags line at left margin for Configure. See # hints/README.hints, especially the section @@ -65,12 +65,12 @@ case "$cc" in pp_ctl_cflags='optimize=-O' ;; *7.*) # Mongoose 7.2.1+ - ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -woff 1009,1110,1184 -OPT:Olimit=0:space=on" - optimize='-O3' + ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -woff 1009,1110,1184 -OPT:Olimit=0:space=ON" + optimize='-O3' ;; *6.2*) # Ragnarok 6.2 ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -woff 1009,1110,1184" - optimize='none' + optimize='none' ;; *) # Be safe and not optimize ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -woff 1009,1110,1184 -OPT:Olimit=0" @@ -78,9 +78,30 @@ pp_ctl_cflags='optimize=-O' ;; esac - ld=ld +# this is to accommodate the 'modules' capability of the +# 7.2 MIPSPro compilers, which allows for the compilers to be installed +# in a nondefault location. Almost everything works as expected, but +# /usr/include isn't caught properly. Hence see the /usr/include/pthread.h +# change below to include TOOLROOT (a modules environment variable), +# and the following code. Additional +# code to accommodate the 'modules' environment should probably be added +# here if possible, or be inserted as a ${TOOLROOT} reference before +# absolute paths (again, see the pthread.h change below). +# -- krishna@sgi.com, 8/23/98 + +if [ "X${TOOLROOT}" != "X" ]; then +# we cant set cppflags because it gets overwritten +# we dont actually need $TOOLROOT/usr/include on the cc line cuz the +# modules functionality already includes it but +# XXX - how do I change cppflags in the hints file? + ccflags="$ccflags -I${TOOLROOT}/usr/include" + usrinc="${TOOLROOT}/usr/include" +fi + + ld=$cc # perl's malloc can return improperly aligned buffer - usemymalloc='undef' + # usemymalloc='undef' +malloc_cflags='ccflags="-DSTRICT_ALIGNMENT $ccflags"' # NOTE: -L/usr/lib32 -L/lib32 are automatically selected by the linker ldflags=' -L/usr/local/lib32 -L/usr/local/lib' cccdlflags=' ' @@ -138,22 +159,23 @@ set `echo X "$libswanted "|sed -e 's/ sun / /' -e 's/ crypt / /' -e 's/ bsd / /' shift libswanted="$*" -if [ "X$usethreads" = "X$define" -o "X$usethreads" = "Xy" ]; then - if test ! -f /usr/include/pthread.h -o ! -f /usr/lib/libpthread.so; then - uname_r=`uname -r` - case "`uname -r`" in - 5*|6.0|6.1) - echo >&4 "IRIX $uname_r does not have the POSIX threads." - echo >&4 "You should upgrade to at least IRIX 6.2 with pthread patches." - echo >&4 "Cannot continue, aborting." - exit 1 - ;; - 6.2) - echo >&4 "" -cat >&4 <<EOF -IRIX 6.2 $uname_r can have the POSIX threads. -The following IRIX patches (or their replacements) must, however, be installed: - +# This script UU/usethreads.cbu will get 'called-back' by Configure +# after it has prompted the user for whether to use threads. +cat > UU/usethreads.cbu <<'EOCBU' +case "$usethreads" in +$define|true|[yY]*) + if test ! -f ${TOOLROOT}/usr/include/pthread.h -o ! -f /usr/lib/libpthread.so; then + case "`uname -r`" in + [1-5].*|6.[01]) + cat >&4 <<EOM +IRIX `uname -r` does not support POSIX threads. +You should upgrade to at least IRIX 6.2 with pthread patches. +EOM + ;; + 6.2) + cat >&4 <<EOM +IRIX 6.2 can have the POSIX threads. +However, the following IRIX patches (or their replacements) MUST be installed: 1404 Irix 6.2 Posix 1003.1b man pages 1645 IRIX 6.2 & 6.3 POSIX header file updates 2000 Irix 6.2 Posix 1003.1b support modules @@ -163,28 +185,27 @@ IMPORTANT: Without patch 2401, a kernel bug in IRIX 6.2 will cause your machine to panic and crash when running threaded perl. IRIX 6.3 and up should be OK. - - +EOM + ;; + [67].*) + cat >&4 <<EOM +IRIX `uname -r` should have the POSIX threads. +But, somehow, you do not seem to have them installed. +EOM + ;; + esac + cat >&4 <<EOM Cannot continue, aborting. -EOF - exit 1 - ;; - 6.*|7.*) - echo >&4 "IRIX $uname_r should have the POSIX threads." - echo >&4 "But somehow you do not seem to have them installed." - echo >&4 "Cannot continue, aborting." - exit 1 - ;; - esac - unset uname_r - fi - # -lpthread needs to come before -lc but after other libraries such - # as -lgdbm and such like. We assume here that -lc is present in - # libswanted. If that fails to be true in future, then this can be - # changed to add pthread to the very end of libswanted. - set `echo X "$libswanted "| sed -e 's/ c / pthread /'` - ld="${cc:-cc}" - shift - libswanted="$*" - usemymalloc='n' -fi +EOM + exit 1 + fi + set `echo X "$libswanted "| sed -e 's/ c / pthread /'` + ld="${cc:-cc}" + shift + libswanted="$*" + + usemymalloc='n' + ;; +esac +EOCBU + diff --git a/contrib/perl5/hints/irix_6_0.sh b/contrib/perl5/hints/irix_6_0.sh index b0a3994..e61db04 100644 --- a/contrib/perl5/hints/irix_6_0.sh +++ b/contrib/perl5/hints/irix_6_0.sh @@ -42,10 +42,13 @@ libswanted="$*" # shift # libswanted="$*" -if [ "X$usethreads" = "X$define" ]; then - echo >&4 "IRIX 6.0 does not have POSIX threads." - echo >&4 "You should upgrade to at least IRIX 6.3." - echo >&4 "Cannot continue, aborting." - exit 1 -fi +case "$usethreads" in +$define|true|[yY]*) + cat >&4 <<EOM +IRIX `uname -r` does not support POSIX threads. +You should upgrade to at least IRIX 6.2 with pthread patches. +EOM + exit 1 + ;; +esac diff --git a/contrib/perl5/hints/irix_6_1.sh b/contrib/perl5/hints/irix_6_1.sh index 1c54f77..e61db04 100644 --- a/contrib/perl5/hints/irix_6_1.sh +++ b/contrib/perl5/hints/irix_6_1.sh @@ -42,9 +42,13 @@ libswanted="$*" # shift # libswanted="$*" -if [ "X$usethreads" = "X$define" ]; then - echo >&4 "IRIX 6.1 does not have POSIX threads." - echo >&4 "You should upgrade to at least IRIX 6.3." - echo >&4 "Cannot continue, aborting." - exit 1 -fi +case "$usethreads" in +$define|true|[yY]*) + cat >&4 <<EOM +IRIX `uname -r` does not support POSIX threads. +You should upgrade to at least IRIX 6.2 with pthread patches. +EOM + exit 1 + ;; +esac + diff --git a/contrib/perl5/hints/linux.sh b/contrib/perl5/hints/linux.sh index 545f50e..4764e9e 100644 --- a/contrib/perl5/hints/linux.sh +++ b/contrib/perl5/hints/linux.sh @@ -18,6 +18,27 @@ # No version of Linux supports setuid scripts. d_suidsafe='undef' +# Debian and Red Hat, and perhaps other vendors, provide both runtime and +# development packages for some libraries. The runtime packages contain shared +# libraries with version information in their names (e.g., libgdbm.so.1.7.3); +# the development packages supplement this with versionless shared libraries +# (e.g., libgdbm.so). +# +# If you want to link against such a library, you must install the development +# version of the package. +# +# These packages use a -dev naming convention in both Debian and Red Hat: +# libgdbmg1 (non-development version of GNU libc 2-linked GDBM library) +# libgdbmg1-dev (development version of GNU libc 2-linked GDBM library) +# So make sure that for any libraries you wish to link Perl with under +# Debian or Red Hat you have the -dev packages installed. +# +# Some operating systems (e.g., Solaris 2.6) will link to a versioned shared +# library implicitly. For example, on Solaris, `ld foo.o -lgdbm' will find an +# appropriate version of libgdbm, if one is available; Linux, however, doesn't +# do the implicit mapping. +ignore_versioned_solibs='y' + # perl goes into the /usr tree. See the Filesystem Standard # available via anonymous FTP at tsx-11.mit.edu in # /pub/linux/docs/linux-standards/fsstnd. @@ -187,29 +208,31 @@ fi # Shimpei Yamashita <shimpei@socrates.patnet.caltech.edu> # Message-Id: <33EF1634.B36B6500@pobox.com> # -# MkLinux (osname=linux,archname=ppc-linux), which differs slightly from other -# linuces, needs special flags passed in order for dynamic loading to work. +# The DR2 of MkLinux (osname=linux,archname=ppc-linux) may need +# special flags passed in order for dynamic loading to work. # instead of the recommended: +# # ccdlflags='-rdynamic' # # it should be: # ccdlflags='-Wl,-E' - -# XXX EXPERIMENTAL A.D. 2/27/1998 -# XXX This script UU/usethreads.cbu will get 'called-back' by Configure -# XXX after it has prompted the user for whether to use threads. -cat > UU/usethreads.cbu <<'EOSH' +# +# So if your DR2 (DR3 came out summer 1998, consider upgrading) +# has problems with dynamic loading, uncomment the +# following three lines, make distclean, and re-Configure: +#case "`uname -r | sed 's/^[0-9.-]*//'``arch`" in +#'osfmach3ppc') ccdlflags='-Wl,-E' ;; +#esac + +# This script UU/usethreads.cbu will get 'called-back' by Configure +# after it has prompted the user for whether to use threads. +cat > UU/usethreads.cbu <<'EOCBU' case "$usethreads" in $define|true|[yY]*) - ccflags="-D_REENTRANT $ccflags" - # -lpthread needs to come before -lc but after other libraries such - # as -lgdbm and such like. We assume here that -lc is present in - # libswanted. If that fails to be true in future, then this can be - # changed to add pthread to the very end of libswanted. - set `echo X "$libswanted "| sed -e 's/ c / pthread c /'` - shift - libswanted="$*" - ;; + ccflags="-D_REENTRANT $ccflags" + set `echo X "$libswanted "| sed -e 's/ c / pthread c /'` + shift + libswanted="$*" + ;; esac -EOSH -# XXX EXPERIMENTAL --end of call-back +EOCBU diff --git a/contrib/perl5/hints/mint.sh b/contrib/perl5/hints/mint.sh new file mode 100644 index 0000000..22d854c --- /dev/null +++ b/contrib/perl5/hints/mint.sh @@ -0,0 +1,94 @@ +# hints/mint.sh +# +# talk to gufl0000@stud.uni-sb.de if you want to change this file. +# Please read the README.mint file. +# +# misc stuff + +case `uname -m` in + atarist*) archname="m68000-mint" + ;; + *) archname="m68k-mint" + ;; +esac + +here=`pwd | tr -d '\015'` + +cc='gcc' + +# The weird include path is really to work around some bugs in +# broken system header files. +ccflags="-D__MINT__ -Uatarist -DDEBUGGING -I$here/../mint" + +# libs + +libpth="$prefix/lib /usr/lib /usr/local/lib" +glibpth="$libpth" +xlibpth="$libpth" + +libswanted='gdbm socket port m' +so='none' + +# +# compiler & linker flags +# +optimize='-O2 -fomit-frame-pointer -fno-defer-pop -fstrength-reduce' + +# The setlocale function in the MiNTLib is actually a bad joke. We +# lend a workaround from Ultrix. If neither LC_ALL nor LANG is +# set in the environment, perl won't complain. If one is set to +# anything but "C" you will see a warning. Note that you can +# still use the GNU extension "$LANGUAGE" if you want to use +# the i18n features of some GNU packages. +util_cflags='ccflags="$ccflags -DLOCALE_ENVIRON_REQUIRED"' + +# +# Some good answers to the questions in Configure: +usenm='true' +d_suidsafe='true' +clocktype='long' +usevfork='true' +d_fsetpos='fpos_t' +gidtype='gid_t' +groupstype='gid_t' +lseektype='long' +models='none' +modetype='mode_t' +sizetype='size_t' +timetype='time_t' +uidtype='uid_t' + +# Don't remove that leading tab character (Configure Black Magic (TM)). + broken_pwd= +case "`/bin/pwd|tr -d xy|tr '\015\012' 'xy'`" in +*xy) broken_pwd=yes ;; +esac + +if test X"$broken_pwd" = Xyes +then + echo " " + echo "*** Building fixed 'pwd'... (as described in README.mint) ***" + echo " " + cd mint + make pwd + cd .. + if test -x mint/pwd -a -w /usr/bin + then + echo " " + echo "*** Installing fixed 'pwd'... ***" + echo " " + cd mint + make install + cd .. + if cmp -s mint/pwd /usr/bin/pwd + then + echo "*** Installed fixed 'pwd' successfully. ***" + else + echo "*** Failed to install fixed 'pwd'. Aborting. ***" + exit 1 + fi + else + echo "*** Cannot install fixed 'pwd'. Aborting. ***" + exit 1 + fi +fi diff --git a/contrib/perl5/hints/mpeix.sh b/contrib/perl5/hints/mpeix.sh index 4a32b77..9ebb0ba 100644 --- a/contrib/perl5/hints/mpeix.sh +++ b/contrib/perl5/hints/mpeix.sh @@ -51,8 +51,8 @@ toke_cflags='ccflags="$ccflags -DARG_ZERO_IS_SCRIPT"' # Linking. # lddlflags='-b' -libs='-lbind -lsvipc -lsocket -lm -lc' -loclibpth='/usr/local/lib /usr/contrib/lib /BIND/PUB/lib' +libs='-lbind -lsyslog -lcurses -lsvipc -lsocket -lm -lc' +loclibpth='/usr/local/lib /usr/contrib/lib /BIND/PUB/lib /SYSLOG/PUB' # # External functions and data items. # diff --git a/contrib/perl5/hints/netbsd.sh b/contrib/perl5/hints/netbsd.sh index 71d5084..6d99a13 100644 --- a/contrib/perl5/hints/netbsd.sh +++ b/contrib/perl5/hints/netbsd.sh @@ -1,12 +1,11 @@ # hints/netbsd.sh # -# talk to mrg@eterna.com.au if you want to change this file. +# talk to packages@netbsd.org if you want to change this file. # # netbsd keeps dynamic loading dl*() functions in /usr/lib/crt0.o, # so Configure doesn't find them (unless you abandon the nm scan). # this should be *just* 0.9 below as netbsd 0.9a was the first to -# introduce shared libraries. however, they don't work/build on -# pmax, powerpc and alpha ports correctly, yet. +# introduce shared libraries. case "$archname" in '') @@ -19,34 +18,26 @@ case "$osvers" in usedl="$undef" ;; *) - case `uname -m` in - alpha|powerpc|pmax) + if [ -f /usr/libexec/ld.elf_so ]; then + d_dlopen=$define + d_dlerror=$define + ccdlflags="-Wl,-E -Wl,-R${PREFIX}/lib $ccdlflags" + cccdlflags="-DPIC -fPIC $cccdlflags" + lddlflags="--whole-archive -shared $lddlflags" + elif [ "`uname -m`" = "pmax" ]; then +# NetBSD 1.3 and 1.3.1 on pmax shipped an `old' ld.so, which will not work. d_dlopen=$undef - ;; -# this doesn't work (yet). -# alpha) -# d_dlopen=$define -# d_dlerror=$define -# cccdlflags="-DPIC -fPIC $cccdlflags" -# lddlflags="-shared $lddlflags" -# ;; - *) + elif [ -f /usr/libexec/ld.so ]; then d_dlopen=$define d_dlerror=$define + ccdlflags="-Wl,-R${PREFIX}/lib $ccdlflags" # we use -fPIC here because -fpic is *NOT* enough for some of the # extensions like Tk on some netbsd platforms (the sparc is one) cccdlflags="-DPIC -fPIC $cccdlflags" lddlflags="-Bforcearchive -Bshareable $lddlflags" - ;; - esac - ;; -esac -# netbsd 1.3 linker warns about setr[gu]id being deprecated. -# (setregid, setreuid, preferred?) -case "$osvers" in -1.3|1.3*) - d_setrgid="$undef" - d_setruid="$undef" + else + d_dlopen=$undef + fi ;; esac @@ -55,25 +46,31 @@ esac # way to make perl call setuid() or setgid(). if they aren't, then # ($<, $>) = ($u, $u); will work (same for $(/$)). this is because # you can not change the real userid of a process under 4.4BSD. -# netbsd fixed this in 1.2A. +# netbsd fixed this in 1.3.2. case "$osvers" in -0.9*|1.0*|1.1*|1.2_*|1.2|1.2.*) +0.9*|1.[012]*|1.3|1.3.1) d_setregid="$undef" d_setreuid="$undef" - d_setrgid="$undef" - d_setruid="$undef" - ;; -esac -# netbsd 1.3 linker warns about setr[gu]id being deprecated. -# (setregid, setreuid, preferred?) -case "$osvers" in -1.3|1.3*) - d_setrgid="$undef" - d_setruid="$undef" ;; esac -# vfork is ok on NetBSD. +# These are obsolete in any netbsd. +d_setrgid="$undef" +d_setruid="$undef" + +# there's no problem with vfork. case "$usevfork" in '') usevfork=true ;; esac + +# Avoid telldir prototype conflict in pp_sys.c (NetBSD uses const DIR *) +# Configure should test for this. Volunteers? +pp_sys_cflags='ccflags="$ccflags -DHAS_TELLDIR_PROTOTYPE"' + +# Pre-empt the /usr/bin/perl question of installperl. +installusrbinperl='n' + +# Recognize the NetBSD packages collection. +# GDBM might be here. +test -d /usr/pkg/lib && loclibpth="$loclibpth /usr/pkg/lib" +test -d /usr/pkg/include && locincpth="$locincpth /usr/pkg/include" diff --git a/contrib/perl5/hints/next_3.sh b/contrib/perl5/hints/next_3.sh index 43340c0..99adf50 100644 --- a/contrib/perl5/hints/next_3.sh +++ b/contrib/perl5/hints/next_3.sh @@ -129,3 +129,13 @@ ranlib='sleep 5; /bin/ranlib' # This is true whether we're on an HPPA machine or cross-compiling # for one. pp_cflags='optimize=""' + +# The SysV IPC is optional (ftp://ftp.nluug.nl/pub/comp/next/SysVIPC/) +# Gerben_Wierda@RnA.nl +if [ -f /usr/local/lib/libIPC.a ]; then + libswanted="$libswanted IPC" + # As of Sep 1998 d_msg wasn't supported in that library, + # only d_sem and d_shm, but Configure should be able to + # figure that out. --jhi + # Note also the next3 ext/IPC/SysV hints file. +fi diff --git a/contrib/perl5/hints/next_4.sh b/contrib/perl5/hints/next_4.sh index b3887e6..d1d0398 100644 --- a/contrib/perl5/hints/next_4.sh +++ b/contrib/perl5/hints/next_4.sh @@ -12,7 +12,7 @@ # useposix='undef' -libpth='/lib /usr/lib' +libpth='/lib /usr/lib /usr/local/lib' libswanted=' ' libc='/NextLibrary/Frameworks/System.framework/System' @@ -35,7 +35,20 @@ ld='cc' # # archs='m68k i386' # -archs=`/bin/lipo -info /usr/lib/libm.a | sed -n 's/^[^:]*:[^:]*: //p'` + +# On m68k machines, toke.c cannot be compiled at all for i386 and it can +# only be compiled for m68k itself without optimization (this is under +# OPENSTEP 4.2). +# +if [ `hostinfo | grep 'NeXT Mach.*:' | sed 's/.*RELEASE_//'` = M68K ] +then + echo "Cross compilation is impossible on m68k hardware under OS 4" + echo "Forcing architecture to m68k only" + toke_cflags='optimize=""' + archs='m68k' +else + archs=`/bin/lipo -info /usr/lib/libm.a | sed -n 's/^[^:]*:[^:]*: //p'` +fi # # leave the following part alone diff --git a/contrib/perl5/hints/openbsd.sh b/contrib/perl5/hints/openbsd.sh index 4c98ec8..e9d8ea4 100644 --- a/contrib/perl5/hints/openbsd.sh +++ b/contrib/perl5/hints/openbsd.sh @@ -48,4 +48,14 @@ d_suidsafe='define' # Allow a command-line override, such as -Doptimize=-g test "$optimize" || optimize='-O2' +# This script UU/usethreads.cbu will get 'called-back' by Configure +# after it has prompted the user for whether to use threads. +cat > UU/usethreads.cbu <<'EOCBU' +case "$usethreads" in +$define|true|[yY]*) + # any openbsd version dependencies with pthreads? + libswanted="$libswanted pthread" +esac +EOCBU + # end diff --git a/contrib/perl5/hints/os2.sh b/contrib/perl5/hints/os2.sh index 78d370a..310ae91 100644 --- a/contrib/perl5/hints/os2.sh +++ b/contrib/perl5/hints/os2.sh @@ -113,10 +113,11 @@ aout_lib_ext='.a' aout_ar='ar' aout_plibext='.a' aout_lddlflags="-Zdll $ld_dll_optimize" +# Cannot have 32000K stack: get SYS0170 ?! if [ $emxcrtrev -ge 50 ]; then - aout_ldflags='-Zexe -Zsmall-conv -Zstack 32000' + aout_ldflags='-Zexe -Zsmall-conv -Zstack 16000' else - aout_ldflags='-Zexe -Zstack 32000' + aout_ldflags='-Zexe -Zstack 16000' fi # To get into config.sh: @@ -249,15 +250,6 @@ nm_opt='-p' d_getprior='define' d_setprior='define' -if [ "X$usethreads" = "X$define" ]; then - ccflags="-Zmt $ccflags" - cppflags="-Zmt $cppflags" # Do we really need to set this? - aout_ccflags="-DUSE_THREADS $aout_ccflags" - aout_cppflags="-DUSE_THREADS $aout_cppflags" - aout_lddlflags="-Zmt $aout_lddlflags" - aout_ldflags="-Zmt $aout_ldflags" -fi - # The next two are commented. pdksh handles #!, extproc gives no path part. # sharpbang='extproc ' # shsharp='false' @@ -269,6 +261,21 @@ fi cp ./README.os2 ./pod/perlos2.pod +# This script UU/usethreads.cbu will get 'called-back' by Configure +# after it has prompted the user for whether to use threads. +cat > UU/usethreads.cbu <<'EOCBU' +case "$usethreads" in +$define|true|[yY]*) + ccflags="-Zmt $ccflags" + cppflags="-Zmt $cppflags" # Do we really need to set this? + aout_ccflags="-DUSE_THREADS $aout_ccflags" + aout_cppflags="-DUSE_THREADS $aout_cppflags" + aout_lddlflags="-Zmt $aout_lddlflags" + aout_ldflags="-Zmt $aout_ldflags" + ;; +esac +EOCBU + # Now install the external modules. We are in the ./hints directory. cd ./os2/OS2 diff --git a/contrib/perl5/hints/os390.sh b/contrib/perl5/hints/os390.sh index 1cf945d..08b60c8 100644 --- a/contrib/perl5/hints/os390.sh +++ b/contrib/perl5/hints/os390.sh @@ -17,6 +17,8 @@ # To get ANSI C, we need to use c89, and ld doesn't exist cc='c89' ld='c89' +# To link via definition side decks we need the dll option +cccdlflags='-W 0,dll,"langlvl(extended)"' # c89 hides most of the useful header stuff, _ALL_SOURCE turns it on again, # YYDYNAMIC ensures that the OS/390 yacc generated parser is reentrant. # -DEBCDIC should come from Configure. @@ -54,3 +56,6 @@ case "$archname" in esac archobjs=ebcdic.o + +# We have our own cppstdin. +echo 'cat >.$$.c; '"$cc"' -E -Wc,NOLOC ${1+"$@"} .$$.c; rm .$$.c' > cppstdin diff --git a/contrib/perl5/hints/sco.sh b/contrib/perl5/hints/sco.sh index cef1c0c..eb59845 100644 --- a/contrib/perl5/hints/sco.sh +++ b/contrib/perl5/hints/sco.sh @@ -1,140 +1,233 @@ -# sco.sh +# sco.sh # Courtesy of Joel Rosi-Schwartz <j.schwartz@agonet.it> - +############################################################### # Additional SCO version info from # Peter Wolfe <wolfe@teloseng.com> -# Last revised # Fri Jul 19 14:54:25 EDT 1996 -# by Andy Dougherty <doughera@lafcol.lafayette.edu> - -# To use gcc, use sh Configure -Dcc=gcc -# But gcc will *not* do dynamic laoding on 3.2.5, -# for that use sh Configure -Dcc=icc -# See below for more details. +# and again Tue Sep 29 16:37:25 EDT 1998 +# by Andy Dougherty <doughera@lafayette.edu> +# Mostly rewritten on +# Tue Jan 19 23:00:00 CET 1999 +# by Francois Desarmenien <desar@club-internet.fr> +############################################################### +# +# To use cc, use sh Configure +# To use gcc, use sh Configure -Dcc=gcc +# +# Default on 3.2v4 is to use static link (dynamic loading unsupported). +# Default on 3.2v5 is to use dynamic loading. +# To use static linkink instead, use to sh Configure -Dusedl=n +# +# Warning: - to use dynamic loading with gcc, you need gcc 2.8.0 or later +# ******** - to compile with older releases of gcc, use Configure -Dusedl=n +# or it wont compile properly +# +############################################################### +# NOTES: +# ----- +# +# I Have removed inclusion of ODBM_File for OSR5 +# because it core dumps and make tests fails. +# +# Support for icc compiler has been removed, because it 'breaks' +# a lot of code :-( +# +# It's *always* a good idea to first make a static link to be sure to +# have all symbols resolved with the current choice of libraries, since +# with dynamic linking, unresolved symbols are allowed an will be detected +# only at runtime (when you try to load the module or worse, when you call +# the symbol) +# +# The best choice of compiler on OSR 5 (3.2v5.*) seems to be gcc >= 2.8.0: +# -You cannot optimize with genuine sco cc (miniperl core dumps), +# so Perl is faster if compiled with gcc. +# -Even optimized for speed, gcc generated code is smaller (!!!) +# -gcc is free +# -I use ld to link which is distributed with the core OS distribution, so you +# don't need to buy the developement kit, just find someone kind enough to +# give you a binary release of gcc. +# +# +############################################################### # figure out what SCO version we are. The output of uname -X is # something like: # System = SCO_SV # Node = xxxxx # Release = 3.2v5.0.0 # KernelID = 95/08/08 -# Machine = Pentium +# Machine = Pentium # BusType = ISA # Serial = xxxxx # Users = 5-user # OEM# = 0 # Origin# = 1 -# NumCPU = 1 - -# Use /bin/uname (because Gnu may be first on the path and +# NumCPU = 1 + +# Use /bin/uname (because GNU uname may be first in $PATH and # it does not support -X) to figure out what SCO version we are: -case `/bin/uname -X | egrep '^Release'` in -*3.2v4.*) scorls=3 ;; # I don't know why this is 3 instead of 4 :-) -*3.2v5.*) scorls=5 ;; -*) scorls=3 ;; # this probabaly shouldn't happen +# Matching '^Release' is broken by locale setting: +# matching '3.2v' should be enough -- FD +case `/bin/uname -X | egrep '3\.2v'` in +*3.2v4.*) scorls=3 ;; # OSR 3 +*3.2v5.*) scorls=5 ;; # OSR 5 +*) + # Future of SCO OSR is SCO UnixWare: there should not be new OSR releases + echo "************************************************************" >&4 + echo "" >&4 + echo " sco.sh hints file only supports:" >&4 + echo "" >&4 + echo " - SCO Unix 3.2v4.x (OSR 3)" >&4 + echo " - SCO Unix 3.2v5.x (OSR 5)" >&4 + echo "" >&4 + echo "" >&4 + echo " For UnixWare, use svr4.sh hints instead" >&4 + echo "" >&4 + echo "***********************************************************" >&4 + exit +;; esac +############################################################### +# Common fixes for all compilers an releases: + +############################################################### +# What is true for SCO5 is true for SCO3 too today, so let's have a single +# symbol for both +ccflags="-U M_XENIX -D PERL_SCO" + +############################################################### +# Compilers options section: +if test "$scorls" = "3" +then + dlext='' + case "$cc" in + gcc) optimize='-O2' ;; + *) ccflags="$ccflags -W0 -quiet" + optimize='-O' ;; + esac +else + ############################################################### + # Need this in release 5 because of changed fpu exeption rules + ccflags="$ccflags -D PERL_SCO5" + + ############################################################### + # In Release 5, always compile ELF objects + case "$cc" in + gcc) + ccflags="$ccflags -melf" + optimize='-O2' + ;; + *) + ccflags="$ccflags -w0 -belf" + optimize='-O0' + ;; + esac + ############################################################### + # Dynamic loading section: + # + # We use ld to build shared libraries as it is always available + # and seems to work better than GNU's one on SCO + # + # 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 'foreign' libraries + # are usually put there in sco + # + if test "$usedl" != "n"; then + ld='ld' + case "$cc" in + gcc) + ccdlflags='-Xlinker -Bexport -L/usr/local/lib' + cccdlflags='-fpic' + lddlflags='-G -L/usr/local/lib' + ;; + *) + ccdlflags='-Bexport -L/usr/local/lib' + cccdlflags='-Kpic' + lddlflags='-G -L/usr/local/lib' + ;; + esac + + ############################################################### + # Use dynamic loading + usedl='define' + dlext='so' + dlsrc='dl_dlopen.xs' + + ############################################################### + # Force to define those symbols, as they are #defines and not + # catched by Configure, and they are useful + d_dlopen='define' + d_dlerror='define' + fi +fi + + +############################################################### +# Various hints, common to all releases, to have it work better: + +############################################################### +# We need to remove libdl, as libdl.so exists, but ld complains +# it can't find libdl.a ! Bug or feature ? :-) +libswanted=`echo " $libswanted " | sed -e 's/ dl / /'` +set X $libswanted +shift +libswanted="$*" + +############################################################### # Try to use libintl.a since it has strcoll and strxfrm libswanted="intl $libswanted" + +############################################################### # Try to use libdbm.nfs.a since it has dbmclose. -# if test -f /usr/lib/libdbm.nfs.a ; then libswanted=`echo "dbm.nfs $libswanted " | sed -e 's/ dbm / /'` + set X $libswanted + shift + libswanted="$*" fi -set X $libswanted -shift -libswanted="$*" +############################################################### +# We disable ODBM_File if OSR5 because it's mostly broken +# but keep it for ODT3 as it seems to work. +if test "$scorls" = "5"; then + i_dbm='undef' +fi + +############################################################### # We don't want Xenix cross-development libraries glibpth=`echo $glibpth | sed -e 's! /usr/lib/386 ! !' -e 's! /lib/386 ! !'` xlibpth='' -case "$cc" in -*gcc*) ccflags="$ccflags -U M_XENIX" - optimize="$optimize -O2" - ;; -scocc) ;; - -# On SCO 3.2v5 both cc and icc can build dynamic load, but cc core -# dumps if optimised, so I am only setting this up for icc. -# It is possible that some 3.2v4.2 system have icc, I seem to -# recall it was available as a seperate product but I have no -# knowledge if it can do dynamic loading and if so how. -# Joel Rosi-Schwartz -icc)# Apparently, SCO's cc gives rather verbose warnings - # Set -w0 to turn them off. - case $scorls in - 3) ccflags="$ccflags -W0 -quiet -U M_XENIX" ;; - 5) ccflags="$ccflags -belf -w0 -U M_XENIX" - optimize="-O1" # -g -O1 will not work - # optimize="-O0" may be needed for pack test to pass. - lddlflags='-G -L/usr/local/lib' - ldflags=' -W l,-Bexport -L/usr/local/lib' - dlext='so' - dlsrc='dl_dlopen.xs' - usedl='define' - ;; - esac - ;; - -*) # Apparently, miniperl core dumps if -O is used. - case "$optimize" in - '') optimize=none ;; - esac - # Apparently, SCO's cc gives rather verbose warnings - # Set -w0 to turn them off. - case $scorls in - 3) ccflags="$ccflags -W0 -quiet -U M_XENIX" ;; - 5) ccflags="$ccflags -w0 -U M_XENIX -DPERL_SCO5" ;; - esac - ;; -esac -i_varargs=undef - +############################################################### # I have received one report that nm extraction doesn't work if you're # using the scocc compiler. This system had the following 'myconfig' # uname='xxx xxx 3.2 2 i386 ' # cc='scocc', optimize='-O' -usenm='false' +# You can override this with Configure -Dusenm. +case "$usenm" in +'') usenm='false' ;; +esac +############################################################### # If you want to use nm, you'll probably have to use nm -p. The # following does that for you: nm_opt='-p' +############################################################### # I have received one report that you can't include utime.h in # pp_sys.c. Uncomment the following line if that happens to you: # i_utime=undef -# Apparently, some versions of SCO include both .so and .a libraries, -# but they don't mix as they do on other ELF systems. The upshot is -# that Configure finds -ldl (libdl.so) but 'ld' complains it can't -# find libdl.a. -# I don't know which systems have this feature, so I'll just remove -# -dl from libswanted for all SCO systems until someone can figure -# out how to get dynamic loading working on SCO. -# -# The output of uname -X on one such system was -# System = SCO_SV -# Node = xxxxx -# Release = 3.2v5.0.0 -# KernelID = 95/08/08 -# Machine = Pentium -# BusType = ISA -# Serial = xxxxx -# Users = 5-user -# OEM# = 0 -# Origin# = 1 -# NumCPU = 1 -# -# The 5.0.0 on the Release= line is probably the thing to watch. -# Andy Dougherty <doughera@lafcol.lafayette.edu> -# Thu Feb 1 15:06:56 EST 1996 -libswanted=`echo " $libswanted " | sed -e 's/ dl / /'` -set X $libswanted -shift -libswanted="$*" - +############################################################### # Perl 5.003_05 and later try to include both <time.h> and <sys/select.h> # in pp_sys.c, but that fails due to a redefinition of struct timeval. # This will generate a WHOA THERE. Accept the default. i_sysselct=$undef + + +############################################################### +#END of hint file diff --git a/contrib/perl5/hints/solaris_2.sh b/contrib/perl5/hints/solaris_2.sh index 856f801..935f00d 100644 --- a/contrib/perl5/hints/solaris_2.sh +++ b/contrib/perl5/hints/solaris_2.sh @@ -261,25 +261,26 @@ rm -f core # XXX EOSH -if [ "X$usethreads" = "X$define" ]; then - ccflags="-D_REENTRANT $ccflags" - # -lpthread needs to come before -lc but after other libraries such - # as -lgdbm and such like. We assume here that -lc is present in - # libswanted. If that fails to be true in future, then this can be - # changed to add pthread to the very end of libswanted. - # sched_yield is in -lposix4 - set `echo X "$libswanted "| sed -e 's/ c / posix4 pthread c /'` - shift - libswanted="$*" - - # On Solaris 2.6 x86 there is a bug with sigsetjmp() and siglongjmp() - # when linked with the threads library, such that whatever positive value - # you pass to siglongjmp(), sigsetjmp() returns 1. - # Thanks to Simon Parsons <S.Parsons@ftel.co.uk> for this report. - # Sun BugID is 4117946, "sigsetjmp always returns 1 when called by - # siglongjmp in a MT program". As of 19980622, there is no patch - # available. - cat >try.c <<'EOM' +# This script UU/usethreads.cbu will get 'called-back' by Configure +# after it has prompted the user for whether to use threads. +cat > UU/usethreads.cbu <<'EOCBU' +case "$usethreads" in +$define|true|[yY]*) + ccflags="-D_REENTRANT $ccflags" + + # sched_yield is in -lposix4 + set `echo X "$libswanted "| sed -e 's/ c / posix4 pthread c /'` + shift + libswanted="$*" + + # On Solaris 2.6 x86 there is a bug with sigsetjmp() and siglongjmp() + # when linked with the threads library, such that whatever positive + # value you pass to siglongjmp(), sigsetjmp() returns 1. + # Thanks to Simon Parsons <S.Parsons@ftel.co.uk> for this report. + # Sun BugID is 4117946, "sigsetjmp always returns 1 when called by + # siglongjmp in a MT program". As of 19980622, there is no patch + # available. + cat >try.c <<'EOM' /* Test for sig(set|long)jmp bug. */ #include <setjmp.h> @@ -293,18 +294,20 @@ if [ "X$usethreads" = "X$define" ]; then siglongjmp(env, 2); } EOM - if test "`arch`" = i86pc -a "$osvers" = 2.6 \ - && ${cc:-cc} try.c -lpthread >/dev/null 2>&1 && ./a.out; then - d_sigsetjmp=$undef - cat << 'EOM' >&2 + if test "`arch`" = i86pc -a "$osvers" = 2.6 && \ + ${cc:-cc} try.c -lpthread >/dev/null 2>&1 && ./a.out; then + d_sigsetjmp=$undef + cat << 'EOM' >&2 You will see a *** WHOA THERE!!! *** message from Configure for d_sigsetjmp. Keep the recommended value. See hints/solaris_2.sh for more information. EOM - fi -fi + fi + ;; +esac +EOCBU # This is just a trick to include some useful notes. cat > /dev/null <<'End_of_Solaris_Notes' diff --git a/contrib/perl5/hints/ultrix_4.sh b/contrib/perl5/hints/ultrix_4.sh index d8d2063..7b841e5 100644 --- a/contrib/perl5/hints/ultrix_4.sh +++ b/contrib/perl5/hints/ultrix_4.sh @@ -34,16 +34,16 @@ case "$cc" in *gcc*) ;; *) case "$osvers" in - *4.1*) ccflags="$ccflags -DLANGUAGE_C -Olimit 3200" ;; - *4.2*) ccflags="$ccflags -DLANGUAGE_C -Olimit 3200" + *4.1*) ccflags="$ccflags -DLANGUAGE_C -Olimit 3400" ;; + *4.2*) ccflags="$ccflags -DLANGUAGE_C -Olimit 3400" # Prototypes sometimes cause compilation errors in 4.2. prototype=undef case "$myuname" in *risc*) d_volatile=undef ;; esac ;; - *4.3*) ccflags="$ccflags -std1 -DLANGUAGE_C -Olimit 3200" ;; - *) ccflags="$ccflags -std -Olimit 3200" ;; + *4.3*) ccflags="$ccflags -std1 -DLANGUAGE_C -Olimit 3400" ;; + *) ccflags="$ccflags -std -Olimit 3400" ;; esac ;; esac diff --git a/contrib/perl5/hints/uwin.sh b/contrib/perl5/hints/uwin.sh new file mode 100644 index 0000000..0e5e11a --- /dev/null +++ b/contrib/perl5/hints/uwin.sh @@ -0,0 +1,36 @@ +# +# hint file for U/WIN (UNIX for Windows 95/NT) +# +# created for U/WIN version 1.55 +# running under Windows NT 4.0 SP 3 +# using MSVC++ 5.0 for the compiler +# +# created by Joe Buehler (jbuehler@hekimian.com) +# +# for information about U/WIN see www.gtlinc.com +# + +#ccflags=-D_BSDCOMPAT +# confusion in Configure over preprocessor +cppstdin=`pwd`/cppstdin +cpprun=`pwd`/cppstdin +# pwd.h confuses Configure +d_pwcomment=undef +d_pwgecos=define +# work around case-insensitive file names +firstmakefile=GNUmakefile +# avoid compilation error +i_utime=undef +# compile/link flags +ldflags=-g +optimize=-g +static_ext="B Data/Dumper Fcntl IO IPC/SysV Opcode POSIX SDBM_File Socket attrs" +#static_ext=none +# dynamic loading needs work +usedl=undef +# perl malloc will not work +usemymalloc=n +# cannot use nm +usenm=undef +# vfork() is buggy (as of 1.55 anyway) +usevfork=false diff --git a/contrib/perl5/hv.c b/contrib/perl5/hv.c index 40bb9b8..e0091ea 100644 --- a/contrib/perl5/hv.c +++ b/contrib/perl5/hv.c @@ -1,6 +1,6 @@ /* hv.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -18,7 +18,7 @@ static void hv_magic_check _((HV *hv, bool *needs_copy, bool *needs_store)); #ifndef PERL_OBJECT static void hsplit _((HV *hv)); static void hfreeentries _((HV *hv)); -static HE* more_he _((void)); +static void more_he _((void)); #endif #if defined(STRANGE_MALLOC) || defined(MYMALLOC) @@ -32,22 +32,25 @@ STATIC HE* new_he(void) { HE* he; - if (PL_he_root) { - he = PL_he_root; - PL_he_root = HeNEXT(he); - return he; - } - return more_he(); + LOCK_SV_MUTEX; + if (!PL_he_root) + more_he(); + he = PL_he_root; + PL_he_root = HeNEXT(he); + UNLOCK_SV_MUTEX; + return he; } STATIC void del_he(HE *p) { + LOCK_SV_MUTEX; HeNEXT(p) = (HE*)PL_he_root; PL_he_root = p; + UNLOCK_SV_MUTEX; } -STATIC HE* +STATIC void more_he(void) { register HE* he; @@ -60,7 +63,6 @@ more_he(void) he++; } HeNEXT(he) = 0; - return new_he(); } STATIC HEK * @@ -830,19 +832,18 @@ HV * newHVhv(HV *ohv) { register HV *hv; - register XPVHV* xhv; STRLEN hv_max = ohv ? HvMAX(ohv) : 0; STRLEN hv_fill = ohv ? HvFILL(ohv) : 0; hv = newHV(); while (hv_max && hv_max + 1 >= hv_fill * 2) hv_max = hv_max / 2; /* Is always 2^n-1 */ - ((XPVHV*)SvANY(hv))->xhv_max = hv_max; + HvMAX(hv) = hv_max; if (!hv_fill) return hv; #if 0 - if (!SvRMAGICAL(ohv) || !mg_find((SV*)ohv,'P')) { + if (! SvTIED_mg((SV*)ohv, 'P')) { /* Quick way ???*/ } else @@ -853,7 +854,7 @@ newHVhv(HV *ohv) HE *hv_eiter = HvEITER(ohv); /* current entry of iterator */ /* Slow way */ - hv_iterinit(hv); + hv_iterinit(ohv); while (entry = hv_iternext(ohv)) { hv_store(hv, HeKEY(entry), HeKLEN(entry), SvREFCNT_inc(HeVAL(entry)), HeHASH(entry)); @@ -1014,7 +1015,7 @@ hv_iternext(HV *hv) xhv = (XPVHV*)SvANY(hv); oldentry = entry = xhv->xhv_eiter; - if (SvRMAGICAL(hv) && (mg = mg_find((SV*)hv,'P'))) { + if (mg = SvTIED_mg((SV*)hv, 'P')) { SV *key = sv_newmortal(); if (entry) { sv_setsv(key, HeSVKEY_force(entry)); @@ -1149,6 +1150,7 @@ unsharepvn(char *str, I32 len, U32 hash) } */ xhv = (XPVHV*)SvANY(PL_strtab); /* assert(xhv_array != 0) */ + LOCK_STRTAB_MUTEX; oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) { if (HeHASH(entry) != hash) /* strings can't be equal */ @@ -1168,6 +1170,7 @@ unsharepvn(char *str, I32 len, U32 hash) } break; } + UNLOCK_STRTAB_MUTEX; if (!found) warn("Attempt to free non-existent shared string"); @@ -1193,6 +1196,7 @@ share_hek(char *str, I32 len, register U32 hash) */ xhv = (XPVHV*)SvANY(PL_strtab); /* assert(xhv_array != 0) */ + LOCK_STRTAB_MUTEX; oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) { if (HeHASH(entry) != hash) /* strings can't be equal */ @@ -1219,6 +1223,7 @@ share_hek(char *str, I32 len, register U32 hash) } ++HeVAL(entry); /* use value slot as REFCNT */ + UNLOCK_STRTAB_MUTEX; return HeKEY_hek(entry); } diff --git a/contrib/perl5/hv.h b/contrib/perl5/hv.h index 19694ac..007892d 100644 --- a/contrib/perl5/hv.h +++ b/contrib/perl5/hv.h @@ -1,6 +1,6 @@ /* hv.h * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. diff --git a/contrib/perl5/installman b/contrib/perl5/installman index e637720..6fa4231 100755 --- a/contrib/perl5/installman +++ b/contrib/perl5/installman @@ -134,7 +134,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') { + if ($^O eq 'os2' || $^O eq 'amigaos' || $^O eq 'uwin') { $manpage =~ s#/#.#g; } else { $manpage =~ s#/#::#g; diff --git a/contrib/perl5/installperl b/contrib/perl5/installperl index 2db72d4..b1d5bfb 100755 --- a/contrib/perl5/installperl +++ b/contrib/perl5/installperl @@ -220,6 +220,11 @@ else { @corefiles = <*.h libperl*.*>; # AIX needs perl.exp installed as well. push(@corefiles,'perl.exp') if $^O eq 'aix'; + if ($^O eq 'mpeix') { + # MPE needs mpeixish.h installed as well. + mkpath("$installarchlib/CORE/mpeix", 1, 0777); + push(@corefiles,'mpeix/mpeixish.h'); + } # If they have built sperl.o... push(@corefiles,'sperl.o') if -f 'sperl.o'; } @@ -251,7 +256,8 @@ if (! $versiononly && ! samepath($installbin, '.') && ($^O ne 'dos') && ! $Is_VM my $mainperl_is_instperl = 0; -if (!$versiononly && !$nonono && !$Is_W32 && !$Is_VMS && -t STDIN && -t STDERR +if ($Config{installusrbinperl} eq 'define' && + !$versiononly && !$nonono && !$Is_W32 && !$Is_VMS && -t STDIN && -t STDERR && -w $mainperldir && ! samepath($mainperldir, $installbin)) { my($usrbinperl) = "$mainperldir/$perl$exe_ext"; my($instperl) = "$installbin/$perl$exe_ext"; @@ -327,7 +333,7 @@ if (! $versiononly) { # Install pod pages. Where? I guess in $installprivlib/pod. -if (! $versiononly || !($installprivlib =~ m/\Q$]/)) { +unless ( $versiononly && !($installprivlib =~ m/\Q$]/)) { # as line 200 mkpath("${installprivlib}/pod", 1, 0777); # If Perl 5.003's perldiag.pod is there, rename it. @@ -564,8 +570,6 @@ sub installlib { and chmod($name =~ /\.(so|$dlext)$/o ? 0555 : 0444, "$installlib/$name"); } - } elsif (-d $_) { - mkpath("$installlib/$name", 1, 0777); } } diff --git a/contrib/perl5/intrpvar.h b/contrib/perl5/intrpvar.h index dfdcca8..1f6244d 100644 --- a/contrib/perl5/intrpvar.h +++ b/contrib/perl5/intrpvar.h @@ -199,6 +199,7 @@ PERLVAR(Isublex_info, SUBLEXINFO) /* from toke.c */ #ifdef USE_THREADS PERLVAR(Ithrsv, SV *) /* struct perl_thread for main thread */ PERLVARI(Ithreadnum, U32, 0) /* incremented each thread creation */ +PERLVAR(Istrtab_mutex, perl_mutex) /* Mutex for string table access */ #endif /* USE_THREADS */ PERLVARI(Ibytecode_iv_overflows,int, 0) /* from bytecode.h */ diff --git a/contrib/perl5/iperlsys.h b/contrib/perl5/iperlsys.h index 91389a2..da8c5d6 100644 --- a/contrib/perl5/iperlsys.h +++ b/contrib/perl5/iperlsys.h @@ -114,7 +114,7 @@ public: virtual int Printf(PerlIO*, int &err, const char *,...) = 0; virtual int Vprintf(PerlIO*, int &err, const char *, va_list) = 0; virtual long Tell(PerlIO*, int &err) = 0; - virtual int Seek(PerlIO*, off_t, int, int &err) = 0; + virtual int Seek(PerlIO*, Off_t, int, int &err) = 0; virtual void Rewind(PerlIO*, int &err) = 0; virtual PerlIO * Tmpfile(int &err) = 0; virtual int Getpos(PerlIO*, Fpos_t *, int &err) = 0; @@ -322,10 +322,10 @@ extern int PerlIO_sprintf _((char *, int, const char *,...)) extern int PerlIO_vprintf _((PerlIO *, const char *, va_list)); #endif #ifndef PerlIO_tell -extern long PerlIO_tell _((PerlIO *)); +extern Off_t PerlIO_tell _((PerlIO *)); #endif #ifndef PerlIO_seek -extern int PerlIO_seek _((PerlIO *,off_t,int)); +extern int PerlIO_seek _((PerlIO *, Off_t, int)); #endif #ifndef PerlIO_rewind extern void PerlIO_rewind _((PerlIO *)); @@ -907,6 +907,7 @@ public: #define PerlSock_inet_addr(c) inet_addr(c) #define PerlSock_inet_ntoa(i) inet_ntoa(i) #define PerlSock_listen(s, b) listen(s, b) +#define PerlSock_recv(s, b, l, f) recv(s, b, l, f) #define PerlSock_recvfrom(s, b, l, f, from, fromlen) \ recvfrom(s, b, l, f, from, fromlen) #define PerlSock_select(n, r, w, e, t) select(n, r, w, e, t) diff --git a/contrib/perl5/lib/AutoLoader.pm b/contrib/perl5/lib/AutoLoader.pm index 666c6ca..5b083a7 100644 --- a/contrib/perl5/lib/AutoLoader.pm +++ b/contrib/perl5/lib/AutoLoader.pm @@ -178,7 +178,7 @@ such a file exists, AUTOLOAD will read and evaluate it, thus (presumably) defining the needed subroutine. AUTOLOAD will then C<goto> the newly defined subroutine. -Once this process completes for a given funtion, it is defined, so +Once this process completes for a given function, it is defined, so future calls to the subroutine will bypass the AUTOLOAD mechanism. =head2 Subroutine Stubs @@ -266,7 +266,7 @@ C<__DATA__>, after which routines are cached. B<SelfLoader> can also handle multiple packages in a file. B<AutoLoader> only reads code as it is requested, and in many cases -should be faster, but requires a machanism like B<AutoSplit> be used to +should be faster, but requires a mechanism like B<AutoSplit> be used to create the individual files. L<ExtUtils::MakeMaker> will invoke B<AutoSplit> automatically if B<AutoLoader> is used in a module source file. diff --git a/contrib/perl5/lib/AutoSplit.pm b/contrib/perl5/lib/AutoSplit.pm index 121d261..f818371 100644 --- a/contrib/perl5/lib/AutoSplit.pm +++ b/contrib/perl5/lib/AutoSplit.pm @@ -11,7 +11,7 @@ use vars qw( $Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime ); -$VERSION = "1.0302"; +$VERSION = "1.0303"; @ISA = qw(Exporter); @EXPORT = qw(&autosplit &autosplit_lib_modules); @EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime); @@ -219,7 +219,7 @@ sub autosplit_file { while (<IN>) { # Skip pod text. $fnr++; - $in_pod = 1 if /^=/; + $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); diff --git a/contrib/perl5/lib/Benchmark.pm b/contrib/perl5/lib/Benchmark.pm index a28f510..ef12d02 100644 --- a/contrib/perl5/lib/Benchmark.pm +++ b/contrib/perl5/lib/Benchmark.pm @@ -124,6 +124,11 @@ The COUNT can be zero or negative, see timethis(). Returns the difference between two Benchmark times as a Benchmark object suitable for passing to timestr(). +=item timesum ( T1, T2 ) + +Returns the sum of two Benchmark times as a Benchmark object suitable +for passing to timestr(). + =item timestr ( TIMEDIFF, [ STYLE, [ FORMAT ] ] ) Returns a string that formats the times in the TIMEDIFF object in @@ -293,6 +298,15 @@ sub timediff { bless \@r; } +sub timesum { + my($a, $b) = @_; + my @r; + for (my $i=0; $i < @$a; ++$i) { + push(@r, $a->[$i] + $b->[$i]); + } + bless \@r; +} + sub timestr { my($tr, $style, $f) = @_; my @t = @$tr; diff --git a/contrib/perl5/lib/CGI.pm b/contrib/perl5/lib/CGI.pm index 22d91a4..f5615f2 100644 --- a/contrib/perl5/lib/CGI.pm +++ b/contrib/perl5/lib/CGI.pm @@ -15,11 +15,10 @@ require 5.004; # listing the modifications you have made. # The most recent version and complete docs are available at: -# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html -# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/ +# http://stein.cshl.org/WWW/software/CGI/ -$CGI::revision = '$Id: CGI.pm,v 1.32 1998/05/28 21:55:43 lstein Exp lstein $'; -$CGI::VERSION='2.42'; +$CGI::revision = '$Id: CGI.pm,v 1.5 1998/12/06 10:19:48 lstein Exp $'; +$CGI::VERSION='2.46'; # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. @@ -59,6 +58,12 @@ sub initialize_globals { # Change this to 1 to disable uploads entirely: $DISABLE_UPLOADS = 0; + # Change this to 1 to suppress redundant HTTP headers + $HEADERS_ONCE = 0; + + # separate the name=value pairs by semicolons rather than ampersands + $USE_PARAM_SEMICOLONS = 0; + # Other globals that you shouldn't worry about. undef $Q; $BEEN_THERE = 0; @@ -116,8 +121,9 @@ $SL = { $IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; # Turn on special checking for Doug MacEachern's modperl -if (defined($ENV{'GATEWAY_INTERFACE'}) && - ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//)) +if (exists $ENV{'GATEWAY_INTERFACE'} + && + ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/)) { $| = 1; require Apache; @@ -151,20 +157,21 @@ if ($needs_binmode) { tt u i b blockquote pre img a address cite samp dfn html head base body Link nextid title meta kbd start_html end_html input Select option comment/], - ':html3'=>[qw/div table caption th td TR Tr sup sub strike applet Param + ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param embed basefont style span layer ilayer font frameset frame script small big/], ':netscape'=>[qw/blink fontsize center/], ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group submit reset defaults radio_group popup_menu button autoEscape scrolling_list image_button start_form end_form startform endform - start_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/], - ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie dump - raw_cookie request_method query_string accept user_agent remote_host + start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/], + ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie Dump + raw_cookie request_method query_string Accept user_agent remote_host remote_addr referer server_name server_software server_port server_protocol virtual_host remote_ident auth_type http use_named_parameters save_parameters restore_parameters param_fetch remote_user user_name header redirect import_names put Delete Delete_all url_param/], ':ssl' => [qw/https/], + ':imagemap' => [qw/Area Map/], ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/], ':html' => [qw/:html2 :html3 :netscape/], ':standard' => [qw/:html2 :html3 :form :cgi/], @@ -206,6 +213,7 @@ sub compile { sub expand_tags { my($tag) = @_; + return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/; my(@r); return ($tag) unless $EXPORT_TAGS{$tag}; foreach (@{$EXPORT_TAGS{$tag}}) { @@ -273,7 +281,7 @@ sub param { $name = $p[0]; } - return () unless defined($name) && $self->{$name}; + return unless defined($name) && $self->{$name}; return wantarray ? @{$self->{$name}} : $self->{$name}->[0]; } @@ -315,6 +323,7 @@ sub self_or_CGI { sub init { my($self,$initializer) = @_; my($query_string,$meth,$content_length,$fh,@lines) = ('','','',''); + local($/) = "\n"; # if we get called more than once, we want to initialize # ourselves from the original query (which may be gone @@ -341,7 +350,7 @@ sub init { && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data| && !defined($initializer) ) { - my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";]+)\"?/; + my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/; $self->read_multipart($boundary,$content_length); last METHOD; } @@ -496,7 +505,7 @@ sub save_request { sub parse_params { my($self,$tosplit) = @_; - my(@pairs) = split('&',$tosplit); + my(@pairs) = split(/[&;]/,$tosplit); my($param,$value); foreach (@pairs) { ($param,$value) = split('=',$_,2); @@ -526,11 +535,9 @@ sub binmode { } sub _make_tag_func { - my $tagname = shift; - return qq{ + my ($self,$tagname) = @_; + my $func = qq# sub $tagname { - # handle various cases in which we're called - # most of this bizarre stuff is to avoid -w errors shift if \$_[0] && (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) || (ref(\$_[0]) && @@ -542,12 +549,20 @@ sub _make_tag_func { my(\@attr) = make_attributes( '',shift() ); \$attr = " \@attr" if \@attr; } + #; + if ($tagname=~/start_(\w+)/i) { + $func .= qq! return "<\U$1\E\$attr>";} !; + } elsif ($tagname=~/end_(\w+)/i) { + $func .= qq! return "<\U/$1\E>"; } !; + } else { + $func .= qq# my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U</$tagname>\E"); return \$tag unless \@_; my \@result = map { "\$tag\$_\$untag" } (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_"; return "\@result"; - } -} + }#; + } +return $func; } sub AUTOLOAD { @@ -619,12 +634,13 @@ sub _compile { $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY'); if (!$code) { + (my $base = $func_name) =~ s/^(start_|end_)//i; if ($EXPORT{':any'} || $EXPORT{'-any'} || - $EXPORT{$func_name} || + $EXPORT{$base} || (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html'))) - && $EXPORT_OK{$func_name}) { - $code = _make_tag_func($func_name); + && $EXPORT_OK{$base}) { + $code = $CGI::DefaultClass->_make_tag_func($func_name); } } die "Undefined subroutine $AUTOLOAD\n" unless $code; @@ -644,14 +660,15 @@ sub _setup_symbols { my $self = shift; my $compile = 0; foreach (@_) { - $NPH++, next if /^[:-]nph$/; - $NO_DEBUG++, next if /^[:-]no_?[Dd]ebug$/; - $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/; - $EXPORT{$_}++, next if /^[:-]any$/; - $compile++, next if /^[:-]compile$/; + $HEADERS_ONCE++, next if /^[:-]unique_headers$/; + $NPH++, next if /^[:-]nph$/; + $NO_DEBUG++, next if /^[:-]no_?[Dd]ebug$/; + $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/; + $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/; + $EXPORT{$_}++, next if /^[:-]any$/; + $compile++, next if /^[:-]compile$/; - # This is probably extremely evil code -- to be deleted - # some day. + # This is probably extremely evil code -- to be deleted some day. if (/^[-]autoload$/) { my($pkg) = caller(1); *{"${pkg}::AUTOLOAD"} = sub { @@ -978,7 +995,7 @@ sub url_param { unless (exists($self->{'.url_param'})) { $self->{'.url_param'}={}; # empty hash if ($ENV{QUERY_STRING} =~ /=/) { - my(@pairs) = split('&',$ENV{QUERY_STRING}); + my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING}); my($param,$value); foreach (@pairs) { ($param,$value) = split('=',$_,2); @@ -1043,6 +1060,7 @@ sub save { $filehandle = to_filehandle($filehandle); my($param); local($,) = ''; # set print field separator back to a sane value + local($\) = ''; # set output line separator to a sane value foreach $param ($self->param) { my($escaped_param) = escape($param); my($value); @@ -1141,18 +1159,21 @@ sub header { my($self,@p) = self_or_default(@_); my(@header); + return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE; + my($type,$status,$cookie,$target,$expires,$nph,@other) = - $self->rearrange([TYPE,STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p); + $self->rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'], + STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p); $nph ||= $NPH; # rearrange() was designed for the HTML portion, so we # need to fix it up a little. foreach (@other) { - next unless my($header,$value) = /([^\s=]+)=\"?([^\"]+)\"?/; + next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/; ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ": $value"/e; } - $type = $type || 'text/html'; + $type ||= 'text/html' unless defined($type); # Maybe future compatibility. Maybe not. my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0'; @@ -1164,7 +1185,8 @@ sub header { if ($cookie) { my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie; foreach (@cookie) { - push(@header,"Set-Cookie: " . (UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_)); + my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_; + push(@header,"Set-Cookie: $cs") if $cs ne ''; } } # if the user indicates an expiration time, then we need @@ -1175,7 +1197,7 @@ sub header { push(@header,"Date: " . expires(0,'http')) if $expires || $cookie; push(@header,"Pragma: no-cache") if $self->cache(); push(@header,@other); - push(@header,"Content-Type: $type"); + push(@header,"Content-Type: $type") if $type ne ''; my $header = join($CRLF,@header)."${CRLF}${CRLF}"; if ($MOD_PERL and not $nph) { @@ -1221,6 +1243,7 @@ sub redirect { '-nph'=>$nph); unshift(@o,'-Target'=>$target) if $target; unshift(@o,'-Cookie'=>$cookie) if $cookie; + unshift(@o,'-Type'=>''); return $self->header(@o); } END_OF_FUNC @@ -1407,6 +1430,11 @@ sub start_form { } END_OF_FUNC +'end_multipart_form' => <<'END_OF_FUNC', +sub end_multipart_form { + &endform; +} +END_OF_FUNC #### Method: start_multipart_form # synonym for startform @@ -1459,8 +1487,11 @@ sub _textfield { $name = defined($name) ? $self->escapeHTML($name) : ''; my($s) = defined($size) ? qq/ SIZE=$size/ : ''; my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : ''; - my($other) = @other ? " @other" : ''; - return qq/<INPUT TYPE="$tag" NAME="$name" VALUE="$current"$s$m$other>/; + my($other) = @other ? " @other" : ''; + # this entered at cristy's request to fix problems with file upload fields + # and WebTV -- not sure it won't break stuff + my($value) = $current ne '' ? qq(VALUE="$current") : ''; + return qq/<INPUT TYPE="$tag" NAME="$name" $value$s$m$other>/; } END_OF_FUNC @@ -1787,12 +1818,17 @@ END_OF_FUNC sub unescapeHTML { my $string = ref($_[0]) ? $_[1] : $_[0]; return undef unless defined($string); - $string=~s/&/&/ig; - $string=~s/"/\"/ig; - $string=~s/>/>/ig; - $string=~s/</</ig; - $string=~s/&#(\d+);/chr($1)/eg; - $string=~s/&#[xX]([0-9a-fA-F]);/chr(hex($1))/eg; + # thanks to Randal Schwartz for the correct solution to this one + $string=~ s[&(.*?);]{ + local $_ = $1; + /^amp$/i ? "&" : + /^quot$/i ? '"' : + /^gt$/i ? ">" : + /^lt$/i ? "<" : + /^#(\d+)$/ ? chr($1) : + /^#x([0-9a-f]+)$/i ? chr(hex($1)) : + $_ + }gex; return $string; } END_OF_FUNC @@ -1867,14 +1903,13 @@ sub radio_group { } else { $checked = $default; } - # If no check array is specified, check the first by default - $checked = $values->[0] unless defined($checked) && $checked ne ''; - $name=$self->escapeHTML($name); - my(@elements,@values); - @values = $self->_set_values_and_labels($values,\$labels,$name); + # If no check array is specified, check the first by default + $checked = $values[0] unless defined($checked) && $checked ne ''; + $name=$self->escapeHTML($name); + my($other) = @other ? " @other" : ''; foreach (@values) { my($checkit) = $checked eq $_ ? ' CHECKED' : ''; @@ -2321,7 +2356,7 @@ sub query_string { push(@pairs,"$eparam=$value"); } } - return join("&",@pairs); + return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs); } END_OF_FUNC @@ -2337,8 +2372,8 @@ END_OF_FUNC # declares a quantitative score for it. # This handles MIME type globs correctly. #### -'accept' => <<'END_OF_FUNC', -sub accept { +'Accept' => <<'END_OF_FUNC', +sub Accept { my($self,$search) = self_or_CGI(@_); my(%prefs,$type,$pref,$pat); @@ -2758,6 +2793,7 @@ sub read_multipart { chmod 0600,$tmp; # only the owner can tamper with it my ($data); + local($\) = ''; while (defined($data = $buffer->read)) { print $filehandle $data; } @@ -2841,10 +2877,18 @@ $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; 'asString' => <<'END_OF_FUNC', sub asString { my $self = shift; - my $i = $$self; - $i=~ s/^\*(\w+::)+//; # get rid of package name + # get rid of package name + (my $i = $$self) =~ s/^\*(\w+::)+//; $i =~ s/\\(.)/$1/g; return $i; +# BEGIN DEAD CODE +# This was an extremely clever patch that allowed "use strict refs". +# Unfortunately it relied on another bug that caused leaky file descriptors. +# The underlying bug has been fixed, so this no longer works. However +# "strict refs" still works for some reason. +# my $self = shift; +# return ${*{$self}{SCALAR}}; +# END DEAD CODE } END_OF_FUNC @@ -2861,11 +2905,12 @@ sub new { my($pack,$name,$file,$delete) = @_; require Fcntl unless defined &Fcntl::O_RDWR; ++$FH; - *{$FH} = quotemeta($name); - sysopen($FH,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL()) + my $ref = \*{'Fh::' . quotemeta($name)}; + sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL()) || die "CGI open of $file: $!\n"; unlink($file) if $delete; - return bless \*{$FH},$pack; + delete $Fh::{$FH}; + return bless $ref,$pack; } END_OF_FUNC @@ -2883,10 +2928,10 @@ END_OF_AUTOLOAD package MultipartBuffer; # how many bytes to read at a time. We use -# a 5K buffer by default. -$INITIAL_FILLUNIT = 1024 * 5; -$TIMEOUT = 10*60; # 10 minute timeout -$SPIN_LOOP_MAX = 1000; # bug fix for some Netscape servers +# a 4K buffer by default. +$INITIAL_FILLUNIT = 1024 * 4; +$TIMEOUT = 240*60; # 4 hour timeout for big files +$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers $CRLF=$CGI::CRLF; #reuse the autoload function @@ -2930,8 +2975,8 @@ sub new { # characters "--" PLUS the Boundary string # BUG: IE 3.01 on the Macintosh uses just the boundary -- not - # the two extra spaces. We do a special case here on the user-agent!!!! - $boundary = "--$boundary" unless CGI::user_agent('MSIE 3\.0[12]; Mac'); + # the two extra hyphens. We do a special case here on the user-agent!!!! + $boundary = "--$boundary" unless CGI::user_agent('MSIE 3\.0[12]; ?Mac'); } else { # otherwise we find it ourselves my($old); @@ -3088,6 +3133,7 @@ sub fillBuffer { \$self->{BUFFER}, $bytesToRead, $bufferLength); + $self->{BUFFER} = '' unless defined $self->{BUFFER}; # An apparent bug in the Apache server causes the read() # to return zero bytes repeatedly without blocking if the @@ -3129,7 +3175,7 @@ $MAC = $CGI::OS eq 'MACINTOSH'; my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : ""; unless ($TMPDIRECTORY) { @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp", - "${SL}tmp","${SL}temp","${vol}${SL}Temporary Items", + "C:${SL}temp","${SL}tmp","${SL}temp","${vol}${SL}Temporary Items", "${SL}WWW_ROOT"); foreach (@TEMP) { do {$TMPDIRECTORY = $_; last} if -d $_ && -w _; @@ -3273,10 +3319,10 @@ the CGI script, and because each object's parameter list is independent of the others, this allows you to save the state of the script and restore it later. -For example, using the object oriented style, here is now you create +For example, using the object oriented style, here is how you create a simple "Hello World" HTML page: - #!/usr/local/bin/pelr + #!/usr/local/bin/perl use CGI; # load CGI routines $q = new CGI; # create new CGI object print $q->header, # create the HTTP header @@ -3294,7 +3340,7 @@ The main differences are that we now need to import a set of functions into our name space (usually the "standard" functions), and we don't need to create the CGI object. - #!/usr/local/bin/pelr + #!/usr/local/bin/perl use CGI qw/:standard/; # load standard CGI routines print header, # create the HTTP header start_html('hello world'), # start the HTML @@ -3319,7 +3365,7 @@ acceptable. In fact, only the first argument needs to begin with a dash. If a dash is present in the first argument, CGI.pm assumes dashes for the subsequent ones. -You don't have to use the hyphen at allif you don't want to. After +You don't have to use the hyphen at all if you don't want to. After creating a CGI object, call the B<use_named_parameters()> method with a nonzero value. This will tell CGI.pm that you intend to use named parameters exclusively: @@ -3667,7 +3713,7 @@ methods, and then use them directly: $zipcode = param('zipcode'); More frequently, you'll import common sets of functions by referring -to the gropus by name. All function sets are preceded with a ":" +to the groups by name. All function sets are preceded with a ":" character as in ":html3" (for tags defined in the HTML 3 standard). Here is a list of the function sets you can import: @@ -3719,7 +3765,7 @@ provide for the rapidly-evolving HTML "standard." For example, say Microsoft comes out with a new tag called <GRADIENT> (which causes the user's desktop to be flooded with a rotating gradient fill until his machine reboots). You don't need to wait for a new version of CGI.pm -to start using it immeidately: +to start using it immediately: use CGI qw/:standard :html3 gradient/; print gradient({-start=>'red',-end=>'blue'}); @@ -3799,7 +3845,7 @@ This causes the indicated autoloaded methods to be compiled up front, rather than deferred to later. This is useful for scripts that run for an extended period of time under FastCGI or mod_perl, and for those destined to be crunched by Malcom Beattie's Perl compiler. Use -it in conjunction with the methods or method familes you plan to use. +it in conjunction with the methods or method families you plan to use. use CGI qw(-compile :standard :html3); @@ -3819,6 +3865,17 @@ parsed header) script. You may need to do other things as well to tell the server that the script is NPH. See the discussion of NPH scripts below. +=item -newstyle_urls + +Separate the name=value pairs in CGI parameter query strings with +semicolons rather than ampersands. For example: + + ?name=fred;age=24;favorite_color=3 + +Semicolon-delimited query strings are always accepted, but will not be +emitted by self_url() and query_string() unless the -newstyle_urls +pragma is specified. + =item -autoload This overrides the autoloader so that any function in your program @@ -3859,7 +3916,51 @@ upload, even if it is confidential information. On Unix systems, the -private_tempfiles pragma will cause the temporary file to be unlinked as soon as it is opened and before any data is written into it, eliminating the risk of eavesdropping. -n + +=back + +=head2 SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS + +Many of the methods generate HTML tags. As described below, tag +functions automatically generate both the opening and closing tags. +For example: + + print h1('Level 1 Header'); + +produces + + <H1>Level 1 Header</H1> + +There will be some times when you want to produce the start and end +tags yourself. In this case, you can use the form start_I<tag_name> +and end_I<tag_name>, as in: + + print start_h1,'Level 1 Header',end_h1; + +With a few exceptions (described below), start_I<tag_name> and +end_I<tag_name> functions are not generated automatically when you +I<use CGI>. However, you can specify the tags you want to generate +I<start/end> functions for by putting an asterisk in front of their +name, or, alternatively, requesting either "start_I<tag_name>" or +"end_I<tag_name>" in the import list. + +Example: + + use CGI qw/:standard *table start_ul/; + +In this example, the following functions are generated in addition to +the standard ones: + +=over 4 + +=item 1. start_table() (generates a <TABLE> tag) + +=item 2. end_table() (generates a </TABLE> tag) + +=item 3. start_ul() (generates a <UL> tag) + +=item 4. end_ul() (generates a </UL> tag) + =back =head1 GENERATING DYNAMIC DOCUMENTS @@ -4247,6 +4348,25 @@ as a synonym. =back +=head2 MIXING POST AND URL PARAMETERS + + $color = $query->url_param('color'); + +It is possible for a script to receive CGI parameters in the URL as +well as in the fill-out form by creating a form that POSTs to a URL +containing a query string (a "?" mark followed by arguments). The +B<param()> method will always return the contents of the POSTed +fill-out form, ignoring the URL's query string. To retrieve URL +parameters, call the B<url_param()> method. Use it in the same way as +B<param()>. The main difference is that it allows you to read the +parameters, but not set them. + + +Under no circumstances will the contents of the URL query string +interfere with similarly-named CGI parameters in POSTed forms. If you +try to mix a URL query string with a form submitted with the GET +method, the results will not be what you expect. + =head1 CREATING STANDARD HTML ELEMENTS: CGI.pm defines general HTML shortcut methods for most, if not all of @@ -4325,7 +4445,7 @@ that points to an undef string: Prior to CGI.pm version 2.41, providing an empty ('') string as an attribute argument was the same as providing undef. However, this has -changed in order to accomodate those who want to create tags of the form +changed in order to accommodate those who want to create tags of the form <IMG ALT="">. The difference is shown in these two pieces of code: CODE RESULT @@ -4410,11 +4530,21 @@ begin with initial caps: Tr Link Delete + Accept + Sub In addition, start_html(), end_html(), start_form(), end_form(), start_multipart_form() and all the fill-out form tags are special. See their respective sections. +=head2 PRETTY-PRINTING HTML + +By default, all the HTML produced by these functions comes out as one +long line without carriage returns or indentation. This is yuck, but +it does reduce the size of the documents by 10-20%. To get +pretty-printed output, please use L<CGI::Pretty>, a subclass +contributed by Brian Paulsen. + =head1 CREATING FILL-OUT FORMS: I<General note> The various form-creating methods all return strings @@ -4469,7 +4599,7 @@ default is to process the query with the current script. print $query->startform(-method=>$method, -action=>$action, - -encoding=>$encoding); + -enctype=>$encoding); <... various form stuff ...> print $query->endform; @@ -4484,11 +4614,11 @@ action and form encoding that you specify. The defaults are: method: POST action: this script - encoding: application/x-www-form-urlencoded + enctype: application/x-www-form-urlencoded endform() returns the closing </FORM> tag. -Startform()'s encoding method tells the browser how to package the various +Startform()'s enctype argument tells the browser how to package the various fields of the form before sending the form to the server. Two values are possible: @@ -4671,12 +4801,11 @@ The first parameter is the required name for the field (-name). The optional second parameter is the starting value for the field contents to be used as the default file name (-default). -The beta2 version of Netscape 2.0 currently doesn't pay any attention -to this field, and so the starting value will always be blank. Worse, -the field loses its "sticky" behavior and forgets its previous -contents. The starting value field is called for in the HTML -specification, however, and possibly later versions of Netscape will -honor it. +For security reasons, browsers don't pay any attention to this field, +and so the starting value will always be blank. Worse, the field +loses its "sticky" behavior and forgets its previous contents. The +starting value field is called for in the HTML specification, however, +and possibly some browser will eventually provide support for it. =item 3. @@ -5093,7 +5222,7 @@ To include row and column headings in the returned table, you can use the B<-rowheader> and B<-colheader> parameters. Both of these accept a pointer to an array of headings to use. The headings are just decorative. They don't reorganize the -interpetation of the radio buttons -- they're still a single named +interpretation of the radio buttons -- they're still a single named unit. =back @@ -5157,6 +5286,9 @@ reset() creates the "reset" button. Note that it restores the form to its value from the last time the script was called, NOT necessarily to the defaults. +Note that this conflicts with the Perl reset() built-in. Use +CORE::reset() to get the original reset function. + =head2 CREATING A DEFAULT BUTTON print $query->defaults('button_label') @@ -5263,11 +5395,12 @@ pointed to by the B<-onClick> parameter will be executed. On non-Netscape browsers this form element will probably not even display. -=head1 NETSCAPE COOKIES +=head1 HTTP COOKIES -Netscape browsers versions 1.1 and higher support a so-called -"cookie" designed to help maintain state within a browser session. -CGI.pm has several methods that support cookies. +Netscape browsers versions 1.1 and higher, and all versions of +Internet Explorer, support a so-called "cookie" designed to help +maintain state within a browser session. CGI.pm has several methods +that support cookies. A cookie is a name=value pair much like the named parameters in a CGI query string. CGI scripts create one or more cookies and send @@ -5285,15 +5418,15 @@ optional attributes: This is a time/date string (in a special GMT format) that indicates when a cookie expires. The cookie will be saved and returned to your script until this expiration date is reached if the user exits -Netscape and restarts it. If an expiration date isn't specified, the cookie -will remain active until the user quits Netscape. +the browser and restarts it. If an expiration date isn't specified, the cookie +will remain active until the user quits the browser. =item 2. a domain This is a partial or complete domain name for which the cookie is valid. The browser will return the cookie to any host that matches the partial domain name. For example, if you specify a domain name -of ".capricorn.com", then Netscape will return the cookie to +of ".capricorn.com", then the browser will return the cookie to Web servers running on any of the machines "www.capricorn.com", "www2.capricorn.com", "feckless.capricorn.com", etc. Domain names must contain at least two periods to prevent attempts to match @@ -5318,7 +5451,7 @@ script if the CGI request is occurring on a secure channel, such as SSL. =back -The interface to Netscape cookies is the B<cookie()> method: +The interface to HTTP cookies is the B<cookie()> method: $cookie = $query->cookie(-name=>'sessionID', -value=>'xyzzy', @@ -5335,7 +5468,7 @@ B<cookie()> creates a new cookie. Its parameters include: =item B<-name> The name of the cookie (required). This can be any string at all. -Although Netscape limits its cookie names to non-whitespace +Although browsers limit their cookie names to non-whitespace alphanumeric characters, CGI.pm removes this restriction by escaping and unescaping cookies behind the scenes. @@ -5406,19 +5539,11 @@ simple to turn a CGI parameter into a cookie, and vice-versa: See the B<cookie.cgi> example script for some ideas on how to use cookies effectively. -B<NOTE:> There appear to be some (undocumented) restrictions on -Netscape cookies. In Netscape 2.01, at least, I haven't been able to -set more than three cookies at a time. There may also be limits on -the length of cookies. If you need to store a lot of information, -it's probably better to create a unique session ID, store it in a -cookie, and use the session ID to locate an external file/database -saved on the server's side of the connection. - -=head1 WORKING WITH NETSCAPE FRAMES +=head1 WORKING WITH FRAMES -It's possible for CGI.pm scripts to write into several browser -panels and windows using Netscape's frame mechanism. -There are three techniques for defining new frames programmatically: +It's possible for CGI.pm scripts to write into several browser panels +and windows using the HTML 4 frame mechanism. There are three +techniques for defining new frames programmatically: =over 4 @@ -5441,12 +5566,12 @@ You may provide a B<-target> parameter to the header() method: print $q->header(-target=>'ResultsWindow'); -This will tell Netscape to load the output of your script into the -frame named "ResultsWindow". If a frame of that name doesn't -already exist, Netscape will pop up a new window and load your -script's document into that. There are a number of magic names -that you can use for targets. See the frame documents on Netscape's -home pages for details. +This will tell the browser to load the output of your script into the +frame named "ResultsWindow". If a frame of that name doesn't already +exist, the browser will pop up a new window and load your script's +document into that. There are a number of magic names that you can +use for targets. See the frame documents on Netscape's home pages for +details. =item 3. Specify the destination for the document in the <FORM> tag @@ -5591,13 +5716,8 @@ Produces something that looks like: </UL> </UL> -You can pass a value of 'true' to dump() in order to get it to -print the results out as plain text, suitable for incorporating -into a <PRE> section. - -As a shortcut, as of version 1.56 you can interpolate the entire CGI -object into a string and it will be replaced with the a nice HTML dump -shown above: +As a shortcut, you can interpolate the entire CGI object into a string +and it will be replaced with the a nice HTML dump shown above: $query=new CGI; print "<H2>Current Values</H2> $query\n"; @@ -5609,24 +5729,25 @@ through this interface. The methods are as follows: =over 4 -=item B<accept()> +=item B<Accept()> + +Return a list of MIME types that the remote browser accepts. If you +give this method a single argument corresponding to a MIME type, as in +$query->Accept('text/html'), it will return a floating point value +corresponding to the browser's preference for this type from 0.0 +(don't want) to 1.0. Glob types (e.g. text/*) in the browser's accept +list are handled correctly. -Return a list of MIME types that the remote browser -accepts. If you give this method a single argument -corresponding to a MIME type, as in -$query->accept('text/html'), it will return a -floating point value corresponding to the browser's -preference for this type from 0.0 (don't want) to 1.0. -Glob types (e.g. text/*) in the browser's accept list -are handled correctly. +Note that the capitalization changed between version 2.43 and 2.44 in +order to avoid conflict with Perl's accept() function. =item B<raw_cookie()> Returns the HTTP_COOKIE variable, an HTTP extension implemented by -Netscape browsers version 1.1 and higher. Cookies have a special -format, and this method call just returns the raw form (?cookie -dough). See cookie() for ways of setting and retrieving cooked -cookies. +Netscape browsers version 1.1 and higher, and all versions of Internet +Explorer. Cookies have a special format, and this method call just +returns the raw form (?cookie dough). See cookie() for ways of +setting and retrieving cooked cookies. Called with no parameters, raw_cookie() returns the packed cookie structure. You can separate it into individual cookies by splitting @@ -5708,10 +5829,9 @@ verification, if this script is protected. =item B<user_name ()> -Attempt to obtain the remote user's name, using a variety -of different techniques. This only works with older browsers -such as Mosaic. Netscape does not reliably report the user -name! +Attempt to obtain the remote user's name, using a variety of different +techniques. This only works with older browsers such as Mosaic. +Newer browsers do not report the user name for privacy reasons! =item B<request_method()> @@ -5935,14 +6055,17 @@ of CGI.pm without rewriting your old scripts from scratch. =head1 AUTHOR INFORMATION -Copyright 1995-1997, Lincoln D. Stein. All rights reserved. It may -be used and modified freely, but I do request that this copyright -notice remain attached to the file. You may modify this module as you -wish, but if you redistribute a modified version, please attach a note -listing the modifications you have made. +Copyright 1995-1998, Lincoln D. Stein. All rights reserved. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. -Address bug reports and comments to: -lstein@genome.wi.mit.edu +Address bug reports and comments to: lstein@cshl.org. When sending +bug reports, please provide the version of CGI.pm, the version of +Perl, the name and version of your Web server, and the name and +version of the operating system you are using. If the problem is even +remotely browser dependent, please provide information about the +affected browers as well. =head1 CREDITS @@ -5962,7 +6085,7 @@ Thanks very much to: =item Joergen Haegg (jh@axis.se) -=item Laurent Delfosse (delfosse@csgrad1.cs.wvu.edu) +=item Laurent Delfosse (delfosse@delfosse.com) =item Richard Resnick (applepi1@aol.com) @@ -6054,7 +6177,7 @@ for suggestions and bug fixes. -rows=>10, -columns=>50); - print "<P>",$query->reset; + print "<P>",$query->Reset; print $query->submit('Action','Shout'); print $query->submit('Action','Scream'); print $query->endform; @@ -6095,8 +6218,8 @@ warnings when programs are run with the B<-w> switch. =head1 SEE ALSO L<CGI::Carp>, L<URI::URL>, L<CGI::Request>, L<CGI::MiniSvr>, -L<CGI::Base>, L<CGI::Form>, L<CGI::Apache>, L<CGI::Switch>, -L<CGI::Push>, L<CGI::Fast> +L<CGI::Base>, L<CGI::Form>, L<CGI::Push>, L<CGI::Fast>, +L<CGI::Pretty> =cut diff --git a/contrib/perl5/lib/CGI/Apache.pm b/contrib/perl5/lib/CGI/Apache.pm index eed3e55..82a3669 100644 --- a/contrib/perl5/lib/CGI/Apache.pm +++ b/contrib/perl5/lib/CGI/Apache.pm @@ -78,7 +78,7 @@ CGI::Apache - Make things work with CGI.pm against Perl-Apache API =head1 DESCRIPTION When using the Perl-Apache API, your applications are faster, but the -enviroment is different than CGI. +environment is different than CGI. This module attempts to set-up that environment as best it can. =head1 NOTE 1 diff --git a/contrib/perl5/lib/CGI/Carp.pm b/contrib/perl5/lib/CGI/Carp.pm index e20f754..dfae1a6 100644 --- a/contrib/perl5/lib/CGI/Carp.pm +++ b/contrib/perl5/lib/CGI/Carp.pm @@ -14,6 +14,12 @@ B<CGI::Carp> - CGI routines for writing to the HTTPD (or other) error log warn "I'm confused"; die "I'm dying.\n"; + use CGI::Carp qw(cluck); + cluck "I wouldn't do that if I were you"; + + use CGI::Carp qw(fatalsToBrowser); + die "Fatal error messages are now sent to browser"; + =head1 DESCRIPTION CGI scripts have a nasty habit of leaving warning messages in the error @@ -155,11 +161,21 @@ set_message() from within a BEGIN{} block. 1.10 Patch from Chris Dean (ctdean@cogit.com) to allow module to run correctly under mod_perl. +1.11 Changed order of > and < escapes. + +1.12 Changed die() on line 217 to CORE::die to avoid B<-w> warning. + +1.13 Added cluck() to make the module orthogonal with Carp. + More mod_perl related fixes. + =head1 AUTHORS -Lincoln D. Stein <lstein@genome.wi.mit.edu>. Feel free to redistribute -this under the Perl Artistic License. +Copyright 1995-1998, Lincoln D. Stein. All rights reserved. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. +Address bug reports and comments to: lstein@cshl.org =head1 SEE ALSO @@ -174,11 +190,11 @@ use Carp; @ISA = qw(Exporter); @EXPORT = qw(confess croak carp); -@EXPORT_OK = qw(carpout fatalsToBrowser wrap set_message); +@EXPORT_OK = qw(carpout fatalsToBrowser wrap set_message cluck); $main::SIG{__WARN__}=\&CGI::Carp::warn; $main::SIG{__DIE__}=\&CGI::Carp::die; -$CGI::Carp::VERSION = '1.101'; +$CGI::Carp::VERSION = '1.13'; $CGI::Carp::CUSTOM_MSG = undef; # fancy import routine detects and handles 'errorWrap' specially. @@ -194,7 +210,6 @@ sub import { } # These are the originals -# XXX Why not just use CORE::die etc., instead of these two? GSAR sub realwarn { CORE::warn(@_); } sub realdie { CORE::die(@_); } @@ -230,8 +245,7 @@ sub warn { # eval. These evals don't count when looking at the stack backtrace. sub _longmess { my $message = Carp::longmess(); - my $mod_perl = ($ENV{'GATEWAY_INTERFACE'} - && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//); + my $mod_perl = exists $ENV{MOD_PERL}; $message =~ s,eval[^\n]+Apache/Registry\.pm.*,,s if $mod_perl; return( $message ); } @@ -240,7 +254,7 @@ sub die { my $message = shift; my $time = scalar(localtime); my($file,$line,$id) = id(1); - $message .= " at $file line $line.\n" unless $message=~/\n$/; + $message .= " at $file line $line." unless $message=~/\n$/; &fatalsToBrowser($message) if $WRAP && _longmess() !~ /eval [{\']/m; my $stamp = stamp; $message=~s/^/$stamp/gm; @@ -258,8 +272,9 @@ sub set_message { local $^W=0; eval <<EOF; sub confess { CGI::Carp::die Carp::longmess \@_; } -sub croak { CGI::Carp::die Carp::shortmess \@_; } -sub carp { CGI::Carp::warn Carp::shortmess \@_; } +sub croak { CGI::Carp::die Carp::shortmess \@_; } +sub carp { CGI::Carp::warn Carp::shortmess \@_; } +sub cluck { CGI::Carp::warn Carp::longmess \@_; } EOF ; } @@ -269,7 +284,7 @@ EOF sub carpout { my($in) = @_; my($no) = fileno(to_filehandle($in)); - realdie "Invalid filehandle $in\n" unless defined $no; + realdie("Invalid filehandle $in\n") unless defined $no; open(SAVEERR, ">&STDERR"); open(STDERR, ">&$no") or @@ -279,9 +294,9 @@ sub carpout { # headers sub fatalsToBrowser { my($msg) = @_; + $msg=~s/&/&/g; $msg=~s/>/>/g; $msg=~s/</</g; - $msg=~s/&/&/g; $msg=~s/\"/"/g; my($wm) = $ENV{SERVER_ADMIN} ? qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] : @@ -291,7 +306,9 @@ For help, please send mail to $wm, giving this error message and the time and date of the error. END ; - print STDOUT "Content-type: text/html\n\n"; + my $mod_perl = exists $ENV{MOD_PERL}; + print STDOUT "Content-type: text/html\n\n" + unless $mod_perl; if ($CUSTOM_MSG) { if (ref($CUSTOM_MSG) eq 'CODE') { @@ -302,13 +319,30 @@ END } } - print STDOUT <<END; + my $mess = <<END; <H1>Software error:</H1> <CODE>$msg</CODE> <P> -$outer_message; +$outer_message END ; + + if ($mod_perl) { + my $r = Apache->request; + # If bytes have already been sent, then + # we print the message out directly. + # Otherwise we make a custom error + # handler to produce the doc for us. + if ($r->bytes_sent) { + $r->print($mess); + $r->exit; + } else { + $r->status(500); + $r->custom_response(500,$mess); + } + } else { + print STDOUT $mess; + } } # Cut and paste from CGI.pm so that we don't have the overhead of diff --git a/contrib/perl5/lib/CGI/Cookie.pm b/contrib/perl5/lib/CGI/Cookie.pm index c32891a..204d67b 100644 --- a/contrib/perl5/lib/CGI/Cookie.pm +++ b/contrib/perl5/lib/CGI/Cookie.pm @@ -69,7 +69,9 @@ sub parse { my($key,$value) = split("="); my(@values) = map CGI::unescape($_),split('&',$value); $key = CGI::unescape($key); - $results{$key} = $self->new(-name=>$key,-value=>\@values); + # A bug in Netscape can cause several cookies with same name to + # appear. The FIRST one in HTTP_COOKIE is the most recent version. + $results{$key} ||= $self->new(-name=>$key,-value=>\@values); } return \%results unless wantarray; return %results; @@ -399,13 +401,12 @@ Get or set the cookie's expiration time. =head1 AUTHOR INFORMATION -be used and modified freely, but I do request that this copyright -notice remain attached to the file. You may modify this module as you -wish, but if you redistribute a modified version, please attach a note -listing the modifications you have made. +Copyright 1997-1998, Lincoln D. Stein. All rights reserved. -Address bug reports and comments to: -lstein@genome.wi.mit.edu +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +Address bug reports and comments to: lstein@cshl.org =head1 BUGS diff --git a/contrib/perl5/lib/CGI/Fast.pm b/contrib/perl5/lib/CGI/Fast.pm index 03b5407..a39fe05 100644 --- a/contrib/perl5/lib/CGI/Fast.pm +++ b/contrib/perl5/lib/CGI/Fast.pm @@ -16,7 +16,7 @@ package CGI::Fast; # The most recent version and complete docs are available at: # http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html # ftp://ftp-genome.wi.mit.edu/pub/software/WWW/ -$CGI::Fast::VERSION='1.00a'; +$CGI::Fast::VERSION='1.01'; use CGI; use FCGI; @@ -34,9 +34,11 @@ sub save_request { # New is slightly different in that it calls FCGI's # accept() method. sub new { - return undef unless FCGI::accept() >= 0; - my($self,@param) = @_; - return $CGI::Q = $self->SUPER::new(@param); + my ($self, $initializer, @param) = @_; + unless (defined $initializer) { + return undef unless FCGI::accept() >= 0; + } + return $CGI::Q = $self->SUPER::new($initializer, @param); } 1; @@ -154,13 +156,12 @@ I haven't tested this very much. =head1 AUTHOR INFORMATION -be used and modified freely, but I do request that this copyright -notice remain attached to the file. You may modify this module as you -wish, but if you redistribute a modified version, please attach a note -listing the modifications you have made. +Copyright 1996-1998, Lincoln D. Stein. All rights reserved. -Address bug reports and comments to: -lstein@genome.wi.mit.edu +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +Address bug reports and comments to: lstein@cshl.org =head1 BUGS diff --git a/contrib/perl5/lib/CGI/Push.pm b/contrib/perl5/lib/CGI/Push.pm index eeec3f8..e4a66ae 100644 --- a/contrib/perl5/lib/CGI/Push.pm +++ b/contrib/perl5/lib/CGI/Push.pm @@ -14,8 +14,7 @@ package CGI::Push; # listing the modifications you have made. # The most recent version and complete docs are available at: -# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html -# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/ +# http://stein.cshl.org/WWW/software/CGI/ $CGI::Push::VERSION='1.01'; use CGI; @@ -287,19 +286,14 @@ Recognition of NPH scripts happens automatically with WebSTAR and Microsoft IIS. Users of other servers should see their documentation for help. -=head1 CAVEATS - -This is a new module. It hasn't been extensively tested. - =head1 AUTHOR INFORMATION -be used and modified freely, but I do request that this copyright -notice remain attached to the file. You may modify this module as you -wish, but if you redistribute a modified version, please attach a note -listing the modifications you have made. +Copyright 1995-1998, Lincoln D. Stein. All rights reserved. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. -Address bug reports and comments to: -lstein@genome.wi.mit.edu +Address bug reports and comments to: lstein@cshl.org =head1 BUGS diff --git a/contrib/perl5/lib/CPAN.pm b/contrib/perl5/lib/CPAN.pm index b510ea2..2276943 100644 --- a/contrib/perl5/lib/CPAN.pm +++ b/contrib/perl5/lib/CPAN.pm @@ -1,24 +1,25 @@ package CPAN; -use vars qw{$Try_autoload $Revision +use vars qw{$Try_autoload + $Revision $META $Signal $Cwd $End $Suppress_readline %Dontload $Frontend $Defaultsite - }; + }; #}; -$VERSION = '1.3901'; +$VERSION = '1.48'; -# $Id: CPAN.pm,v 1.226 1998/07/08 22:29:29 k Exp k $ +# $Id: CPAN.pm,v 1.260 1999/03/06 19:31:02 k Exp $ # only used during development: $Revision = ""; -# $Revision = "[".substr(q$Revision: 1.226 $, 10)."]"; +# $Revision = "[".substr(q$Revision: 1.260 $, 10)."]"; use Carp (); use Config (); use Cwd (); use DirHandle; use Exporter (); -use ExtUtils::MakeMaker (); +use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1; use File::Basename (); use File::Copy (); use File::Find; @@ -27,10 +28,11 @@ use FileHandle (); use Safe (); use Text::ParseWords (); use Text::Wrap; +use File::Spec; END { $End++; &cleanup; } -%CPAN::DEBUG = qw( +%CPAN::DEBUG = qw[ CPAN 1 Index 2 InfoObj 4 @@ -45,7 +47,7 @@ END { $End++; &cleanup; } Eval 2048 Config 4096 Tarzip 8192 - ); +]; $CPAN::DEBUG ||= 0; $CPAN::Signal ||= 0; @@ -56,13 +58,7 @@ package CPAN; use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $term); use strict qw(vars); -@CPAN::ISA = qw(CPAN::Debug Exporter MM); # MM will go away - # soonish. Already version - # 1.29 doesn't rely on - # catfile and catdir being - # available via - # inheritance. Anything else - # in danger? +@CPAN::ISA = qw(CPAN::Debug Exporter); @EXPORT = qw( autobundle bundle expand force get @@ -75,6 +71,7 @@ sub AUTOLOAD { $l =~ s/.*:://; my(%EXPORT); @EXPORT{@EXPORT} = ''; + CPAN::Config->load unless $CPAN::Config_loaded++; if (exists $EXPORT{$l}){ CPAN::Shell->$l(@_); } else { @@ -92,7 +89,9 @@ sub AUTOLOAD { #-> sub CPAN::shell ; sub shell { + my($self) = @_; $Suppress_readline ||= ! -t STDIN; + CPAN::Config->load unless $CPAN::Config_loaded++; my $prompt = "cpan> "; local($^W) = 1; @@ -100,8 +99,20 @@ sub shell { require Term::ReadLine; # import Term::ReadLine; $term = Term::ReadLine->new('CPAN Monitor'); - $readline::rl_completion_function = - $readline::rl_completion_function = 'CPAN::Complete::cpl'; + if ($term->ReadLine eq "Term::ReadLine::Gnu") { + my $attribs = $term->Attribs; +# $attribs->{completion_entry_function} = +# $attribs->{'list_completion_function'}; + $attribs->{attempted_completion_function} = sub { + &CPAN::Complete::gnu_cpl; + } +# $attribs->{completion_word} = +# [qw(help me somebody to find out how +# to use completion with GNU)]; + } else { + $readline::rl_completion_function = + $readline::rl_completion_function = 'CPAN::Complete::cpl'; + } } no strict; @@ -109,6 +120,7 @@ sub shell { my $getcwd; $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; my $cwd = CPAN->$getcwd(); + my $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub"; my $rl_avail = $Suppress_readline ? "suppressed" : ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" : "available (try ``install Bundle::CPAN'')"; @@ -131,7 +143,7 @@ ReadLine support $rl_avail $_ = "$continuation$_" if $continuation; s/^\s+//; next if /^$/; - $_ = 'h' if $_ eq '?'; + $_ = 'h' if /^\s*\?/; if (/^(?:q(?:uit)?|bye|exit)$/i) { last; } elsif (s/\\$//s) { @@ -168,6 +180,20 @@ ReadLine support $rl_avail } } continue { $Signal=0; + CPAN::Queue->nullify_queue; + if ($try_detect_readline) { + if ($CPAN::META->has_inst("Term::ReadLine::Gnu") + || + $CPAN::META->has_inst("Term::ReadLine::Perl") + ) { + delete $INC{"Term/ReadLine.pm"}; + my $redef; + local($SIG{__WARN__}) = CPAN::Shell::dotdot_onreload(\$redef); + require Term::ReadLine; + $CPAN::Frontend->myprint("\n$redef subroutines in Term::ReadLine redefined\n"); + goto &shell; + } + } } } @@ -230,7 +256,7 @@ sub AUTOLOAD { $CPAN::Frontend->mywarn(qq{ Commands starting with "w" require CPAN::WAIT to be installed. Please consider installing CPAN::WAIT to use the fulltext index. -For this you just need to type +For this you just need to type install CPAN::WAIT }); } @@ -260,7 +286,7 @@ sub try_dot_al { if (defined($name=$INC{"$pkg.pm"})) { $name =~ s|^(.*)$pkg\.pm$|$1auto/$pkg/$func.al|; - $name = undef unless (-r $name); + $name = undef unless (-r $name); } unless (defined $name) { @@ -275,7 +301,7 @@ sub try_dot_al { *$autoload = sub {}; $ok = 1; } else { - if ($name =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){ + if ($name =~ s{(\w{12,})\.al$}{substr($1,0,11).".al"}e){ eval {local $SIG{__DIE__};require $name}; } if ($@){ @@ -286,7 +312,9 @@ sub try_dot_al { } } } else { - $ok = 1; + + $ok = 1; + } $@ = $save; # my $lm = Carp::longmess(); @@ -303,7 +331,7 @@ sub try_dot_al { # $Try_autoload = 1; if ($CPAN::Try_autoload) { - my $p; + my $p; for $p (qw( CPAN::Author CPAN::Bundle CPAN::CacheMgr CPAN::Complete CPAN::Config CPAN::Debug CPAN::Distribution CPAN::FTP @@ -318,21 +346,127 @@ use vars qw($AUTOLOAD @ISA); @CPAN::Tarzip::ISA = qw(CPAN::Debug); package CPAN::Queue; -# currently only used to determine if we should or shouldn't announce -# the availability of a new CPAN module + +# One use of the queue is to determine if we should or shouldn't +# announce the availability of a new CPAN module + +# Now we try to use it for dependency tracking. For that to happen +# we need to draw a dependency tree and do the leaves first. This can +# easily be reached by running CPAN.pm recursively, but we don't want +# to waste memory and run into deep recursion. So what we can do is +# this: + +# CPAN::Queue is the package where the queue is maintained. Dependencies +# often have high priority and must be brought to the head of the queue, +# possibly by jumping the queue if they are already there. My first code +# attempt tried to be extremely correct. Whenever a module needed +# immediate treatment, I either unshifted it to the front of the queue, +# or, if it was already in the queue, I spliced and let it bypass the +# others. This became a too correct model that made it impossible to put +# an item more than once into the queue. Why would you need that? Well, +# you need temporary duplicates as the manager of the queue is a loop +# that +# +# (1) looks at the first item in the queue without shifting it off +# +# (2) cares for the item +# +# (3) removes the item from the queue, *even if its agenda failed and +# even if the item isn't the first in the queue anymore* (that way +# protecting against never ending queues) +# +# So if an item has prerequisites, the installation fails now, but we +# want to retry later. That's easy if we have it twice in the queue. +# +# I also expect insane dependency situations where an item gets more +# than two lives in the queue. Simplest example is triggered by 'install +# Foo Foo Foo'. People make this kind of mistakes and I don't want to +# get in the way. I wanted the queue manager to be a dumb servant, not +# one that knows everything. +# +# Who would I tell in this model that the user wants to be asked before +# processing? I can't attach that information to the module object, +# because not modules are installed but distributions. So I'd have to +# tell the distribution object that it should ask the user before +# processing. Where would the question be triggered then? Most probably +# in CPAN::Distribution::rematein. +# Hope that makes sense, my head is a bit off:-) -- AK + +use vars qw{ @All }; + sub new { my($class,$mod) = @_; - # warn "Queue object for mod[$mod]"; - bless {mod => $mod}, $class; + my $self = bless {mod => $mod}, $class; + push @All, $self; + # my @all = map { $_->{mod} } @All; + # warn "Adding Queue object for mod[$mod] all[@all]"; + return $self; } -package CPAN; +sub first { + my $obj = $All[0]; + $obj->{mod}; +} + +sub delete_first { + my($class,$what) = @_; + my $i; + for my $i (0..$#All) { + if ( $All[$i]->{mod} eq $what ) { + splice @All, $i, 1; + return; + } + } +} + +sub jumpqueue { + my $class = shift; + my @what = @_; + my $obj; + WHAT: for my $what (reverse @what) { + my $jumped = 0; + for (my $i=0; $i<$#All;$i++) { #prevent deep recursion + if ($All[$i]->{mod} eq $what){ + $jumped++; + if ($jumped > 100) { # one's OK if e.g. just processing now; + # more are OK if user typed it several + # times + $CPAN::Frontend->mywarn( +qq{Object [$what] queued more than 100 times, ignoring} + ); + next WHAT; + } + } + } + my $obj = bless { mod => $what }, $class; + unshift @All, $obj; + } +} + +sub exists { + my($self,$what) = @_; + my @all = map { $_->{mod} } @All; + my $exists = grep { $_->{mod} eq $what } @All; + # warn "Checking exists in Queue object for mod[$what] all[@all] exists[$exists]"; + $exists; +} + +sub delete { + my($self,$mod) = @_; + @All = grep { $_->{mod} ne $mod } @All; + # my @all = map { $_->{mod} } @All; + # warn "Deleting Queue object for mod[$mod] all[@all]"; +} -$META ||= CPAN->new; # In case we reeval ourselves we - # need a || +sub nullify_queue { + @All = (); +} + + + +package CPAN; -# Do this after you have set up the whole inheritance -CPAN::Config->load unless defined $CPAN::No_Config_is_ok; +$META ||= CPAN->new; # In case we re-eval ourselves we need the || 1; @@ -356,12 +490,14 @@ sub clean; sub test; #-> sub CPAN::all ; -sub all { +sub all_objects { my($mgr,$class) = @_; + CPAN::Config->load unless $CPAN::Config_loaded++; CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG; CPAN::Index->reload; values %{ $META->{$class} }; } +*all = \&all_objects; # Called by shell, not in batch mode. Not clean XXX #-> sub CPAN::checklock ; @@ -434,8 +570,8 @@ or $self->{LOCK} = $lockfile; $fh->close; $SIG{'TERM'} = sub { - &cleanup; - $CPAN::Frontend->mydie("Got SIGTERM, leaving"); + &cleanup; + $CPAN::Frontend->mydie("Got SIGTERM, leaving"); }; $SIG{'INT'} = sub { # no blocks!!! @@ -491,13 +627,18 @@ sub has_inst { $file =~ s|/|\\|g if $^O eq 'MSWin32'; $file .= ".pm"; if ($INC{$file}) { -# warn "$file in %INC"; #debug + # checking %INC is wrong, because $INC{LWP} may be true + # although $INC{"URI/URL.pm"} may have failed. But as + # I really want to say "bla loaded OK", I have to somehow + # cache results. + ### warn "$file in %INC"; #debug return 1; } elsif (eval { require $file }) { # eval is good: if we haven't yet read the database it's # perfect and if we have installed the module in the meantime, # it tries again. The second require is only a NOOP returning # 1 if we had success, otherwise it's retrying + $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n"); if ($mod eq "CPAN::WAIT") { push @CPAN::Shell::ISA, CPAN::WAIT; @@ -518,6 +659,8 @@ sub has_inst { }); sleep 2; + } else { + delete $INC{$file}; # if it inc'd LWP but failed during, say, URI } return 0; } @@ -537,16 +680,30 @@ sub new { #-> sub CPAN::cleanup ; sub cleanup { - local $SIG{__DIE__} = ''; - my $i = 0; my $ineval = 0; my $sub; - while ((undef,undef,undef,$sub) = caller(++$i)) { - $ineval = 1, last if $sub eq '(eval)'; + # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]"; + local $SIG{__DIE__} = ''; + my($message) = @_; + my $i = 0; + my $ineval = 0; + if ( + 0 && # disabled, try reload cpan with it + $] > 5.004_60 # thereabouts + ) { + $ineval = $^S; + } else { + my($subroutine); + while ((undef,undef,undef,$subroutine) = caller(++$i)) { + $ineval = 1, last if + $subroutine eq '(eval)'; } - return if $ineval && !$End; - return unless defined $META->{'LOCK'}; - return unless -f $META->{'LOCK'}; - unlink $META->{'LOCK'}; - $CPAN::Frontend->mywarn("Lockfile removed.\n"); + } + return if $ineval && !$End; + return unless defined $META->{'LOCK'}; + return unless -f $META->{'LOCK'}; + unlink $META->{'LOCK'}; + # require Carp; + # Carp::cluck("DEBUGGING"); + $CPAN::Frontend->mywarn("Lockfile removed.\n"); } package CPAN::CacheMgr; @@ -597,7 +754,8 @@ sub entries { $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; my($cwd) = CPAN->$getcwd(); chdir $dir or Carp::croak("Can't chdir to $dir: $!"); - my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir $dir: $!"); + my $dh = DirHandle->new(File::Spec->curdir) + or Carp::croak("Couldn't opendir $dir: $!"); my(@entries); for ($dh->read) { next if $_ eq "." || $_ eq ".."; @@ -621,9 +779,15 @@ sub disk_usage { my($Du) = 0; find( sub { - $File::Find::prune++ if $CPAN::Signal; - return if -l $_; - $Du += -s _; + $File::Find::prune++ if $CPAN::Signal; + return if -l $_; + if ($^O eq 'MacOS') { + require Mac::Files; + my $cat = Mac::Files::FSpGetCatInfo($_); + $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen(); + } else { + $Du += (-s _); + } }, $dir ); @@ -655,26 +819,36 @@ sub new { my $self = { ID => $CPAN::Config->{'build_dir'}, MAX => $CPAN::Config->{'build_cache'}, + SCAN => $CPAN::Config->{'scan_cache'} || 'atstart', DU => 0 }; File::Path::mkpath($self->{ID}); my $dh = DirHandle->new($self->{ID}); bless $self, $class; - my $e; + $self->scan_cache; + $t2 = time; + $debug .= "timing of CacheMgr->new: ".($t2 - $time); + $time = $t2; + CPAN->debug($debug) if $CPAN::DEBUG; + $self; +} + +#-> sub CPAN::CacheMgr::scan_cache ; +sub scan_cache { + my $self = shift; + return if $self->{SCAN} eq 'never'; + $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}") + unless $self->{SCAN} eq 'atstart'; $CPAN::Frontend->myprint( sprintf("Scanning cache %s for sizes\n", $self->{ID})); + my $e; for $e ($self->entries($self->{ID})) { next if $e eq ".." || $e eq "."; $self->disk_usage($e); return if $CPAN::Signal; } $self->tidyup; - $t2 = time; - $debug .= "timing of CacheMgr->new: ".($t2 - $time); - $time = $t2; - CPAN->debug($debug) if $CPAN::DEBUG; - $self; } package CPAN::Debug; @@ -755,7 +929,7 @@ sub commit { unless (defined $configpm){ $configpm ||= $INC{"CPAN/MyConfig.pm"}; $configpm ||= $INC{"CPAN/Config.pm"}; - $configpm || Carp::confess(qq{ + $configpm || Carp::confess(q{ CPAN::Config::commit called without an argument. Please specify a filename where to save the configuration or try "o conf init" to have an interactive course through configing. @@ -779,6 +953,7 @@ Please specify a filename where to save the configuration or try EOF $msg ||= "\n"; my($fh) = FileHandle->new; + rename $configpm, "$configpm~" if -f $configpm; open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!"; $fh->print(qq[$msg\$CPAN::Config = \{\n]); foreach (sort keys %$CPAN::Config) { @@ -823,6 +998,7 @@ sub init { sub load { my($self) = shift; my(@miss); + use Carp; eval {require CPAN::Config;}; # We eval because of some # MakeMaker problems unless ($dot_cpan++){ @@ -887,11 +1063,11 @@ sub load { } } local($") = ", "; - $CPAN::Frontend->myprint(qq{ + $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled; We have to reconfigure CPAN.pm due to following uninitialized parameters: @miss -}) if $redo && ! $theycalled; +END $CPAN::Frontend->myprint(qq{ $configpm initialized. }); @@ -903,9 +1079,10 @@ $configpm initialized. sub not_loaded { my(@miss); for (qw( - cpan_home keep_source_where build_dir build_cache index_expire - gzip tar unzip make pager makepl_arg make_arg make_install_arg - urllist inhibit_startup_message ftp_proxy http_proxy no_proxy + cpan_home keep_source_where build_dir build_cache scan_cache + index_expire gzip tar unzip make pager makepl_arg make_arg + make_install_arg urllist inhibit_startup_message + ftp_proxy http_proxy no_proxy prerequisites_policy )) { push @miss, $_ unless defined $CPAN::Config->{$_}; } @@ -918,10 +1095,9 @@ sub unload { delete $INC{'CPAN/Config.pm'}; } -*h = \&help; #-> sub CPAN::Config::help ; sub help { - $CPAN::Frontend->myprint(qq{ + $CPAN::Frontend->myprint(q[ Known options: defaults reload default config values from disk commit commit session changes to disk @@ -937,7 +1113,7 @@ You may edit key values in the follow fashion: o conf urllist unshift ftp://ftp.foo.bar/ -}); +]); undef; #don't reprint CPAN::Config } @@ -1024,7 +1200,9 @@ sub b { #-> sub CPAN::Shell::d ; sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));} #-> sub CPAN::Shell::m ; -sub m { $CPAN::Frontend->myprint(shift->format_result('Module',@_));} +sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here + $CPAN::Frontend->myprint(shift->format_result('Module',@_)); +} #-> sub CPAN::Shell::i ; sub i { @@ -1139,6 +1317,21 @@ Known options: } } +sub dotdot_onreload { + my($ref) = shift; + sub { + if ( $_[0] =~ /Subroutine (\w+) redefined/ ) { + my($subr) = $1; + ++$$ref; + local($|) = 1; + # $CPAN::Frontend->myprint(".($subr)"); + $CPAN::Frontend->myprint("."); + return; + } + warn @_; + }; +} + #-> sub CPAN::Shell::reload ; sub reload { my($self,$command,@arg) = @_; @@ -1148,27 +1341,16 @@ sub reload { CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG; my $fh = FileHandle->new($INC{'CPAN.pm'}); local($/); - undef $/; $redef = 0; - local($SIG{__WARN__}) - = sub { - if ( $_[0] =~ /Subroutine \w+ redefined/ ) { - ++$redef; - local($|) = 1; - $CPAN::Frontend->myprint("."); - return; - } - warn @_; - }; + local($SIG{__WARN__}) = dotdot_onreload(\$redef); eval <$fh>; warn $@ if $@; $CPAN::Frontend->myprint("\n$redef subroutines redefined\n"); } elsif ($command =~ /index/) { - CPAN::Index->force_reload; + CPAN::Index->force_reload; } else { - $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file -index re-reads the index files -}); + $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file +index re-reads the index files\n}); } } @@ -1323,6 +1505,7 @@ sub u { #-> sub CPAN::Shell::autobundle ; sub autobundle { my($self) = shift; + CPAN::Config->load unless $CPAN::Config_loaded++; my(@bundle) = $self->_u_r_common("a",@_); my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle"); File::Path::mkpath($todir); @@ -1379,7 +1562,7 @@ sub expand { my $class = "CPAN::$type"; my $obj; if (defined $regex) { - for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all($class)) { + for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all_objects($class)) { push @m, $obj if $obj->id =~ /$regex/i @@ -1500,22 +1683,23 @@ sub rematein { CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG; my($s,@s); foreach $s (@some) { + CPAN::Queue->new($s); + } + while ($s = CPAN::Queue->first) { my $obj; if (ref $s) { $obj = $s; } elsif ($s =~ m|/|) { # looks like a file $obj = $CPAN::META->instance('CPAN::Distribution',$s); } elsif ($s =~ m|^Bundle::|) { - $CPAN::META->{'CPAN::Queue'}{$s} ||= CPAN::Queue->new($s); $obj = $CPAN::META->instance('CPAN::Bundle',$s); } else { - $CPAN::META->{'CPAN::Queue'}{$s} ||= CPAN::Queue->new($s); $obj = $CPAN::META->instance('CPAN::Module',$s) if $CPAN::META->exists('CPAN::Module',$s); } if (ref $obj) { CPAN->debug( - qq{pragma[$pragma] meth[$meth] obj[$obj] as_string\[}. + qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}. $obj->as_string. qq{\]} ) if $CPAN::DEBUG; @@ -1530,7 +1714,9 @@ sub rematein { if ($]>=5.00303 && $obj->can('called_for')) { $obj->called_for($s); } - $obj->$meth(); + CPAN::Queue->delete($s) if $obj->$meth(); # if it is more + # than once in + # the queue } elsif ($CPAN::META->exists('CPAN::Author',$s)) { $obj = $CPAN::META->instance('CPAN::Author',$s); $CPAN::Frontend->myprint( @@ -1540,7 +1726,9 @@ sub rematein { " ;-)\n" ); } else { - $CPAN::Frontend->myprint(qq{Warning: Cannot $meth $s, don\'t know what it is. + $CPAN::Frontend + ->myprint(qq{Warning: Cannot $meth $s, }. + qq{don\'t know what it is. Try the command i /$s/ @@ -1548,6 +1736,7 @@ Try the command to find objects with similar identifiers. }); } + CPAN::Queue->delete_first($s); } } @@ -1572,35 +1761,35 @@ package CPAN::FTP; #-> sub CPAN::FTP::ftp_get ; sub ftp_get { - my($class,$host,$dir,$file,$target) = @_; - $class->debug( - qq[Going to fetch file [$file] from dir [$dir] + my($class,$host,$dir,$file,$target) = @_; + $class->debug( + qq[Going to fetch file [$file] from dir [$dir] on host [$host] as local [$target]\n] ) if $CPAN::DEBUG; - my $ftp = Net::FTP->new($host); - return 0 unless defined $ftp; - $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG; - $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]); - unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){ - warn "Couldn't login on $host"; - return; - } - unless ( $ftp->cwd($dir) ){ - warn "Couldn't cwd $dir"; - return; - } - $ftp->binary; - $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG; - unless ( $ftp->get($file,$target) ){ - warn "Couldn't fetch $file from $host\n"; - return; - } - $ftp->quit; # it's ok if this fails - return 1; + my $ftp = Net::FTP->new($host); + return 0 unless defined $ftp; + $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG; + $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]); + unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){ + warn "Couldn't login on $host"; + return; + } + unless ( $ftp->cwd($dir) ){ + warn "Couldn't cwd $dir"; + return; + } + $ftp->binary; + $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG; + unless ( $ftp->get($file,$target) ){ + warn "Couldn't fetch $file from $host\n"; + return; + } + $ftp->quit; # it's ok if this fails + return 1; } # If more accuracy is wanted/needed, Chris Leach sent me this patch... - + # leach,> *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997 # leach,> --- /tmp/cp Wed Sep 24 13:26:40 1997 # leach,> *************** @@ -1664,6 +1853,20 @@ sub localize { $self->debug("file[$file] aslocal[$aslocal] force[$force]") if $CPAN::DEBUG; + if ($^O eq 'MacOS') { + my($name, $path) = File::Basename::fileparse($aslocal, ''); + if (length($name) > 31) { + $name =~ s/(\.(readme(\.(gz|Z))?|(tar\.)?(gz|Z)|tgz|zip|pm\.(gz|Z)))$//; + my $suf = $1; + my $size = 31 - length($suf); + while (length($name) > $size) { + chop $name; + } + $name .= $suf; + $aslocal = File::Spec->catfile($path, $name); + } + } + return $aslocal if -f $aslocal && -r _ && !($force & 1); my($restore) = 0; if (-f $aslocal){ @@ -1679,7 +1882,7 @@ sub localize { to insufficient permissions.\n}) unless -w $aslocal_dir; # Inheritance is not easier to manage than a few if/else branches - if ($CPAN::META->has_inst('LWP')) { + if ($CPAN::META->has_inst('LWP::UserAgent')) { require LWP::UserAgent; unless ($Ua) { $Ua = LWP::UserAgent->new; @@ -1704,7 +1907,7 @@ sub localize { @reordered = sort { (substr($CPAN::Config->{urllist}[$b],0,4) eq "file") - <=> + <=> (substr($CPAN::Config->{urllist}[$a],0,4) eq "file") or defined($Thesite) @@ -1713,11 +1916,6 @@ sub localize { <=> ($a == $Thesite) } 0..$last; - -# ((grep { substr($CPAN::Config->{urllist}[$_],0,4) -# eq "file" } 0..$last), -# (grep { substr($CPAN::Config->{urllist}[$_],0,4) -# ne "file" } 0..$last)); } my($level,@levels); if ($Themethod) { @@ -1725,6 +1923,7 @@ sub localize { } else { @levels = qw/easy hard hardest/; } + @levels = qw/easy/ if $^O eq 'MacOS'; for $level (@levels) { my $method = "host$level"; my @host_seq = $level eq "easy" ? @@ -1732,9 +1931,11 @@ sub localize { @host_seq = (0) unless @host_seq; my $ret = $self->$method(\@host_seq,$file,$aslocal); if ($ret) { - $Themethod = $level; - $self->debug("level[$level]") if $CPAN::DEBUG; - return $ret; + $Themethod = $level; + $self->debug("level[$level]") if $CPAN::DEBUG; + return $ret; + } else { + unlink $aslocal; } } my(@mess); @@ -1780,8 +1981,11 @@ sub hosteasy { # fileurl = "file://" [ host | "localhost" ] "/" fpath # Thanks to "Mark D. Baushke" <mdb@cisco.com> for # the code - ($l = $url) =~ s,^file://[^/]+,,; # discard the host part - $l =~ s/^file://; # assume they meant file://localhost + ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part + $l =~ s|^file:||; # assume they + # meant + # file://localhost + $l =~ s|^/|| unless -f $l; # e.g. /P: } if ( -f $l && -r _) { $Thesite = $i; @@ -1797,10 +2001,14 @@ sub hosteasy { } } } - if ($CPAN::META->has_inst('LWP')) { + if ($CPAN::META->has_inst('LWP')) { $CPAN::Frontend->myprint("Fetching with LWP: $url "); + unless ($Ua) { + require LWP::UserAgent; + $Ua = LWP::UserAgent->new; + } my $res = $Ua->mirror($url, $aslocal); if ($res->is_success) { $Thesite = $i; @@ -1847,7 +2055,7 @@ sub hosteasy { $CPAN::Frontend->myprint("Fetching with Net::FTP $url.gz "); - if (CPAN::FTP->ftp_get($host, + if (CPAN::FTP->ftp_get($host, $dir, "$getfile.gz", $gz) && @@ -1864,15 +2072,17 @@ sub hosteasy { } sub hosthard { - my($self,$host_seq,$file,$aslocal) = @_; + my($self,$host_seq,$file,$aslocal) = @_; - # Came back if Net::FTP couldn't establish connection (or - # failed otherwise) Maybe they are behind a firewall, but they - # gave us a socksified (or other) ftp program... + # Came back if Net::FTP couldn't establish connection (or + # failed otherwise) Maybe they are behind a firewall, but they + # gave us a socksified (or other) ftp program... - my($i); - my($aslocal_dir) = File::Basename::dirname($aslocal); - File::Path::mkpath($aslocal_dir); + my($i); + my($devnull) = $CPAN::Config->{devnull} || ""; + # < /dev/null "; + my($aslocal_dir) = File::Basename::dirname($aslocal); + File::Path::mkpath($aslocal_dir); HOSTHARD: for $i (@$host_seq) { my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite; unless ($self->is_reachable($url)) { @@ -1894,7 +2104,7 @@ sub hosthard { } $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG; my($f,$funkyftp); - for $f ('lynx','ncftp') { + for $f ('lynx','ncftpget','ncftp') { next unless exists $CPAN::Config->{$f}; $funkyftp = $CPAN::Config->{$f}; next unless defined $funkyftp; @@ -1903,14 +2113,14 @@ sub hosthard { my $aslocal_uncompressed; ($aslocal_uncompressed = $aslocal) =~ s/\.gz//; my($source_switch) = ""; - $source_switch = "-source" if $funkyftp =~ /\blynx$/; - $source_switch = "-c" if $funkyftp =~ /\bncftp$/; + $source_switch = " -source" if $funkyftp =~ /\blynx$/; + $source_switch = " -c" if $funkyftp =~ /\bncftp$/; $CPAN::Frontend->myprint( - qq{ -Trying with "$funkyftp $source_switch" to get + qq[ +Trying with "$funkyftp$source_switch" to get $url -}); - my($system) = "$funkyftp $source_switch '$url' > ". +]); + my($system) = "$funkyftp$source_switch '$url' $devnull > ". "$aslocal_uncompressed"; $self->debug("system[$system]") if $CPAN::DEBUG; my($wstatus); @@ -1929,36 +2139,40 @@ Trying with "$funkyftp $source_switch" to get CPAN::Tarzip->gzip($aslocal_uncompressed, "$aslocal_uncompressed.gz"); } - $Thesite = $i; - return $aslocal; } + $Thesite = $i; + return $aslocal; } elsif ($url !~ /\.gz$/) { - my $gz = "$aslocal.gz"; - my $gzurl = "$url.gz"; - $CPAN::Frontend->myprint( - qq{ -Trying with "$funkyftp $source_switch" to get + unlink $aslocal_uncompressed if + -f $aslocal_uncompressed && -s _ == 0; + my $gz = "$aslocal.gz"; + my $gzurl = "$url.gz"; + $CPAN::Frontend->myprint( + qq[ +Trying with "$funkyftp$source_switch" to get $url.gz -}); - my($system) = "$funkyftp $source_switch '$url.gz' > ". - "$aslocal_uncompressed.gz"; - $self->debug("system[$system]") if $CPAN::DEBUG; - my($wstatus); - if (($wstatus = system($system)) == 0 - && - -s "$aslocal_uncompressed.gz" - ) { - # test gzip integrity - if (CPAN::Tarzip->gtest("$aslocal_uncompressed.gz")) { - CPAN::Tarzip->gunzip("$aslocal_uncompressed.gz", - $aslocal); - } else { - rename $aslocal_uncompressed, $aslocal; - } -#line 1739 - $Thesite = $i; - return $aslocal; +]); + my($system) = "$funkyftp$source_switch '$url.gz' $devnull > ". + "$aslocal_uncompressed.gz"; + $self->debug("system[$system]") if $CPAN::DEBUG; + my($wstatus); + if (($wstatus = system($system)) == 0 + && + -s "$aslocal_uncompressed.gz" + ) { + # test gzip integrity + if (CPAN::Tarzip->gtest("$aslocal_uncompressed.gz")) { + CPAN::Tarzip->gunzip("$aslocal_uncompressed.gz", + $aslocal); + } else { + rename $aslocal_uncompressed, $aslocal; } + $Thesite = $i; + return $aslocal; + } else { + unlink "$aslocal_uncompressed.gz" if + -f "$aslocal_uncompressed.gz"; + } } else { my $estatus = $wstatus >> 8; my $size = -f $aslocal ? ", left\n$aslocal with size ".-s _ : ""; @@ -2047,7 +2261,7 @@ sub hosthardest { $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host nor does it have a default entry\n"); } - + # OK, they don't have a valid ~/.netrc. Use 'ftp -n' # then and login manually to host, using e-mail as # password. @@ -2085,7 +2299,6 @@ sub talk_ftp { Subprocess "|$command" returned status $estatus (wstat $wstatus) }) if $wstatus; - } # find2perl needs modularization, too, all the following is stolen @@ -2212,6 +2425,27 @@ sub contains { package CPAN::Complete; +sub gnu_cpl { + my($text, $line, $start, $end) = @_; + my(@perlret) = cpl($text, $line, $start); + # find longest common match. Can anybody show me how to peruse + # T::R::Gnu to have this done automatically? Seems expensive. + return () unless @perlret; + my($newtext) = $text; + for (my $i = length($text)+1;;$i++) { + last unless length($perlret[0]) && length($perlret[0]) >= $i; + my $try = substr($perlret[0],0,$i); + my @tries = grep {substr($_,0,$i) eq $try} @perlret; + # warn "try[$try]tries[@tries]"; + if (@tries == @perlret) { + $newtext = $try; + } else { + last; + } + } + ($newtext,@perlret); +} + #-> sub CPAN::Complete::cpl ; sub cpl { my($word,$line,$pos) = @_; @@ -2257,7 +2491,7 @@ sub cpl { #-> sub CPAN::Complete::cplx ; sub cplx { my($class, $word) = @_; - grep /^\Q$word\E/, map { $_->id } $CPAN::META->all($class); + grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class); } #-> sub CPAN::Complete::cpl_any ; @@ -2327,26 +2561,35 @@ sub reload { my $needshort = $^O eq "dos"; - $cl->rd_authindex($cl->reload_x( - "authors/01mailrc.txt.gz", - $needshort ? "01mailrc.gz" : "", - $force)); + $cl->rd_authindex($cl + ->reload_x( + "authors/01mailrc.txt.gz", + $needshort ? + File::Spec->catfile('authors', '01mailrc.gz') : + File::Spec->catfile('authors', '01mailrc.txt.gz'), + $force)); $t2 = time; $debug = "timing reading 01[".($t2 - $time)."]"; $time = $t2; return if $CPAN::Signal; # this is sometimes lengthy - $cl->rd_modpacks($cl->reload_x( - "modules/02packages.details.txt.gz", - $needshort ? "02packag.gz" : "", - $force)); + $cl->rd_modpacks($cl + ->reload_x( + "modules/02packages.details.txt.gz", + $needshort ? + File::Spec->catfile('modules', '02packag.gz') : + File::Spec->catfile('modules', '02packages.details.txt.gz'), + $force)); $t2 = time; $debug .= "02[".($t2 - $time)."]"; $time = $t2; return if $CPAN::Signal; # this is sometimes lengthy - $cl->rd_modlist($cl->reload_x( - "modules/03modlist.data.gz", - $needshort ? "03mlist.gz" : "", - $force)); + $cl->rd_modlist($cl + ->reload_x( + "modules/03modlist.data.gz", + $needshort ? + File::Spec->catfile('modules', '03mlist.gz') : + File::Spec->catfile('modules', '03modlist.data.gz'), + $force)); $t2 = time; $debug .= "03[".($t2 - $time)."]"; $time = $t2; @@ -2379,7 +2622,8 @@ sub reload_x { #-> sub CPAN::Index::rd_authindex ; sub rd_authindex { - my($cl,$index_target) = @_; + my($cl, $index_target) = @_; + my @lines; return unless defined $index_target; $CPAN::Frontend->myprint("Going to read $index_target\n"); # my $fh = CPAN::Tarzip->TIEHANDLE($index_target); @@ -2388,10 +2632,10 @@ sub rd_authindex { local(*FH); tie *FH, CPAN::Tarzip, $index_target; local($/) = "\n"; - while (<FH>) { - chomp; + push @lines, split /\012/ while <FH>; + foreach (@lines) { my($userid,$fullname,$email) = - /alias\s+(\S+)\s+\"([^\"\<]+)\s+<([^\>]+)\>\"/; + m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/; next unless $userid && $fullname && $email; # instantiate an author object @@ -2410,26 +2654,34 @@ sub userid { #-> sub CPAN::Index::rd_modpacks ; sub rd_modpacks { - my($cl,$index_target) = @_; + my($cl, $index_target) = @_; + my @lines; return unless defined $index_target; $CPAN::Frontend->myprint("Going to read $index_target\n"); my $fh = CPAN::Tarzip->TIEHANDLE($index_target); local($/) = "\n"; while ($_ = $fh->READLINE) { - last if /^\s*$/; + s/\012/\n/g; + my @ls = map {"$_\n"} split /\n/, $_; + unshift @ls, "\n" x length($1) if /^(\n+)/; + push @lines, @ls; } - while ($_ = $fh->READLINE) { + while (@lines) { + my $shift = shift(@lines); + last if $shift =~ /^\s*$/; + } + foreach (@lines) { chomp; my($mod,$version,$dist) = split; ### $version =~ s/^\+//; # if it is a bundle, instatiate a bundle object my($bundle,$id,$userid); - + if ($mod eq 'CPAN' && ! ( - $CPAN::META->exists('CPAN::Queue','Bundle::CPAN') || - $CPAN::META->exists('CPAN::Queue','CPAN') + CPAN::Queue->exists('Bundle::CPAN') || + CPAN::Queue->exists('CPAN') ) ) { local($^W)= 0; @@ -2452,9 +2704,11 @@ sub rd_modpacks { if ($bundle){ $id = $CPAN::META->instance('CPAN::Bundle',$mod); + # warn "made mod[$mod]a bundle"; # Let's make it a module too, because bundles have so much # in common with modules $CPAN::META->instance('CPAN::Module',$mod); + # warn "made mod[$mod]a module"; # This "next" makes us faster but if the job is running long, we ignore # rereads which is bad. So we have to be a bit slower again. @@ -2499,13 +2753,19 @@ sub rd_modlist { my @eval; local($/) = "\n"; while ($_ = $fh->READLINE) { - if (/^Date:\s+(.*)/){ + s/\012/\n/g; + my @ls = map {"$_\n"} split /\n/, $_; + unshift @ls, "\n" x length($1) if /^(\n+)/; + push @eval, @ls; + } + while (@eval) { + my $shift = shift(@eval); + if ($shift =~ /^Date:\s+(.*)/){ return if $date_of_03 eq $1; ($date_of_03) = $1; } - last if /^\s*$/; + last if $shift =~ /^\s*$/; } - push @eval, $_ while $_ = $fh->READLINE; undef $fh; push @eval, q{CPAN::Modulelist->data;}; local($^W) = 0; @@ -2604,6 +2864,7 @@ sub as_glimpse { #-> sub CPAN::Author::fullname ; sub fullname { shift->{'FULLNAME'} } *name = \&fullname; + #-> sub CPAN::Author::email ; sub email { shift->{'EMAIL'} } @@ -2667,11 +2928,12 @@ sub get { } else { $self->{archived} = "NO"; } - chdir ".."; + chdir File::Spec->updir; if ($self->{archived} ne 'NO') { - chdir "tmp"; + chdir File::Spec->catdir(File::Spec->curdir, "tmp"); # Let's check if the package has its own directory. - my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir .: $!"); + my $dh = DirHandle->new(File::Spec->curdir) + or Carp::croak("Couldn't opendir .: $!"); my @readdir = grep $_ !~ /^\.\.?$/, $dh->read; ### MAC?? $dh->close; my ($distdir,$packagedir); @@ -2694,7 +2956,7 @@ sub get { } } $self->{'build_dir'} = $packagedir; - chdir ".."; + chdir File::Spec->updir; $self->debug("Changed directory to .. (self is $self [".$self->as_string."])") if $CPAN::DEBUG; @@ -2783,6 +3045,12 @@ sub new { #-> sub CPAN::Distribution::look ; sub look { my($self) = @_; + + if ($^O eq 'MacOS') { + $self->ExtUtils::MM_MacOS::look; + return; + } + if ( $CPAN::Config->{'shell'} ) { $CPAN::Frontend->myprint(qq{ Trying to open a subshell in the build directory... @@ -2825,6 +3093,12 @@ sub readme { $local_file = CPAN::FTP->localize("authors/id/$sans.readme", $local_wanted) or $CPAN::Frontend->mydie(qq{No $sans.readme found});; + + if ($^O eq 'MacOS') { + ExtUtils::MM_MacOS::launch_file($local_file); + return; + } + my $fh_pager = FileHandle->new; local($SIG{PIPE}) = "IGNORE"; $fh_pager->open("|$CPAN::Config->{'pager'}") @@ -2891,6 +3165,7 @@ sub MD5_check_file { if (open $fh, $chk_file){ local($/); my $eval = <$fh>; + $eval =~ s/\015?\012/\n/g; close $fh; my($comp) = Safe->new(); $cksum = $comp->reval($eval); @@ -2978,16 +3253,14 @@ sub eq_MD5 { #-> sub CPAN::Distribution::force ; sub force { - my($self) = @_; - $self->{'force_update'}++; - delete $self->{'MD5_STATUS'}; - delete $self->{'archived'}; - delete $self->{'build_dir'}; - delete $self->{'localfile'}; - delete $self->{'make'}; - delete $self->{'install'}; - delete $self->{'unwrapped'}; - delete $self->{'writemakefile'}; + my($self) = @_; + $self->{'force_update'}++; + for my $att (qw( + MD5_STATUS archived build_dir localfile make install unwrapped + writemakefile have_sponsored + )) { + delete $self->{$att}; + } } sub isa_perl { @@ -3078,6 +3351,11 @@ or chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!"); $self->debug("Changed directory to $builddir") if $CPAN::DEBUG; + if ($^O eq 'MacOS') { + ExtUtils::MM_MacOS::make($self); + return; + } + my $system; if ($self->{'configure'}) { $system = $self->{'configure'}; @@ -3097,10 +3375,11 @@ or if ($CPAN::Config->{inactivity_timeout}) { eval { alarm $CPAN::Config->{inactivity_timeout}; - local $SIG{CHLD} = sub { wait }; + local $SIG{CHLD}; # = sub { wait }; if (defined($pid = fork)) { if ($pid) { #parent - wait; + # wait; + waitpid $pid, 0; } else { #child # note, this exec isn't necessary if # inactivity_timeout is 0. On the Mac I'd @@ -3122,37 +3401,41 @@ or return; } } else { - if (0) { - warn "Trying to intercept the output of 'perl Makefile.PL'"; - require IO::File; - # my $fh = FileHandle->new("$system 2>&1 |") or - my $fh = IO::File->new("$system 2>&1 |") or - die "Couldn't run '$system': $!"; - local($|) = 1; - while (length($_ = getc($fh))) { - print $_; # we want to parse that some day! - # unfortunately we have Makefile.PLs that want to talk - # and we can't emulate that reliably. I think, we have - # to parse Makefile.PL directly - } - $ret = $fh->close; - unless ($ret) { - warn $! ? "Error during 'perl Makefile.PL' subprocess: $!" : - "Exit status of 'perl Makefile.PL': $?"; - $self->{writemakefile} = "NO"; - return; - } - } else { - $ret = system($system); - if ($ret != 0) { - $self->{writemakefile} = "NO"; - return; - } + $ret = system($system); + if ($ret != 0) { + $self->{writemakefile} = "NO"; + return; } } $self->{writemakefile} = "YES"; } return if $CPAN::Signal; + if (my @prereq = $self->needs_prereq){ + my $id = $self->id; + $CPAN::Frontend->myprint("---- Dependencies detected ". + "during [$id] -----\n"); + + for my $p (@prereq) { + $CPAN::Frontend->myprint(" $p\n"); + } + my $follow = 0; + if ($CPAN::Config->{prerequisites_policy} eq "follow") { + $follow = 1; + } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") { + require ExtUtils::MakeMaker; + my $answer = ExtUtils::MakeMaker::prompt( +"Shall I follow them and prepend them to the queue +of modules we are processing right now?", "yes"); + $follow = $answer =~ /^\s*y/i; + } else { + local($") = ", "; + $CPAN::Frontend->myprint(" Ignoring dependencies on modules @prereq\n"); + } + if ($follow) { + CPAN::Queue->jumpqueue(@prereq,$id); # requeue yourself + return; + } + } $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg}; if (system($system) == 0) { $CPAN::Frontend->myprint(" $system -- OK\n"); @@ -3164,6 +3447,44 @@ or } } +#-> sub CPAN::Distribution::needs_prereq ; +sub needs_prereq { + my($self) = @_; + return unless -f "Makefile"; # we cannot say much + my $fh = FileHandle->new("<Makefile") or + $CPAN::Frontend->mydie("Couldn't open Makefile: $!"); + local($/) = "\n"; + + my(@p,@need); + while (<$fh>) { + last if /MakeMaker post_initialize section/; + my($p) = m{^[\#] + \s+PREREQ_PM\s+=>\s+(.+) + }x; + next unless $p; + # warn "Found prereq expr[$p]"; + + while ( $p =~ m/(?:\s)([\w\:]+)=>q\[.*?\],?/g ){ + push @p, $1; + } + last; + } + for my $p (@p) { + my $mo = $CPAN::META->instance("CPAN::Module",$p); + next if $mo->uptodate; + # it's not needed, so don't push it. We cannot omit this step, because + # if 'force' is in effect, nobody else will check. + if ($self->{'have_sponsored'}{$p}++){ + # We have already sponsored it and for some reason it's still + # not available. So we do nothing. Or what should we do? + # if we push it again, we have a potential infinite loop + next; + } + push @need, $p; + } + return @need; +} + #-> sub CPAN::Distribution::test ; sub test { my($self) = @_; @@ -3186,6 +3507,12 @@ sub test { Carp::croak("Couldn't chdir to $self->{'build_dir'}"); $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG; + + if ($^O eq 'MacOS') { + ExtUtils::MM_MacOS::make_test($self); + return; + } + my $system = join " ", $CPAN::Config->{'make'}, "test"; if (system($system) == 0) { $CPAN::Frontend->myprint(" $system -- OK\n"); @@ -3208,6 +3535,12 @@ sub clean { chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}"); $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG; + + if ($^O eq 'MacOS') { + ExtUtils::MM_MacOS::make_clean($self); + return; + } + my $system = join " ", $CPAN::Config->{'make'}, "clean"; if (system($system) == 0) { $CPAN::Frontend->myprint(" $system -- OK\n"); @@ -3250,9 +3583,16 @@ sub install { Carp::croak("Couldn't chdir to $self->{'build_dir'}"); $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG; + + if ($^O eq 'MacOS') { + ExtUtils::MM_MacOS::make_install($self); + return; + } + my $system = join(" ", $CPAN::Config->{'make'}, "install", $CPAN::Config->{make_install_arg}); - my($pipe) = FileHandle->new("$system 2>&1 |"); + my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 "; + my($pipe) = FileHandle->new("$system $stderr |"); my($makeout) = ""; while (<$pipe>){ $CPAN::Frontend->myprint($_); @@ -3261,7 +3601,7 @@ sub install { $pipe->close; if ($?==0) { $CPAN::Frontend->myprint(" $system -- OK\n"); - $self->{'install'} = "YES"; + return $self->{'install'} = "YES"; } else { $self->{'install'} = "NO"; $CPAN::Frontend->myprint(" $system -- NOT OK\n"); @@ -3289,58 +3629,67 @@ sub as_string { #-> sub CPAN::Bundle::contains ; sub contains { - my($self) = @_; - my($parsefile) = $self->inst_file; - my($id) = $self->id; - $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG; - unless ($parsefile) { - # Try to get at it in the cpan directory - $self->debug("no parsefile") if $CPAN::DEBUG; - Carp::confess "I don't know a $id" unless $self->{CPAN_FILE}; - my $dist = $CPAN::META->instance('CPAN::Distribution', - $self->{CPAN_FILE}); - $dist->get; - $self->debug($dist->as_string) if $CPAN::DEBUG; - my($todir) = $CPAN::Config->{'cpan_home'}; - my(@me,$from,$to,$me); - @me = split /::/, $self->id; - $me[-1] .= ".pm"; - $me = MM->catfile(@me); - $from = $self->find_bundle_file($dist->{'build_dir'},$me); - $to = MM->catfile($todir,$me); - File::Path::mkpath(File::Basename::dirname($to)); - File::Copy::copy($from, $to) - or Carp::confess("Couldn't copy $from to $to: $!"); - $parsefile = $to; - } - my @result; - my $fh = FileHandle->new; - local $/ = "\n"; - open($fh,$parsefile) or die "Could not open '$parsefile': $!"; - my $inpod = 0; - $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG; - while (<$fh>) { - $inpod = /^=(?!head1\s+CONTENTS)/ ? 0 : - /^=head1\s+CONTENTS/ ? 1 : $inpod; - next unless $inpod; - next if /^=/; - next if /^\s+$/; - chomp; - push @result, (split " ", $_, 2)[0]; - } - close $fh; - delete $self->{STATUS}; - $self->{CONTAINS} = join ", ", @result; - $self->debug("CONTAINS[@result]") if $CPAN::DEBUG; - @result; + my($self) = @_; + my($parsefile) = $self->inst_file; + my($id) = $self->id; + $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG; + unless ($parsefile) { + # Try to get at it in the cpan directory + $self->debug("no parsefile") if $CPAN::DEBUG; + Carp::confess "I don't know a $id" unless $self->{CPAN_FILE}; + my $dist = $CPAN::META->instance('CPAN::Distribution', + $self->{CPAN_FILE}); + $dist->get; + $self->debug($dist->as_string) if $CPAN::DEBUG; + my($todir) = $CPAN::Config->{'cpan_home'}; + my(@me,$from,$to,$me); + @me = split /::/, $self->id; + $me[-1] .= ".pm"; + $me = MM->catfile(@me); + $from = $self->find_bundle_file($dist->{'build_dir'},$me); + $to = MM->catfile($todir,$me); + File::Path::mkpath(File::Basename::dirname($to)); + File::Copy::copy($from, $to) + or Carp::confess("Couldn't copy $from to $to: $!"); + $parsefile = $to; + } + my @result; + my $fh = FileHandle->new; + local $/ = "\n"; + open($fh,$parsefile) or die "Could not open '$parsefile': $!"; + my $inpod = 0; + $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG; + while (<$fh>) { + $inpod = m/^=(?!head1\s+CONTENTS)/ ? 0 : + m/^=head1\s+CONTENTS/ ? 1 : $inpod; + next unless $inpod; + next if /^=/; + next if /^\s+$/; + chomp; + push @result, (split " ", $_, 2)[0]; + } + close $fh; + delete $self->{STATUS}; + $self->{CONTAINS} = join ", ", @result; + $self->debug("CONTAINS[@result]") if $CPAN::DEBUG; + unless (@result) { + $CPAN::Frontend->mywarn(qq{ +The bundle file "$parsefile" may be a broken +bundlefile. It seems not to contain any bundle definition. +Please check the file and if it is bogus, please delete it. +Sorry for the inconvenience. +}); + } + @result; } #-> sub CPAN::Bundle::find_bundle_file sub find_bundle_file { my($self,$where,$what) = @_; $self->debug("where[$where]what[$what]") if $CPAN::DEBUG; - my $bu = MM->catfile($where,$what); - return $bu if -f $bu; +### The following two lines let CPAN.pm become Bundle/CPAN.pm :-( +### my $bu = MM->catfile($where,$what); +### return $bu if -f $bu; my $manifest = MM->catfile($where,"MANIFEST"); unless (-f $manifest) { require ExtUtils::Manifest; @@ -3353,20 +3702,30 @@ sub find_bundle_file { my $fh = FileHandle->new($manifest) or Carp::croak("Couldn't open $manifest: $!"); local($/) = "\n"; + my $what2 = $what; + if ($^O eq 'MacOS') { + $what =~ s/^://; + $what2 =~ tr|:|/|; + $what2 =~ s/:Bundle://; + $what2 =~ tr|:|/|; + } else { + $what2 =~ s|Bundle/||; + } + my $bu; while (<$fh>) { next if /^\s*\#/; my($file) = /(\S+)/; if ($file =~ m|\Q$what\E$|) { $bu = $file; - return MM->catfile($where,$bu); - } elsif ($what =~ s|Bundle/||) { # retry if she managed to - # have no Bundle directory - if ($file =~ m|\Q$what\E$|) { - $bu = $file; - return MM->catfile($where,$bu); - } + # return MM->catfile($where,$bu); # bad + last; } + # retry if she managed to + # have no Bundle directory + $bu = $file if $file =~ m|\Q$what2\E$|; } + $bu =~ tr|/|:| if $^O eq 'MacOS'; + return MM->catfile($where, $bu) if $bu; Carp::croak("Couldn't find a Bundle file in $where"); } @@ -3395,7 +3754,7 @@ sub rematein { my($id) = $self->id; Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n" unless $self->inst_file || $self->{CPAN_FILE}; - my($s); + my($s,%fail); for $s ($self->contains) { my($type) = $s =~ m|/| ? 'CPAN::Distribution' : $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module'; @@ -3406,7 +3765,26 @@ explicitly a file $s. }); sleep 3; } - $CPAN::META->instance($type,$s)->$meth(); + # possibly noisy action: + my $obj = $CPAN::META->instance($type,$s); + $obj->$meth(); + my $success = $obj->can("uptodate") ? $obj->uptodate : 0; + $success ||= $obj->{'install'} && $obj->{'install'} eq "YES"; + $fail{$s} = 1 unless $success; + } + # recap with less noise + if ( $meth eq "install") { + if (%fail) { + $CPAN::Frontend->myprint(qq{\nBundle summary: }. + qq{The following items seem to }. + qq{have had installation problems:\n}); + for $s ($self->contains) { + $CPAN::Frontend->myprint( "$s " ) if $fail{$s}; + } + $CPAN::Frontend->myprint(qq{\n}); + } else { + $self->{'install'} = 'YES'; + } } } @@ -3429,7 +3807,6 @@ sub test { shift->rematein('test',@_); } sub install { my $self = shift; $self->rematein('install',@_); - $CPAN::META->delete('CPAN::Queue',$self->id); } #-> sub CPAN::Bundle::clean ; sub clean { shift->rematein('clean',@_); } @@ -3496,9 +3873,9 @@ sub as_string { pre-alpha alpha beta released mature standard,; @stats{qw,? m d u n,} = qw,unknown mailing-list developer comp.lang.perl.* none,; - @statl{qw,? p c + o,} = qw,unknown perl C C++ other,; - @stati{qw,? f r O,} = qw,unknown functions - references+ties object-oriented,; + @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,; + @stati{qw,? f r O h,} = qw,unknown functions + references+ties object-oriented hybrid,; $statd{' '} = 'unknown'; $stats{' '} = 'unknown'; $statl{' '} = 'unknown'; @@ -3544,8 +3921,8 @@ sub manpage_headline { my $inpod = 0; local $/ = "\n"; while (<$fh>) { - $inpod = /^=(?!head1\s+NAME)/ ? 0 : - /^=head1\s+NAME/ ? 1 : $inpod; + $inpod = m/^=(?!head1\s+NAME)/ ? 0 : + m/^=head1\s+NAME/ ? 1 : $inpod; next unless $inpod; next if /^=/; next if /^\s+$/; @@ -3586,7 +3963,7 @@ sub cpan_file { #-> sub CPAN::Module::cpan_version ; sub cpan_version { my $self = shift; - $self->{'CPAN_VERSION'} = 'undef' + $self->{'CPAN_VERSION'} = 'undef' unless defined $self->{'CPAN_VERSION'}; # I believe this is # always a bug in the # index and should be @@ -3640,10 +4017,9 @@ sub get { shift->rematein('get',@_); } sub make { shift->rematein('make') } #-> sub CPAN::Module::test ; sub test { shift->rematein('test') } -#-> sub CPAN::Module::install ; -sub install { +#-> sub CPAN::Module::uptodate ; +sub uptodate { my($self) = @_; - my($doit) = 0; my($latest) = $self->cpan_version; $latest ||= 0; my($inst_file) = $self->inst_file; @@ -3651,22 +4027,28 @@ sub install { if (defined $inst_file) { $have = $self->inst_version; } - if (1){ # A block for scoping $^W, the if is just for the visual - # appeal - local($^W)=0; - if ($inst_file - && - $have >= $latest - && - not exists $self->{'force_update'} - ) { - $CPAN::Frontend->myprint( $self->id. " is up to date.\n"); - } else { - $doit = 1; - } + local($^W)=0; + if ($inst_file + && + $have >= $latest + ) { + return 1; + } + return; +} +#-> sub CPAN::Module::install ; +sub install { + my($self) = @_; + my($doit) = 0; + if ($self->uptodate + && + not exists $self->{'force_update'} + ) { + $CPAN::Frontend->myprint( $self->id. " is up to date.\n"); + } else { + $doit = 1; } $self->rematein('install') if $doit; - $CPAN::META->delete('CPAN::Queue',$self->id); } #-> sub CPAN::Module::clean ; sub clean { shift->rematein('clean') } @@ -3707,6 +4089,7 @@ sub inst_version { my($self) = @_; my $parsefile = $self->inst_file or return; local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38; + # warn "HERE"; my $have = MM->parse_version($parsefile) || "undef"; $have =~ s/\s+//g; $have; @@ -3728,7 +4111,7 @@ sub gzip { $fhw->close; return 1; } else { - system("$CPAN::Config->{'gzip'} -c $read > $write")==0; + system("$CPAN::Config->{'gzip'} -c $read > $write")==0; } } @@ -3830,15 +4213,40 @@ sub untar { if (MM->maybe_command($CPAN::Config->{'gzip'}) && MM->maybe_command($CPAN::Config->{'tar'})) { - my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " . - "$file | $CPAN::Config->{tar} xvf -"; - return system($system) == 0; + if ($^O =~ /win/i) { # irgggh + # people find the most curious tar binaries that cannot handle + # pipes + my $system = "$CPAN::Config->{'gzip'} --decompress $file"; + if (system($system)==0) { + $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n}); + } else { + $CPAN::Frontend->mydie( + qq{Couldn\'t uncompress $file\n} + ); + } + $file =~ s/\.gz$//; + $system = "$CPAN::Config->{tar} xvf $file"; + if (system($system)==0) { + $CPAN::Frontend->myprint(qq{Untarred $file successfully\n}); + } else { + $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n}); + } + return 1; + } else { + my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " . + "< $file | $CPAN::Config->{tar} xvf -"; + return system($system) == 0; + } } elsif ($CPAN::META->has_inst("Archive::Tar") && $CPAN::META->has_inst("Compress::Zlib") ) { my $tar = Archive::Tar->new($file,1); $tar->extract($tar->list_files); # I'm pretty sure we have nothing # that isn't compressed + + ExtUtils::MM_MacOS::convert_files([$tar->list_files], 1) + if ($^O eq 'MacOS'); + return 1; } else { $CPAN::Frontend->mydie(qq{ @@ -3893,7 +4301,15 @@ session. The cache manager keeps track of the disk space occupied by the make processes and deletes excess space according to a simple FIFO mechanism. -All methods provided are accessible in a programmer style and in an +For extended searching capabilities there's a plugin for CPAN available, +L<CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine that indexes +all documents available in CPAN authors directories. If C<CPAN::WAIT> +is installed on your system, the interactive shell of <CPAN.pm> will +enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands which send +queries to the WAIT server that has been configured for your +installation. + +All other methods provided are accessible in a programmer style and in an interactive shell style. =head2 Interactive Mode @@ -3949,11 +4365,13 @@ each as object-E<gt>as_glimpse. E.g. =item make, test, install, clean modules or distributions -These commands take any number of arguments and investigate what is +These commands take any number of arguments and investigates what is necessary to perform the action. If the argument is a distribution -file name (recognized by embedded slashes), it is processed. If it is a -module, CPAN determines the distribution file in which this module is -included and processes that. +file name (recognized by embedded slashes), it is processed. If it is +a module, CPAN determines the distribution file in which this module +is included and processes that, following any dependencies named in +the module's Makefile.PL (this behavior is controlled by +I<prerequisites_policy>.) Any C<make> or C<test> are run unconditionally. An @@ -3983,7 +4401,7 @@ Example: OpenGL-0.4/COPYRIGHT [...] -A C<clean> command results in a +A C<clean> command results in a make clean @@ -4133,7 +4551,7 @@ functionalities that are available in the shell. =back -=head2 Methods in the four +=head2 Methods in the four Classes =head2 Cache Manager @@ -4212,7 +4630,7 @@ the $VERSION variable. Currently all programs that are dealing with version use something like this perl -MExtUtils::MakeMaker -le \ - 'print MM->parse_version($ARGV[0])' filename + 'print MM->parse_version(shift)' filename If you are author of a package and wonder if your $VERSION can be parsed, please try the above method. @@ -4239,7 +4657,7 @@ have an idea which part of the package may have a bug, it's sometimes worth to give it a try and send me more specific output. You should know that "o debug" has built-in completion support. -=head2 Floppy, Zip, and all that Jazz +=head2 Floppy, Zip, Offline Mode CPAN.pm works nicely without network too. If you maintain machines that are not networked at all, you should consider working with file: @@ -4278,10 +4696,17 @@ defined: make_install_arg same as make_arg for 'make install' makepl_arg arguments passed to 'perl Makefile.PL' pager location of external program more (or any pager) + prerequisites_policy + what to do if you are missing module prerequisites + ('follow' automatically, 'ask' me, or 'ignore') + scan_cache controls scanning of cache ('atstart' or 'never') tar location of external program tar unzip location of external program unzip urllist arrayref to nearby CPAN sites (or equivalent locations) wait_list arrayref to a wait server to try (See CPAN::WAIT) + ftp_proxy, } the three usual variables for configuring + http_proxy, } proxy requests. Both as CPAN::Config variables + no_proxy } and as environment variables configurable. You can set and query each of these options interactively in the cpan shell with the command set defined within the C<o conf> command: @@ -4311,7 +4736,7 @@ works like the corresponding perl commands. =back -=head2 CD-ROM support +=head2 urllist parameter has CD-ROM support The C<urllist> parameter of the configuration table contains a list of URLs that are to be used for downloading. If the list contains any @@ -4326,6 +4751,14 @@ CPAN.pm will then fetch the index files from one of the CPAN sites that come at the beginning of urllist. It will later check for each module if there is a local copy of the most recent version. +Another peculiarity of urllist is that the site that we could +successfully fetch the last file from automatically gets a preference +token and is tried as the first site for the next request. So if you +add a new site at runtime it may happen that the previously preferred +site will be tried another time. This means that if you want to disallow +a site for the next transfer, it must be explicitly removed from +urllist. + =head1 SECURITY There's no strong security layer in CPAN.pm. CPAN.pm helps you to @@ -4333,7 +4766,7 @@ install foreign, unmasked, unsigned code on your machine. We compare to a checksum that comes from the net just as the distribution file itself. If somebody has managed to tamper with the distribution file, they may have as well tampered with the CHECKSUMS file. Future -development will go towards strong authentification. +development will go towards strong authentication. =head1 EXPORT @@ -4341,6 +4774,90 @@ Most functions in package CPAN are exported per default. The reason for this is that the primary use is intended for the cpan shell or for oneliners. +=head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES + +To populate a freshly installed perl with my favorite modules is pretty +easiest by maintaining a private bundle definition file. To get a useful +blueprint of a bundle definition file, the command autobundle can be used +on the CPAN shell command line. This command writes a bundle definition +file for all modules that re installed for the currently running perl +interpreter. It's recommended to run this command only once and from then +on maintain the file manually under a private name, say +Bundle/my_bundle.pm. With a clever bundle file you can then simply say + + cpan> install Bundle::my_bundle + +then answer a few questions and then go out. + +Maintaining a bundle definition file means to keep track of two things: +dependencies and interactivity. CPAN.pm (currently) does not take into +account dependencies between distributions, so a bundle definition file +should specify distributions that depend on others B<after> the others. +On the other hand, it's a bit annoying that many distributions need some +interactive configuring. So what I try to accomplish in my private bundle +file is to have the packages that need to be configured early in the file +and the gentle ones later, so I can go out after a few minutes and leave +CPAN.pm unattained. + +=head1 WORKING WITH CPAN.pm BEHIND FIREWALLS + +Thanks to Graham Barr for contributing the firewall following howto. + +Firewalls can be categorized into three basic types. + +=over + +=item http firewall + +This is where the firewall machine runs a web server and to access the +outside world you must do it via the web server. If you set environment +variables like http_proxy or ftp_proxy to a values beginning with http:// +or in your web browser you have to set proxy information then you know +you are running a http firewall. + +To access servers outside these types of firewalls with perl (even for +ftp) you will need to use LWP. + +=item ftp firewall + +This where the firewall machine runs a ftp server. This kind of firewall will +only let you access ftp serves outside the firewall. This is usually done by +connecting to the firewall with ftp, then entering a username like +"user@outside.host.com" + +To access servers outside these type of firewalls with perl you +will need to use Net::FTP. + +=item One way visibility + +I say one way visibility as these firewalls try to make themselve look +invisible to the users inside the firewall. An FTP data connection is +normally created by sending the remote server your IP address and then +listening for the connection. But the remote server will not be able to +connect to you because of the firewall. So for these types of firewall +FTP connections need to be done in a passive mode. + +There are two that I can think off. + +=over + +=item SOCKS + +If you are using a SOCKS firewall you will need to compile perl and link +it with the SOCKS library, this is what is normally called a ``socksified'' +perl. With this executable you will be able to connect to servers outside +the firewall as if it is not there. + +=item IP Masquerade + +This is the firewall implemented in the Linux kernel, it allows you to +hide a complete network behind one IP address. With this firewall no +special compiling is need as you can access hosts directly. + +=back + +=back + =head1 BUGS We should give coverage for _all_ of the CPAN and not just the PAUSE @@ -4358,7 +4875,7 @@ traditional method of building a Perl module package from a shell. =head1 AUTHOR -Andreas König E<lt>a.koenig@mind.deE<gt> +Andreas König E<lt>a.koenig@kulturbox.deE<gt> =head1 SEE ALSO diff --git a/contrib/perl5/lib/CPAN/FirstTime.pm b/contrib/perl5/lib/CPAN/FirstTime.pm index aa7a55d..df95812 100644 --- a/contrib/perl5/lib/CPAN/FirstTime.pm +++ b/contrib/perl5/lib/CPAN/FirstTime.pm @@ -16,7 +16,7 @@ use FileHandle (); use File::Basename (); use File::Path (); use vars qw($VERSION); -$VERSION = substr q$Revision: 1.29 $, 10; +$VERSION = substr q$Revision: 1.36 $, 10; =head1 NAME @@ -37,7 +37,9 @@ file. Nothing special. sub init { my($configpm) = @_; use Config; - require CPAN::Nox; + unless ($CPAN::VERSION) { + require CPAN::Nox; + } eval {require CPAN::Config;}; $CPAN::Config ||= {}; local($/) = "\n"; @@ -45,12 +47,12 @@ sub init { local($|) = 1; my($ans,$default,$local,$cont,$url,$expected_size); - + # # Files, directories # - print qq{ + print qq[ CPAN is the world-wide archive of perl resources. It consists of about 100 sites that all replicate the same contents all around the globe. @@ -62,7 +64,7 @@ If you do not want to enter a dialog now, you can answer 'no' to this question and I\'ll try to autoconfigure. (Note: you can revisit this dialog anytime later by typing 'o conf init' at the cpan prompt.) -}; +]; my $manual_conf = ExtUtils::MakeMaker::prompt("Are you ready for manual configuration?", @@ -111,16 +113,21 @@ First of all, I\'d like to create this directory. Where? $default = $cpan_home; while ($ans = prompt("CPAN build and cache directory?",$default)) { - File::Path::mkpath($ans); # dies if it can't - if (-d $ans && -w _) { - last; - } else { - warn "Couldn't find directory $ans + eval { File::Path::mkpath($ans); }; # dies if it can't + if ($@) { + warn "Couldn't create directory $ans. +Please retry.\n"; + next; + } + if (-d $ans && -w _) { + last; + } else { + warn "Couldn't find directory $ans or directory is not writable. Please retry.\n"; - } + } } $CPAN::Config->{cpan_home} = $ans; - + print qq{ If you want, I can keep the source files after a build in the cpan @@ -151,6 +158,42 @@ with all the intermediate files? # XXX This the time when we refetch the index files (in days) $CPAN::Config->{'index_expire'} = 1; + print qq{ + +By default, each time the CPAN module is started, cache scanning +is performed to keep the cache size in sync. To prevent from this, +disable the cache scanning with 'never'. + +}; + + $default = $CPAN::Config->{scan_cache} || 'atstart'; + do { + $ans = prompt("Perform cache scanning (atstart or never)?", $default); + } while ($ans ne 'atstart' && $ans ne 'never'); + $CPAN::Config->{scan_cache} = $ans; + + # + # prerequisites_policy + # Do we follow PREREQ_PM? + # + print qq{ + +The CPAN module can detect when a module that which you are trying to +build depends on prerequisites. If this happens, it can build the +prerequisites for you automatically ('follow'), ask you for +confirmation ('ask'), or just ignore them ('ignore'). Please set your +policy to one of the three values. + +}; + + $default = $CPAN::Config->{prerequisites_policy} || 'follow'; + do { + $ans = + prompt("Policy on building prerequisites (follow, ask or ignore)?", + $default); + } while ($ans ne 'follow' && $ans ne 'ask' && $ans ne 'ignore'); + $CPAN::Config->{prerequisites_policy} = $ans; + # # External programs # @@ -164,36 +207,46 @@ those. }; + my $old_warn = $^W; + local $^W if $^O eq 'MacOS'; my(@path) = split /$Config{'path_sep'}/, $ENV{'PATH'}; + local $^W = $old_warn; my $progname; - for $progname (qw/gzip tar unzip make lynx ncftp ftp/){ + for $progname (qw/gzip tar unzip make lynx ncftpget ncftp ftp/){ + if ($^O eq 'MacOS') { + $CPAN::Config->{$progname} = 'not_here'; + next; + } my $progcall = $progname; - my $path = $CPAN::Config->{$progname} - || $Config::Config{$progname} - || ""; - if (MM->file_name_is_absolute($path)) { - # testing existence is not good enough, some have these exe - # extensions - - # warn "Warning: configured $path does not exist\n" unless -e $path; - # $path = ""; - } else { - $path = ''; - } - unless ($path) { - # e.g. make -> nmake - $progcall = $Config::Config{$progname} if $Config::Config{$progname}; - } + # we don't need ncftp if we have ncftpget + next if $progname eq "ncftp" && $CPAN::Config->{ncftpget} gt " "; + my $path = $CPAN::Config->{$progname} + || $Config::Config{$progname} + || ""; + if (MM->file_name_is_absolute($path)) { + # testing existence is not good enough, some have these exe + # extensions + + # warn "Warning: configured $path does not exist\n" unless -e $path; + # $path = ""; + } else { + $path = ''; + } + unless ($path) { + # e.g. make -> nmake + $progcall = $Config::Config{$progname} if $Config::Config{$progname}; + } - $path ||= find_exe($progcall,[@path]); - warn "Warning: $progcall not found in PATH\n" unless - $path; # not -e $path, because find_exe already checked that - $ans = prompt("Where is your $progname program?",$path) || $path; - $CPAN::Config->{$progname} = $ans; + $path ||= find_exe($progcall,[@path]); + warn "Warning: $progcall not found in PATH\n" unless + $path; # not -e $path, because find_exe already checked that + $ans = prompt("Where is your $progname program?",$path) || $path; + $CPAN::Config->{$progname} = $ans; } my $path = $CPAN::Config->{'pager'} || $ENV{PAGER} || find_exe("less",[@path]) || - find_exe("more",[@path]) || "more"; + find_exe("more",[@path]) || ($^O eq 'MacOS' ? $ENV{EDITOR} : 0 ) + || "more"; $ans = prompt("What is your favorite pager program?",$path); $CPAN::Config->{'pager'} = $ans; $path = $CPAN::Config->{'shell'}; @@ -202,9 +255,13 @@ those. $path = ""; } $path ||= $ENV{SHELL}; - $path =~ s,\\,/,g if $^O eq 'os2'; # Cosmetic only - $ans = prompt("What is your favorite shell?",$path); - $CPAN::Config->{'shell'} = $ans; + if ($^O eq 'MacOS') { + $CPAN::Config->{'shell'} = 'not_here'; + } else { + $path =~ s,\\,/,g if $^O eq 'os2'; # Cosmetic only + $ans = prompt("What is your favorite shell?",$path); + $CPAN::Config->{'shell'} = $ans; + } # # Arguments to make etc. @@ -327,11 +384,38 @@ sub find_exe { } } +sub picklist { + my($items,$prompt,$default,$require_nonempty,$empty_warning)=@_; + $default ||= ''; + + my ($item, $i); + for $item (@$items) { + printf "(%d) %s\n", ++$i, $item; + } + + my @nums; + while (1) { + my $num = prompt($prompt,$default); + @nums = split (' ', $num); + (warn "invalid items entered, try again\n"), next + if grep (/\D/ || $_ < 1 || $_ > $i, @nums); + if ($require_nonempty) { + (warn "$empty_warning\n"), next + unless @nums; + } + last; + } + print "\n"; + for (@nums) { $_-- } + @{$items}[@nums]; +} + sub read_mirrored_by { my($local) = @_; my(%all,$url,$expected_size,$default,$ans,$host,$dst,$country,$continent,@location); my $fh = FileHandle->new; $fh->open($local) or die "Couldn't open $local: $!"; + local $/ = "\012"; while (<$fh>) { ($host) = /^([\w\.\-]+)/ unless defined $host; next unless defined $host; @@ -339,6 +423,7 @@ sub read_mirrored_by { /location\s+=\s+\"([^\"]+)/ and @location = (split /\s*,\s*/, $1) and ($continent, $country) = @location[-1,-2]; $continent =~ s/\s\(.*//; + $continent =~ s/\W+$//; # if Jarkko doesn't know latitude/longitude /dst_dst\s+=\s+\"([^\"]+)/ and $dst = $1; next unless $host && $dst && $continent && $country; $all{$continent}{$country}{$dst} = CPAN::Mirrored::By->new($continent,$country,$dst); @@ -347,93 +432,97 @@ sub read_mirrored_by { } $fh->close; $CPAN::Config->{urllist} ||= []; - if ($expected_size = @{$CPAN::Config->{urllist}}) { - for $url (@{$CPAN::Config->{urllist}}) { - # sanity check, scheme+colon, not "q" there: - next unless $url =~ /^\w+:\/./; - $all{"[From previous setup]"}{"found URL"}{$url}=CPAN::Mirrored::By->new('[From previous setup]','found URL',$url); - } + my(@previous_urls); + if (@previous_urls = @{$CPAN::Config->{urllist}}) { $CPAN::Config->{urllist} = []; - } else { - $expected_size = 6; } - + print qq{ -Now we need to know, where your favorite CPAN sites are located. Push +Now we need to know where your favorite CPAN sites are located. Push a few sites onto the array (just in case the first on the array won\'t work). If you are mirroring CPAN to your local workstation, specify a file: URL. -You can enter the number in front of the URL on the next screen, a -file:, ftp: or http: URL, or "q" to finish selecting. +First, pick a nearby continent and country (you can pick several of +each, separated by spaces, or none if you just want to keep your +existing selections). Then, you will be presented with a list of URLs +of CPAN mirrors in the countries you selected, along with previously +selected URLs. Select some of those URLs, or just keep the old list. +Finally, you will be prompted for any extra URLs -- file:, ftp:, or +http: -- that host a CPAN mirror. }; - $ans = prompt("Press RETURN to continue"); - my $other; - $ans = $other = ""; - my(%seen); - - my $pipe = -t *STDIN ? "| $CPAN::Config->{'pager'}" : ">/dev/null"; - while () { - my(@valid,$previous_best); - my $fh = FileHandle->new; - $fh->open($pipe); - { - my($cont,$country,$url,$item); - my(@cont) = sort keys %all; - for $cont (@cont) { - $fh->print(" $cont\n"); - for $country (sort {lc $a cmp lc $b} keys %{$all{$cont}}) { - for $url (sort {lc $a cmp lc $b} keys %{$all{$cont}{$country}}) { - my $t = sprintf( - " %-16s (%2d) %s\n", - $country, - ++$item, - $url - ); - if ($cont =~ /^\[/) { - $previous_best ||= $item; - } - push @valid, $all{$cont}{$country}{$url}; - $fh->print($t); - } - } - } - } - $fh->close; - $previous_best ||= ""; - $default = - @{$CPAN::Config->{urllist}} >= - $expected_size ? "q" : $previous_best; - $ans = prompt( - "\nSelect an$other ftp or file URL or a number (q to finish)", - $default - ); - my $sel; - if ($ans =~ /^\d/) { - my $this = $valid[$ans-1]; - my($con,$cou,$url) = ($this->continent,$this->country,$this->url); - push @{$CPAN::Config->{urllist}}, $url unless $seen{$url}++; - delete $all{$con}{$cou}{$url}; - # print "Was a number [$ans] con[$con] cou[$cou] url[$url]\n"; - } elsif ($ans =~ /^q/i) { - last; - } else { - $ans =~ s|/?$|/|; # has to end with one slash - $ans = "file:$ans" unless $ans =~ /:/; # without a scheme is a file: - if ($ans =~ /^\w+:\/./) { - push @{$CPAN::Config->{urllist}}, $ans unless $seen{$ans}++; - } else { - print qq{"$ans" doesn\'t look like an URL at first sight. -I\'ll ignore it for now. You can add it to lib/CPAN/Config.pm -later and report a bug in my Makefile.PL to me (andreas koenig). -Thanks.\n}; - } - } - $other ||= "other"; + my (@cont, $cont, %cont, @countries, @urls, %seen); + my $no_previous_warn = + "Sorry! since you don't have any existing picks, you must make a\n" . + "geographic selection."; + @cont = picklist([sort keys %all], + "Select your continent (or several nearby continents)", + '', + ! @previous_urls, + $no_previous_warn); + + + foreach $cont (@cont) { + my @c = sort keys %{$all{$cont}}; + @cont{@c} = map ($cont, 0..$#c); + @c = map ("$_ ($cont)", @c) if @cont > 1; + push (@countries, @c); + } + + if (@countries) { + @countries = picklist (\@countries, + "Select your country (or several nearby countries)", + '', + ! @previous_urls, + $no_previous_warn); + %seen = map (($_ => 1), @previous_urls); + # hmmm, should take list of defaults from CPAN::Config->{'urllist'}... + foreach $country (@countries) { + (my $bare_country = $country) =~ s/ \(.*\)//; + my @u = sort keys %{$all{$cont{$bare_country}}{$bare_country}}; + @u = grep (! $seen{$_}, @u); + @u = map ("$_ ($bare_country)", @u) + if @countries > 1; + push (@urls, @u); + } } + push (@urls, map ("$_ (previous pick)", @previous_urls)); + my $prompt = "Select as many URLs as you like"; + if (@previous_urls) { + $default = join (' ', ((scalar @urls) - (scalar @previous_urls) + 1) .. + (scalar @urls)); + $prompt .= "\n(or just hit RETURN to keep your previous picks)"; + } + + @urls = picklist (\@urls, $prompt, $default); + foreach (@urls) { s/ \(.*\)//; } + %seen = map (($_ => 1), @urls); + + do { + $ans = prompt ("Enter another URL or RETURN to quit:", ""); + + if ($ans) { + $ans =~ s|/?$|/|; # has to end with one slash + $ans = "file:$ans" unless $ans =~ /:/; # without a scheme is a file: + if ($ans =~ /^\w+:\/./) { + push @urls, $ans + unless $seen{$ans}; + } + else { + print qq{"$ans" doesn\'t look like an URL at first sight. +I\'ll ignore it for now. You can add it to $INC{'CPAN/MyConfig.pm'} +later if you\'re sure it\'s right.\n}; + } + } + } while $ans; + + push @{$CPAN::Config->{urllist}}, @urls; + # xxx delete or comment these out when you're happy that it works + print "New set of picks:\n"; + map { print " $_\n" } @{$CPAN::Config->{urllist}}; } 1; diff --git a/contrib/perl5/lib/CPAN/Nox.pm b/contrib/perl5/lib/CPAN/Nox.pm index c4016a4..e9cb189 100644 --- a/contrib/perl5/lib/CPAN/Nox.pm +++ b/contrib/perl5/lib/CPAN/Nox.pm @@ -1,7 +1,10 @@ +package CPAN::Nox; + BEGIN{$CPAN::Suppress_readline=1 unless defined $CPAN::term;} use CPAN; +$VERSION = "1.00"; $CPAN::META->has_inst('MD5','no'); $CPAN::META->has_inst('LWP','no'); $CPAN::META->has_inst('Compress::Zlib','no'); diff --git a/contrib/perl5/lib/Carp.pm b/contrib/perl5/lib/Carp.pm index 6bac364..f8f750a 100644 --- a/contrib/perl5/lib/Carp.pm +++ b/contrib/perl5/lib/Carp.pm @@ -35,7 +35,7 @@ and a carp as a cluck across I<all> modules. In other words, force a detailed stack trace to be given. This can be very helpful when trying to understand why, or from where, a warning or error is being generated. -This feature is enabled by 'importing' the non-existant symbol +This feature is enabled by 'importing' the non-existent symbol 'verbose'. You would typically enable it by saying perl -MCarp=verbose script.pl @@ -43,6 +43,12 @@ This feature is enabled by 'importing' the non-existant symbol or by including the string C<MCarp=verbose> in the L<PERL5OPT> environment variable. +=head1 BUGS + +The Carp routines don't handle exception objects currently. +If called with a first argument that is a reference, they simply +call die() or warn(), as appropriate. + =cut # This package is heavily used. Be small. Be fast. Be good. @@ -88,6 +94,7 @@ sub export_fail { # each function call on the stack. sub longmess { + return @_ if ref $_[0]; my $error = join '', @_; my $mess = ""; my $i = 1 + $CarpLevel; @@ -190,6 +197,7 @@ sub longmess { sub shortmess { # Short-circuit &longmess if called via multiple packages goto &longmess if $Verbose; + return @_ if ref $_[0]; my $error = join '', @_; my ($prevpack) = caller(1); my $extra = $CarpLevel; diff --git a/contrib/perl5/lib/Cwd.pm b/contrib/perl5/lib/Cwd.pm index 7febb0d..5c10e8e 100644 --- a/contrib/perl5/lib/Cwd.pm +++ b/contrib/perl5/lib/Cwd.pm @@ -32,7 +32,7 @@ The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions in Perl. The abs_path() function takes a single argument and returns the -absolute pathname for that argument. It uses the same algoritm as +absolute pathname for that argument. It uses the same algorithm as getcwd(). (actually getcwd() is abs_path(".")) The fastcwd() function looks the same as getcwd(), but runs faster. @@ -269,7 +269,7 @@ sub fast_abs_path { # --- PORTING SECTION --- # VMS: $ENV{'DEFAULT'} points to default directory at all times -# 06-Mar-1996 Charles Bailey bailey@genetics.upenn.edu +# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu # Note: Use of Cwd::chdir() causes the logical name PWD to be defined # in the process logical name table as the default device and directory # seen by Perl. This may not be the same as the default device diff --git a/contrib/perl5/lib/Dumpvalue.pm b/contrib/perl5/lib/Dumpvalue.pm new file mode 100644 index 0000000..5bcd58f --- /dev/null +++ b/contrib/perl5/lib/Dumpvalue.pm @@ -0,0 +1,600 @@ +require 5.005; # For (defined ref) and $#$v +package Dumpvalue; +use strict; +use vars qw(%address *stab %subs); + +# translate control chars to ^X - Randal Schwartz +# Modifications to print types by Peter Gordon v1.0 + +# Ilya Zakharevich -- patches after 5.001 (and some before ;-) + +# Won't dump symbol tables and contents of debugged files by default + +# (IZ) changes for objectification: +# c) quote() renamed to method set_quote(); +# d) unctrlSet() renamed to method set_unctrl(); +# f) Compiles with `use strict', but in two places no strict refs is needed: +# maybe more problems are waiting... + +my %defaults = ( + globPrint => 0, + printUndef => 1, + tick => "auto", + unctrl => 'quote', + subdump => 1, + dumpReused => 0, + bareStringify => 1, + hashDepth => '', + arrayDepth => '', + dumpDBFiles => '', + dumpPackages => '', + quoteHighBit => '', + usageOnly => '', + compactDump => '', + veryCompact => '', + stopDbSignal => '', + ); + +sub new { + my $class = shift; + my %opt = (%defaults, @_); + bless \%opt, $class; +} + +sub set { + my $self = shift; + my %opt = @_; + @$self{keys %opt} = values %opt; +} + +sub get { + my $self = shift; + wantarray ? @$self{@_} : $$self{pop @_}; +} + +sub dumpValue { + my $self = shift; + die "usage: \$dumper->dumpValue(value)" unless @_ == 1; + local %address; + local $^W=0; + (print "undef\n"), return unless defined $_[0]; + (print $self->stringify($_[0]), "\n"), return unless ref $_[0]; + $self->unwrap($_[0],0); +} + +sub dumpValues { + my $self = shift; + local %address; + local $^W=0; + (print "undef\n"), return unless defined $_[0]; + $self->unwrap(\@_,0); +} + +# This one is good for variable names: + +sub unctrl { + local($_) = @_; + + return \$_ if ref \$_ eq "GLOB"; + s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg; + $_; +} + +sub stringify { + my $self = shift; + local $_ = shift; + my $noticks = shift; + my $tick = $self->{tick}; + + return 'undef' unless defined $_ or not $self->{printUndef}; + return $_ . "" if ref \$_ eq 'GLOB'; + { no strict 'refs'; + $_ = &{'overload::StrVal'}($_) + if $self->{bareStringify} and ref $_ + and defined %overload:: and defined &{'overload::StrVal'}; + } + + if ($tick eq 'auto') { + if (/[\000-\011\013-\037\177]/) { + $tick = '"'; + } else { + $tick = "'"; + } + } + if ($tick eq "'") { + s/([\'\\])/\\$1/g; + } elsif ($self->{unctrl} eq 'unctrl') { + s/([\"\\])/\\$1/g ; + s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg; + s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg + if $self->{quoteHighBit}; + } elsif ($self->{unctrl} eq 'quote') { + s/([\"\\\$\@])/\\$1/g if $tick eq '"'; + s/\033/\\e/g; + s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg; + } + s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $self->{quoteHighBit}; + ($noticks || /^\d+(\.\d*)?\Z/) + ? $_ + : $tick . $_ . $tick; +} + +sub DumpElem { + my ($self, $v) = (shift, shift); + my $short = $self->stringify($v, ref $v); + my $shortmore = ''; + if ($self->{veryCompact} && ref $v + && (ref $v eq 'ARRAY' and !grep(ref $_, @$v) )) { + my $depth = $#$v; + ($shortmore, $depth) = (' ...', $self->{arrayDepth} - 1) + if $self->{arrayDepth} and $depth >= $self->{arrayDepth}; + my @a = map $self->stringify($_), @$v[0..$depth]; + print "0..$#{$v} @a$shortmore\n"; + } elsif ($self->{veryCompact} && ref $v + && (ref $v eq 'HASH') and !grep(ref $_, values %$v)) { + my @a = sort keys %$v; + my $depth = $#a; + ($shortmore, $depth) = (' ...', $self->{hashDepth} - 1) + if $self->{hashDepth} and $depth >= $self->{hashDepth}; + my @b = map {$self->stringify($_) . " => " . $self->stringify($$v{$_})} + @a[0..$depth]; + local $" = ', '; + print "@b$shortmore\n"; + } else { + print "$short\n"; + $self->unwrap($v,shift); + } +} + +sub unwrap { + my $self = shift; + return if $DB::signal and $self->{stopDbSignal}; + my ($v) = shift ; + my ($s) = shift ; # extra no of spaces + my $sp; + my (%v,@v,$address,$short,$fileno); + + $sp = " " x $s ; + $s += 3 ; + + # Check for reused addresses + if (ref $v) { + my $val = $v; + { no strict 'refs'; + $val = &{'overload::StrVal'}($v) + if defined %overload:: and defined &{'overload::StrVal'}; + } + ($address) = $val =~ /(0x[0-9a-f]+)\)$/ ; + if (!$self->{dumpReused} && defined $address) { + $address{$address}++ ; + if ( $address{$address} > 1 ) { + print "${sp}-> REUSED_ADDRESS\n" ; + return ; + } + } + } elsif (ref \$v eq 'GLOB') { + $address = "$v" . ""; # To avoid a bug with globs + $address{$address}++ ; + if ( $address{$address} > 1 ) { + print "${sp}*DUMPED_GLOB*\n" ; + return ; + } + } + + if ( UNIVERSAL::isa($v, 'HASH') ) { + my @sortKeys = sort keys(%$v) ; + my $more; + my $tHashDepth = $#sortKeys ; + $tHashDepth = $#sortKeys < $self->{hashDepth}-1 ? $#sortKeys : $self->{hashDepth}-1 + unless $self->{hashDepth} eq '' ; + $more = "....\n" if $tHashDepth < $#sortKeys ; + my $shortmore = ""; + $shortmore = ", ..." if $tHashDepth < $#sortKeys ; + $#sortKeys = $tHashDepth ; + if ($self->{compactDump} && !grep(ref $_, values %{$v})) { + $short = $sp; + my @keys; + for (@sortKeys) { + push @keys, $self->stringify($_) . " => " . $self->stringify($v->{$_}); + } + $short .= join ', ', @keys; + $short .= $shortmore; + (print "$short\n"), return if length $short <= $self->{compactDump}; + } + for my $key (@sortKeys) { + return if $DB::signal and $self->{stopDbSignal}; + my $value = $ {$v}{$key} ; + print $sp, $self->stringify($key), " => "; + $self->DumpElem($value, $s); + } + print "$sp empty hash\n" unless @sortKeys; + print "$sp$more" if defined $more ; + } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) { + my $tArrayDepth = $#{$v} ; + my $more ; + $tArrayDepth = $#$v < $self->{arrayDepth}-1 ? $#$v : $self->{arrayDepth}-1 + unless $self->{arrayDepth} eq '' ; + $more = "....\n" if $tArrayDepth < $#{$v} ; + my $shortmore = ""; + $shortmore = " ..." if $tArrayDepth < $#{$v} ; + if ($self->{compactDump} && !grep(ref $_, @{$v})) { + if ($#$v >= 0) { + $short = $sp . "0..$#{$v} " . + join(" ", + map {$self->stringify($_)} @{$v}[0..$tArrayDepth]) + . "$shortmore"; + } else { + $short = $sp . "empty array"; + } + (print "$short\n"), return if length $short <= $self->{compactDump}; + } + for my $num ($[ .. $tArrayDepth) { + return if $DB::signal and $self->{stopDbSignal}; + print "$sp$num "; + $self->DumpElem($v->[$num], $s); + } + print "$sp empty array\n" unless @$v; + print "$sp$more" if defined $more ; + } elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) { + print "$sp-> "; + $self->DumpElem($$v, $s); + } elsif ( UNIVERSAL::isa($v, 'CODE') ) { + print "$sp-> "; + $self->dumpsub(0, $v); + } elsif ( UNIVERSAL::isa($v, 'GLOB') ) { + print "$sp-> ",$self->stringify($$v,1),"\n"; + if ($self->{globPrint}) { + $s += 3; + $self->dumpglob('', $s, "{$$v}", $$v, 1); + } elsif (defined ($fileno = fileno($v))) { + print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" ); + } + } elsif (ref \$v eq 'GLOB') { + if ($self->{globPrint}) { + $self->dumpglob('', $s, "{$v}", $v, 1); + } elsif (defined ($fileno = fileno(\$v))) { + print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" ); + } + } +} + +sub matchvar { + $_[0] eq $_[1] or + ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and + ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/}); +} + +sub compactDump { + my $self = shift; + $self->{compactDump} = shift if @_; + $self->{compactDump} = 6*80-1 + if $self->{compactDump} and $self->{compactDump} < 2; + $self->{compactDump}; +} + +sub veryCompact { + my $self = shift; + $self->{veryCompact} = shift if @_; + $self->compactDump(1) if !$self->{compactDump} and $self->{veryCompact}; + $self->{veryCompact}; +} + +sub set_unctrl { + my $self = shift; + if (@_) { + my $in = shift; + if ($in eq 'unctrl' or $in eq 'quote') { + $self->{unctrl} = $in; + } else { + print "Unknown value for `unctrl'.\n"; + } + } + $self->{unctrl}; +} + +sub set_quote { + my $self = shift; + if (@_ and $_[0] eq '"') { + $self->{tick} = '"'; + $self->{unctrl} = 'quote'; + } elsif (@_ and $_[0] eq 'auto') { + $self->{tick} = 'auto'; + $self->{unctrl} = 'quote'; + } elsif (@_) { # Need to set + $self->{tick} = "'"; + $self->{unctrl} = 'unctrl'; + } + $self->{tick}; +} + +sub dumpglob { + my $self = shift; + return if $DB::signal and $self->{stopDbSignal}; + my ($package, $off, $key, $val, $all) = @_; + local(*stab) = $val; + my $fileno; + if (($key !~ /^_</ or $self->{dumpDBFiles}) and defined $stab) { + print( (' ' x $off) . "\$", &unctrl($key), " = " ); + $self->DumpElem($stab, 3+$off); + } + if (($key !~ /^_</ or $self->{dumpDBFiles}) and defined @stab) { + print( (' ' x $off) . "\@$key = (\n" ); + $self->unwrap(\@stab,3+$off) ; + print( (' ' x $off) . ")\n" ); + } + if ($key ne "main::" && $key ne "DB::" && defined %stab + && ($self->{dumpPackages} or $key !~ /::$/) + && ($key !~ /^_</ or $self->{dumpDBFiles}) + && !($package eq "Dumpvalue" and $key eq "stab")) { + print( (' ' x $off) . "\%$key = (\n" ); + $self->unwrap(\%stab,3+$off) ; + print( (' ' x $off) . ")\n" ); + } + if (defined ($fileno = fileno(*stab))) { + print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" ); + } + if ($all) { + if (defined &stab) { + $self->dumpsub($off, $key); + } + } +} + +sub dumpsub { + my $self = shift; + my ($off,$sub) = @_; + $sub = $1 if $sub =~ /^\{\*(.*)\}$/; + my $subref = \&$sub; + my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub}) + || ($self->{subdump} && ($sub = $self->findsubs("$subref")) + && $DB::sub{$sub}); + $place = '???' unless defined $place; + print( (' ' x $off) . "&$sub in $place\n" ); +} + +sub findsubs { + my $self = shift; + return undef unless defined %DB::sub; + my ($addr, $name, $loc); + while (($name, $loc) = each %DB::sub) { + $addr = \&$name; + $subs{"$addr"} = $name; + } + $self->{subdump} = 0; + $subs{ shift() }; +} + +sub dumpvars { + my $self = shift; + my ($package,@vars) = @_; + local(%address,$^W); + my ($key,$val); + $package .= "::" unless $package =~ /::$/; + *stab = *main::; + + while ($package =~ /(\w+?::)/g) { + *stab = $ {stab}{$1}; + } + $self->{TotalStrings} = 0; + $self->{Strings} = 0; + $self->{CompleteTotal} = 0; + while (($key,$val) = each(%stab)) { + return if $DB::signal and $self->{stopDbSignal}; + next if @vars && !grep( matchvar($key, $_), @vars ); + if ($self->{usageOnly}) { + $self->globUsage(\$val, $key) + unless $package eq 'Dumpvalue' and $key eq 'stab'; + } else { + $self->dumpglob($package, 0,$key, $val); + } + } + if ($self->{usageOnly}) { + print <<EOP; +String space: $self->{TotalStrings} bytes in $self->{Strings} strings. +EOP + $self->{CompleteTotal} += $self->{TotalStrings}; + print <<EOP; +Grand total = $self->{CompleteTotal} bytes (1 level deep) + overhead. +EOP + } +} + +sub scalarUsage { + my $self = shift; + my $size = length($_[0]); + $self->{TotalStrings} += $size; + $self->{Strings}++; + $size; +} + +sub arrayUsage { # array ref, name + my $self = shift; + my $size = 0; + map {$size += $self->scalarUsage($_)} @{$_[0]}; + my $len = @{$_[0]}; + print "\@$_[1] = $len item", ($len > 1 ? "s" : ""), " (data: $size bytes)\n" + if defined $_[1]; + $self->{CompleteTotal} += $size; + $size; +} + +sub hashUsage { # hash ref, name + my $self = shift; + my @keys = keys %{$_[0]}; + my @values = values %{$_[0]}; + my $keys = $self->arrayUsage(\@keys); + my $values = $self->arrayUsage(\@values); + my $len = @keys; + my $total = $keys + $values; + print "\%$_[1] = $len item", ($len > 1 ? "s" : ""), + " (keys: $keys; values: $values; total: $total bytes)\n" + if defined $_[1]; + $total; +} + +sub globUsage { # glob ref, name + my $self = shift; + local *stab = *{$_[0]}; + my $total = 0; + $total += $self->scalarUsage($stab) if defined $stab; + $total += $self->arrayUsage(\@stab, $_[1]) if defined @stab; + $total += $self->hashUsage(\%stab, $_[1]) + if defined %stab and $_[1] ne "main::" and $_[1] ne "DB::"; + #and !($package eq "Dumpvalue" and $key eq "stab")); + $total; +} + +1; + +=head1 NAME + +Dumpvalue - provides screen dump of Perl data. + +=head1 SYNOPSYS + + use Dumpvalue; + my $dumper = new Dumpvalue; + $dumper->set(globPrint => 1); + $dumper->dumpValue(\*::); + $dumper->dumpvars('main'); + +=head1 DESCRIPTION + +=head2 Creation + +A new dumper is created by a call + + $d = new Dumpvalue(option1 => value1, option2 => value2) + +Recognized options: + +=over + +=item C<arrayDepth>, C<hashDepth> + +Print only first N elements of arrays and hashes. If false, prints all the +elements. + +=item C<compactDump>, C<veryCompact> + +Change style of array and hash dump. If true, short array +may be printed on one line. + +=item C<globPrint> + +Whether to print contents of globs. + +=item C<DumpDBFiles> + +Dump arrays holding contents of debugged files. + +=item C<DumpPackages> + +Dump symbol tables of packages. + +=item C<DumpReused> + +Dump contents of "reused" addresses. + +=item C<tick>, C<HighBit>, C<printUndef> + +Change style of string dump. Default value of C<tick> is C<auto>, one +can enable either double-quotish dump, or single-quotish by setting it +to C<"> or C<'>. By default, characters with high bit set are printed +I<as is>. + +=item C<UsageOnly> + +I<very> rudimentally per-package memory usage dump. If set, +C<dumpvars> calculates total size of strings in variables in the package. + +=item unctrl + +Changes the style of printout of strings. Possible values are +C<unctrl> and C<quote>. + +=item subdump + +Whether to try to find the subroutine name given the reference. + +=item bareStringify + +Whether to write the non-overloaded form of the stringify-overloaded objects. + +=item quoteHighBit + +Whether to print chars with high bit set in binary or "as is". + +=item stopDbSignal + +Whether to abort printing if debugger signal flag is raised. + +=back + +Later in the life of the object the methods may be queries with get() +method and set() method (which accept multiple arguments). + +=head2 Methods + +=over + +=item dumpValue + + $dumper->dumpValue($value); + $dumper->dumpValue([$value1, $value2]); + +=item dumpValues + + $dumper->dumpValues($value1, $value2); + +=item dumpvars + + $dumper->dumpvars('my_package'); + $dumper->dumpvars('my_package', 'foo', '~bar$', '!......'); + +The optional arguments are considered as literal strings unless they +start with C<~> or C<!>, in which case they are interpreted as regular +expressions (possibly negated). + +The second example prints entries with names C<foo>, and also entries +with names which ends on C<bar>, or are shorter than 5 chars. + +=item set_quote + + $d->set_quote('"'); + +Sets C<tick> and C<unctrl> options to suitable values for printout with the +given quote char. Possible values are C<auto>, C<'> and C<">. + +=item set_unctrl + + $d->set_unctrl('"'); + +Sets C<unctrl> option with checking for an invalid argument. +Possible values are C<unctrl> and C<quote>. + +=item compactDump + + $d->compactDump(1); + +Sets C<compactDump> option. If the value is 1, sets to a reasonable +big number. + +=item veryCompact + + $d->veryCompact(1); + +Sets C<compactDump> and C<veryCompact> options simultaneously. + +=item set + + $d->set(option1 => value1, option2 => value2); + +=item get + + @values = $d->get('option1', 'option2'); + +=back + +=cut + diff --git a/contrib/perl5/lib/English.pm b/contrib/perl5/lib/English.pm index bbb6bd7..9f29a48 100644 --- a/contrib/perl5/lib/English.pm +++ b/contrib/perl5/lib/English.pm @@ -15,6 +15,14 @@ English - use nice English (or awk) names for ugly punctuation variables =head1 DESCRIPTION +You should I<not> use this module in programs intended to be portable +among Perl versions, programs that must perform regular expression +matching operations efficiently, or libraries intended for use with +such programs. In a sense, this module is deprecated. The reasons +for this have to do with implementation details of the Perl +interpreter which are too thorny to go into here. Perhaps someday +they will be fixed to make "C<use English>" more practical. + This module provides aliases for the built-in variables whose names no one seems to like to read. Variables with side-effects which get triggered just by accessing them (like $0) will still @@ -160,6 +168,7 @@ sub import { *PERL_VERSION = *] ; *ACCUMULATOR = *^A ; + *COMPILING = *^C ; *DEBUGGING = *^D ; *SYSTEM_FD_MAX = *^F ; *INPLACE_EDIT = *^I ; diff --git a/contrib/perl5/lib/ExtUtils/Command.pm b/contrib/perl5/lib/ExtUtils/Command.pm index 2f5f1e1..e900e51 100644 --- a/contrib/perl5/lib/ExtUtils/Command.pm +++ b/contrib/perl5/lib/ExtUtils/Command.pm @@ -31,8 +31,8 @@ ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc. =head1 DESCRIPTION -The module is used in Win32 port to replace common UNIX commands. -Most commands are wrapers on generic modules File::Path and File::Basename. +The module is used in the Win32 port to replace common UNIX commands. +Most commands are wrappers on generic modules File::Path and File::Basename. =over 4 diff --git a/contrib/perl5/lib/ExtUtils/Embed.pm b/contrib/perl5/lib/ExtUtils/Embed.pm index e41ca40..4b56e88 100644 --- a/contrib/perl5/lib/ExtUtils/Embed.pm +++ b/contrib/perl5/lib/ExtUtils/Embed.pm @@ -416,7 +416,7 @@ This will print arguments for linking with B<libperl.a>, B<DynaLoader> and extensions found in B<$Config{static_ext}>. This includes libraries found in B<$Config{libs}> and the first ModuleName.a library for each extension that is found by searching B<@INC> or the path -specifed by the B<-I> option. +specified by the B<-I> option. In addition, when ModuleName.a is found, additional linker arguments are picked up from the B<extralibs.ld> file in the same directory. diff --git a/contrib/perl5/lib/ExtUtils/Install.pm b/contrib/perl5/lib/ExtUtils/Install.pm index 6a5c184..f75aa55 100644 --- a/contrib/perl5/lib/ExtUtils/Install.pm +++ b/contrib/perl5/lib/ExtUtils/Install.pm @@ -354,7 +354,7 @@ The argument is the value of MakeMaker's C<FULLEXT> key, like F<Tk/Canvas>. This function calls install() with the same arguments as the defaults the MakeMaker would use. -The argumement-less form is convenient for install scripts like +The argument-less form is convenient for install scripts like perl -MExtUtils::Install -e install_default Tk/Canvas diff --git a/contrib/perl5/lib/ExtUtils/Liblist.pm b/contrib/perl5/lib/ExtUtils/Liblist.pm index b072c12..dae3125 100644 --- a/contrib/perl5/lib/ExtUtils/Liblist.pm +++ b/contrib/perl5/lib/ExtUtils/Liblist.pm @@ -225,6 +225,9 @@ sub _win32_ext { my $search = 1; my($fullname, $thislib, $thispth); + # add "$Config{installarchlib}/CORE" to default search path + push @libpath, "$Config{installarchlib}/CORE"; + foreach (Text::ParseWords::quotewords('\s+', 0, $potential_libs)){ $thislib = $_; @@ -240,8 +243,8 @@ sub _win32_ext { # if searching is disabled, do compiler-specific translations unless ($search) { - s/^-L/-libpath:/ if $VC; s/^-l(.+)$/$1.lib/ unless $GC; + s/^-L/-libpath:/ if $VC; push(@extralibs, $_); $found++; next; @@ -575,7 +578,7 @@ Unix-OS/2 version in several respects: =item * Input library and path specifications are accepted with or without the -C<-l> and C<-L> prefices used by Unix linkers. If neither prefix is +C<-l> and C<-L> prefixes used by Unix linkers. If neither prefix is present, a token is considered a directory to search if it is in fact a directory, and a library to search for otherwise. Authors who wish their extensions to be portable to Unix or OS/2 should use the Unix @@ -586,7 +589,7 @@ prefixes, since the Unix-OS/2 version of ext() requires them. Wherever possible, shareable images are preferred to object libraries, and object libraries to plain object files. In accordance with VMS naming conventions, ext() looks for files named I<lib>shr and I<lib>rtl; -it also looks for I<lib>lib and libI<lib> to accomodate Unix conventions +it also looks for I<lib>lib and libI<lib> to accommodate Unix conventions used in some ported software. =item * @@ -625,14 +628,15 @@ Unix-OS/2 version in several respects: If C<$potential_libs> is empty, the return value will be empty. Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) will be appended to the list of C<$potential_libs>. The libraries -will be searched for in the directories specified in C<$potential_libs> -as well as in C<$Config{libpth}>. For each library that is found, a -space-separated list of fully qualified library pathnames is generated. +will be searched for in the directories specified in C<$potential_libs>, +C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +For each library that is found, a space-separated list of fully qualified +library pathnames is generated. =item * Input library and path specifications are accepted with or without the -C<-l> and C<-L> prefices used by Unix linkers. +C<-l> and C<-L> prefixes used by Unix linkers. An entry of the form C<-La:\foo> specifies the C<a:\foo> directory to look for the libraries that follow. @@ -651,7 +655,7 @@ library to search for otherwise. The C<$Config{lib_ext}> suffix will be appended to any entries that are not directories and don't already have the suffix. -Note that the C<-L> and <-l> prefixes are B<not required>, but authors +Note that the C<-L> and C<-l> prefixes are B<not required>, but authors who wish their extensions to be portable to Unix or OS/2 should use the prefixes, since the Unix-OS/2 version of ext() requires them. diff --git a/contrib/perl5/lib/ExtUtils/MM_OS2.pm b/contrib/perl5/lib/ExtUtils/MM_OS2.pm index 8bddb42..5d6034c 100644 --- a/contrib/perl5/lib/ExtUtils/MM_OS2.pm +++ b/contrib/perl5/lib/ExtUtils/MM_OS2.pm @@ -15,6 +15,7 @@ sub dlsyms { my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}; my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; + my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || []; my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {}; my(@m); (my $boot = $self->{NAME}) =~ s/:/_/g; @@ -27,14 +28,46 @@ $self->{BASEEXT}.def: Makefile.PL Mksymlists("NAME" => "', $self->{NAME}, '", "DLBASE" => "',$self->{DLBASE}, '", "DL_FUNCS" => ',neatvalue($funcs), + ', "FUNCLIST" => ',neatvalue($funclist), ', "IMPORTS" => ',neatvalue($imports), ', "VERSION" => "',$self->{VERSION}, '", "DL_VARS" => ', neatvalue($vars), ');\' '); } + if (%{$self->{IMPORTS}}) { + # Make import files (needed for static build) + -d 'tmp_imp' or mkdir 'tmp_imp', 0777 or die "Can't mkdir tmp_imp"; + open IMP, '>tmpimp.imp' or die "Can't open tmpimp.imp"; + my ($name, $exp); + while (($name, $exp)= each %{$self->{IMPORTS}}) { + my ($lib, $id) = ($exp =~ /(.*)\.(.*)/) or die "Malformed IMPORT `$exp'"; + print IMP "$name $lib $id ?\n"; + } + close IMP or die "Can't close tmpimp.imp"; + # print "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp\n"; + system "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp" + and die "Cannot make import library: $!, \$?=$?"; + unlink <tmp_imp/*>; + system "cd tmp_imp; $Config::Config{ar} x ../tmpimp$Config::Config{lib_ext}" + and die "Cannot extract import objects: $!, \$?=$?"; + } join('',@m); } +sub static_lib { + my($self) = @_; + my $old = $self->ExtUtils::MM_Unix::static_lib(); + return $old unless %{$self->{IMPORTS}}; + + my @chunks = split /\n{2,}/, $old; + shift @chunks unless length $chunks[0]; # Empty lines at the start + $chunks[0] .= <<'EOC'; + + $(AR) $(AR_STATIC_ARGS) $@ tmp_imp/* && $(RANLIB) $@ +EOC + return join "\n\n". '', @chunks; +} + sub replace_manpage_separator { my($self,$man) = @_; $man =~ s,/+,.,g; diff --git a/contrib/perl5/lib/ExtUtils/MM_Unix.pm b/contrib/perl5/lib/ExtUtils/MM_Unix.pm index 9a96504..38bb061 100644 --- a/contrib/perl5/lib/ExtUtils/MM_Unix.pm +++ b/contrib/perl5/lib/ExtUtils/MM_Unix.pm @@ -8,7 +8,7 @@ use strict; use vars qw($VERSION $Is_Mac $Is_OS2 $Is_VMS $Is_Win32 $Is_Dos $Is_PERL_OBJECT $Verbose %pm %static $Xsubpp_Version); -$VERSION = substr q$Revision: 1.12601 $, 10; +$VERSION = substr q$Revision: 1.12602 $, 10; # $Id: MM_Unix.pm,v 1.126 1998/06/28 21:32:49 k Exp k $ Exporter::import('ExtUtils::MakeMaker', @@ -19,7 +19,7 @@ $Is_Mac = $^O eq 'MacOS'; $Is_Win32 = $^O eq 'MSWin32'; $Is_Dos = $^O eq 'dos'; -$Is_PERL_OBJECT = 1 if $Config{'ccflags'} =~ /-DPERL_OBJECT/; +$Is_PERL_OBJECT = $Config{'ccflags'} =~ /-DPERL_OBJECT/; if ($Is_VMS = $^O eq 'VMS') { require VMS::Filespec; @@ -84,10 +84,10 @@ sub canonpath { if ( $^O eq 'qnx' && $path =~ s|^(//\d+)/|/| ) { $node = $1; } - $path =~ s|/+|/|g ; # xx////xx -> xx/xx + $path =~ s|(?<=[^/])/+|/|g ; # xx////xx -> xx/xx $path =~ s|(/\.)+/|/|g ; # xx/././xx -> xx/xx $path =~ s|^(\./)+|| unless $path eq "./"; # ./xx -> xx - $path =~ s|/$|| unless $path eq "/"; # xx/ -> xx + $path =~ s|(?<=[^/])/$|| ; # xx/ -> xx "$node$path"; } @@ -233,6 +233,7 @@ sub ExtUtils::MM_Unix::tools_other ; sub ExtUtils::MM_Unix::top_targets ; sub ExtUtils::MM_Unix::writedoc ; sub ExtUtils::MM_Unix::xs_c ; +sub ExtUtils::MM_Unix::xs_cpp ; sub ExtUtils::MM_Unix::xs_o ; sub ExtUtils::MM_Unix::xsubpp_version ; @@ -374,9 +375,9 @@ sub cflags { $self->{uc $_} ||= $cflags{$_} } - if ($self->{CAPI} && $Is_PERL_OBJECT == 1) { + if ($self->{CAPI} && $Is_PERL_OBJECT) { $self->{CCFLAGS} =~ s/-DPERL_OBJECT(\s|$)//; - $self->{CCFLAGS} .= '-DPERL_CAPI'; + $self->{CCFLAGS} .= ' -DPERL_CAPI '; if ($Is_Win32 && $Config{'cc'} =~ /^cl.exe/i) { # Turn off C++ mode of the MSC compiler $self->{CCFLAGS} =~ s/-TP(\s|$)//; @@ -818,7 +819,7 @@ ci : =item dist_core (o) -Defeines the targets dist, tardist, zipdist, uutardist, shdist +Defines the targets dist, tardist, zipdist, uutardist, shdist =cut @@ -915,6 +916,7 @@ sub dlsyms { my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}; my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; + my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || []; my(@m); push(@m," @@ -931,7 +933,8 @@ static :: $self->{BASEEXT}.exp $self->{BASEEXT}.exp: Makefile.PL ",' $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e \'use ExtUtils::Mksymlists; \\ Mksymlists("NAME" => "',$self->{NAME},'", "DL_FUNCS" => ', - neatvalue($funcs),', "DL_VARS" => ', neatvalue($vars), ');\' + neatvalue($funcs), ', "FUNCLIST" => ', neatvalue($funclist), + ', "DL_VARS" => ', neatvalue($vars), ');\' '); join('',@m); @@ -2018,7 +2021,7 @@ uninstall_from_sitedirs :: =item installbin (o) -Defines targets to install EXE_FILES. +Defines targets to make and to install EXE_FILES. =cut @@ -2045,7 +2048,7 @@ EXE_FILES = @{$self->{EXE_FILES}} } : q{FIXIN = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::MakeMaker \ -e "MY->fixin(shift)" }).qq{ -all :: @to +pure_all :: @to $self->{NOECHO}\$(NOOP) realclean :: @@ -2347,7 +2350,7 @@ $tmp/perlmain\$(OBJ_EXT): $tmp/perlmain.c $tmp/perlmain.c: $makefilename}, q{ }.$self->{NOECHO}.q{echo Writing $@ }.$self->{NOECHO}.q{$(PERL) $(MAP_PERLINC) -MExtUtils::Miniperl \\ - -e "writemain(grep s#.*/auto/##, qw|$(MAP_STATIC)|)" > $@t && $(MV) $@t $@ + -e "writemain(grep s#.*/auto/##, split(q| |, q|$(MAP_STATIC)|))" > $@t && $(MV) $@t $@ }; push @m, "\t",$self->{NOECHO}.q{$(PERL) $(INSTALLSCRIPT)/fixpmain @@ -2746,10 +2749,13 @@ sub ppd { push(@m, "\t\@\$(PERL) -e \"print qq{<SOFTPKG NAME=\\\"$self->{DISTNAME}\\\" VERSION=\\\"$pack_ver\\\">\\n}"); push(@m, ". qq{\\t<TITLE>$self->{DISTNAME}</TITLE>\\n}"); my $abstract = $self->{ABSTRACT}; + $abstract =~ s/\n/\\n/sg; $abstract =~ s/</</g; $abstract =~ s/>/>/g; push(@m, ". qq{\\t<ABSTRACT>$abstract</ABSTRACT>\\n}"); my ($author) = $self->{AUTHOR}; + $author =~ s/</</g; + $author =~ s/>/>/g; $author =~ s/@/\\@/g; push(@m, ". qq{\\t<AUTHOR>$author</AUTHOR>\\n}"); push(@m, ". qq{\\t<IMPLEMENTATION>\\n}"); @@ -2757,9 +2763,11 @@ sub ppd { foreach $prereq (sort keys %{$self->{PREREQ_PM}}) { my $pre_req = $prereq; $pre_req =~ s/::/-/g; - push(@m, ". qq{\\t\\t<DEPENDENCY NAME=\\\"$pre_req\\\" />\\n}"); + my ($dep_ver) = join ",", (split (/\./, $self->{PREREQ_PM}{$prereq}), (0) x 4) [0 .. 3]; + push(@m, ". qq{\\t\\t<DEPENDENCY NAME=\\\"$pre_req\\\" VERSION=\\\"$dep_ver\\\" />\\n}"); } push(@m, ". qq{\\t\\t<OS NAME=\\\"\$(OSNAME)\\\" />\\n}"); + push(@m, ". qq{\\t\\t<ARCHITECTURE NAME=\\\"$Config{'archname'}\\\" />\\n}"); my ($bin_location) = $self->{BINARY_LOCATION}; $bin_location =~ s/\\/\\\\/g; if ($self->{PPM_INSTALL_SCRIPT}) { @@ -2783,7 +2791,7 @@ Returns the attribute C<PERM_RW> or the string C<644>. Used as the string that is passed to the C<chmod> command to set the permissions for read/writeable files. MakeMaker chooses C<644> because it has turned out in the past that -relying on the umask provokes hard-to-track bugreports. +relying on the umask provokes hard-to-track bug reports. When the return value is used by the perl function C<chmod>, it is interpreted as an octal value. @@ -2889,13 +2897,18 @@ sub processPL { return "" unless $self->{PL_FILES}; my(@m, $plfile); foreach $plfile (sort keys %{$self->{PL_FILES}}) { + my $list = ref($self->{PL_FILES}->{$plfile}) + ? $self->{PL_FILES}->{$plfile} + : [$self->{PL_FILES}->{$plfile}]; + foreach $target (@$list) { push @m, " -all :: $self->{PL_FILES}->{$plfile} +all :: $target $self->{NOECHO}\$(NOOP) -$self->{PL_FILES}->{$plfile} :: $plfile - \$(PERL) -I\$(INST_ARCHLIB) -I\$(INST_LIB) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) $plfile +$target :: $plfile + \$(PERL) -I\$(INST_ARCHLIB) -I\$(INST_LIB) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) $plfile $target "; + } } join "", @m; } @@ -2943,7 +2956,11 @@ form Foo/Bar and replaces the slash with C<::>. Returns the replacement. sub replace_manpage_separator { my($self,$man) = @_; - $man =~ s,/+,::,g; + if ($^O eq 'uwin') { + $man =~ s,/+,.,g; + } else { + $man =~ s,/+,::,g; + } $man; } @@ -3304,7 +3321,7 @@ sub tool_xsubpp { } } - $xsubpp = $self->{CAPI} ? "xsubpp -object_capi" : "xsubpp"; + my $xsubpp = $self->{CAPI} ? "xsubpp -object_capi" : "xsubpp"; return qq{ XSUBPPDIR = $xsdir @@ -3454,7 +3471,7 @@ Version_check: =item writedoc -Obsolete, depecated method. Not used since Version 5.21. +Obsolete, deprecated method. Not used since Version 5.21. =cut @@ -3478,7 +3495,22 @@ sub xs_c { return '' unless $self->needs_linking(); ' .xs.c: - $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >$*.tc && $(MV) $*.tc $@ + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >xstmp.c && $(MV) xstmp.c $*.c +'; +} + +=item xs_cpp (o) + +Defines the suffix rules to compile XS files to C++. + +=cut + +sub xs_cpp { + my($self) = shift; + return '' unless $self->needs_linking(); + ' +.xs.cpp: + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >xstmp.c && $(MV) xstmp.c $*.cpp '; } @@ -3509,6 +3541,7 @@ and Win32 do. sub perl_archive { + return '$(PERL_INC)' . "/$Config{libperl}" if $^O eq "beos"; return ""; } diff --git a/contrib/perl5/lib/ExtUtils/MM_VMS.pm b/contrib/perl5/lib/ExtUtils/MM_VMS.pm index d7e59c2..8f8ac17 100644 --- a/contrib/perl5/lib/ExtUtils/MM_VMS.pm +++ b/contrib/perl5/lib/ExtUtils/MM_VMS.pm @@ -3,7 +3,7 @@ # This package is inserted into @ISA of MakeMaker's MM before the # built-in ExtUtils::MM_Unix methods if MakeMaker.pm is run under VMS. # -# Author: Charles Bailey bailey@genetics.upenn.edu +# Author: Charles Bailey bailey@newman.upenn.edu package ExtUtils::MM_VMS; @@ -14,7 +14,7 @@ use VMS::Filespec; use File::Basename; use vars qw($Revision); -$Revision = '5.42 (31-Mar-1997)'; +$Revision = '5.52 (12-Sep-1998)'; unshift @MM::ISA, 'ExtUtils::MM_VMS'; @@ -829,7 +829,7 @@ sub cflags { $quals =~ s/ -$type$def\s*//; $def =~ s/"/""/g; if ($type eq 'D') { $definestr .= qq["$def",]; } - elsif ($type eq 'I') { $flagincstr .= ',' . $self->fixpath($def,1); } + elsif ($type eq 'I') { $incstr .= ',' . $self->fixpath($def,1); } else { $undefstr .= qq["$def",]; } } } @@ -869,7 +869,7 @@ sub cflags { my(@includes) = split(/\s+/,$self->{INC}); foreach (@includes) { s/^-I//; - $incstr .= ', '.$self->fixpath($_,1); + $incstr .= ','.$self->fixpath($_,1); } } $quals .= "$incstr)"; @@ -1322,6 +1322,7 @@ sub dlsyms { my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}; my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; + my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || []; my(@m); unless ($self->{SKIPHASH}{'dynamic'}) { @@ -1343,7 +1344,8 @@ $(INST_ARCHAUTODIR)$(BASEEXT).opt : $(BASEEXT).opt $(BASEEXT).opt : Makefile.PL $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::Mksymlists;" - ',qq[-e "Mksymlists('NAME' => '$self->{NAME}', 'DL_FUNCS' => ], - neatvalue($funcs),q[, 'DL_VARS' => ],neatvalue($vars),')" + neatvalue($funcs),q[, 'DL_VARS' => ],neatvalue($vars), + q[, 'FUNCLIST' => ],neatvalue($funclist),')" $(PERL) -e "print ""$(INST_STATIC)/Include=$(BASEEXT)\n$(INST_STATIC)/Library\n"";" >>$(MMS$TARGET) '); @@ -1389,7 +1391,7 @@ INST_DYNAMIC_DEP = $inst_dynamic_dep push @m, ' $(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt $(INST_ARCHAUTODIR).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) $(NOECHO) $(MKPATH) $(INST_ARCHAUTODIR) - $(NOECHO) If F$TrnLNm("',$shr,'").eqs."" Then Define/NoLog/User ',"$shr Sys\$Share:$shr.$Config{'dlext'}",' + If F$TrnLNm("',$shr,'").eqs."" Then Define/NoLog/User ',"$shr Sys\$Share:$shr.$Config{'dlext'}",' Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,$(PERL_INC)perlshr_attr.opt/Option '; @@ -1441,7 +1443,7 @@ $(INST_STATIC) : $(NOECHO) $(NOOP) ' unless ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB}); - my(@m); + my(@m,$lib); push @m,' # Rely on suffix rule for update action $(OBJECT) : $(INST_ARCHAUTODIR).exists @@ -1463,7 +1465,10 @@ $(INST_STATIC) : $(OBJECT) $(MYEXTLIB) push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)',"\n"); } - push(@m,"\t",'$(NOECHO) $(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR)extralibs.ld\';print F qq{$(EXTRALIBS)\n};close F;"',"\n"); + foreach $lib (split $self->{EXTRALIBS}) { + $lib = '""' if $lib eq '"'; + push(@m,"\t",'$(NOECHO) $(PERL) -e "print qq{',$lib,'\n}" >>$(INST_ARCHAUTODIR)extralibs.ld',"\n"); + } push @m, $self->dir_target('$(INST_ARCHAUTODIR)'); join('',@m); } @@ -1530,15 +1535,20 @@ sub processPL { return "" unless $self->{PL_FILES}; my(@m, $plfile); foreach $plfile (sort keys %{$self->{PL_FILES}}) { - my $vmsplfile = vmsify($plfile); - my $vmsfile = vmsify($self->{PL_FILES}->{$plfile}); - push @m, " + my $list = ref($self->{PL_FILES}->{$plfile}) + ? $self->{PL_FILES}->{$plfile} + : [$self->{PL_FILES}->{$plfile}]; + foreach $target (@$list) { + my $vmsplfile = vmsify($plfile); + my $vmsfile = vmsify($target); + push @m, " all :: $vmsfile \$(NOECHO) \$(NOOP) $vmsfile :: $vmsplfile -",' $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" '," $vmsplfile +",' $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" '," $vmsplfile $vmsfile "; + } } join "", @m; } @@ -2188,7 +2198,8 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) } - my($linkcmd,@staticopts,@staticpkgs,$extralist,$targdir,$libperldir); + my($linkcmd,@optlibs,@staticpkgs,$extralist,$targdir,$libperldir,%libseen); + local($_); # The front matter of the linkcommand... $linkcmd = join ' ', $Config{'ld'}, @@ -2251,28 +2262,46 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) # (e.g. Intuit::DWIM will precede Intuit, so unresolved # references from [.intuit.dwim]dwim.obj can be found # in [.intuit]intuit.olb). - for (sort keys %olbs) { + for (sort { length($a) <=> length($b) } keys %olbs) { next unless $olbs{$_} =~ /\Q$self->{LIB_EXT}\E$/; my($dir) = $self->fixpath($_,1); my($extralibs) = $dir . "extralibs.ld"; my($extopt) = $dir . $olbs{$_}; $extopt =~ s/$self->{LIB_EXT}$/.opt/; + push @optlibs, "$dir$olbs{$_}"; + # Get external libraries this extension will need if (-f $extralibs ) { + my %seenthis; open LIST,$extralibs or warn $!,next; - push @$extra, <LIST>; + while (<LIST>) { + chomp; + # Include a library in the link only once, unless it's mentioned + # multiple times within a single extension's options file, in which + # case we assume the builder needed to search it again later in the + # link. + my $skip = exists($libseen{$_}) && !exists($seenthis{$_}); + $libseen{$_}++; $seenthis{$_}++; + next if $skip; + push @$extra,$_; + } close LIST; } + # Get full name of extension for ExtUtils::Miniperl if (-f $extopt) { open OPT,$extopt or die $!; while (<OPT>) { next unless /(?:UNIVERSAL|VECTOR)=boot_([\w_]+)/; - # ExtUtils::Miniperl expects Unix paths - (my($pkg) = "$1_$1$self->{LIB_EXT}") =~ s#_*#/#g; + my $pkg = $1; + $pkg =~ s#__*#::#g; push @staticpkgs,$pkg; } - push @staticopts, $extopt; } } + # Place all of the external libraries after all of the Perl extension + # libraries in the final link, in order to maximize the opportunity + # for XS code from multiple extensions to resolve symbols against the + # same external library while only including that library once. + push @optlibs, @$extra; $target = "Perl$Config{'exe_ext'}" unless $target; ($shrtarget,$targdir) = fileparse($target); @@ -2281,11 +2310,11 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) $target = "Perlshr.$Config{'dlext'}" unless $target; $tmp = "[]" unless $tmp; $tmp = $self->fixpath($tmp,1); - if (@$extra) { - $extralist = join(' ',@$extra); - $extralist =~ s/[,\s\n]+/, /g; - } - else { $extralist = ''; } + if (@optlibs) { $extralist = join(' ',@optlibs); } + else { $extralist = ''; } + # Let ExtUtils::Liblist find the necessary for us (but skip PerlShr; + # that's what we're building here). + push @optlibs, grep { !/PerlShr/i } split +($self->ext())[2]; if ($libperl) { unless (-f $libperl || -f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',$libperl))) { print STDOUT "Warning: $libperl not found\n"; @@ -2309,19 +2338,22 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) MAP_TARGET = ',$self->fixpath($target,0),' MAP_SHRTARGET = ',$self->fixpath($shrtarget,0)," MAP_LINKCMD = $linkcmd -MAP_PERLINC = ", $perlinc ? map('"$_" ',@{$perlinc}) : '',' -# We use the linker options files created with each extension, rather than -#specifying the object files directly on the command line. -MAP_STATIC = ',@staticopts ? join(' ', @staticopts) : '',' -MAP_OPTS = ',@staticopts ? ','.join(',', map($_.'/Option', @staticopts)) : ''," +MAP_PERLINC = ", $perlinc ? map('"$_" ',@{$perlinc}) : ''," MAP_EXTRA = $extralist MAP_LIBPERL = ",$self->fixpath($libperl,0),' '; - push @m,' -$(MAP_SHRTARGET) : $(MAP_LIBPERL) $(MAP_STATIC) ',"${libperldir}Perlshr_Attr.Opt",' - $(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_OPTS), $(MAP_EXTRA), $(MAP_LIBPERL) ',"${libperldir}Perlshr_Attr.Opt",' + push @m,"\n${tmp}Makeaperl.Opt : \$(MAP_EXTRA)\n"; + foreach (@optlibs) { + push @m,' $(NOECHO) $(PERL) -e "print q{',$_,'}" >>$(MMS$TARGET)',"\n"; + } + push @m,"\n${tmp}PerlShr.Opt :\n\t"; + push @m,'$(NOECHO) $(PERL) -e "print q{$(MAP_SHRTARGET)}" >$(MMS$TARGET)',"\n"; + +push @m,' +$(MAP_SHRTARGET) : $(MAP_LIBPERL) Makeaperl.Opt ',"${libperldir}Perlshr_Attr.Opt",' + $(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_LIBPERL), Makeaperl.Opt/Option ',"${libperldir}Perlshr_Attr.Opt/Option",' $(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmp}perlmain\$(OBJ_EXT) ${tmp}PerlShr.Opt",' $(MAP_LINKCMD) ',"${tmp}perlmain\$(OBJ_EXT)",', PerlShr.Opt/Option $(NOECHO) $(SAY) "To install the new ""$(MAP_TARGET)"" binary, say" @@ -2329,13 +2361,17 @@ $(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmp}perlmain\$(OBJ_EXT) ${tmp}PerlShr.Opt" $(NOECHO) $(SAY) "To remove the intermediate files, say $(NOECHO) $(SAY) " $(MMS)$(MMSQUALIFIERS)$(USEMAKEFILE)$(MAKEFILE) map_clean" '; - push @m,' -',"${tmp}perlmain.c",' : $(MAKEFILE) - $(NOECHO) $(PERL) $(MAP_PERLINC) -e "use ExtUtils::Miniperl; writemain(qw|',@staticpkgs,'|)" >$(MMS$TARGET) -'; + push @m,"\n${tmp}perlmain.c : \$(MAKEFILE)\n\t\$(NOECHO) \$(PERL) -e 1 >${tmp}Writemain.tmp\n"; + push @m, "# More from the 255-char line length limit\n"; + foreach (@staticpkgs) { + push @m,' $(NOECHO) $(PERL) -e "print q{',$_,qq[}" >>${tmp}Writemain.tmp\n]; + } + push @m,' + $(NOECHO) $(PERL) $(MAP_PERLINC) -ane "use ExtUtils::Miniperl; writemain(@F)" ',$tmp,'Writemain.tmp >$(MMS$TARGET) + $(NOECHO) $(RM_F) ',"${tmp}Writemain.tmp\n"; push @m, q[ -# More from the 255-char line length limit +# Still more from the 255-char line length limit doc_inst_perl : $(NOECHO) $(PERL) -e "print 'Perl binary $(MAP_TARGET)|'" >.MM_tmp $(NOECHO) $(PERL) -e "print 'MAP_STATIC|$(MAP_STATIC)|'" >>.MM_tmp @@ -2358,7 +2394,7 @@ clean :: map_clean map_clean : \$(RM_F) ${tmp}perlmain\$(OBJ_EXT) ${tmp}perlmain.c \$(MAKEFILE) - \$(RM_F) ${tmp}PerlShr.Opt \$(MAP_TARGET) + \$(RM_F) ${tmp}Makeaperl.Opt ${tmp}PerlShr.Opt \$(MAP_TARGET) "; join '', @m; diff --git a/contrib/perl5/lib/ExtUtils/MM_Win32.pm b/contrib/perl5/lib/ExtUtils/MM_Win32.pm index a1226b5..4070b2e 100644 --- a/contrib/perl5/lib/ExtUtils/MM_Win32.pm +++ b/contrib/perl5/lib/ExtUtils/MM_Win32.pm @@ -33,6 +33,7 @@ $BORLAND = 1 if $Config{'cc'} =~ /^bcc/i; $GCC = 1 if $Config{'cc'} =~ /^gcc/i; $DMAKE = 1 if $Config{'make'} =~ /^dmake/i; $NMAKE = 1 if $Config{'make'} =~ /^nmake/i; +$PERLMAKE = 1 if $Config{'make'} =~ /^pmake/i; $OBJ = 1 if $Config{'ccflags'} =~ /PERL_OBJECT/i; sub dlsyms { @@ -40,6 +41,7 @@ sub dlsyms { my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}; my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; + my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || []; my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {}; my(@m); (my $boot = $self->{NAME}) =~ s/:/_/g; @@ -52,6 +54,7 @@ $self->{BASEEXT}.def: Makefile.PL -e "Mksymlists('NAME' => '!, $self->{NAME}, q!', 'DLBASE' => '!,$self->{DLBASE}, q!', 'DL_FUNCS' => !,neatvalue($funcs), + q!, 'FUNCLIST' => !,neatvalue($funclist), q!, 'IMPORTS' => !,neatvalue($imports), q!, 'DL_VARS' => !, neatvalue($vars), q!);" !); @@ -445,11 +448,18 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)\.exists $(LD) -o $@ -Wl,--base-file -Wl,dll.base $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp dlltool --def $(EXPORT_LIST) --base-file dll.base --output-exp dll.exp $(LD) -o $@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp }); - } else { - push(@m, $BORLAND ? - q{ $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) }.$ldfrom.q{,$@,,$(PERL_ARCHIVE:s,/,\,) $(LDLOADLIBS:s,/,\,) $(MYEXTLIB:s,/,\,),$(EXPORT_LIST:s,/,\,),$(RESFILES)} : - q{ $(LD) -out:$@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) -def:$(EXPORT_LIST)} - ); + } elsif ($BORLAND) { + push(@m, + q{ $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) }.$ldfrom.q{,$@,,} + .($DMAKE ? q{$(PERL_ARCHIVE:s,/,\,) $(LDLOADLIBS:s,/,\,) } + .q{$(MYEXTLIB:s,/,\,),$(EXPORT_LIST:s,/,\,)} + : q{$(subst /,\,$(PERL_ARCHIVE)) $(subst /,\,$(LDLOADLIBS)) } + .q{$(subst /,\,$(MYEXTLIB)),$(subst /,\,$(EXPORT_LIST))}) + .q{,$(RESFILES)}); + } else { # VC + push(@m, + q{ $(LD) -out:$@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) } + .q{$(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) -def:$(EXPORT_LIST)}); } push @m, ' $(CHMOD) 755 $@ @@ -463,7 +473,7 @@ sub perl_archive { my ($self) = @_; if($OBJ) { - if ($self->{CAPI} eq 'TRUE') { + if ($self->{CAPI}) { return '$(PERL_INC)\perlCAPI$(LIB_EXT)'; } } @@ -524,10 +534,11 @@ sub pm_to_blib { pm_to_blib: $(TO_INST_PM) }.$self->{NOECHO}.q{$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" \ "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Install \ - -e "pm_to_blib(qw[ }. - ($NMAKE ? '<<pmfiles.dat' - : '$(mktmp,pmfiles.dat $(PM_TO_BLIB:s,\\,\\\\,)\n)'). - q{ ],'}.$autodir.q{')" + -e "pm_to_blib(}. + ($NMAKE ? 'qw[ <<pmfiles.dat ],' + : $DMAKE ? 'qw[ $(mktmp,pmfiles.dat $(PM_TO_BLIB:s,\\,\\\\,)\n) ],' + : '{ qw[$(PM_TO_BLIB)] },' + ).q{'}.$autodir.q{')" }. ($NMAKE ? q{ $(PM_TO_BLIB) << diff --git a/contrib/perl5/lib/ExtUtils/MakeMaker.pm b/contrib/perl5/lib/ExtUtils/MakeMaker.pm index 5b7bb0b..08a1c66 100644 --- a/contrib/perl5/lib/ExtUtils/MakeMaker.pm +++ b/contrib/perl5/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 = $VERSION = "5.4301"; +$VERSION = "5.4302"; $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+$//; @@ -35,9 +35,7 @@ use vars qw( # @ISA = qw(Exporter); @EXPORT = qw(&WriteMakefile &writeMakefile $Verbose &prompt); -@EXPORT_OK = qw($VERSION &Version_check &neatvalue &mkbootstrap &mksymlists - $Version); - # $Version in mixed case will go away! +@EXPORT_OK = qw($VERSION &Version_check &neatvalue &mkbootstrap &mksymlists); # # Dummy package MM inherits actual methods from OS-specific @@ -73,10 +71,6 @@ $Is_OS2 = $^O eq 'os2'; $Is_Mac = $^O eq 'MacOS'; $Is_Win32 = $^O eq 'MSWin32'; -# This is for module authors to query, so they can enable 'CAPI' => 'TRUE' -# in their Makefile.pl -$CAPI_support = 1; - require ExtUtils::MM_Unix; if ($Is_VMS) { @@ -192,7 +186,7 @@ sub prompt ($;$) { } else { print "$def\n"; } - return $ans || $def; + return ($ans ne '') ? $ans : $def; } sub eval_in_subdirs { @@ -241,29 +235,23 @@ sub full_setup { @Attrib_help = qw/ - AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION LICENSE_HREF CAPI - C CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DL_FUNCS DL_VARS - EXE_FILES EXCLUDE_EXT INCLUDE_EXT NO_VC FIRST_MAKEFILE FULLPERL H - INC INSTALLARCHLIB INSTALLBIN INSTALLDIRS INSTALLMAN1DIR + AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION + C CAPI CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DL_FUNCS DL_VARS + EXCLUDE_EXT EXE_FILES FIRST_MAKEFILE FULLPERL FUNCLIST H IMPORTS + INC INCLUDE_EXT INSTALLARCHLIB INSTALLBIN INSTALLDIRS INSTALLMAN1DIR INSTALLMAN3DIR INSTALLPRIVLIB INSTALLSCRIPT INSTALLSITEARCH INSTALLSITELIB INST_ARCHLIB INST_BIN INST_EXE INST_LIB - INST_MAN1DIR INST_MAN3DIR INST_SCRIPT LDFROM LIBPERL_A LIB LIBS + INST_MAN1DIR INST_MAN3DIR INST_SCRIPT LDFROM LIB LIBPERL_A LIBS LINKTYPE MAKEAPERL MAKEFILE MAN1PODS MAN3PODS MAP_TARGET MYEXTLIB - NAME NEEDS_LINKING NOECHO NORECURS OBJECT OPTIMIZE PERL PERLMAINCC + NAME NEEDS_LINKING NOECHO NORECURS NO_VC OBJECT OPTIMIZE PERL PERLMAINCC PERL_ARCHLIB PERL_LIB PERL_SRC PERM_RW PERM_RWX - PL_FILES PM PMLIBDIRS PREFIX + PL_FILES PM PMLIBDIRS PPM_INSTALL_EXEC PPM_INSTALL_SCRIPT PREFIX PREREQ_PM SKIP TYPEMAPS VERSION VERSION_FROM XS XSOPT XSPROTOARG XS_VERSION clean depend dist dynamic_lib linkext macro realclean - tool_autosplit PPM_INSTALL_SCRIPT PPM_INSTALL_EXEC - - IMPORTS - - installpm + tool_autosplit /; - # IMPORTS is used under OS/2 - - # ^^^ installpm is deprecated, will go about Summer 96 + # IMPORTS is used under OS/2 and Win32 # @Overridable is close to @MM_Sections but not identical. The # order is important. Many subroutines declare macros. These @@ -428,6 +416,7 @@ sub ExtUtils::MakeMaker::new { } my $newclass = ++$PACKNAME; + local @Parent = @Parent; # Protect against non-local exits { # no strict; print "Blessing Object into class [$newclass]\n" if $Verbose>=2; @@ -450,9 +439,17 @@ sub ExtUtils::MakeMaker::new { unless $self->file_name_is_absolute($self->{$key}) || ($^O eq 'VMS' and ($key =~ /PERL$/ && $self->{$key} =~ /^[\w\-\$]+$/)); } - $self->{PARENT}->{CHILDREN}->{$newclass} = $self if $self->{PARENT}; + if ($self->{PARENT}) { + $self->{PARENT}->{CHILDREN}->{$newclass} = $self; + if (exists $self->{PARENT}->{CAPI} + and not exists $self->{CAPI}) + { + # inherit, but only if already unspecified + $self->{CAPI} = $self->{PARENT}->{CAPI}; + } + } } else { - parse_args($self,@ARGV); + parse_args($self,split(' ', $ENV{PERL_MM_OPT} || ''),@ARGV); } $self->{NAME} ||= $self->guess_name; @@ -487,6 +484,9 @@ END $self->init_dirscan(); $self->init_others(); + my($argv) = neatvalue(\@ARGV); + $argv =~ s/^\[/(/; + $argv =~ s/\]$/)/; push @{$self->{RESULT}}, <<END; # This Makefile is for the $self->{NAME} extension to perl. @@ -497,6 +497,8 @@ END # # ANY CHANGES MADE HERE WILL BE LOST! # +# MakeMaker ARGV: $argv +# # MakeMaker Parameters: END @@ -541,7 +543,6 @@ END } push @{$self->{RESULT}}, "\n# End."; - pop @Parent; $self; } @@ -1026,7 +1027,7 @@ This will replace the string specified by $Config{prefix} in all $Config{install*} values. Note, that in both cases the tilde expansion is done by MakeMaker, not -by perl by default, nor by make. Conflicts between parmeters LIB, +by perl by default, nor by make. Conflicts between parameters LIB, PREFIX and the various INSTALL* arguments are resolved so that XXX @@ -1176,12 +1177,33 @@ recommends it (or you know what you're doing). The following attributes can be specified as arguments to WriteMakefile() or as NAME=VALUE pairs on the command line: -=cut +=over 2 -# The following "=item C" is used by the attrib_help routine -# likewise the "=back" below. So be careful when changing it! +=item AUTHOR -=over 2 +String containing name (and email address) of package author(s). Is used +in PPD (Perl Package Description) files for PPM (Perl Package Manager). + +=item ABSTRACT + +One line description of the module. Will be included in PPD file. + +=item ABSTRACT_FROM + +Name of the file that contains the package description. MakeMaker looks +for a line in the POD matching /^($package\s-\s)(.*)/. This is typically +the first line in the "=head1 NAME" section. $2 becomes the abstract. + +=item BINARY_LOCATION + +Used when creating PPD files for binary packages. It can be set to a +full or relative path or URL to the binary archive for a particular +architecture. For example: + + perl Makefile.PL BINARY_LOCATION=x86/Agent.tar.gz + +builds a PPD package that references a binary of the C<Agent> package, +located in the C<x86> directory relative to the PPD itself. =item C @@ -1189,6 +1211,14 @@ Ref to array of *.c file names. Initialised from a directory scan and the values portion of the XS attribute hash. This is not currently used by MakeMaker but may be handy in Makefile.PLs. +=item CAPI + +Switch to force usage of the Perl C API even when compiling for PERL_OBJECT. + +Note that this attribute is passed through to any recursive build, +but if and only if the submodule's Makefile.PL itself makes no mention +of the 'CAPI' attribute. + =item CCFLAGS String that will be included in the compiler call command line between @@ -1237,12 +1267,12 @@ NAME above. =item DL_FUNCS -Hashref of symbol names for routines to be made available as -universal symbols. Each key/value pair consists of the package name -and an array of routine names in that package. Used only under AIX -(export lists) and VMS (linker options) at present. The routine -names supplied will be expanded in the same way as XSUB names are -expanded by the XS() macro. Defaults to +Hashref of symbol names for routines to be made available as universal +symbols. Each key/value pair consists of the package name and an +array of routine names in that package. Used only under AIX, OS/2, +VMS and Win32 at present. The routine names supplied will be expanded +in the same way as XSUB names are expanded by the XS() macro. +Defaults to {"$(NAME)" => ["boot_$(NAME)" ] } @@ -1251,12 +1281,14 @@ e.g. {"RPC" => [qw( boot_rpcb rpcb_gettime getnetconfigent )], "NetconfigPtr" => [ 'DESTROY'] } +Please see the L<ExtUtils::Mksymlists> documentation for more information +about the DL_FUNCS, DL_VARS and FUNCLIST attributes. + =item DL_VARS -Array of symbol names for variables to be made available as -universal symbols. Used only under AIX (export lists) and VMS -(linker options) at present. Defaults to []. (e.g. [ qw( -Foo_version Foo_numstreams Foo_tree ) ]) +Array of symbol names for variables to be made available as universal symbols. +Used only under AIX, OS/2, VMS and Win32 at present. Defaults to []. +(e.g. [ qw(Foo_version Foo_numstreams Foo_tree ) ]) =item EXCLUDE_EXT @@ -1265,7 +1297,7 @@ is ignored if INCLUDE_EXT is present. Consult INCLUDE_EXT for more details. (e.g. [ qw( Socket POSIX ) ] ) This attribute may be most useful when specified as a string on the -commandline: perl Makefile.PL EXCLUDE_EXT='Socket Safe' +command line: perl Makefile.PL EXCLUDE_EXT='Socket Safe' =item EXE_FILES @@ -1273,13 +1305,6 @@ Ref to array of executable files. The files will be copied to the INST_SCRIPT directory. Make realclean will delete them from there again. -=item NO_VC - -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. - =item FIRST_MAKEFILE The name of the Makefile to be produced. Defaults to the contents of @@ -1290,13 +1315,21 @@ that will be produced for the MAP_TARGET. Perl binary able to run this extension. +=item FUNCLIST + +This provides an alternate means to specify function names to be +exported from the extension. Its value is a reference to an +array of function names to be exported by the extension. These +names are passed through unaltered to the linker options file. + =item H Ref to array of *.h file names. Similar to C. =item IMPORTS -IMPORTS is only used on OS/2. +This attribute is used to specify names to be imported into the +extension. It is only used on OS/2 and Win32. =item INC @@ -1315,7 +1348,7 @@ filling in INCLUDE_EXT. If the INCLUDE_EXT is mentioned but is empty then only DynaLoader and the current extension will be included in the build. This attribute may be most useful when specified as a string on the -commandline: perl Makefile.PL INCLUDE_EXT='POSIX Socket Devel::Peek' +command line: perl Makefile.PL INCLUDE_EXT='POSIX Socket Devel::Peek' =item INSTALLARCHLIB @@ -1353,14 +1386,14 @@ directory if INSTALLDIRS is set to perl. Used by 'make install' which copies files from INST_SCRIPT to this directory. -=item INSTALLSITELIB +=item INSTALLSITEARCH -Used by 'make install', which copies files from INST_LIB to this +Used by 'make install', which copies files from INST_ARCHLIB to this directory if INSTALLDIRS is set to site (default). -=item INSTALLSITEARCH +=item INSTALLSITELIB -Used by 'make install', which copies files from INST_ARCHLIB to this +Used by 'make install', which copies files from INST_LIB to this directory if INSTALLDIRS is set to site (default). =item INST_ARCHLIB @@ -1403,16 +1436,16 @@ defaults to "$(OBJECT)" and is used in the ld command to specify what files to link/load from (also see dynamic_lib below for how to specify ld flags) -=item LIBPERL_A - -The filename of the perllibrary that will be used together with this -extension. Defaults to libperl.a. - =item LIB LIB can only be set at C<perl Makefile.PL> time. It has the effect of setting both INSTALLPRIVLIB and INSTALLSITELIB to that value regardless any +=item LIBPERL_A + +The filename of the perllibrary that will be used together with this +extension. Defaults to libperl.a. + =item LIBS An anonymous array of alternative library @@ -1497,6 +1530,13 @@ itself. Boolean. Attribute to inhibit descending into subdirectories. +=item NO_VC + +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. + =item OBJECT List of object files, defaults to '$(BASEEXT)$(OBJ_EXT)', but can be a long @@ -1532,7 +1572,7 @@ avoided, it may be undefined) =item PERM_RW -Desired Permission for read/writable files. Defaults to C<644>. +Desired permission for read/writable files. Defaults to C<644>. See also L<MM_Unix/perm_rw>. =item PERM_RWX @@ -1549,7 +1589,11 @@ and the basename of the file being the value. E.g. {'foobar.PL' => 'foobar'} The *.PL files are expected to produce output to the target files -themselves. +themselves. If multiple files can be generated from the same *.PL +file then the value in the hash can be a reference to an array of +target file names. E.g. + + {'foobar.PL' => ['foobar1','foobar2']} =item PM @@ -1569,6 +1613,15 @@ they contain will be installed in the corresponding location in the library. A libscan() method can be used to alter the behaviour. Defining PM in the Makefile.PL will override PMLIBDIRS. +=item PPM_INSTALL_EXEC + +Name of the executable used to run C<PPM_INSTALL_SCRIPT> below. (e.g. perl) + +=item PPM_INSTALL_SCRIPT + +Name of the script that gets executed by the Perl Package Manager after +the installation of a package. + =item PREFIX Can be used to set the three INSTALL* attributes in one go (except for @@ -1703,10 +1756,6 @@ links the rest. Default is 'best'. {ARMAYBE => 'ar', OTHERLDFLAGS => '...', INST_DYNAMIC_DEP => '...'} -=item installpm - -Deprecated as of MakeMaker 5.23. See L<ExtUtils::MM_Unix/pm_to_blib>. - =item linkext {LINKTYPE => 'static', 'dynamic' or ''} @@ -1733,12 +1782,6 @@ be linked. =back -=cut - -# bug in pod2html, so leave the =back - -# Don't delete this cut, MM depends on it! - =head2 Overriding MakeMaker Methods If you cannot achieve the desired Makefile behaviour by specifying @@ -1916,6 +1959,18 @@ in a subdirectory of some other distribution, or is listed as a dependency in a CPAN::Bundle, but the functionality is supported by different means on the current architecture). +=head1 ENVIRONMENT + +=over 8 + +=item PERL_MM_OPT + +Command line options used by C<MakeMaker-E<gt>new()>, and thus by +C<WriteMakefile()>. The string is split on whitespace, and the result +is processed before any actual command line arguments are processed. + +=back + =head1 SEE ALSO ExtUtils::MM_Unix, ExtUtils::Manifest, ExtUtils::testlib, @@ -1925,7 +1980,7 @@ ExtUtils::Install, ExtUtils::Embed Andy Dougherty <F<doughera@lafcol.lafayette.edu>>, Andreas KE<ouml>nig <F<A.Koenig@franz.ww.TU-Berlin.DE>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>>. -VMS support by Charles Bailey <F<bailey@genetics.upenn.edu>>. OS/2 +VMS support by Charles Bailey <F<bailey@newman.upenn.edu>>. OS/2 support by Ilya Zakharevich <F<ilya@math.ohio-state.edu>>. Contact the makemaker mailing list C<mailto:makemaker@franz.ww.tu-berlin.de>, if you have any questions. diff --git a/contrib/perl5/lib/ExtUtils/Manifest.pm b/contrib/perl5/lib/ExtUtils/Manifest.pm index 5557089..1a6dde7 100644 --- a/contrib/perl5/lib/ExtUtils/Manifest.pm +++ b/contrib/perl5/lib/ExtUtils/Manifest.pm @@ -298,7 +298,7 @@ but in doing so checks each line in an existing C<MANIFEST> file and includes any comments that are found in the existing C<MANIFEST> file in the new one. Anything between white space and an end of line within a C<MANIFEST> file is considered to be a comment. Filenames and -comments are seperated by one or more TAB characters in the +comments are separated by one or more TAB characters in the output. All files that match any regular expression in a file C<MANIFEST.SKIP> (if such a file exists) are ignored. @@ -317,7 +317,7 @@ Fullcheck() does both a manicheck() and a filecheck(). Skipcheck() lists all the files that are skipped due to your C<MANIFEST.SKIP> file. -Manifind() retruns a hash reference. The keys of the hash are the +Manifind() returns a hash reference. The keys of the hash are the files found below the current directory. Maniread($file) reads a named C<MANIFEST> file (defaults to diff --git a/contrib/perl5/lib/ExtUtils/Mkbootstrap.pm b/contrib/perl5/lib/ExtUtils/Mkbootstrap.pm index 35d5236..25c374c 100644 --- a/contrib/perl5/lib/ExtUtils/Mkbootstrap.pm +++ b/contrib/perl5/lib/ExtUtils/Mkbootstrap.pm @@ -1,6 +1,6 @@ package ExtUtils::Mkbootstrap; -$VERSION = substr q$Revision: 1.13 $, 10; +$VERSION = substr q$Revision: 1.14 $, 10; # $Date: 1996/09/03 17:04:43 $ use Config; @@ -49,7 +49,7 @@ sub Mkbootstrap { print BS "# $baseext DynaLoader bootstrap file for $^O architecture.\n"; print BS "# Do not edit this file, changes will be lost.\n"; print BS "# This file was automatically generated by the\n"; - print BS "# Mkbootstrap routine in ExtUtils::Mkbootstrap (v$Version).\n"; + print BS "# Mkbootstrap routine in ExtUtils::Mkbootstrap (v$VERSION).\n"; print BS "\@DynaLoader::dl_resolve_using = "; # If @all contains names in the form -lxxx or -Lxxx then it's asking for # runtime library location so we automatically add a call to dl_findfile() diff --git a/contrib/perl5/lib/ExtUtils/Mksymlists.pm b/contrib/perl5/lib/ExtUtils/Mksymlists.pm index 0b92ca0..76535d9 100644 --- a/contrib/perl5/lib/ExtUtils/Mksymlists.pm +++ b/contrib/perl5/lib/ExtUtils/Mksymlists.pm @@ -19,10 +19,10 @@ sub Mksymlists { $spec{DL_VARS} = [] unless $spec{DL_VARS}; ($spec{FILE} = $spec{NAME}) =~ s/.*::// unless $spec{FILE}; + $spec{FUNCLIST} = [] unless $spec{FUNCLIST}; $spec{DL_FUNCS} = { $spec{NAME} => [] } unless ( ($spec{DL_FUNCS} and keys %{$spec{DL_FUNCS}}) or - $spec{FUNCLIST}); - $spec{FUNCLIST} = [] unless $spec{FUNCLIST}; + @{$spec{FUNCLIST}}); if (defined $spec{DL_FUNCS}) { my($package); foreach $package (keys %{$spec{DL_FUNCS}}) { @@ -89,10 +89,10 @@ sub _write_os2 { print DEF join("\n ",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}}; if (%{$data->{IMPORTS}}) { print DEF "IMPORTS\n"; -my ($name, $exp); -while (($name, $exp)= each %{$data->{IMPORTS}}) { - print DEF " $name=$exp\n"; -} + my ($name, $exp); + while (($name, $exp)= each %{$data->{IMPORTS}}) { + print DEF " $name=$exp\n"; + } } close DEF; } @@ -207,10 +207,13 @@ keys are recognized: =over -=item NAME +=item DLBASE -This gives the name of the extension (I<e.g.> Tk::Canvas) for which -the linker option file will be produced. +This item specifies the name by which the linker knows the +extension, which may be different from the name of the +extension itself (for instance, some linkers add an '_' to the +name of the extension). If it is not specified, it is derived +from the NAME attribute. It is presently used only by OS2 and Win32. =item DL_FUNCS @@ -219,7 +222,7 @@ from which it is usually taken. Its value is a reference to an associative array, in which each key is the name of a package, and each value is an a reference to an array of function names which should be exported by the extension. For instance, one might say -C<DL_FUNCS =E<gt> { Homer::Iliad =E<gt> [ qw(trojans greeks) ], +C<DL_FUNCS =E<gt> { Homer::Iliad =E<gt> [ qw(trojans greeks) ], Homer::Odyssey =E<gt> [ qw(travellers family suitors) ] }>. The function names should be identical to those in the XSUB code; C<Mksymlists> will alter the names written to the linker option @@ -243,7 +246,7 @@ be exported by the extension. This key can be used to specify the name of the linker option file (minus the OS-specific extension), if for some reason you do not want to use the default value, which is the last word of the NAME -attribute (I<e.g.> for Tk::Canvas, FILE defaults to 'Canvas'). +attribute (I<e.g.> for C<Tk::Canvas>, FILE defaults to C<Canvas>). =item FUNCLIST @@ -251,14 +254,25 @@ This provides an alternate means to specify function names to be exported from the extension. Its value is a reference to an array of function names to be exported by the extension. These names are passed through unaltered to the linker options file. +Specifying a value for the FUNCLIST attribute suppresses automatic +generation of the bootstrap function for the package. To still create +the bootstrap name you have to specify the package name in the +DL_FUNCS hash: -=item DLBASE + Mksymlists({ NAME => $name , + FUNCLIST => [ $func1, $func2 ], + DL_FUNCS => { $pkg => [] } }); -This item specifies the name by which the linker knows the -extension, which may be different from the name of the -extension itself (for instance, some linkers add an '_' to the -name of the extension). If it is not specified, it is derived -from the NAME attribute. It is presently used only by OS2. + +=item IMPORTS + +This attribute is used to specify names to be imported into the +extension. It is currently only used by OS/2 and Win32. + +=item NAME + +This gives the name of the extension (I<e.g.> C<Tk::Canvas>) for which +the linker option file will be produced. =back @@ -269,7 +283,7 @@ can be used to provide additional information to the linker. =head1 AUTHOR -Charles Bailey I<E<lt>bailey@genetics.upenn.eduE<gt>> +Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> =head1 REVISION diff --git a/contrib/perl5/lib/ExtUtils/typemap b/contrib/perl5/lib/ExtUtils/typemap index 28fd99c..b1ec063 100644 --- a/contrib/perl5/lib/ExtUtils/typemap +++ b/contrib/perl5/lib/ExtUtils/typemap @@ -1,12 +1,12 @@ # $Header$ # basic C types int T_IV -unsigned T_IV -unsigned int T_IV +unsigned T_UV +unsigned int T_UV long T_IV -unsigned long T_IV +unsigned long T_UV short T_IV -unsigned short T_IV +unsigned short T_UV char T_CHAR unsigned char T_U_CHAR char * T_PV @@ -34,7 +34,7 @@ I16 T_IV I8 T_IV U32 T_U_LONG U16 T_U_SHORT -U8 T_IV +U8 T_UV Result T_U_CHAR Boolean T_IV double T_DOUBLE @@ -73,6 +73,8 @@ T_CVREF croak(\"$var is not of type ${ntype}\") T_SYSRET $var NOT IMPLEMENTED +T_UV + $var = ($type)SvUV($arg) T_IV $var = ($type)SvIV($arg) T_INT @@ -82,19 +84,19 @@ T_ENUM T_BOOL $var = (int)SvIV($arg) T_U_INT - $var = (unsigned int)SvIV($arg) + $var = (unsigned int)SvUV($arg) T_SHORT $var = (short)SvIV($arg) T_U_SHORT - $var = (unsigned short)SvIV($arg) + $var = (unsigned short)SvUV($arg) T_LONG $var = (long)SvIV($arg) T_U_LONG - $var = (unsigned long)SvIV($arg) + $var = (unsigned long)SvUV($arg) T_CHAR $var = (char)*SvPV($arg,PL_na) T_U_CHAR - $var = (unsigned char)SvIV($arg) + $var = (unsigned char)SvUV($arg) T_FLOAT $var = (float)SvNV($arg) T_NV @@ -191,6 +193,8 @@ T_CVREF $arg = newRV((SV*)$var); T_IV sv_setiv($arg, (IV)$var); +T_UV + sv_setuv($arg, (UV)$var); T_INT sv_setiv($arg, (IV)$var); T_SYSRET @@ -205,19 +209,19 @@ T_ENUM T_BOOL $arg = boolSV($var); T_U_INT - sv_setiv($arg, (IV)$var); + sv_setuv($arg, (UV)$var); T_SHORT sv_setiv($arg, (IV)$var); T_U_SHORT - sv_setiv($arg, (IV)$var); + sv_setuv($arg, (UV)$var); T_LONG sv_setiv($arg, (IV)$var); T_U_LONG - sv_setiv($arg, (IV)$var); + sv_setuv($arg, (UV)$var); T_CHAR sv_setpvn($arg, (char *)&$var, 1); T_U_CHAR - sv_setiv($arg, (IV)$var); + sv_setuv($arg, (UV)$var); T_FLOAT sv_setnv($arg, (double)$var); T_NV diff --git a/contrib/perl5/lib/ExtUtils/xsubpp b/contrib/perl5/lib/ExtUtils/xsubpp index 523dabc..1ee7b29 100755 --- a/contrib/perl5/lib/ExtUtils/xsubpp +++ b/contrib/perl5/lib/ExtUtils/xsubpp @@ -776,7 +776,7 @@ while (<$FH>) { /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/; if ($OBJ) { - s/#if(?:def|\s+defined)\s+(\(__cplusplus\)|__cplusplus)/#if defined(__cplusplus) && !defined(PERL_OBJECT)/; + s/#if(?:def\s|\s+defined)\s*(\(__cplusplus\)|__cplusplus)/#if defined(__cplusplus) && !defined(PERL_OBJECT)/; } print $_; } @@ -1254,30 +1254,37 @@ EOF } # print initialization routine -if ($WantCAPI) { + print Q<<"EOF"; -# ##ifdef __cplusplus #extern "C" ##endif +EOF + +if ($WantCAPI) { +print Q<<"EOF"; +##ifdef PERL_CAPI #XS(boot__CAPI_entry) -#[[ -# dXSARGS; -# char* file = __FILE__; -# +##else EOF -} else { +} + print Q<<"EOF"; -##ifdef __cplusplus -#extern "C" -##endif #XS(boot_$Module_cname) +EOF + +if ($WantCAPI) { +print Q<<"EOF"; +##endif /* PERL_CAPI */ +EOF +} + +print Q<<"EOF"; #[[ # dXSARGS; # char* file = __FILE__; # EOF -} print Q<<"EOF" if $WantVersionChk ; # XS_VERSION_BOOTCHECK ; @@ -1312,7 +1319,7 @@ EOF if ($WantCAPI) { print Q<<"EOF"; -# +##ifdef PERL_CAPI ##define XSCAPI(name) void name(CV* cv, void* pPerl) # ##ifdef __cplusplus @@ -1323,7 +1330,7 @@ print Q<<"EOF"; # SetCPerlObj(pPerl); # boot__CAPI_entry(cv); #]] -# +##endif /* PERL_CAPI */ EOF } diff --git a/contrib/perl5/lib/Fatal.pm b/contrib/perl5/lib/Fatal.pm index a1e5cff..d1d95af 100644 --- a/contrib/perl5/lib/Fatal.pm +++ b/contrib/perl5/lib/Fatal.pm @@ -111,11 +111,13 @@ EOS $code .= write_invocation($core, $call, $name, @protos); $code .= "}\n"; print $code if $Debug; - $code = eval($code); - die if $@; - local($^W) = 0; # to avoid: Subroutine foo redefined ... - no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ... - *{$sub} = $code; + { + no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ... + $code = eval("package $pkg; use Carp; $code"); + die if $@; + local($^W) = 0; # to avoid: Subroutine foo redefined ... + *{$sub} = $code; + } } 1; diff --git a/contrib/perl5/lib/File/Copy.pm b/contrib/perl5/lib/File/Copy.pm index d0b3c89..e1da6b6 100644 --- a/contrib/perl5/lib/File/Copy.pm +++ b/contrib/perl5/lib/File/Copy.pm @@ -235,7 +235,7 @@ B<Note that passing in files as handles instead of names may lead to loss of information on some operating systems; it is recommended that you use file names whenever possible.> Files are opened in binary mode where -applicable. To get a consistent behavour when copying from a +applicable. To get a consistent behaviour when copying from a filehandle to a file, use C<binmode> on the filehandle. An optional third parameter can be used to specify the buffer @@ -274,7 +274,7 @@ C<copy> routine. For VMS systems, this calls the C<rmscopy> routine (see below). For OS/2 systems, this calls the C<syscopy> XSUB directly. -=head2 Special behavior if C<syscopy> is defined (VMS and OS/2) +=head2 Special behaviour if C<syscopy> is defined (VMS and OS/2) If both arguments to C<copy> are not file handles, then C<copy> will perform a "system copy" of @@ -336,7 +336,7 @@ $! will be set if an error was encountered. =head1 AUTHOR File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995, -and updated by Charles Bailey I<E<lt>bailey@genetics.upenn.eduE<gt>> in 1996. +and updated by Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> in 1996. =cut diff --git a/contrib/perl5/lib/File/Find.pm b/contrib/perl5/lib/File/Find.pm index 1305d21..7e67003 100644 --- a/contrib/perl5/lib/File/Find.pm +++ b/contrib/perl5/lib/File/Find.pm @@ -22,10 +22,10 @@ finddepth - traverse a directory structure depth-first =head1 DESCRIPTION The first argument to find() is either a hash reference describing the -operations to be performed for each file, or a code reference. 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, 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. Currently the only other supported key for the above hash is C<bydepth>, in presense of which the walk over directories is @@ -177,6 +177,8 @@ sub finddir { --$subcount; next if $prune; + # Untaint $_, so that we can do a chdir + $_ = $1 if /^(.*)/; if (chdir $_) { $name =~ s/\.dir$// if $Is_VMS; &finddir($wanted,$name,$nlink, $bydepth); @@ -194,7 +196,7 @@ sub finddir { sub wrap_wanted { my $wanted = shift; - defined &$wanted ? {wanted => $wanted} : $wanted; + ref($wanted) eq 'HASH' ? $wanted : { wanted => $wanted }; } sub find { diff --git a/contrib/perl5/lib/File/Path.pm b/contrib/perl5/lib/File/Path.pm index 39f1ba1..225ecab 100644 --- a/contrib/perl5/lib/File/Path.pm +++ b/contrib/perl5/lib/File/Path.pm @@ -88,7 +88,7 @@ in situations where security is an issue. =head1 AUTHORS Tim Bunce <F<Tim.Bunce@ig.co.uk>> and -Charles Bailey <F<bailey@genetics.upenn.edu>> +Charles Bailey <F<bailey@newman.upenn.edu>> =head1 REVISION @@ -135,8 +135,9 @@ sub mkpath { } print "mkdir $path\n" if $verbose; unless (mkdir($path,$mode)) { - # allow for another process to have created it meanwhile - croak "mkdir $path: $!" 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/contrib/perl5/lib/File/Spec.pm b/contrib/perl5/lib/File/Spec.pm index 5f3dbf5..616dcbc 100644 --- a/contrib/perl5/lib/File/Spec.pm +++ b/contrib/perl5/lib/File/Spec.pm @@ -91,7 +91,7 @@ but rather as class methods: File::Spec->catfile('a','b'); -For a reference of available functions, pleaes consult L<File::Spec::Unix>, +For a reference of available functions, please consult L<File::Spec::Unix>, which contains the entire set, and inherited by the modules for other platforms. For further information, please see L<File::Spec::Mac>, L<File::Spec::OS2>, L<File::Spec::Win32>, or L<File::Spec::VMS>. @@ -106,7 +106,7 @@ File::Spec::VMS, ExtUtils::MakeMaker Kenneth Albanowski <F<kjahds@kjahds.com>>, Andy Dougherty <F<doughera@lafcol.lafayette.edu>>, Andreas KE<ouml>nig <F<A.Koenig@franz.ww.TU-Berlin.DE>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>>. VMS -support by Charles Bailey <F<bailey@genetics.upenn.edu>>. OS/2 support by +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>>. diff --git a/contrib/perl5/lib/File/Spec/Mac.pm b/contrib/perl5/lib/File/Spec/Mac.pm index 4968e24..63a9e12 100644 --- a/contrib/perl5/lib/File/Spec/Mac.pm +++ b/contrib/perl5/lib/File/Spec/Mac.pm @@ -52,7 +52,7 @@ The fundamental requirement of this routine is that File::Spec->catdir(split(":",$path)) eq $path But because of the nature of Macintosh paths, some additional -possibilities are allowed to make using this routine give resonable results +possibilities are allowed to make using this routine give reasonable results for some common situations. Here are the rules that are used. Each argument has its trailing ":" removed. Each argument, except the first, has its leading ":" removed. They are then joined together by a ":". @@ -78,7 +78,7 @@ Under MacPerl, there is an additional ambiguity. Does the user intend that File::Spec->catfile("LWP","Protocol","http.pm") be relative or absolute? There's no way of telling except by checking for the -existance of LWP: or :LWP, and even there he may mean a dismounted volume or +existence of LWP: or :LWP, and even there he may mean a dismounted volume or a relative path in a different directory (like in @INC). So those checks aren't done here. This routine will treat this as absolute. diff --git a/contrib/perl5/lib/FindBin.pm b/contrib/perl5/lib/FindBin.pm index d6bd7b7..9e1c0a0 100644 --- a/contrib/perl5/lib/FindBin.pm +++ b/contrib/perl5/lib/FindBin.pm @@ -55,7 +55,10 @@ Workaround is to invoke perl as =head1 AUTHORS -Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt> +FindBin is supported as part of the core perl distribution. Please send bug +reports to E<lt>F<perlbug@perl.org>E<gt> using the perlbug program included with perl. + +Graham Barr E<lt>F<gbarr@pobox.com>E<gt> Nick Ing-Simmons E<lt>F<nik@tiuk.ti.com>E<gt> =head1 COPYRIGHT @@ -64,10 +67,6 @@ Copyright (c) 1995 Graham Barr & Nick Ing-Simmons. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -=head1 REVISION - -$Revision: 1.4 $ - =cut package FindBin; @@ -77,31 +76,13 @@ require Exporter; use Cwd qw(getcwd abs_path); use Config; use File::Basename; +use File::Spec; @EXPORT_OK = qw($Bin $Script $RealBin $RealScript $Dir $RealDir); %EXPORT_TAGS = (ALL => [qw($Bin $Script $RealBin $RealScript $Dir $RealDir)]); @ISA = qw(Exporter); -$VERSION = $VERSION = sprintf("%d.%02d", q$Revision: 1.41 $ =~ /(\d+)\.(\d+)/); - -sub is_abs_path -{ - local $_ = shift if (@_); - if ($^O eq 'MSWin32' || $^O eq 'dos') - { - return m#^[a-z]:[\\/]#i; - } - elsif ($^O eq 'VMS') - { - # If it's a logical name, expand it. - $_ = $ENV{$_} while /^[\w\$\-]+$/ and $ENV{$_}; - return m!^/! or m![<\[][^.\-\]>]! or /:[^<\[]/; - } - else - { - return m#^/#; - } -} +$VERSION = $VERSION = "1.42"; BEGIN { @@ -131,13 +112,12 @@ BEGIN && -f $script) { my $dir; - my $pathvar = 'PATH'; - - foreach $dir (split(/$Config{'path_sep'}/,$ENV{$pathvar})) + foreach $dir (File::Spec->path) { - if(-r "$dir/$script" && (!$IsWin32 || -x _)) + my $scr = File::Spec->catfile($dir, $script); + if(-r $scr && (!$IsWin32 || -x _)) { - $script = "$dir/$script"; + $script = $scr; if (-f $0) { @@ -160,7 +140,8 @@ BEGIN # Ensure $script contains the complete path incase we C<chdir> - $script = getcwd() . "/" . $script unless is_abs_path($script); + $script = File::Spec->catfile(getcwd(), $script) + unless File::Spec->file_name_is_absolute($script); ($Script,$Bin) = fileparse($script); @@ -172,9 +153,9 @@ BEGIN ($RealScript,$RealBin) = fileparse($script); last unless defined $linktext; - $script = (is_abs_path($linktext)) + $script = (File::Spec->file_name_is_absolute($linktext)) ? $linktext - : $RealBin . "/" . $linktext; + : File::Spec->catfile($RealBin, $linktext); } # Get absolute paths to directories diff --git a/contrib/perl5/lib/Getopt/Long.pm b/contrib/perl5/lib/Getopt/Long.pm index 1966ef3..c125ccf 100644 --- a/contrib/perl5/lib/Getopt/Long.pm +++ b/contrib/perl5/lib/Getopt/Long.pm @@ -6,13 +6,13 @@ package Getopt::Long; # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Sun Jun 14 13:17:22 1998 -# Update Count : 705 +# Last Modified On: Fri Jan 8 14:48:43 1999 +# Update Count : 707 # Status : Released ################ Copyright ################ -# This program is Copyright 1990,1998 by Johan Vromans. +# This program is Copyright 1990,1999 by Johan Vromans. # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 2 @@ -35,7 +35,7 @@ BEGIN { require 5.004; use Exporter (); use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - $VERSION = "2.17"; + $VERSION = "2.19"; @ISA = qw(Exporter); @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); @@ -547,6 +547,7 @@ sub FindOption ($$$$$$$) { # If bundling == 2, long options can override bundles. if ( $bundling == 2 and + defined ($rest) and defined ($type = $opctl->{$tryopt.$rest}) ) { print STDERR ("=> $starter$tryopt rebundled to ", "$starter$tryopt$rest\n") if $debug; @@ -1363,7 +1364,7 @@ Johan Vromans E<lt>jvromans@squirrel.nlE<gt> =head1 COPYRIGHT AND DISCLAIMER -This program is Copyright 1990,1998 by Johan Vromans. +This program is Copyright 1990,1999 by Johan Vromans. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 diff --git a/contrib/perl5/lib/Getopt/Std.pm b/contrib/perl5/lib/Getopt/Std.pm index c2cd123..390bf14 100644 --- a/contrib/perl5/lib/Getopt/Std.pm +++ b/contrib/perl5/lib/Getopt/Std.pm @@ -42,8 +42,7 @@ the argument or 1 if no argument is specified. @ISA = qw(Exporter); @EXPORT = qw(getopt getopts); - -# $RCSfile: getopt.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:58 $ +$VERSION = $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 @@ -145,7 +144,7 @@ sub getopts ($;$) { } } else { - print STDERR "Unknown option: $first\n"; + warn "Unknown option: $first\n"; ++$errs; if($rest ne '') { $ARGV[0] = "-$rest"; diff --git a/contrib/perl5/lib/IPC/Open3.pm b/contrib/perl5/lib/IPC/Open3.pm index f1415e3..d079041 100644 --- a/contrib/perl5/lib/IPC/Open3.pm +++ b/contrib/perl5/lib/IPC/Open3.pm @@ -2,15 +2,15 @@ package IPC::Open3; use strict; no strict 'refs'; # because users pass me bareword filehandles -use vars qw($VERSION @ISA @EXPORT $Fh $Me); +use vars qw($VERSION @ISA @EXPORT $Me); require 5.001; require Exporter; use Carp; -use Symbol 'qualify'; +use Symbol qw(gensym qualify); -$VERSION = 1.0102; +$VERSION = 1.0103; @ISA = qw(Exporter); @EXPORT = qw(open3); @@ -94,7 +94,6 @@ C<cat -v> and continually read and write a line from it. # rdr or wtr are null # a system call fails -$Fh = 'FHOPEN000'; # package static in case called more than once $Me = 'open3 (bug)'; # you should never see this, it's always localized # Fatal.pm needs to be fixed WRT prototypes. @@ -140,9 +139,9 @@ sub _open3 { $dad_rdr = qualify $dad_rdr, $package; $dad_err = qualify $dad_err, $package; - my $kid_rdr = ++$Fh; - my $kid_wtr = ++$Fh; - my $kid_err = ++$Fh; + my $kid_rdr = gensym; + my $kid_wtr = gensym; + my $kid_err = gensym; xpipe $kid_rdr, $dad_wtr if !$dup_wtr; xpipe $dad_rdr, $kid_wtr if !$dup_rdr; @@ -154,7 +153,7 @@ sub _open3 { # save a copy of her stdout before I put something else there. if ($dad_rdr ne $dad_err && $dup_err && fileno($dad_err) == fileno(STDOUT)) { - my $tmp = ++$Fh; + my $tmp = gensym; xopen($tmp, ">&$dad_err"); $dad_err = $tmp; } @@ -163,24 +162,24 @@ sub _open3 { xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != fileno($dad_wtr); } else { xclose $dad_wtr; - xopen \*STDIN, "<&$kid_rdr"; - xclose $kid_rdr; + xopen \*STDIN, "<&=" . fileno $kid_rdr; } if ($dup_rdr) { xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != fileno($dad_rdr); } else { xclose $dad_rdr; - xopen \*STDOUT, ">&$kid_wtr"; - xclose $kid_wtr; + xopen \*STDOUT, ">&=" . fileno $kid_wtr; } if ($dad_rdr ne $dad_err) { if ($dup_err) { - xopen \*STDERR, ">&$dad_err" + # I have to use a fileno here because in this one case + # I'm doing a dup but the filehandle might be a reference + # (from the special case above). + xopen \*STDERR, ">&" . fileno $dad_err if fileno(STDERR) != fileno($dad_err); } else { xclose $dad_err; - xopen \*STDERR, ">&$kid_err"; - xclose $kid_err; + xopen \*STDERR, ">&=" . fileno $kid_err; } } else { xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT); @@ -194,23 +193,23 @@ sub _open3 { my @close; if ($dup_wtr) { - $kid_rdr = $dad_wtr; - push @close, \*{$kid_rdr}; + $kid_rdr = \*{$dad_wtr}; + push @close, $kid_rdr; } else { - push @close, \*{$dad_wtr}, \*{$kid_rdr}; + push @close, \*{$dad_wtr}, $kid_rdr; } if ($dup_rdr) { - $kid_wtr = $dad_rdr; - push @close, \*{$kid_wtr}; + $kid_wtr = \*{$dad_rdr}; + push @close, $kid_wtr; } else { - push @close, \*{$dad_rdr}, \*{$kid_wtr}; + push @close, \*{$dad_rdr}, $kid_wtr; } if ($dad_rdr ne $dad_err) { if ($dup_err) { - $kid_err = $dad_err ; - push @close, \*{$kid_err}; + $kid_err = \*{$dad_err}; + push @close, $kid_err; } else { - push @close, \*{$dad_err}, \*{$kid_err}; + push @close, \*{$dad_err}, $kid_err; } } else { $kid_err = $kid_wtr; @@ -218,13 +217,13 @@ sub _open3 { require IO::Pipe; $kidpid = eval { spawn_with_handles( [ { mode => 'r', - open_as => \*{$kid_rdr}, + open_as => $kid_rdr, handle => \*STDIN }, { mode => 'w', - open_as => \*{$kid_wtr}, + open_as => $kid_wtr, handle => \*STDOUT }, { mode => 'w', - open_as => \*{$kid_err}, + open_as => $kid_err, handle => \*STDERR }, ], \@close, @cmd); }; diff --git a/contrib/perl5/lib/Math/BigFloat.pm b/contrib/perl5/lib/Math/BigFloat.pm index 576f341..03bc2f4 100644 --- a/contrib/perl5/lib/Math/BigFloat.pm +++ b/contrib/perl5/lib/Math/BigFloat.pm @@ -301,7 +301,7 @@ floats as =item number format canonical strings have the form /[+-]\d+E[+-]\d+/ . Input values can -have inbedded whitespace. +have imbedded whitespace. =item Error returns 'NaN' diff --git a/contrib/perl5/lib/Math/BigInt.pm b/contrib/perl5/lib/Math/BigInt.pm index ef4af61..b61b884 100644 --- a/contrib/perl5/lib/Math/BigInt.pm +++ b/contrib/perl5/lib/Math/BigInt.pm @@ -258,9 +258,9 @@ sub bdiv { #(dividend: num_str, divisor: num_str) return num_str else { push(@x, 0); } - @q = (); ($v2,$v1) = @y[-2,-1]; + @q = (); ($v2,$v1) = ($y[-2] || 0, $y[-1]); while ($#x > $#y) { - ($u2,$u1,$u0) = @x[-3..-1]; + ($u2,$u1,$u0) = ($x[-3] || 0, $x[-2] || 0, $x[-1]); $q = (($u0 == $v1) ? 99999 : int(($u0*1e5+$u1)/$v1)); --$q while ($v2*$q > ($u0*1e5+$u1-$q*$v1)*1e5+$u2); if ($q) { @@ -400,8 +400,8 @@ In particular perl -MMath::BigInt=:constant -e 'print 2**100' -print the integer value of C<2**100>. Note that without convertion of -constants the expression 2**100 will be calculatted as floating point number. +print the integer value of C<2**100>. Note that without conversion of +constants the expression 2**100 will be calculated as floating point number. =head1 BUGS diff --git a/contrib/perl5/lib/Math/Complex.pm b/contrib/perl5/lib/Math/Complex.pm index e711c14..5b69039 100644 --- a/contrib/perl5/lib/Math/Complex.pm +++ b/contrib/perl5/lib/Math/Complex.pm @@ -14,7 +14,7 @@ use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS); my ( $i, $ip2, %logn ); -$VERSION = sprintf("%s", q$Id: Complex.pm,v 1.25 1998/02/05 16:07:37 jhi Exp $ =~ /(\d+\.\d+)/); +$VERSION = sprintf("%s", q$Id: Complex.pm,v 1.26 1998/11/01 00:00:00 dsl Exp $ =~ /(\d+\.\d+)/); @ISA = qw(Exporter); @@ -401,38 +401,21 @@ sub divide { } # -# _zerotozero -# -# Die on zero raised to the zeroth. -# -sub _zerotozero { - my $mess = "The zero raised to the zeroth power is not defined.\n"; - - my @up = caller(1); - - $mess .= "Died at $up[1] line $up[2].\n"; - - die $mess; -} - -# # (power) # # Computes z1**z2 = exp(z2 * log z1)). # sub power { my ($z1, $z2, $inverted) = @_; - my $z1z = $z1 == 0; - my $z2z = $z2 == 0; - _zerotozero if ($z1z and $z2z); if ($inverted) { - return 0 if ($z2z); - return 1 if ($z1z or $z2 == 1); + return 1 if $z1 == 0 || $z2 == 1; + return 0 if $z2 == 0 && Re($z1) > 0; } else { - return 0 if ($z1z); - return 1 if ($z2z or $z1 == 1); + return 1 if $z2 == 0 || $z1 == 1; + return 0 if $z1 == 0 && Re($z2) > 0; } - my $w = $inverted ? CORE::exp($z1 * CORE::log($z2)) : CORE::exp($z2 * CORE::log($z1)); + my $w = $inverted ? CORE::exp($z1 * CORE::log($z2)) + : CORE::exp($z2 * CORE::log($z1)); # If both arguments cartesian, return cartesian, else polar. return $z1->{c_dirty} == 0 && (not ref $z2 or $z2->{c_dirty} == 0) ? @@ -443,7 +426,7 @@ sub power { # (spaceship) # # Computes z1 <=> z2. -# Sorts on the real part first, then on the imaginary part. Thus 2-4i > 3+8i. +# Sorts on the real part first, then on the imaginary part. Thus 2-4i < 3+8i. # sub spaceship { my ($z1, $z2, $inverted) = @_; @@ -1273,7 +1256,7 @@ sub gcd { my ($a, $b) = @_; my $id = "$a $b"; - + unless (exists $gcd{$id}) { $gcd{$id} = _gcd($a, $b); $gcd{"$b $a"} = $gcd{$id}; @@ -1702,7 +1685,7 @@ Here are some examples: The division (/) and the following functions log ln log10 logn - tan sec csc cot + tan sec csc cot atan asec acsc acot tanh sech csch coth atanh asech acsch acoth diff --git a/contrib/perl5/lib/Math/Trig.pm b/contrib/perl5/lib/Math/Trig.pm index b7b5d5d..924286d 100644 --- a/contrib/perl5/lib/Math/Trig.pm +++ b/contrib/perl5/lib/Math/Trig.pm @@ -314,9 +314,11 @@ known as the I<radial> coordinate. The angle in the I<xy>-plane coordinate. The angle from the I<z>-axis is B<phi>, also known as the I<polar> coordinate. The `North Pole' is therefore I<0, 0, rho>, and the `Bay of Guinea' (think of the missing big chunk of Africa) I<0, -pi/2, rho>. +pi/2, rho>. In geographical terms I<phi> is latitude (northward +positive, southward negative) and I<theta> is longitude (eastward +positive, westward negative). -B<Beware>: some texts define I<theta> and I<phi> the other way round, +B<BEWARE>: some texts define I<theta> and I<phi> the other way round, some texts define the I<phi> to start from the horizontal plane, some texts use I<r> in place of I<rho>. @@ -374,13 +376,25 @@ by importing the C<great_circle_distance> function: use Math::Trig 'great_circle_distance' - $distance = great_circle_distance($theta0, $phi0, $theta1, $phi, [, $rho]); + $distance = great_circle_distance($theta0, $phi0, $theta1, $phi1, [, $rho]); The I<great circle distance> is the shortest distance between two points on a sphere. The distance is in C<$rho> units. The C<$rho> is optional, it defaults to 1 (the unit sphere), therefore the distance defaults to radians. +If you think geographically the I<theta> are longitudes: zero at the +Greenwhich meridian, eastward positive, westward negative--and the +I<phi> are latitudes: zero at the North Pole, northward positive, +southward negative. B<NOTE>: this formula thinks in mathematics, not +geographically: the I<phi> zero is at the North Pole, not at the +Equator on the west coast of Africa (Bay of Guinea). You need to +subtract your geographical coordinates from I<pi/2> (also known as 90 +degrees). + + $distance = great_circle_distance($lon0, pi/2 - $lat0, + $lon1, pi/2 - $lat1, $rho); + =head1 EXAMPLES To calculate the distance between London (51.3N 0.5W) and Tokyo (35.7N @@ -394,8 +408,8 @@ To calculate the distance between London (51.3N 0.5W) and Tokyo (35.7N $km = great_circle_distance(@L, @T, 6378); -The answer may be off by up to 0.3% because of the irregular (slightly -aspherical) form of the Earth. +The answer may be off by few percentages because of the irregular +(slightly aspherical) form of the Earth. =head1 BUGS diff --git a/contrib/perl5/lib/Net/hostent.pm b/contrib/perl5/lib/Net/hostent.pm index 96b090d..d586358 100644 --- a/contrib/perl5/lib/Net/hostent.pm +++ b/contrib/perl5/lib/Net/hostent.pm @@ -89,7 +89,7 @@ $h_name if you import the fields. Array references are available as regular array variables, so for example C<@{ $host_obj-E<gt>aliases() }> would be simply @h_aliases. -The gethost() funtion is a simple front-end that forwards a numeric +The gethost() function is a simple front-end that forwards a numeric argument to gethostbyaddr() by way of Socket::inet_aton, and the rest to gethostbyname(). diff --git a/contrib/perl5/lib/Net/netent.pm b/contrib/perl5/lib/Net/netent.pm index b82447c..fbc6d98 100644 --- a/contrib/perl5/lib/Net/netent.pm +++ b/contrib/perl5/lib/Net/netent.pm @@ -92,7 +92,7 @@ $n_name if you import the fields. Array references are available as regular array variables, so for example C<@{ $net_obj-E<gt>aliases() }> would be simply @n_aliases. -The getnet() funtion is a simple front-end that forwards a numeric +The getnet() function is a simple front-end that forwards a numeric argument to getnetbyaddr(), and the rest to getnetbyname(). diff --git a/contrib/perl5/lib/Pod/Html.pm b/contrib/perl5/lib/Pod/Html.pm index 5d2e07b..e71afa8 100644 --- a/contrib/perl5/lib/Pod/Html.pm +++ b/contrib/perl5/lib/Pod/Html.pm @@ -11,6 +11,8 @@ use Cwd; use Carp; +use locale; # make \w work right in non-ASCII lands + use strict; use Config; @@ -300,18 +302,20 @@ sub pod2html { open(HTML, ">$htmlfile") || die "$0: cannot open $htmlfile file for output: $!\n"; - # put a title in the HTML file - $title = ''; - TITLE_SEARCH: { - for (my $i = 0; $i < @poddata; $i++) { - if ($poddata[$i] =~ /^=head1\s*NAME\b/m) { - for my $para ( @poddata[$i, $i+1] ) { - last TITLE_SEARCH if ($title) = $para =~ /(\S+\s+-+.*\S)/s; - } - } + # put a title in the HTML file if one wasn't specified + if ($title eq '') { + TITLE_SEARCH: { + for (my $i = 0; $i < @poddata; $i++) { + if ($poddata[$i] =~ /^=head1\s*NAME\b/m) { + for my $para ( @poddata[$i, $i+1] ) { + last TITLE_SEARCH + if ($title) = $para =~ /(\S+\s+-+.*\S)/s; + } + } - } - } + } + } + } if (!$title and $podfile =~ /\.pod$/) { # probably a split pod so take first =head[12] as title for (my $i = 0; $i < @poddata; $i++) { @@ -1371,9 +1375,6 @@ sub process_L { # LREF: a la HREF L<show this text|man/section> $linktext = $1 if s:^([^|]+)\|::; - # a :: acts like a / - s,::,/,; - # make sure sections start with a / s,^",/",g; s,^,/,g if (!m,/, && / /); @@ -1397,6 +1398,11 @@ sub process_L { if ($page eq "") { $link = "#" . htmlify(0,$section); $linktext = $section unless defined($linktext); + } elsif ( $page =~ /::/ ) { + $linktext = ($section ? "$section" : "$page"); + $page =~ s,::,/,g; + $link = "$htmlroot/$page.html"; + $link .= "#" . htmlify(0,$section) if ($section); } elsif (!defined $pages{$page}) { warn "$0: $podfile: cannot resolve L<$str> in paragraph $paragraph: no such page '$page'\n"; $link = ""; diff --git a/contrib/perl5/lib/Pod/Text.pm b/contrib/perl5/lib/Pod/Text.pm index 67993db..549bab5 100644 --- a/contrib/perl5/lib/Pod/Text.pm +++ b/contrib/perl5/lib/Pod/Text.pm @@ -52,6 +52,8 @@ require Exporter; use vars qw($VERSION); $VERSION = "1.0203"; +use locale; # make \w work right in non-ASCII lands + $termcap=0; $opt_alt_format = 0; @@ -273,14 +275,14 @@ sub prepare_for_output { my $paratag = $_; $_ = <IN>; if (/^=/) { # tricked! - local($indent) = $indent[$#index - 1] || $DEF_INDENT; + local($indent) = $indent[$#indent - 1] || $DEF_INDENT; output($paratag); redo POD_DIRECTIVE; } &prepare_for_output; IP_output($paratag, $_); } else { - local($indent) = $indent[$#index - 1] || $DEF_INDENT; + local($indent) = $indent[$#indent - 1] || $DEF_INDENT; output($_, 0); } } @@ -368,7 +370,7 @@ sub fill { sub IP_output { local($tag, $_) = @_; - local($tag_indent) = $indent[$#index - 1] || $DEF_INDENT; + local($tag_indent) = $indent[$#indent - 1] || $DEF_INDENT; $tag_cols = $SCREEN - $tag_indent; $cols = $SCREEN - $indent; $tag =~ s/\s*$//; diff --git a/contrib/perl5/lib/SelfLoader.pm b/contrib/perl5/lib/SelfLoader.pm index a73f68a..311d953 100644 --- a/contrib/perl5/lib/SelfLoader.pm +++ b/contrib/perl5/lib/SelfLoader.pm @@ -133,7 +133,7 @@ is available for reading via the filehandle FOOBAR::DATA, where FOOBAR is the name of the current package when the C<__DATA__> token is reached. This works just the same as C<__END__> does in package 'main', but for other modules data after C<__END__> is not -automatically retreivable , whereas data after C<__DATA__> is. +automatically retrievable, whereas data after C<__DATA__> is. The C<__DATA__> token is not recognized in versions of perl prior to 5.001m. @@ -203,7 +203,7 @@ There is no need to inherit from the B<SelfLoader>. The B<SelfLoader> works similarly to the AutoLoader, but picks up the subs from after the C<__DATA__> instead of in the 'lib/auto' directory. -There is a maintainance gain in not needing to run AutoSplit on the module +There is a maintenance gain in not needing to run AutoSplit on the module at installation, and a runtime gain in not needing to keep opening and closing files to load subs. There is a runtime loss in needing to parse the code after the C<__DATA__>. Details of the B<AutoLoader> and diff --git a/contrib/perl5/lib/Symbol.pm b/contrib/perl5/lib/Symbol.pm index 5ed6b26..a842c1c 100644 --- a/contrib/perl5/lib/Symbol.pm +++ b/contrib/perl5/lib/Symbol.pm @@ -46,7 +46,7 @@ C<Symbol::qualify> turns unqualified symbol names into qualified variable names (e.g. "myvar" -E<gt> "MyPackage::myvar"). If it is given a second parameter, C<qualify> uses it as the default package; otherwise, it uses the package of its caller. Regardless, global -variable names (e.g. "STDOUT", "ENV", "SIG") are always qualfied with +variable names (e.g. "STDOUT", "ENV", "SIG") are always qualified with "main::". Qualification applies only to symbol names (strings). References are diff --git a/contrib/perl5/lib/Term/Complete.pm b/contrib/perl5/lib/Term/Complete.pm index 275aade..445dfca 100644 --- a/contrib/perl5/lib/Term/Complete.pm +++ b/contrib/perl5/lib/Term/Complete.pm @@ -5,7 +5,7 @@ require Exporter; @ISA = qw(Exporter); @EXPORT = qw(Complete); -# @(#)complete.pl,v1.1 (me@anywhere.EBay.Sun.COM) 09/23/91 +# @(#)complete.pl,v1.2 (me@anywhere.EBay.Sun.COM) 09/23/91 =head1 NAME @@ -13,8 +13,8 @@ Term::Complete - Perl word completion module =head1 SYNOPSIS - $input = complete('prompt_string', \@completion_list); - $input = complete('prompt_string', @completion_list); + $input = Complete('prompt_string', \@completion_list); + $input = Complete('prompt_string', @completion_list); =head1 DESCRIPTION @@ -56,7 +56,7 @@ Bell sounds when word completion fails. =head1 BUGS -The completion charater E<lt>tabE<gt> cannot be changed. +The completion character E<lt>tabE<gt> cannot be changed. =head1 AUTHOR @@ -72,7 +72,11 @@ CONFIG: { } sub Complete { - my($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r); + my($prompt, @cmp_list, $cmp, $test, $l, @match); + my ($return, $r) = ("", 0); + + $return = ""; + $r = 0; $prompt = shift; if (ref $_[0] || $_[0] =~ /^\*/) { @@ -90,17 +94,17 @@ sub Complete { # (TAB) attempt completion $_ eq "\t" && do { @match = grep(/^$return/, @cmp_lst); - $l = length($test = shift(@match)); unless ($#match < 0) { + $l = length($test = shift(@match)); foreach $cmp (@match) { until (substr($cmp, 0, $l) eq substr($test, 0, $l)) { $l--; } } print("\a"); + print($test = substr($test, $r, $l - $r)); + $r = length($return .= $test); } - print($test = substr($test, $r, $l - $r)); - $r = length($return .= $test); last CASE; }; @@ -113,8 +117,8 @@ sub Complete { # (^U) kill $_ eq $kill && do { if ($r) { - undef $r; - undef $return; + $r = 0; + $return = ""; print("\r\n"); redo LOOP; } diff --git a/contrib/perl5/lib/Term/ReadLine.pm b/contrib/perl5/lib/Term/ReadLine.pm index 470226d..e7cf00c 100644 --- a/contrib/perl5/lib/Term/ReadLine.pm +++ b/contrib/perl5/lib/Term/ReadLine.pm @@ -139,7 +139,7 @@ None =head1 ENVIRONMENT -The envrironment variable C<PERL_RL> governs which ReadLine clone is +The environment variable C<PERL_RL> governs which ReadLine clone is loaded. If the value is false, a dummy interface is used. If the value is true, it should be tail of the name of the package to use, such as C<Perl> or C<Gnu>. diff --git a/contrib/perl5/lib/Test.pm b/contrib/perl5/lib/Test.pm index 6f57415..7a0e59b 100644 --- a/contrib/perl5/lib/Test.pm +++ b/contrib/perl5/lib/Test.pm @@ -2,17 +2,19 @@ use strict; package Test; use Test::Harness 1.1601 (); use Carp; -use vars (qw($VERSION @ISA @EXPORT $ntest $TestLevel), #public-ish - qw($ONFAIL %todo %history $planned @FAILDETAIL)); #private-ish -$VERSION = '1.04'; +use vars (qw($VERSION @ISA @EXPORT @EXPORT_OK $ntest $TestLevel), #public-ish + qw($TESTOUT $ONFAIL %todo %history $planned @FAILDETAIL)); #private-ish +$VERSION = '1.122'; require Exporter; @ISA=('Exporter'); -@EXPORT= qw(&plan &ok &skip $ntest); +@EXPORT=qw(&plan &ok &skip); +@EXPORT_OK=qw($ntest $TESTOUT); $TestLevel = 0; # how many extra stack frames to skip $|=1; #$^W=1; ? $ntest=1; +$TESTOUT = *STDOUT{IO}; # Use of this variable is strongly discouraged. It is set mainly to # help test coverage analyzers know which test is running. @@ -35,9 +37,9 @@ sub plan { } my @todo = sort { $a <=> $b } keys %todo; if (@todo) { - print "1..$max todo ".join(' ', @todo).";\n"; + print $TESTOUT "1..$max todo ".join(' ', @todo).";\n"; } else { - print "1..$max\n"; + print $TESTOUT "1..$max\n"; } ++$planned; } @@ -47,9 +49,6 @@ sub to_value { (ref $v or '') eq 'CODE' ? $v->() : $v; } -# STDERR is NOT used for diagnostic output which should have been -# fixed before release. Is this appropriate? - sub ok ($;$$) { croak "ok: plan before you test!" if !$planned; my ($pkg,$file,$line) = caller($TestLevel); @@ -63,49 +62,49 @@ sub ok ($;$$) { $ok = $result; } else { $expected = to_value(shift); - # until regex can be manipulated like objects... my ($regex,$ignore); - if (($regex) = ($expected =~ m,^ / (.+) / $,sx) or + if ((ref($expected)||'') eq 'Regexp') { + $ok = $result =~ /$expected/; + } elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or ($ignore, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) { $ok = $result =~ /$regex/; } else { $ok = $result eq $expected; } } - if ($todo{$ntest}) { - if ($ok) { - print "ok $ntest # Wow! ($context)\n"; - } else { - $diag = to_value(shift) if @_; - if (!$diag) { - print "not ok $ntest # (failure expected in $context)\n"; - } else { - print "not ok $ntest # (failure expected: $diag)\n"; - } - } + my $todo = $todo{$ntest}; + if ($todo and $ok) { + $context .= ' TODO?!' if $todo; + print $TESTOUT "ok $ntest # ($context)\n"; } else { - print "not " if !$ok; - print "ok $ntest\n"; + print $TESTOUT "not " if !$ok; + print $TESTOUT "ok $ntest\n"; if (!$ok) { my $detail = { 'repetition' => $repetition, 'package' => $pkg, - 'result' => $result }; + 'result' => $result, 'todo' => $todo }; $$detail{expected} = $expected if defined $expected; $diag = $$detail{diagnostic} = to_value(shift) if @_; + $context .= ' *TODO*' if $todo; if (!defined $expected) { if (!$diag) { - print STDERR "# Failed test $ntest in $context\n"; + print $TESTOUT "# Failed test $ntest in $context\n"; } else { - print STDERR "# Failed test $ntest in $context: $diag\n"; + print $TESTOUT "# Failed test $ntest in $context: $diag\n"; } } else { my $prefix = "Test $ntest"; - print STDERR "# $prefix got: '$result' ($context)\n"; + print $TESTOUT "# $prefix got: '$result' ($context)\n"; $prefix = ' ' x (length($prefix) - 5); + if ((ref($expected)||'') eq 'Regexp') { + $expected = 'qr/'.$expected.'/' + } else { + $expected = "'$expected'"; + } if (!$diag) { - print STDERR "# $prefix Expected: '$expected'\n"; + print $TESTOUT "# $prefix Expected: $expected\n"; } else { - print STDERR "# $prefix Expected: '$expected' ($diag)\n"; + print $TESTOUT "# $prefix Expected: $expected ($diag)\n"; } } push @FAILDETAIL, $detail; @@ -116,8 +115,10 @@ sub ok ($;$$) { } sub skip ($$;$$) { - if (to_value(shift)) { - print "ok $ntest # skip\n"; + my $whyskip = to_value(shift); + if ($whyskip) { + $whyskip = 'skip' if $whyskip =~ m/^\d+$/; + print $TESTOUT "ok $ntest # $whyskip\n"; ++ $ntest; 1; } else { @@ -141,7 +142,12 @@ __END__ use strict; use Test; - BEGIN { plan tests => 13, todo => [3,4] } + + # use a BEGIN block so we print our plan before MyModule is loaded + BEGIN { plan tests => 14, todo => [3,4] } + + # load your module... + use MyModule; ok(0); # failure ok(1); # success @@ -152,10 +158,11 @@ __END__ ok(0,1); # failure: '0' ne '1' ok('broke','fixed'); # failure: 'broke' ne 'fixed' ok('fixed','fixed'); # success: 'fixed' eq 'fixed' + ok('fixed',qr/x/); # success: 'fixed' =~ qr/x/ ok(sub { 1+1 }, 2); # success: '2' eq '2' ok(sub { 1+1 }, 3); # failure: '2' ne '3' - ok(0, int(rand(2)); # (just kidding! :-) + ok(0, int(rand(2)); # (just kidding :-) my @list = (0,0); ok @list, 3, "\@list=".join(',',@list); #extra diagnostics @@ -165,9 +172,9 @@ __END__ =head1 DESCRIPTION -Test::Harness expects to see particular output when it executes tests. -This module aims to make writing proper test scripts just a little bit -easier (and less error prone :-). +L<Test::Harness> expects to see particular output when it executes +tests. This module aims to make writing proper test scripts just a +little bit easier (and less error prone :-). =head1 TEST TYPES @@ -175,57 +182,64 @@ easier (and less error prone :-). =item * NORMAL TESTS -These tests are expected to succeed. If they don't, something's +These tests are expected to succeed. If they don't something's screwed up! =item * SKIPPED TESTS -Skip tests need a platform specific feature that might or might not be -available. The first argument should evaluate to true if the required -feature is NOT available. After the first argument, skip tests work +Skip is for tests that might or might not be possible to run depending +on the availability of platform specific features. The first argument +should evaluate to true (think "yes, please skip") if the required +feature is not available. After the first argument, skip works exactly the same way as do normal tests. =item * TODO TESTS -TODO tests are designed for maintaining an executable TODO list. -These tests are expected NOT to succeed (otherwise the feature they -test would be on the new feature list, not the TODO list). +TODO tests are designed for maintaining an B<executable TODO list>. +These tests are expected NOT to succeed. If a TODO test does succeed, +the feature in question should not be on the TODO list, now should it? -Packages should NOT be released with successful TODO tests. As soon +Packages should NOT be released with succeeding TODO tests. As soon as a TODO test starts working, it should be promoted to a normal test -and the newly minted feature should be documented in the release -notes. +and the newly working feature should be documented in the release +notes or change log. =back +=head1 RETURN VALUE + +Both C<ok> and C<skip> return true if their test succeeds and false +otherwise in a scalar context. + =head1 ONFAIL BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } } -The test failures can trigger extra diagnostics at the end of the test -run. C<onfail> is passed an array ref of hash refs that describe each -test failure. Each hash will contain at least the following fields: -package, repetition, and result. (The file, line, and test number are -not included because their correspondance to a particular test is -fairly weak.) If the test had an expected value or a diagnostic -string, these will also be included. - -This optional feature might be used simply to print out the version of -your package and/or how to report problems. It might also be used to -generate extremely sophisticated diagnostics for a particular test -failure. It's not a panacea, however. Core dumps or other -unrecoverable errors will prevent the C<onfail> hook from running. -(It is run inside an END block.) Besides, C<onfail> is probably -over-kill in the majority of cases. (Your test code should be simpler +While test failures should be enough, extra diagnostics can be +triggered at the end of a test run. C<onfail> is passed an array ref +of hash refs that describe each test failure. Each hash will contain +at least the following fields: C<package>, C<repetition>, and +C<result>. (The file, line, and test number are not included because +their correspondance to a particular test is tenuous.) If the test +had an expected value or a diagnostic string, these will also be +included. + +The B<optional> C<onfail> hook might be used simply to print out the +version of your package and/or how to report problems. It might also +be used to generate extremely sophisticated diagnostics for a +particularly bizarre test failure. However it's not a panacea. Core +dumps or other unrecoverable errors prevent the C<onfail> hook from +running. (It is run inside an C<END> block.) Besides, C<onfail> is +probably over-kill in most cases. (Your test code should be simpler than the code it is testing, yes?) =head1 SEE ALSO -L<Test::Harness> and various test coverage analysis tools. +L<Test::Harness> and, perhaps, test coverage analysis tools. =head1 AUTHOR -Copyright (C) 1998 Joshua Nathaniel Pritikin. All rights reserved. +Copyright (c) 1998 Joshua Nathaniel Pritikin. All rights reserved. This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified diff --git a/contrib/perl5/lib/Test/Harness.pm b/contrib/perl5/lib/Test/Harness.pm index 9c61d3a..935e8f0 100644 --- a/contrib/perl5/lib/Test/Harness.pm +++ b/contrib/perl5/lib/Test/Harness.pm @@ -160,7 +160,7 @@ sub runtests { } else { push @failed, $next..$max; $failed = @failed; - (my $txt, $canon) = canonfailed($max,@failed); + (my $txt, $canon) = canonfailed($max,$skipped,@failed); $percent = 100*(scalar @failed)/$max; print "DIED. ",$txt; } @@ -173,7 +173,7 @@ sub runtests { } elsif ($ok == $max && $next == $max+1) { if ($max and $skipped + $bonus) { my @msg; - push(@msg, "$skipped subtest".($skipped>1?'s':'')." skipped") + push(@msg, "$skipped/$max subtest".($skipped>1?'s':'')." skipped") if $skipped; push(@msg, "$bonus subtest".($bonus>1?'s':''). " unexpectedly succeeded") @@ -191,7 +191,7 @@ sub runtests { push @failed, $next..$max; } if (@failed) { - my ($txt, $canon) = canonfailed($max,@failed); + my ($txt, $canon) = canonfailed($max,$skipped,@failed); print $txt; $failedtests{$test} = { canon => $canon, max => $max, failed => scalar @failed, @@ -300,7 +300,7 @@ sub corestatus { } sub canonfailed ($@) { - my($max,@failed) = @_; + my($max,$skipped,@failed) = @_; my %seen; @failed = sort {$a <=> $b} grep !$seen{$_}++, @failed; my $failed = @failed; @@ -330,7 +330,12 @@ sub canonfailed ($@) { } push @result, "\tFailed $failed/$max tests, "; - push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay\n"; + push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay"; + my $ender = 's' x ($skipped > 1); + my $good = $max - $failed - $skipped; + my $goodper = sprintf("%.2f",100*($good/$max)); + push @result, " (-$skipped skipped test$ender: $good okay, $goodper%)" if $skipped; + push @result, "\n"; my $txt = join "", @result; ($txt, $canon); } diff --git a/contrib/perl5/lib/Text/ParseWords.pm b/contrib/perl5/lib/Text/ParseWords.pm index 2414f80..065c2f7 100644 --- a/contrib/perl5/lib/Text/ParseWords.pm +++ b/contrib/perl5/lib/Text/ParseWords.pm @@ -63,7 +63,7 @@ sub parse_line { ([\000-\377]*) # and the rest | # --OR-- ^((?:\\.|[^\\"'])*?) # an $unquoted text - (\Z(?!\n)|$delimiter|(?!^)(?=["'])) + (\Z(?!\n)|(?-x:$delimiter)|(?!^)(?=["'])) # plus EOL, delimiter, or quote ([\000-\377]*) # the rest /x; # extended layout diff --git a/contrib/perl5/lib/Text/Wrap.pm b/contrib/perl5/lib/Text/Wrap.pm index 0fe7fb9..5f95edb 100644 --- a/contrib/perl5/lib/Text/Wrap.pm +++ b/contrib/perl5/lib/Text/Wrap.pm @@ -1,57 +1,65 @@ package Text::Wrap; -use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $columns $debug); -use strict; -use Exporter; +require Exporter; -$VERSION = "97.02"; @ISA = qw(Exporter); -@EXPORT = qw(wrap); -@EXPORT_OK = qw($columns $tabstop fill); +@EXPORT = qw(wrap fill); +@EXPORT_OK = qw($columns $break $huge); -use Text::Tabs qw(expand unexpand $tabstop); +$VERSION = 98.112902; +use vars qw($VERSION $columns $debug $break $huge); +use strict; BEGIN { - $columns = 76; # <= screen width - $debug = 0; + $columns = 76; # <= screen width + $debug = 0; + $break = '\s'; + $huge = 'wrap'; # alternatively: 'die' } +use Text::Tabs qw(expand unexpand); + sub wrap { - my ($ip, $xp, @t) = @_; - - my @rv; - my $t = expand(join(" ",@t)); - - my $lead = $ip; - my $ll = $columns - length(expand($lead)) - 1; - my $nl = ""; - - $t =~ s/^\s+//; - while(length($t) > $ll) { - # remove up to a line length of things that - # aren't new lines and tabs. - if ($t =~ s/^([^\n]{0,$ll})(\s|\Z(?!\n))//) { - my ($l,$r) = ($1,$2); - $l =~ s/\s+$//; - print "WRAP $lead$l..($r)\n" if $debug; - push @rv, unexpand($lead . $l), "\n"; - - } elsif ($t =~ s/^([^\n]{$ll})//) { - print "SPLIT $lead$1..\n" if $debug; - push @rv, unexpand($lead . $1),"\n"; + my ($ip, $xp, @t) = @_; + + my $r = ""; + my $t = expand(join(" ",@t)); + my $lead = $ip; + my $ll = $columns - length(expand($ip)) - 1; + my $nll = $columns - length(expand($xp)) - 1; + my $nl = ""; + my $remainder = ""; + + while ($t !~ /^\s*$/) { + if ($t =~ s/^([^\n]{0,$ll})($break|\Z(?!\n))//xm) { + $r .= unexpand($nl . $lead . $1); + $remainder = $2; + } elsif ($huge eq 'wrap' && $t =~ s/^([^\n]{$ll})//) { + $r .= unexpand($nl . $lead . $1); + $remainder = "\n"; + } elsif ($huge eq 'die') { + die "couldn't wrap '$t'"; + } else { + die "This shouldn't happen"; + } + + $lead = $xp; + $ll = $nll; + $nl = "\n"; } - # recompute the leader - $lead = $xp; - $ll = $columns - length(expand($lead)) - 1; - $t =~ s/^\s+//; - } - print "TAIL $lead$t\n" if $debug; - push @rv, $lead.$t if $t ne ""; - return join '', @rv; -} + $r .= $remainder; + print "-----------$r---------\n" if $debug; + + print "Finish up with '$lead', '$t'\n" if $debug; + + $r .= $lead . $t if $t ne ""; + + print "-----------$r---------\n" if $debug;; + return $r; +} sub fill { @@ -83,26 +91,32 @@ Text::Wrap - line wrapping to form simple paragraphs use Text::Wrap print wrap($initial_tab, $subsequent_tab, @text); + print fill($initial_tab, $subsequent_tab, @text); - use Text::Wrap qw(wrap $columns $tabstop fill); + use Text::Wrap qw(wrap $columns $huge); $columns = 132; - $tabstop = 4; - - print fill($initial_tab, $subsequent_tab, @text); - print fill("", "", `cat book`); + $huge = 'die'; + $huge = 'wrap'; =head1 DESCRIPTION Text::Wrap::wrap() is a very simple paragraph formatter. It formats a -single paragraph at a time by breaking lines at word boundries. +single paragraph at a time by breaking lines at word boundaries. Indentation is controlled for the first line ($initial_tab) and -all subsquent lines ($subsequent_tab) independently. $Text::Wrap::columns -should be set to the full width of your output device. +all subsequent lines ($subsequent_tab) independently. + +Lines are wrapped at $Text::Wrap::columns columns. +$Text::Wrap::columns should be set to the full width of your output device. + +When words that are longer than $columns are encountered, they +are broken up. Previous versions of wrap() die()ed instead. +To restore the old (dying) behavior, set $Text::Wrap::huge to +'die'. Text::Wrap::fill() is a simple multi-paragraph formatter. It formats each paragraph separately and then joins them together when it's done. It -will destory any whitespace in the original text. It breaks text into +will destroy any whitespace in the original text. It breaks text into paragraphs by looking for whitespace after a newline. In other respects it acts like wrap(). @@ -111,15 +125,8 @@ it acts like wrap(). print wrap("\t","","This is a bit of text that forms a normal book-style paragraph"); -=head1 BUGS - -It's not clear what the correct behavior should be when Wrap() is -presented with a word that is longer than a line. The previous -behavior was to die. Now the word is now split at line-length. - =head1 AUTHOR David Muir Sharnoff <muir@idiom.com> with help from Tim Pierce and -others. Updated by Jacqui Caren. +many many others. -=cut diff --git a/contrib/perl5/lib/Tie/Array.pm b/contrib/perl5/lib/Tie/Array.pm index 4041b00..3f34c3b 100644 --- a/contrib/perl5/lib/Tie/Array.pm +++ b/contrib/perl5/lib/Tie/Array.pm @@ -176,23 +176,23 @@ provides the methods below. =item STORE this, index, value -Store datum I<value> into I<index> for the tied array assoicated with +Store datum I<value> into I<index> for the tied array associated with object I<this>. If this makes the array larger then class's mapping of C<undef> should be returned for new positions. =item FETCH this, index -Retrieve the datum in I<index> for the tied array assoicated with +Retrieve the datum in I<index> for the tied array associated with object I<this>. =item FETCHSIZE this -Returns the total number of items in the tied array assoicated with +Returns the total number of items in the tied array associated with object I<this>. (Equivalent to C<scalar(@array)>). =item STORESIZE this, count -Sets the total number of items in the tied array assoicated with +Sets the total number of items in the tied array associated with object I<this> to be I<count>. If this makes the array larger then class's mapping of C<undef> should be returned for new positions. If the array becomes smaller then entries beyond count should be @@ -205,7 +205,7 @@ Can be used to optimize allocation. This method need do nothing. =item CLEAR this -Clear (remove, delete, ...) all values from the tied array assoicated with +Clear (remove, delete, ...) all values from the tied array associated with object I<this>. =item DESTROY this @@ -227,7 +227,7 @@ and return it. =item UNSHIFT this, LIST -Insert LIST elements at the begining of the array, moving existing elements +Insert LIST elements at the beginning of the array, moving existing elements up to make room. =item SPLICE this, offset, length, LIST diff --git a/contrib/perl5/lib/Tie/Hash.pm b/contrib/perl5/lib/Tie/Hash.pm index 7ed1896..2902efb 100644 --- a/contrib/perl5/lib/Tie/Hash.pm +++ b/contrib/perl5/lib/Tie/Hash.pm @@ -92,7 +92,7 @@ but may be omitted in favor of a simple default. =head1 MORE INFORMATION -The packages relating to various DBM-related implemetations (F<DB_File>, +The packages relating to various DBM-related implementations (F<DB_File>, F<NDBM_File>, etc.) show examples of general tied hashes, as does the L<Config> module. While these do not utilize B<Tie::Hash>, they serve as good working examples. diff --git a/contrib/perl5/lib/Tie/SubstrHash.pm b/contrib/perl5/lib/Tie/SubstrHash.pm index 44c2140..4b18a58 100644 --- a/contrib/perl5/lib/Tie/SubstrHash.pm +++ b/contrib/perl5/lib/Tie/SubstrHash.pm @@ -69,7 +69,7 @@ sub FETCH { sub STORE { local($self,$key,$val) = @_; local($klen, $vlen, $tsize, $rlen) = @$self[1..4]; - croak("Table is full") if $self[5] == $tsize; + croak("Table is full") if $$self[5] == $tsize; croak(qq/Value "$val" is not $vlen characters long./) if length($val) != $vlen; my $writeoffset; diff --git a/contrib/perl5/lib/Time/Local.pm b/contrib/perl5/lib/Time/Local.pm index eef412d..b2fba7c 100644 --- a/contrib/perl5/lib/Time/Local.pm +++ b/contrib/perl5/lib/Time/Local.pm @@ -17,16 +17,18 @@ Time::Local - efficiently compute time from local and GMT time =head1 DESCRIPTION -These routines are quite efficient and yet are always guaranteed to agree -with localtime() and gmtime(). We manage this by caching the start times -of any months we've seen before. If we know the start time of the month, -we can always calculate any time within the month. The start times -themselves are guessed by successive approximation starting at the -current time, since most dates seen in practice are close to the -current date. Unlike algorithms that do a binary search (calling gmtime -once for each bit of the time value, resulting in 32 calls), this algorithm -calls it at most 6 times, and usually only once or twice. If you hit -the month cache, of course, it doesn't call it at all. +These routines are quite efficient and yet are always guaranteed to +agree with localtime() and gmtime(), the most notable points being +that year is year-1900 and month is 0..11. We manage this by caching +the start times of any months we've seen before. If we know the start +time of the month, we can always calculate any time within the month. +The start times themselves are guessed by successive approximation +starting at the current time, since most dates seen in practice are +close to the current date. Unlike algorithms that do a binary search +(calling gmtime once for each bit of the time value, resulting in 32 +calls), this algorithm calls it at most 6 times, and usually only once +or twice. If you hit the month cache, of course, it doesn't call it +at all. timelocal is implemented using the same cache. We just assume that we're translating a GMT time, and then fudge it when we're done for the timezone diff --git a/contrib/perl5/lib/Time/gmtime.pm b/contrib/perl5/lib/Time/gmtime.pm index c1d11d7..9b823f6 100644 --- a/contrib/perl5/lib/Time/gmtime.pm +++ b/contrib/perl5/lib/Time/gmtime.pm @@ -69,7 +69,7 @@ still overrides your core functions.) Access these fields as variables named with a preceding C<tm_> in front their method names. Thus, C<$tm_obj-E<gt>mday()> corresponds to $tm_mday if you import the fields. -The gmctime() funtion provides a way of getting at the +The gmctime() function provides a way of getting at the scalar sense of the original CORE::gmtime() function. To access this functionality without the core overrides, diff --git a/contrib/perl5/lib/Time/localtime.pm b/contrib/perl5/lib/Time/localtime.pm index 9437752..18a36c7 100644 --- a/contrib/perl5/lib/Time/localtime.pm +++ b/contrib/perl5/lib/Time/localtime.pm @@ -65,7 +65,7 @@ variables named with a preceding C<tm_> in front their method names. Thus, C<$tm_obj-E<gt>mday()> corresponds to $tm_mday if you import the fields. -The ctime() funtion provides a way of getting at the +The ctime() function provides a way of getting at the scalar sense of the original CORE::localtime() function. To access this functionality without the core overrides, diff --git a/contrib/perl5/lib/User/grent.pm b/contrib/perl5/lib/User/grent.pm index deb0a8d..e4e226d 100644 --- a/contrib/perl5/lib/User/grent.pm +++ b/contrib/perl5/lib/User/grent.pm @@ -74,7 +74,7 @@ to $gr_gid if you import the fields. Array references are available as regular array variables, so C<@{ $group_obj-E<gt>members() }> would be simply @gr_members. -The getpw() funtion is a simple front-end that forwards +The getpw() function is a simple front-end that forwards a numeric argument to getpwuid() and the rest to getpwnam(). To access this functionality without the core overrides, diff --git a/contrib/perl5/lib/User/pwent.pm b/contrib/perl5/lib/User/pwent.pm index 32301ca..bb2dace 100644 --- a/contrib/perl5/lib/User/pwent.pm +++ b/contrib/perl5/lib/User/pwent.pm @@ -84,7 +84,7 @@ variables named with a preceding C<pw_> in front their method names. Thus, C<$passwd_obj-E<gt>shell()> corresponds to $pw_shell if you import the fields. -The getpw() funtion is a simple front-end that forwards +The getpw() function is a simple front-end that forwards a numeric argument to getpwuid() and the rest to getpwnam(). To access this functionality without the core overrides, diff --git a/contrib/perl5/lib/constant.pm b/contrib/perl5/lib/constant.pm index 464e20c..5d3dd91 100644 --- a/contrib/perl5/lib/constant.pm +++ b/contrib/perl5/lib/constant.pm @@ -20,6 +20,18 @@ constant - Perl pragma to declare constants print "This line does nothing" unless DEBUGGING; + # references can be declared constant + use constant CHASH => { foo => 42 }; + use constant CARRAY => [ 1,2,3,4 ]; + use constant CPSEUDOHASH => [ { foo => 1}, 42 ]; + use constant CCODE => sub { "bite $_[0]\n" }; + + print CHASH->{foo}; + print CARRAY->[$i]; + print CPSEUDOHASH->{foo}; + print CCODE->("me"); + print CHASH->[10]; # compile-time error + =head1 DESCRIPTION This will declare a symbol to be a constant with the given scalar @@ -86,6 +98,8 @@ 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. + =head1 TECHNICAL NOTE In the current implementation, scalar constants are actually diff --git a/contrib/perl5/lib/diagnostics.pm b/contrib/perl5/lib/diagnostics.pm index 78bf445..b9aaba5 100755 --- a/contrib/perl5/lib/diagnostics.pm +++ b/contrib/perl5/lib/diagnostics.pm @@ -27,7 +27,7 @@ Aa a program: =head2 The C<diagnostics> Pragma This module extends the terse diagnostics normally emitted by both the -perl compiler and the perl interpeter, augmenting them with the more +perl compiler and the perl interpreter, augmenting them with the more explicative and endearing descriptions found in L<perldiag>. Like the other pragmata, it affects the compilation phase of your program rather than merely the execution phase. diff --git a/contrib/perl5/lib/fields.pm b/contrib/perl5/lib/fields.pm index db2eea7..54602a6 100644 --- a/contrib/perl5/lib/fields.pm +++ b/contrib/perl5/lib/fields.pm @@ -32,7 +32,7 @@ does so by updating the %FIELDS hash in the calling package. If a typed lexical variable holding a reference is used to access a hash element and the %FIELDS hash of the given type exists, then the operation is turned into an array access at compile time. The %FIELDS -hash map from hash element names to the array indices. If the hash +hash maps from hash element names to the array indices. If the hash element is not present in the %FIELDS hash, then a compile-time error is signaled. @@ -57,7 +57,7 @@ constructor like this does the job: { my $class = shift; no strict 'refs'; - my $self = bless [\%{"$class\::FIELDS"], $class; + my $self = bless [\%{"$class\::FIELDS"}], $class; $self; } diff --git a/contrib/perl5/lib/overload.pm b/contrib/perl5/lib/overload.pm index 43fef8a..f06b49c 100644 --- a/contrib/perl5/lib/overload.pm +++ b/contrib/perl5/lib/overload.pm @@ -167,13 +167,6 @@ overload - Package for overloading perl operations ... $strval = overload::StrVal $b; -=head1 CAVEAT SCRIPTOR - -Overloading of operators is a subject not to be taken lightly. -Neither its precise implementation, syntax, nor semantics are -100% endorsed by Larry Wall. So any of these may be changed -at some point in the future. - =head1 DESCRIPTION =head2 Declaration of overloaded functions @@ -274,7 +267,7 @@ value of their arguments, and may leave it as is. The result is going to be assigned to the value in the left-hand-side if different from this value. -This allows for the same method to be used as averloaded C<+=> and +This allows for the same method to be used as overloaded C<+=> and C<+>. Note that this is I<allowed>, but not recommended, since by the semantic of L<"Fallback"> Perl will call the method for C<+> anyway, if C<+=> is not overloaded. @@ -283,7 +276,7 @@ if C<+=> is not overloaded. B<Warning.> Due to the presense of assignment versions of operations, routines which may be called in assignment context may create -self-referencial structures. Currently Perl will not free self-referential +self-referential structures. Currently Perl will not free self-referential structures until cycles are C<explicitly> broken. You may get problems when traversing your structures too. @@ -537,7 +530,7 @@ C<'='> was overloaded with C<\&clone>. =back -Same behaviour is triggered by C<$b = $a++>, which is consider a synonim for +Same behaviour is triggered by C<$b = $a++>, which is consider a synonym for C<$b = $a; ++$a>. =head1 MAGIC AUTOGENERATION @@ -748,7 +741,7 @@ There is no size penalty for data if overload is not used. The only size penalty if overload is used in some package is that I<all> the packages acquire a magic during the next C<bless>ing into the package. This magic is three-words-long for packages without -overloading, and carries the cache tabel if the package is overloaded. +overloading, and carries the cache table if the package is overloaded. Copying (C<$a=$b>) is shallow; however, a one-level-deep copying is carried out before any operation that can imply an assignment to the @@ -760,8 +753,8 @@ to be changed are constant (but this is not enforced). =head1 Metaphor clash -One may wonder why the semantic of overloaded C<=> is so counterintuive. -If it I<looks> counterintuive to you, you are subject to a metaphor +One may wonder why the semantic of overloaded C<=> is so counter intuitive. +If it I<looks> counter intuitive to you, you are subject to a metaphor clash. Here is a Perl object metaphor: @@ -868,7 +861,7 @@ Put this in F<symbolic.pm> in your Perl library directory: This module is very unusual as overloaded modules go: it does not provide any usual overloaded operators, instead it provides the L<Last Resort> operator C<nomethod>. In this example the corresponding -subroutine returns an object which encupsulates operations done over +subroutine returns an object which encapsulates operations done over the objects: C<new symbolic 3> contains C<['n', 3]>, C<2 + new symbolic 3> contains C<['+', 2, ['n', 3]]>. @@ -955,7 +948,7 @@ compare an object to 0. In fact, it is easier to write a numeric conversion routine. Here is the text of F<symbolic.pm> with such a routine added (and -slightly modifed str()): +slightly modified str()): package symbolic; # Primitive symbolic calculator use overload @@ -994,7 +987,7 @@ slightly modifed str()): } All the work of numeric conversion is done in %subr and num(). Of -course, %subr is not complete, it contains only operators used in teh +course, %subr is not complete, it contains only operators used in the example below. Here is the extra-credit question: why do we need an explicit recursion in num()? (Answer is at the end of this section.) @@ -1024,7 +1017,7 @@ mutator methods (C<++>, C<-=> and so on), does not do deep copying (not required without mutators!), and implements only those arithmetic operations which are used in the example. -To implement most arithmetic operattions is easy, one should just use +To implement most arithmetic operations is easy, one should just use the tables of operations, and change the code which fills %subr to my %subr = ( 'n' => sub {$_[0]} ); @@ -1102,8 +1095,8 @@ the argument of num(). If you wonder why defaults for conversion are different for str() and num(), note how easy it was to write the symbolic calculator. This simplicity is due to an appropriate choice of defaults. One extra -note: due to teh explicit recursion num() is more fragile than sym(): -we need to explicitly check for the type of $a and $b. If componets +note: due to the explicit recursion num() is more fragile than sym(): +we need to explicitly check for the type of $a and $b. If components $a and $b happen to be of some related type, this may lead to problems. =head2 I<Really> symbolic calculator diff --git a/contrib/perl5/lib/perl5db.pl b/contrib/perl5/lib/perl5db.pl index 099a49b..4d05e6d 100644 --- a/contrib/perl5/lib/perl5db.pl +++ b/contrib/perl5/lib/perl5db.pl @@ -2,7 +2,7 @@ package DB; # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 1.0401; +$VERSION = 1.0402; $header = "perl5db.pl version $VERSION"; # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) @@ -235,7 +235,11 @@ $pretype = [] unless defined $pretype; warnLevel($warnLevel); dieLevel($dieLevel); signalLevel($signalLevel); -&pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager; +&pager((defined($ENV{PAGER}) + ? $ENV{PAGER} + : ($^O eq 'os2' + ? 'cmd /c more' + : 'more'))) unless defined $pager; &recallCommand("!") unless defined $prc; &shellBang("!") unless defined $psh; $maxtrace = 400 unless defined $maxtrace; @@ -361,7 +365,7 @@ sub DB { # _After_ the perl program is compiled, $single is set to 1: if ($single and not $second_time++) { if ($runnonstop) { # Disable until signal - for ($i=0; $i <= $#stack; ) { + for ($i=0; $i <= $stack_depth; ) { $stack[$i++] &= ~1; } $single = 0; @@ -412,11 +416,11 @@ EOP $was_signal = $signal; $signal = 0; if ($single || ($trace & 1) || $was_signal) { - $term || &setterm; if ($emacs) { $position = "\032\032$filename:$line:0\n"; print $LINEINFO $position; } elsif ($package eq 'DB::fake') { + $term || &setterm; print_help(<<EOP); Debugged program terminated. Use B<q> to quit or B<R> to restart, use B<O> I<inhibit_exit> to avoid stopping after program termination, @@ -439,7 +443,7 @@ EOP $position = "$prefix$line$infix$dbline[$line]$after"; } if ($frame) { - print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after"; + print $LINEINFO ' ' x $stack_depth, "$line:\t$dbline[$line]$after"; } else { print $LINEINFO $position; } @@ -450,7 +454,7 @@ EOP $incr_pos = "$prefix$i$infix$dbline[$i]$after"; $position .= $incr_pos; if ($frame) { - print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after"; + print $LINEINFO ' ' x $stack_depth, "$i:\t$dbline[$i]$after"; } else { print $LINEINFO $incr_pos; } @@ -463,7 +467,7 @@ EOP foreach $evalarg (@$pre) { &eval; } - print $OUT $#stack . " levels deep in subroutine calls!\n" + print $OUT $stack_depth . " levels deep in subroutine calls!\n" if $single & 4; $start = $line; $incr = -1; # for backward motion. @@ -640,8 +644,9 @@ EOP $arrow .= 'b' if $stop; $arrow .= 'a' if $action; print $OUT "$i$arrow\t", $dbline[$i]; - last if $signal; + $i++, last if $signal; } + print $OUT "\n" unless $dbline[$i-1] =~ /\n$/; } $start = $i; # remember in case they want more $start = $max if $start > $max; @@ -879,14 +884,14 @@ EOP } $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p. } - for ($i=0; $i <= $#stack; ) { + for ($i=0; $i <= $stack_depth; ) { $stack[$i++] &= ~1; } last CMD; }; $cmd =~ /^r$/ && do { end_report(), next CMD if $finished and $level <= 1; - $stack[$#stack] |= 1; - $doret = $option{PrintRet} ? $#stack - 1 : -2; + $stack[$stack_depth] |= 1; + $doret = $option{PrintRet} ? $stack_depth - 1 : -2; last CMD; }; $cmd =~ /^R$/ && do { print $OUT "Warning: some settings and command-line options may be lost!\n"; @@ -1169,24 +1174,26 @@ sub sub { if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') { $al = " for $$sub"; } - push(@stack, $single); + local $stack_depth = $stack_depth + 1; # Protect from non-local exits + $#stack = $stack_depth; + $stack[-1] = $single; $single &= 1; - $single |= 4 if $#stack == $deep; + $single |= 4 if $stack_depth == $deep; ($frame & 4 - ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "), + ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in "), # Why -1? But it works! :-( print_trace($LINEINFO, -1, 1, 1, "$sub$al") ) - : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame; + : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame; if (wantarray) { @ret = &$sub; - $single |= pop(@stack); + $single |= $stack[$stack_depth--]; ($frame & 4 - ? ( (print $LINEINFO ' ' x $#stack, "out "), + ? ( (print $LINEINFO ' ' x $stack_depth, "out "), print_trace($LINEINFO, -1, 1, 1, "$sub$al") ) - : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2; - if ($doret eq $#stack or $frame & 16) { - my $fh = ($doret eq $#stack ? $OUT : $LINEINFO); - print $fh ' ' x $#stack if $frame & 16; + : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2; + if ($doret eq $stack_depth or $frame & 16) { + my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO); + print $fh ' ' x $stack_depth if $frame & 16; print $fh "list context return from $sub:\n"; dumpit($fh, \@ret ); $doret = -2; @@ -1198,14 +1205,14 @@ sub sub { } else { &$sub; undef $ret; }; - $single |= pop(@stack); + $single |= $stack[$stack_depth--]; ($frame & 4 - ? ( (print $LINEINFO ' ' x $#stack, "out "), + ? ( (print $LINEINFO ' ' x $stack_depth, "out "), print_trace($LINEINFO, -1, 1, 1, "$sub$al") ) - : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2; - if ($doret eq $#stack or $frame & 16 and defined wantarray) { - my $fh = ($doret eq $#stack ? $OUT : $LINEINFO); - print $fh (' ' x $#stack) if $frame & 16; + : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2; + if ($doret eq $stack_depth or $frame & 16 and defined wantarray) { + my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO); + print $fh (' ' x $stack_depth) if $frame & 16; print $fh (defined wantarray ? "scalar context return from $sub: " : "void context return from $sub\n"); @@ -1226,7 +1233,6 @@ sub save { sub eval { my @res; { - local (@stack) = @stack; # guard against recursive debugging my $otrace = $trace; my $osingle = $single; my $od = $^D; @@ -1284,7 +1290,7 @@ sub postponed { $filename =~ s/^_<//; $signal = 1, print $OUT "'$filename' loaded...\n" if $break_on_load{$filename}; - print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame; + print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame; return unless $postponed_file{$filename}; $had_breakpoints{$filename}++; #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic @@ -1432,7 +1438,6 @@ sub system { sub setterm { local $frame = 0; local $doret = -2; - local @stack = @stack; # Prevent growth by failing `use'. eval { require Term::ReadLine } or die $@; if ($notty) { if ($tty) { @@ -1747,13 +1752,7 @@ sub list_versions { } $version{$file} .= $INC{$file}; } - do 'dumpvar.pl' unless defined &main::dumpValue; - if (defined &main::dumpValue) { - local $frame = 0; - &main::dumpValue(\%version); - } else { - print $OUT "dumpvar.pl not available.\n"; - } + dumpit($OUT,\%version); } sub sethelp { @@ -2073,6 +2072,7 @@ BEGIN { # This does not compile, alas. # @stack and $doret are needed in sub sub, which is called for DB::postponed. # Triggers bug (?) in perl is we postpone this until runtime: @postponed = @stack = (0); + $stack_depth = 0; # Localized $#stack $doret = -2; $frame = 0; } diff --git a/contrib/perl5/makedepend.SH b/contrib/perl5/makedepend.SH index efc12b0..0f32da3 100755 --- a/contrib/perl5/makedepend.SH +++ b/contrib/perl5/makedepend.SH @@ -67,6 +67,7 @@ if test -f Makefile; then # to be out of date. I don't know if OS/2 has touch, so do this: case "$osname" in os2) ;; + netbsd) ;; *) $touch $firstmakefile ;; esac fi @@ -98,6 +99,15 @@ $MAKE clist || ($echo "Searching for .c files..."; \ $echo *.c | $tr ' ' $trnl | $egrep -v '\*' >.clist) for file in `$cat .clist`; do # for file in `cat /dev/null`; do + if [ "$osname" = uwin ]; then + uwinfix="-e s,\\\\\\\\,/,g -e s,\\([a-zA-Z]\\):/,/\\1/,g" + else + if [ "$osname" = os2 ]; then + uwinfix="-e s,\\\\\\\\,/,g" + else + uwinfix= + fi + fi case "$file" in *.c) filebase=`basename $file .c` ;; *.y) filebase=`basename $file .y` ;; @@ -126,7 +136,7 @@ for file in `$cat .clist`; do -e 's/^.*"\(.*\)".*$/'$filebase'\$(OBJ_EXT): \1/' \ -e 's/^# *[0-9][0-9]* \(.*\)$/'$filebase'\$(OBJ_EXT): \1/' \ -e 's|: \./|: |' \ - -e 's|\.c\.c|.c|' | \ + -e 's|\.c\.c|.c|' $uwinfix | \ $uniq | $sort | $uniq >> .deptmp done diff --git a/contrib/perl5/malloc.c b/contrib/perl5/malloc.c index 73c4039..eca7322 100644 --- a/contrib/perl5/malloc.c +++ b/contrib/perl5/malloc.c @@ -141,7 +141,7 @@ #define MIN_BUC_POW2 (sizeof(void*) > 4 ? 3 : 2) /* Allow for 4-byte arena. */ #define MIN_BUCKET (MIN_BUC_POW2 * BUCKETS_PER_POW2) -#if !(defined(I286) || defined(atarist)) +#if !(defined(I286) || defined(atarist) || defined(__MINT__)) /* take 2k unless the block is bigger than that */ # define LOG_OF_MIN_ARENA 11 #else @@ -247,7 +247,7 @@ #define u_short unsigned short /* 286 and atarist like big chunks, which gives too much overhead. */ -#if (defined(RCHECK) || defined(I286) || defined(atarist)) && defined(PACK_MALLOC) +#if (defined(RCHECK) || defined(I286) || defined(atarist) || defined(__MINT__)) && defined(PACK_MALLOC) # undef PACK_MALLOC #endif @@ -570,12 +570,19 @@ static char bucket_of[] = # define BIG_SIZE (1<<16) /* 64K */ # endif +#ifdef MUTEX_INIT_CALLS_MALLOC +# undef MUTEX_LOCK +# define MUTEX_LOCK(m) STMT_START { if (*m) mutex_lock(*m); } STMT_END +# undef MUTEX_UNLOCK +# define MUTEX_UNLOCK(m) STMT_START { if (*m) mutex_unlock(*m); } STMT_END +#endif + static char *emergency_buffer; static MEM_SIZE emergency_buffer_size; +static Malloc_t emergency_sbrk(MEM_SIZE size); static Malloc_t -emergency_sbrk(size) - MEM_SIZE size; +emergency_sbrk(MEM_SIZE size) { MEM_SIZE rsize = (((size - 1)>>LOG_OF_MIN_ARENA) + 1)<<LOG_OF_MIN_ARENA; @@ -599,6 +606,7 @@ emergency_sbrk(size) SV *sv; char *pv; int have = 0; + STRLEN n_a; if (emergency_buffer_size) { add_to_chain(emergency_buffer, emergency_buffer_size, 0); @@ -614,7 +622,7 @@ emergency_sbrk(size) return (char *)-1; /* Now die die die... */ } /* Got it, now detach SvPV: */ - pv = SvPV(sv, PL_na); + pv = SvPV(sv, n_a); /* Check alignment: */ if (((UV)(pv - sizeof(union overhead))) & ((1<<LOG_OF_MIN_ARENA) - 1)) { PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n"); @@ -670,6 +678,7 @@ static u_int start_slack; static u_int goodsbrk; #ifdef DEBUGGING +#undef ASSERT #define ASSERT(p,diag) if (!(p)) botch(diag,STRINGIFY(p)); else static void botch(char *diag, char *s) @@ -944,7 +953,7 @@ getpages(int needed, int *nblksp, int bucket) /* Second, check alignment. */ slack = 0; -#ifndef atarist /* on the atari we dont have to worry about this */ +#if !defined(atarist) && !defined(__MINT__) /* on the atari we dont have to worry about this */ # ifndef I286 /* The sbrk(0) call on the I286 always returns the next segment */ /* CHUNK_SHIFT is 1 for PACK_MALLOC, 0 otherwise. */ @@ -954,7 +963,7 @@ getpages(int needed, int *nblksp, int bucket) add += slack; } # endif -#endif /* atarist */ +#endif /* !atarist && !MINT */ if (add) { DEBUG_m(PerlIO_printf(Perl_debug_log, @@ -1254,7 +1263,7 @@ free(void *mp) * is extern so the caller can modify it). If that fails we just copy * however many bytes was given to realloc() and hope it's not huge. */ -int reall_srchlen = 4; /* 4 should be plenty, -1 =>'s whole list */ +int reall_srchlen = 4; /* 4 should be plenty, -1 =>'s whole list */ Malloc_t realloc(void *mp, size_t nbytes) @@ -1572,11 +1581,7 @@ dump_mstats(char *s) #ifdef USE_PERL_SBRK -# ifdef NeXT -# define PERL_SBRK_VIA_MALLOC -# endif - -# ifdef __MACHTEN_PPC__ +# if defined(__MACHTEN_PPC__) || defined(__NeXT__) # define PERL_SBRK_VIA_MALLOC /* * MachTen's malloc() returns a buffer aligned on a two-byte boundary. @@ -1619,8 +1624,7 @@ static long Perl_sbrk_oldsize; # define PERLSBRK_64_K (1<<16) Malloc_t -Perl_sbrk(size) -int size; +Perl_sbrk(int size) { IV got; int small, reqsize; diff --git a/contrib/perl5/mg.c b/contrib/perl5/mg.c index 9dfbd4f..d69fd53 100644 --- a/contrib/perl5/mg.c +++ b/contrib/perl5/mg.c @@ -1,6 +1,6 @@ /* mg.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -248,7 +248,9 @@ mg_copy(SV *sv, SV *nsv, char *key, I32 klen) MAGIC* mg; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { if (isUPPER(mg->mg_type)) { - sv_magic(nsv, mg->mg_obj, toLOWER(mg->mg_type), key, klen); + sv_magic(nsv, + mg->mg_type == 'P' ? SvTIED_obj(sv, mg) : mg->mg_obj, + toLOWER(mg->mg_type), key, klen); count++; } } @@ -339,8 +341,10 @@ magic_len(SV *sv, MAGIC *mg) return (STRLEN)PL_orslen; } magic_get(sv,mg); - if (!SvPOK(sv) && SvNIOK(sv)) - sv_2pv(sv, &PL_na); + if (!SvPOK(sv) && SvNIOK(sv)) { + STRLEN n_a; + sv_2pv(sv, &n_a); + } if (SvPOK(sv)) return SvCUR(sv); return 0; @@ -360,6 +364,9 @@ magic_get(SV *sv, MAGIC *mg) case '\001': /* ^A */ sv_setsv(sv, PL_bodytarget); break; + case '\003': /* ^C */ + sv_setiv(sv, (IV)PL_minus_c); + break; case '\004': /* ^D */ sv_setiv(sv, (IV)(PL_debug & 32767)); break; @@ -382,8 +389,11 @@ magic_get(SV *sv, MAGIC *mg) sv_setnv(sv, (double)errno); sv_setpv(sv, errno ? Strerror(errno) : ""); } else { - if (errno != errno_isOS2) - Perl_rc = _syserrno(); + if (errno != errno_isOS2) { + int tmp = _syserrno(); + if (tmp) /* 2nd call to _syserrno() makes it 0 */ + Perl_rc = tmp; + } sv_setnv(sv, (double)Perl_rc); sv_setpv(sv, os2error(Perl_rc)); } @@ -716,7 +726,8 @@ magic_setenv(SV *sv, MAGIC *mg) int magic_clearenv(SV *sv, MAGIC *mg) { - my_setenv(MgPV(mg,PL_na),Nullch); + STRLEN n_a; + my_setenv(MgPV(mg,n_a),Nullch); return 0; } @@ -729,12 +740,13 @@ magic_set_all_env(SV *sv, MAGIC *mg) dTHR; if (PL_localizing) { HE* entry; + STRLEN n_a; magic_clear_all_env(sv,mg); hv_iterinit((HV*)sv); while (entry = hv_iternext((HV*)sv)) { I32 keylen; my_setenv(hv_iterkey(entry, &keylen), - SvPV(hv_iterval((HV*)sv, entry), PL_na)); + SvPV(hv_iterval((HV*)sv, entry), n_a)); } } #endif @@ -757,7 +769,7 @@ magic_clear_all_env(SV *sv, MAGIC *mg) *end = '\0'; my_setenv(cur,Nullch); *end = '='; - cur += strlen(end+1)+1; + cur = end + strlen(end+1)+2; } else if ((len = strlen(cur))) cur += len+1; @@ -782,8 +794,9 @@ int magic_getsig(SV *sv, MAGIC *mg) { I32 i; + STRLEN n_a; /* Are we fetching a signal entry? */ - i = whichsig(MgPV(mg,PL_na)); + i = whichsig(MgPV(mg,n_a)); if (i) { if(psig_ptr[i]) sv_setsv(sv,psig_ptr[i]); @@ -805,8 +818,9 @@ int magic_clearsig(SV *sv, MAGIC *mg) { I32 i; + STRLEN n_a; /* Are we clearing a signal entry? */ - i = whichsig(MgPV(mg,PL_na)); + i = whichsig(MgPV(mg,n_a)); if (i) { if(psig_ptr[i]) { SvREFCNT_dec(psig_ptr[i]); @@ -827,8 +841,9 @@ magic_setsig(SV *sv, MAGIC *mg) register char *s; I32 i; SV** svp; + STRLEN n_a; - s = MgPV(mg,PL_na); + s = MgPV(mg,n_a); if (*s == '_') { if (strEQ(s,"__DIE__")) svp = &PL_diehook; @@ -865,7 +880,7 @@ magic_setsig(SV *sv, MAGIC *mg) *svp = SvREFCNT_inc(sv); return 0; } - s = SvPV_force(sv,PL_na); + s = SvPV_force(sv,n_a); if (strEQ(s,"IGNORE")) { if (i) (void)rsignal(i, SIG_IGN); @@ -922,7 +937,7 @@ magic_getnkeys(SV *sv, MAGIC *mg) if (hv) { (void) hv_iterinit(hv); - if (!SvRMAGICAL(hv) || !mg_find((SV*)hv,'P')) + if (! SvTIED_mg((SV*)hv, 'P')) i = HvKEYS(hv); else { /*SUPPRESS 560*/ @@ -947,13 +962,13 @@ magic_setnkeys(SV *sv, MAGIC *mg) /* caller is responsible for stack switching/cleanup */ STATIC int -magic_methcall(MAGIC *mg, char *meth, I32 flags, int n, SV *val) +magic_methcall(SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val) { dSP; PUSHMARK(SP); EXTEND(SP, n); - PUSHs(mg->mg_obj); + PUSHs(SvTIED_obj(sv, mg)); if (n > 1) { if (mg->mg_ptr) { if (mg->mg_len >= 0) @@ -982,7 +997,7 @@ magic_methpack(SV *sv, MAGIC *mg, char *meth) SAVETMPS; PUSHSTACKi(PERLSI_MAGIC); - if (magic_methcall(mg, meth, G_SCALAR, 2, NULL)) { + if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) { sv_setsv(sv, *PL_stack_sp--); } @@ -1007,7 +1022,7 @@ magic_setpack(SV *sv, MAGIC *mg) dSP; ENTER; PUSHSTACKi(PERLSI_MAGIC); - magic_methcall(mg, "STORE", G_SCALAR|G_DISCARD, 3, sv); + magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv); POPSTACK; LEAVE; return 0; @@ -1029,7 +1044,7 @@ magic_sizepack(SV *sv, MAGIC *mg) ENTER; SAVETMPS; PUSHSTACKi(PERLSI_MAGIC); - if (magic_methcall(mg, "FETCHSIZE", G_SCALAR, 2, NULL)) { + if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) { sv = *PL_stack_sp--; retval = (U32) SvIV(sv)-1; } @@ -1046,7 +1061,7 @@ int magic_wipepack(SV *sv, MAGIC *mg) ENTER; PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); - XPUSHs(mg->mg_obj); + XPUSHs(SvTIED_obj(sv, mg)); PUTBACK; perl_call_method("CLEAR", G_SCALAR|G_DISCARD); POPSTACK; @@ -1065,7 +1080,7 @@ magic_nextpack(SV *sv, MAGIC *mg, SV *key) PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); EXTEND(SP, 2); - PUSHs(mg->mg_obj); + PUSHs(SvTIED_obj(sv, mg)); if (SvOK(key)) PUSHs(key); PUTBACK; @@ -1093,11 +1108,12 @@ magic_setdbline(SV *sv, MAGIC *mg) I32 i; GV* gv; SV** svp; + STRLEN n_a; gv = PL_DBline; i = SvTRUE(sv); svp = av_fetch(GvAV(gv), - atoi(MgPV(mg,PL_na)), FALSE); + atoi(MgPV(mg,n_a)), FALSE); if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp))) o->op_private = i; else @@ -1193,10 +1209,11 @@ magic_setglob(SV *sv, MAGIC *mg) { register char *s; GV* gv; + STRLEN n_a; if (!SvOK(sv)) return 0; - s = SvPV(sv, PL_na); + s = SvPV(sv, n_a); if (*s == '*' && s[1]) s++; gv = gv_fetchpv(s,TRUE, SVt_PVGV); @@ -1406,8 +1423,10 @@ vivify_defelem(SV *sv) if (svp) value = *svp; } - if (!value || value == &PL_sv_undef) - croak(no_helem, SvPV(mg->mg_obj, PL_na)); + if (!value || value == &PL_sv_undef) { + STRLEN n_a; + croak(no_helem, SvPV(mg->mg_obj, n_a)); + } } else { AV* av = (AV*)LvTARG(sv); @@ -1498,6 +1517,9 @@ magic_set(SV *sv, MAGIC *mg) case '\001': /* ^A */ sv_setsv(PL_bodytarget, sv); break; + case '\003': /* ^C */ + PL_minus_c = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); + break; case '\004': /* ^D */ PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000; DEBUG_x(dump_all()); @@ -1524,7 +1546,7 @@ magic_set(SV *sv, MAGIC *mg) if (PL_inplace) Safefree(PL_inplace); if (SvOK(sv)) - PL_inplace = savepv(SvPV(sv,PL_na)); + PL_inplace = savepv(SvPV(sv,len)); else PL_inplace = Nullch; break; @@ -1532,7 +1554,7 @@ magic_set(SV *sv, MAGIC *mg) if (PL_osname) Safefree(PL_osname); if (SvOK(sv)) - PL_osname = savepv(SvPV(sv,PL_na)); + PL_osname = savepv(SvPV(sv,len)); else PL_osname = Nullch; break; @@ -1559,12 +1581,12 @@ magic_set(SV *sv, MAGIC *mg) break; case '^': Safefree(IoTOP_NAME(GvIOp(PL_defoutgv))); - IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,PL_na)); + IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len)); IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO); break; case '~': Safefree(IoFMT_NAME(GvIOp(PL_defoutgv))); - IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,PL_na)); + IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len)); IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO); break; case '=': @@ -1621,7 +1643,7 @@ magic_set(SV *sv, MAGIC *mg) case '#': if (PL_ofmt) Safefree(PL_ofmt); - PL_ofmt = savepv(SvPV(sv,PL_na)); + PL_ofmt = savepv(SvPV(sv,len)); break; case '[': PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); @@ -1729,7 +1751,7 @@ magic_set(SV *sv, MAGIC *mg) case ')': #ifdef HAS_SETGROUPS { - char *p = SvPV(sv, PL_na); + char *p = SvPV(sv, len); Groups_t gary[NGROUPS]; SET_NUMERIC_STANDARD(); @@ -1777,7 +1799,7 @@ magic_set(SV *sv, MAGIC *mg) PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); break; case ':': - PL_chopset = SvPV_force(sv,PL_na); + PL_chopset = SvPV_force(sv,len); break; case '0': if (!PL_origalen) { @@ -1790,7 +1812,10 @@ magic_set(SV *sv, MAGIC *mg) || PL_origargv[i] == s + 2 #endif ) - s += strlen(++s); /* this one is ok too */ + { + ++s; + s += strlen(s); /* this one is ok too */ + } else break; } @@ -1803,8 +1828,10 @@ magic_set(SV *sv, MAGIC *mg) my_setenv("NoNe SuCh", Nullch); /* force copy of environment */ for (i = 0; PL_origenviron[i]; i++) - if (PL_origenviron[i] == s + 1) - s += strlen(++s); + if (PL_origenviron[i] == s + 1) { + ++s; + s += strlen(s); + } else break; } @@ -1851,7 +1878,6 @@ magic_mutexfree(SV *sv, MAGIC *mg) croak("panic: magic_mutexfree"); MUTEX_DESTROY(MgMUTEXP(mg)); COND_DESTROY(MgCONDP(mg)); - SvREFCNT_dec(sv); return 0; } #endif /* USE_THREADS */ diff --git a/contrib/perl5/mg.h b/contrib/perl5/mg.h index 16efdb5..ccd3acc 100644 --- a/contrib/perl5/mg.h +++ b/contrib/perl5/mg.h @@ -1,6 +1,6 @@ /* mg.h * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -43,3 +43,8 @@ struct magic { #define MgPV(mg,lp) (((lp = (mg)->mg_len) == HEf_SVKEY) ? \ SvPV((SV*)((mg)->mg_ptr),lp) : \ (mg)->mg_ptr) + +#define SvTIED_mg(sv,how) \ + (SvRMAGICAL(sv) ? mg_find((sv),(how)) : Null(MAGIC*)) +#define SvTIED_obj(sv,mg) \ + ((mg)->mg_obj ? (mg)->mg_obj : sv_2mortal(newRV(sv))) diff --git a/contrib/perl5/miniperlmain.c b/contrib/perl5/miniperlmain.c index 4eb1dcd..cfbe95b 100644 --- a/contrib/perl5/miniperlmain.c +++ b/contrib/perl5/miniperlmain.c @@ -13,6 +13,12 @@ static void xs_init _((void)); static PerlInterpreter *my_perl; +#if defined (__MINT__) || defined (atarist) +/* The Atari operating system doesn't have a dynamic stack. The + stack size is determined from this value. */ +long _stksize = 64 * 1024; +#endif + int main(int argc, char **argv, char **env) { diff --git a/contrib/perl5/objXSUB.h b/contrib/perl5/objXSUB.h index d548d20..94ea6be 100644 --- a/contrib/perl5/objXSUB.h +++ b/contrib/perl5/objXSUB.h @@ -19,6 +19,8 @@ #define PL_colors pPerl->PL_colors #undef PL_colorset #define PL_colorset pPerl->PL_colorset +#undef PL_cred_mutex +#define PL_cred_mutex pPerl->PL_cred_mutex #undef PL_curcop #define PL_curcop pPerl->PL_curcop #undef PL_curpad @@ -443,6 +445,8 @@ #define PL_strchop pPerl->PL_strchop #undef PL_strtab #define PL_strtab pPerl->PL_strtab +#undef PL_strtab_mutex +#define PL_strtab_mutex pPerl->PL_strtab_mutex #undef PL_sub_generation #define PL_sub_generation pPerl->PL_sub_generation #undef PL_sublex_info @@ -902,6 +906,8 @@ #define do_vecset pPerl->Perl_do_vecset #undef do_vop #define do_vop pPerl->Perl_do_vop +#undef dofile +#define dofile pPerl->Perl_dofile #undef dowantarray #define dowantarray pPerl->Perl_dowantarray #undef dump_all @@ -966,6 +972,8 @@ #define get_opargs pPerl->Perl_get_opargs #undef get_specialsv_list #define get_specialsv_list pPerl->Perl_get_specialsv_list +#undef get_vtbl +#define get_vtbl pPerl->Perl_get_vtbl #undef gp_free #define gp_free pPerl->Perl_gp_free #undef gp_ref @@ -1569,6 +1577,8 @@ #define save_freeop pPerl->Perl_save_freeop #undef save_freepv #define save_freepv pPerl->Perl_save_freepv +#undef save_generic_svref +#define save_generic_svref pPerl->Perl_generic_save_svref #undef save_gp #define save_gp pPerl->Perl_save_gp #undef save_hash @@ -1977,8 +1987,8 @@ #define signal PerlProc_signal #define htonl PerlSock_htonl #define htons PerlSock_htons -#define ntohs PerlSock_ntohl -#define ntohl PerlSock_ntohs +#define ntohl PerlSock_ntohl +#define ntohs PerlSock_ntohs #define accept PerlSock_accept #define bind PerlSock_bind #define connect PerlSock_connect diff --git a/contrib/perl5/objpp.h b/contrib/perl5/objpp.h index e0c2f24..dd24e38 100644 --- a/contrib/perl5/objpp.h +++ b/contrib/perl5/objpp.h @@ -3,6 +3,10 @@ #undef amagic_call #define amagic_call CPerlObj::Perl_amagic_call +#undef amagic_cmp +#define amagic_cmp CPerlObj::amagic_cmp +#undef amagic_cmp_locale +#define amagic_cmp_locale CPerlObj::amagic_cmp_locale #undef Gv_AMupdate #define Gv_AMupdate CPerlObj::Perl_Gv_AMupdate #undef add_data @@ -289,6 +293,8 @@ #define do_vecset CPerlObj::Perl_do_vecset #undef do_vop #define do_vop CPerlObj::Perl_do_vop +#undef dofile +#define dofile CPerlObj::Perl_dofile #undef do_clean_all #define do_clean_all CPerlObj::do_clean_all #undef do_clean_named_objs @@ -375,6 +381,8 @@ #define get_opargs CPerlObj::Perl_get_opargs #undef get_specialsv_list #define get_specialsv_list CPerlObj::Perl_get_specialsv_list +#undef get_vtbl +#define get_vtbl CPerlObj::Perl_get_vtbl #undef getlogin #define getlogin CPerlObj::getlogin #undef gp_free @@ -1095,6 +1103,8 @@ #define save_freeop CPerlObj::Perl_save_freeop #undef save_freepv #define save_freepv CPerlObj::Perl_save_freepv +#undef save_generic_svref +#define save_generic_svref CPerlObj::Perl_save_generic_svref #undef save_gp #define save_gp CPerlObj::Perl_save_gp #undef save_hash diff --git a/contrib/perl5/op.c b/contrib/perl5/op.c index 421a093..bf944a6 100644 --- a/contrib/perl5/op.c +++ b/contrib/perl5/op.c @@ -1,6 +1,6 @@ /* op.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -35,6 +35,8 @@ Nullop ) \ : (CHECKCALL[type])((OP*)o)) +#define PAD_MAX 999999999 + static bool scalar_mod_type _((OP *o, I32 type)); #ifndef PERL_OBJECT static I32 list_assignment _((OP *o)); @@ -46,7 +48,7 @@ static OP *too_few_arguments _((OP *o, char* name)); static OP *too_many_arguments _((OP *o, char* name)); static void null _((OP* o)); static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq, - CV* startcv, I32 cx_ix)); + CV* startcv, I32 cx_ix, I32 saweval, U32 flags)); static OP *newDEFSVOP _((void)); static OP *new_logop _((I32 type, I32 flags, OP **firstp, OP **otherp)); #endif @@ -55,8 +57,9 @@ STATIC char* gv_ename(GV *gv) { SV* tmpsv = sv_newmortal(); + STRLEN n_a; gv_efullname3(tmpsv, gv, Nullch); - return SvPV(tmpsv,PL_na); + return SvPV(tmpsv,n_a); } STATIC OP * @@ -131,10 +134,11 @@ pad_allocmy(char *name) for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_floor; off--) { if ((sv = svp[off]) && sv != &PL_sv_undef - && SvIVX(sv) == 999999999 /* var is in open scope */ + && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0) && strEQ(name, SvPVX(sv))) { - warn("\"my\" variable %s masks earlier declaration in same scope", name); + warn("\"my\" variable %s masks earlier declaration in same %s", + name, (SvIVX(sv) == PAD_MAX ? "scope" : "statement")); break; } } @@ -152,7 +156,7 @@ pad_allocmy(char *name) PL_sv_objcount++; } av_store(PL_comppad_name, off, sv); - SvNVX(sv) = (double)999999999; + SvNVX(sv) = (double)PAD_MAX; SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */ if (!PL_min_intro_pending) PL_min_intro_pending = off; @@ -165,8 +169,11 @@ pad_allocmy(char *name) return off; } +#define FINDLEX_NOSEARCH 1 /* don't search outer contexts */ + STATIC PADOFFSET -pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) +pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval, + U32 flags) { dTHR; CV *cv; @@ -174,7 +181,6 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) SV *sv; register I32 i; register PERL_CONTEXT *cx; - int saweval; for (cv = startcv; cv; cv = CvOUTSIDE(cv)) { AV *curlist = CvPADLIST(cv); @@ -214,8 +220,14 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) sv_setpv(namesv, name); av_store(PL_comppad_name, newoff, namesv); SvNVX(namesv) = (double)PL_curcop->cop_seq; - SvIVX(namesv) = 999999999; /* A ref, intro immediately */ + SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */ SvFAKE_on(namesv); /* A ref, not a real var */ + if (SvOBJECT(svp[off])) { /* A typed var */ + SvOBJECT_on(namesv); + (void)SvUPGRADE(namesv, SVt_PVMG); + SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(svp[off])); + PL_sv_objcount++; + } if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) { /* "It's closures all the way down." */ CvCLONE_on(PL_compcv); @@ -227,14 +239,18 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) CV *bcv; for (bcv = startcv; bcv && bcv != cv && !CvCLONE(bcv); - bcv = CvOUTSIDE(bcv)) { + bcv = CvOUTSIDE(bcv)) + { if (CvANON(bcv)) CvCLONE_on(bcv); else { - if (PL_dowarn && !CvUNIQUE(cv)) + if (PL_dowarn + && !CvUNIQUE(bcv) && !CvUNIQUE(cv)) + { warn( "Variable \"%s\" may be unavailable", name); + } break; } } @@ -251,25 +267,28 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) } } + if (flags & FINDLEX_NOSEARCH) + return 0; + /* Nothing in current lexical context--try eval's context, if any. * This is necessary to let the perldb get at lexically scoped variables. * XXX This will also probably interact badly with eval tree caching. */ - saweval = 0; for (i = cx_ix; i >= 0; i--) { cx = &cxstack[i]; - switch (cx->cx_type) { + switch (CxTYPE(cx)) { default: if (i == 0 && saweval) { seq = cxstack[saweval].blk_oldcop->cop_seq; - return pad_findlex(name, newoff, seq, PL_main_cv, 0); + return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0); } break; case CXt_EVAL: switch (cx->blk_eval.old_op_type) { case OP_ENTEREVAL: - saweval = i; + if (CxREALEVAL(cx)) + saweval = i; break; case OP_REQUIRE: /* require must have its own scope */ @@ -285,7 +304,7 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) continue; } seq = cxstack[saweval].blk_oldcop->cop_seq; - return pad_findlex(name, newoff, seq, cv, i-1); + return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH); } } @@ -301,6 +320,8 @@ pad_findmy(char *name) SV *sv; SV **svp = AvARRAY(PL_comppad_name); U32 seq = PL_cop_seqmax; + PERL_CONTEXT *cx; + CV *outside; #ifdef USE_THREADS /* @@ -330,8 +351,20 @@ pad_findmy(char *name) } } + outside = CvOUTSIDE(PL_compcv); + + /* Check if if we're compiling an eval'', and adjust seq to be the + * eval's seq number. This depends on eval'' having a non-null + * CvOUTSIDE() while it is being compiled. The eval'' itself is + * identified by CvEVAL being true and CvGV being null. */ + if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) { + cx = &cxstack[cxstack_ix]; + if (CxREALEVAL(cx)) + seq = cx->blk_oldcop->cop_seq; + } + /* See if it's in a nested scope */ - off = pad_findlex(name, 0, seq, CvOUTSIDE(PL_compcv), cxstack_ix); + off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0); if (off) { /* If there is a pending local definition, this new alias must die */ if (pendoff) @@ -355,7 +388,7 @@ pad_leavemy(I32 fill) } /* "Deintroduce" my variables that are leaving with this scope. */ for (off = AvFILLp(PL_comppad_name); off > fill; off--) { - if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == 999999999) + if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX) SvIVX(sv) = PL_cop_seqmax; } } @@ -517,11 +550,15 @@ find_threadsv(char *name) if (!p) return NOT_IN_PAD; key = p - PL_threadsv_names; + MUTEX_LOCK(&thr->mutex); svp = av_fetch(thr->threadsv, key, FALSE); - if (!svp) { + if (svp) + MUTEX_UNLOCK(&thr->mutex); + else { SV *sv = NEWSV(0, 0); av_store(thr->threadsv, key, sv); thr->threadsvp = AvARRAY(thr->threadsv); + MUTEX_UNLOCK(&thr->mutex); /* * Some magic variables used to be automagically initialised * in gv_fetchpv. Those which are now per-thread magicals get @@ -538,6 +575,16 @@ find_threadsv(char *name) case '`': case '\'': PL_sawampersand = TRUE; + /* FALL THROUGH */ + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': SvREADONLY_on(sv); /* FALL THROUGH */ @@ -774,7 +821,8 @@ scalarvoid(OP *o) SV* sv; /* assumes no premature commitment */ - if (!o || (o->op_flags & OPf_WANT) == OPf_WANT_LIST || PL_error_count + U8 want = o->op_flags & OPf_WANT; + if (!o || (want && want != OPf_WANT_SCALAR) || PL_error_count || o->op_type == OP_RETURN) return o; @@ -1076,6 +1124,7 @@ mod(OP *o, I32 type) dTHR; OP *kid; SV *sv; + STRLEN n_a; if (!o || PL_error_count) return o; @@ -1202,7 +1251,7 @@ mod(OP *o, I32 type) PL_modcount++; if (!type) croak("Can't localize lexical variable %s", - SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), PL_na)); + SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a)); break; #ifdef USE_THREADS @@ -1866,7 +1915,7 @@ append_list(I32 type, LISTOP *first, LISTOP *last) first->op_last = last->op_last; first->op_children += last->op_children; if (first->op_children) - last->op_flags |= OPf_KIDS; + first->op_flags |= OPf_KIDS; Safefree(last); return (OP*)first; @@ -2179,8 +2228,11 @@ pmruntime(OP *o, OP *expr, OP *repl) if (repl) { OP *curop; - if (pm->op_pmflags & PMf_EVAL) + if (pm->op_pmflags & PMf_EVAL) { curop = 0; + if (PL_curcop->cop_line < PL_multi_end) + PL_curcop->cop_line = PL_multi_end; + } #ifdef USE_THREADS else if (repl->op_type == OP_THREADSV && strchr("&`'123456789+", @@ -2339,6 +2391,7 @@ package(OP *o) sv_setpv(PL_curstname,"<none>"); PL_curstash = Nullhv; } + PL_hints |= HINT_BLOCK_SCOPE; PL_copline = NOLINE; PL_expect = XSTATE; } @@ -2351,6 +2404,7 @@ utilize(int aver, I32 floor, OP *version, OP *id, OP *arg) OP *rqop; OP *imop; OP *veop; + GV *gv; if (id->op_type != OP_CONST) croak("Module name must be constant"); @@ -2402,8 +2456,21 @@ utilize(int aver, I32 floor, OP *version, OP *id, OP *arg) newUNOP(OP_METHOD, 0, meth))); } - /* Fake up a require */ - rqop = newUNOP(OP_REQUIRE, 0, id); + /* Fake up a require, handle override, if any */ + gv = gv_fetchpv("require", FALSE, SVt_PVCV); + if (!(gv && GvIMPORTED_CV(gv))) + gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV); + + if (gv && GvIMPORTED_CV(gv)) { + rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, id, + scalar(newUNOP(OP_RV2CV, 0, + newGVOP(OP_GV, 0, + gv)))))); + } + else { + rqop = newUNOP(OP_REQUIRE, 0, id); + } /* Fake up the BEGIN {}, which does its thing immediately. */ newSUB(floor, @@ -2420,6 +2487,29 @@ utilize(int aver, I32 floor, OP *version, OP *id, OP *arg) } OP * +dofile(OP *term) +{ + OP *doop; + GV *gv; + + gv = gv_fetchpv("do", FALSE, SVt_PVCV); + if (!(gv && GvIMPORTED_CV(gv))) + gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV); + + if (gv && GvIMPORTED_CV(gv)) { + doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, term, + scalar(newUNOP(OP_RV2CV, 0, + newGVOP(OP_GV, 0, + gv)))))); + } + else { + doop = newUNOP(OP_DOFILE, 0, scalar(term)); + } + return doop; +} + +OP * newSLICEOP(I32 flags, OP *subscript, OP *listval) { return newBINOP(OP_LSLICE, flags, @@ -2663,7 +2753,7 @@ intro_my(void) svp = AvARRAY(PL_comppad_name); for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) { if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) { - SvIVX(sv) = 999999999; /* Don't know scope end yet. */ + SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */ SvNVX(sv) = (double)PL_cop_seqmax; } } @@ -3115,13 +3205,14 @@ newLOOPEX(I32 type, OP *label) { dTHR; OP *o; + STRLEN n_a; if (type != OP_GOTO || label->op_type == OP_CONST) { /* "last()" means "last" */ if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) o = newOP(type, OPf_SPECIAL); else { o = newPVOP(type, 0, savepv(label->op_type == OP_CONST - ? SvPVx(((SVOP*)label)->op_sv, PL_na) + ? SvPVx(((SVOP*)label)->op_sv, n_a) : "")); } op_free(label); @@ -3211,7 +3302,7 @@ CV* cv; cv, (CvANON(cv) ? "ANON" : (cv == PL_main_cv) ? "MAIN" - : CvUNIQUE(outside) ? "UNIQUE" + : CvUNIQUE(cv) ? "UNIQUE" : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"), outside, (!outside ? "null" @@ -3311,7 +3402,7 @@ cv_clone2(CV *proto, CV *outside) char *name = SvPVX(namesv); /* XXX */ if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */ I32 off = pad_findlex(name, ix, SvIVX(namesv), - CvOUTSIDE(cv), cxstack_ix); + CvOUTSIDE(cv), cxstack_ix, 0, 0); if (!off) PL_curpad[ix] = SvREFCNT_inc(ppad[ix]); else if (off != ix) @@ -3375,7 +3466,11 @@ cv_clone2(CV *proto, CV *outside) CV * cv_clone(CV *proto) { - return cv_clone2(proto, CvOUTSIDE(proto)); + CV *cv; + MUTEX_LOCK(&PL_cred_mutex); /* XXX create separate mutex */ + cv = cv_clone2(proto, CvOUTSIDE(proto)); + MUTEX_UNLOCK(&PL_cred_mutex); /* XXX create separate mutex */ + return cv; } void @@ -3451,10 +3546,11 @@ CV * newSUB(I32 floor, OP *o, OP *proto, OP *block) { dTHR; - char *name = o ? SvPVx(cSVOPo->op_sv, PL_na) : Nullch; + STRLEN n_a; + char *name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch; GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI | (block ? 0 : GV_NOINIT), SVt_PVCV); - char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, PL_na) : Nullch; + char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch; register CV *cv=0; I32 ix; @@ -3536,9 +3632,10 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block) CvSTASH(cv) = PL_curstash; #ifdef USE_THREADS CvOWNER(cv) = 0; - if (!CvMUTEXP(cv)) + if (!CvMUTEXP(cv)) { New(666, CvMUTEXP(cv), 1, perl_mutex); - MUTEX_INIT(CvMUTEXP(cv)); + MUTEX_INIT(CvMUTEXP(cv)); + } #endif /* USE_THREADS */ if (ps) @@ -3558,7 +3655,7 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block) else { /* force display of errors found but not reported */ sv_catpv(ERRSV, not_safe); - croak("%s", SvPVx(ERRSV, PL_na)); + croak("%s", SvPVx(ERRSV, n_a)); } } } @@ -3683,6 +3780,7 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block) return cv; } +/* XXX unsafe for threads if eval_owner isn't held */ void newCONSTSUB(HV *stash, char *name, SV *sv) { @@ -3729,7 +3827,8 @@ newXS(char *name, void (*subaddr) (CV * _CPERLproto), char *filename) && HvNAME(GvSTASH(CvGV(cv))) && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) { line_t oldline = PL_curcop->cop_line; - PL_curcop->cop_line = PL_copline; + if (PL_copline != NOLINE) + PL_curcop->cop_line = PL_copline; warn("Subroutine %s redefined",name); PL_curcop->cop_line = oldline; } @@ -3781,6 +3880,7 @@ newXS(char *name, void (*subaddr) (CV * _CPERLproto), char *filename) if (!PL_initav) PL_initav = newAV(); av_push(PL_initav, (SV *)cv); + GvCV(gv) = 0; } } else @@ -3797,9 +3897,10 @@ newFORM(I32 floor, OP *o, OP *block) char *name; GV *gv; I32 ix; + STRLEN n_a; if (o) - name = SvPVx(cSVOPo->op_sv, PL_na); + name = SvPVx(cSVOPo->op_sv, n_a); else name = "STDOUT"; gv = gv_fetchpv(name,TRUE, SVt_PVFM); @@ -3861,7 +3962,7 @@ oopsAV(OP *o) case OP_PADSV: o->op_type = OP_PADAV; o->op_ppaddr = ppaddr[OP_PADAV]; - return ref(newUNOP(OP_RV2AV, 0, scalar(o)), OP_RV2AV); + return ref(o, OP_RV2AV); case OP_RV2SV: o->op_type = OP_RV2AV; @@ -3884,7 +3985,7 @@ oopsHV(OP *o) case OP_PADAV: o->op_type = OP_PADHV; o->op_ppaddr = ppaddr[OP_PADHV]; - return ref(newUNOP(OP_RV2HV, 0, scalar(o)), OP_RV2HV); + return ref(o, OP_RV2HV); case OP_RV2SV: case OP_RV2AV: @@ -3914,7 +4015,7 @@ newAVREF(OP *o) OP * newGVREF(I32 type, OP *o) { - if (type == OP_MAPSTART) + if (type == OP_MAPSTART || type == OP_GREPSTART) return newUNOP(OP_NULL, 0, o); return ref(newUNOP(OP_RV2GV, OPf_REF, o), type); } @@ -4145,8 +4246,48 @@ ck_rvconst(register OP *o) char *name; int iscv; GV *gv; + SV *kidsv = kid->op_sv; + STRLEN n_a; + + /* Is it a constant from cv_const_sv()? */ + if (SvROK(kidsv) && SvREADONLY(kidsv)) { + SV *rsv = SvRV(kidsv); + int svtype = SvTYPE(rsv); + char *badtype = Nullch; + + switch (o->op_type) { + case OP_RV2SV: + if (svtype > SVt_PVMG) + badtype = "a SCALAR"; + break; + case OP_RV2AV: + if (svtype != SVt_PVAV) + badtype = "an ARRAY"; + break; + case OP_RV2HV: + if (svtype != SVt_PVHV) { + if (svtype == SVt_PVAV) { /* pseudohash? */ + SV **ksv = av_fetch((AV*)rsv, 0, FALSE); + if (ksv && SvROK(*ksv) + && SvTYPE(SvRV(*ksv)) == SVt_PVHV) + { + break; + } + } + badtype = "a HASH"; + } + break; + case OP_RV2CV: + if (svtype != SVt_PVCV) + badtype = "a CODE"; + break; + } + if (badtype) + croak("Constant is not %s reference", badtype); + return o; + } + name = SvPV(kidsv, n_a); - name = SvPV(kid->op_sv, PL_na); if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { char *badthing = Nullch; switch (o->op_type) { @@ -4209,8 +4350,9 @@ ck_ftst(OP *o) SVOP *kid = (SVOP*)cUNOPo->op_first; if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { + STRLEN n_a; OP *newop = newGVOP(type, OPf_REF, - gv_fetchpv(SvPVx(kid->op_sv, PL_na), TRUE, SVt_PVIO)); + gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO)); op_free(o); return newop; } @@ -4245,6 +4387,7 @@ ck_fun(OP *o) } if (o->op_flags & OPf_KIDS) { + STRLEN n_a; tokid = &cLISTOPo->op_first; kid = cLISTOPo->op_first; if (kid->op_type == OP_PUSHMARK || @@ -4274,7 +4417,7 @@ ck_fun(OP *o) case OA_AVREF: if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - char *name = SvPVx(((SVOP*)kid)->op_sv, PL_na); + char *name = SvPVx(((SVOP*)kid)->op_sv, n_a); OP *newop = newAVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVAV) )); if (PL_dowarn) @@ -4292,7 +4435,7 @@ ck_fun(OP *o) case OA_HVREF: if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - char *name = SvPVx(((SVOP*)kid)->op_sv, PL_na); + char *name = SvPVx(((SVOP*)kid)->op_sv, n_a); OP *newop = newHVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVHV) )); if (PL_dowarn) @@ -4323,11 +4466,15 @@ ck_fun(OP *o) if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { OP *newop = newGVOP(OP_GV, 0, - gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, PL_na), TRUE, + gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE, SVt_PVIO) ); op_free(kid); kid = newop; } + else if (kid->op_type == OP_READLINE) { + /* neophyte patrol: open(<FH>), close(<FH>) etc. */ + bad_type(numargs, "HANDLE", op_desc[o->op_type], kid); + } else { kid->op_sibling = 0; kid = newUNOP(OP_RV2GV, 0, scalar(kid)); @@ -4376,7 +4523,9 @@ ck_glob(OP *o) gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); if (gv && GvIMPORTED_CV(gv)) { +#ifndef PERL_OBJECT static int glob_index; +#endif append_elem(OP_GLOB, o, newSVOP(OP_CONST, 0, newSViv(glob_index++))); @@ -4455,6 +4604,8 @@ ck_index(OP *o) { if (o->op_flags & OPf_KIDS) { OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + if (kid) + kid = kid->op_sibling; /* get past "big" */ if (kid && kid->op_type == OP_CONST) fbm_compile(((SVOP*)kid)->op_sv, 0); } @@ -4661,6 +4812,11 @@ ck_sort(OP *o) if (o->op_flags & OPf_STACKED) { OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ OP *k; + + if (o->op_type == OP_SORT) { + GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV)); + GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV)); + } kid = kUNOP->op_first; /* get past rv2gv */ if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { @@ -4693,7 +4849,9 @@ ck_sort(OP *o) kid->op_next = k; o->op_flags |= OPf_SPECIAL; } - } + else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV) + null(cLISTOPo->op_first->op_sibling); + } return o; } @@ -4762,6 +4920,7 @@ ck_subr(OP *o) GV *namegv = 0; int optional = 0; I32 arg = 0; + STRLEN n_a; for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ; if (cvop->op_type == OP_RV2CV) { @@ -4773,7 +4932,7 @@ ck_subr(OP *o) cv = GvCVu(tmpop->op_sv); if (cv && SvPOK(cv) && !(o->op_private & OPpENTERSUB_AMPER)) { namegv = CvANON(cv) ? (GV*)tmpop->op_sv : CvGV(cv); - proto = SvPV((SV*)cv, PL_na); + proto = SvPV((SV*)cv, n_a); } } } @@ -4806,19 +4965,13 @@ ck_subr(OP *o) bad_type(arg, "block", gv_ename(namegv), o2); break; case '*': + /* '*' allows any scalar type, including bareword */ proto++; arg++; if (o2->op_type == OP_RV2GV) - goto wrapref; - { - OP* kid = o2; - OP* sib = kid->op_sibling; - kid->op_sibling = 0; - o2 = newUNOP(OP_RV2GV, 0, kid); - o2->op_sibling = sib; - prev->op_sibling = o2; - } - goto wrapref; + goto wrapref; /* autoconvert GLOB -> GLOBref */ + scalar(o2); + break; case '\\': proto++; arg++; @@ -4865,7 +5018,7 @@ ck_subr(OP *o) default: oops: croak("Malformed prototype for %s: %s", - gv_ename(namegv), SvPV((SV*)cv, PL_na)); + gv_ename(namegv), SvPV((SV*)cv, n_a)); } } else @@ -4909,6 +5062,7 @@ peep(register OP *o) { dTHR; register OP* oldop = 0; + STRLEN n_a; if (!o || o->op_seq) return; ENTER; @@ -4997,24 +5151,6 @@ peep(register OP *o) o->op_seq = PL_op_seqmax++; break; - case OP_PADAV: - if (o->op_next->op_type == OP_RV2AV - && (o->op_next->op_flags & OPf_REF)) - { - null(o->op_next); - o->op_next = o->op_next->op_next; - } - break; - - case OP_PADHV: - if (o->op_next->op_type == OP_RV2HV - && (o->op_next->op_flags & OPf_REF)) - { - null(o->op_next); - o->op_next = o->op_next->op_next; - } - break; - case OP_MAPWHILE: case OP_GREPWHILE: case OP_AND: @@ -5088,7 +5224,7 @@ peep(register OP *o) indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE); if (!indsvp) { croak("No such field \"%s\" in variable %s of type %s", - key, SvPV(lexname, PL_na), HvNAME(SvSTASH(lexname))); + key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname))); } ind = SvIV(*indsvp); if (ind < 1) diff --git a/contrib/perl5/op.h b/contrib/perl5/op.h index 75e674e..d0b56f3 100644 --- a/contrib/perl5/op.h +++ b/contrib/perl5/op.h @@ -1,6 +1,6 @@ /* op.h * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. diff --git a/contrib/perl5/opcode.h b/contrib/perl5/opcode.h index 8f4f00b..81e1690 100644 --- a/contrib/perl5/opcode.h +++ b/contrib/perl5/opcode.h @@ -891,7 +891,7 @@ EXT char *op_desc[] = { "line sequence", "next statement", "debug next statement", - "unstack", + "iteration finalizer", "block entry", "block exit", "block", @@ -2320,7 +2320,7 @@ EXT U32 opargs[] = { 0x00002505, /* anonhash */ 0x02993501, /* splice */ 0x0002351d, /* push */ - 0x00003c14, /* pop */ + 0x00003c04, /* pop */ 0x00003c04, /* shift */ 0x0002351d, /* unshift */ 0x0002d501, /* sort */ @@ -2385,7 +2385,7 @@ EXT U32 opargs[] = { 0x09116504, /* sysopen */ 0x00116504, /* sysseek */ 0x0917651d, /* sysread */ - 0x0911651d, /* syswrite */ + 0x0991651d, /* syswrite */ 0x0911651d, /* send */ 0x0117651d, /* recv */ 0x0000ec14, /* eof */ diff --git a/contrib/perl5/opcode.pl b/contrib/perl5/opcode.pl index f2ed795..cec51c0 100755 --- a/contrib/perl5/opcode.pl +++ b/contrib/perl5/opcode.pl @@ -432,7 +432,7 @@ anonhash anonymous hash ck_fun ms@ L splice splice ck_fun m@ A S? S? L push push ck_fun imst@ A L -pop pop ck_shift si% A +pop pop ck_shift s% A shift shift ck_shift s% A unshift unshift ck_fun imst@ A L sort sort ck_sort m@ C? L @@ -470,7 +470,7 @@ reset reset ck_fun is% S? lineseq line sequence ck_null @ nextstate next statement ck_null s; dbstate debug next statement ck_null s; -unstack unstack ck_null s0 +unstack iteration finalizer ck_null s0 enter block entry ck_null 0 leave block exit ck_null @ scope block ck_null @ @@ -519,7 +519,7 @@ print print ck_listiob ims@ F? L sysopen sysopen ck_fun s@ F S S S? sysseek sysseek ck_fun s@ F S S sysread sysread ck_fun imst@ F R S S? -syswrite syswrite ck_fun imst@ F S S S? +syswrite syswrite ck_fun imst@ F S S? S? send send ck_fun imst@ F S S S? recv recv ck_fun imst@ F R S S diff --git a/contrib/perl5/patchlevel.h b/contrib/perl5/patchlevel.h index 2245b1f..cbf0b1d 100644 --- a/contrib/perl5/patchlevel.h +++ b/contrib/perl5/patchlevel.h @@ -1,7 +1,7 @@ #ifndef __PATCHLEVEL_H_INCLUDED__ #define PATCHLEVEL 5 #undef SUBVERSION /* OS/390 has a SUBVERSION in a system header */ -#define SUBVERSION 2 +#define SUBVERSION 3 /* local_patches -- list of locally applied less-than-subversion patches. diff --git a/contrib/perl5/perl.c b/contrib/perl5/perl.c index e76d83a..cc1f7ed 100644 --- a/contrib/perl5/perl.c +++ b/contrib/perl5/perl.c @@ -1,6 +1,6 @@ /* perl.c * - * Copyright (c) 1987-1998 Larry Wall + * Copyright (c) 1987-1999 Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -64,6 +64,9 @@ static void my_exit_jump _((void)) __attribute__((noreturn)); static void nuke_stacks _((void)); static void open_script _((char *, bool, SV *, int *fd)); static void usage _((char *)); +#ifdef IAMSUID +static int fd_on_nosuid_fs _((int)); +#endif static void validate_suid _((char *, char*, int)); static I32 read_e_script _((int idx, SV *buf_sv, int maxlen)); #endif @@ -126,6 +129,7 @@ perl_construct(register PerlInterpreter *sv_interp) croak("panic: pthread_key_create"); #endif MUTEX_INIT(&PL_sv_mutex); + MUTEX_INIT(&PL_cred_mutex); /* * Safe to use basic SV functions from now on (though * not things like mortals or tainting yet). @@ -551,9 +555,14 @@ perl_destruct(register PerlInterpreter *sv_interp) DEBUG_P(debprofdump()); #ifdef USE_THREADS + MUTEX_DESTROY(&PL_strtab_mutex); MUTEX_DESTROY(&PL_sv_mutex); + MUTEX_DESTROY(&PL_cred_mutex); MUTEX_DESTROY(&PL_eval_mutex); COND_DESTROY(&PL_eval_cond); +#ifdef EMULATE_ATOMIC_REFCOUNTS + MUTEX_DESTROY(&PL_svref_mutex); +#endif /* EMULATE_ATOMIC_REFCOUNTS */ /* As the penultimate thing, free the non-arena SV for thrsv */ Safefree(SvPVX(PL_thrsv)); @@ -719,6 +728,9 @@ setuid perl scripts securely.\n"); s = argv[0]+1; reswitch: switch (*s) { +#ifndef PERL_STRICT_CR + case '\r': +#endif case ' ': case '0': case 'F': @@ -1138,6 +1150,7 @@ CV* perl_get_cv(char *name, I32 create) { GV* gv = gv_fetchpv(name, create, SVt_PVCV); + /* XXX unsafe for threads if eval_owner isn't held */ if (create && !GvCVu(gv)) return newSUB(start_subparse(FALSE, 0), newSVOP(OP_CONST, 0, newSVpv(name,0)), @@ -1440,8 +1453,10 @@ perl_eval_pv(char *p, I32 croak_on_error) sv = POPs; PUTBACK; - if (croak_on_error && SvTRUE(ERRSV)) - croak(SvPVx(ERRSV, PL_na)); + if (croak_on_error && SvTRUE(ERRSV)) { + STRLEN n_a; + croak(SvPVx(ERRSV, n_a)); + } return sv; } @@ -1713,7 +1728,7 @@ moreswitches(char *s) LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : ""); #endif - printf("\n\nCopyright 1987-1998, Larry Wall\n"); + printf("\n\nCopyright 1987-1999, Larry Wall\n"); #ifdef MSDOS printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); #endif @@ -1737,6 +1752,12 @@ moreswitches(char *s) #ifdef OEMVS printf("MVS (OS390) port by Mortice Kern Systems, 1997-1998\n"); #endif +#ifdef __VOS__ + printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n"); +#endif +#ifdef __MINT__ + printf("MiNT port by Guido Flohr, 1997\n"); +#endif #ifdef BINARY_BUILD_NOTICE BINARY_BUILD_NOTICE; #endif @@ -1758,7 +1779,7 @@ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); break; case '-': case 0: -#ifdef WIN32 +#if defined(WIN32) || !defined(PERL_STRICT_CR) case '\r': #endif case '\n': @@ -1886,6 +1907,9 @@ init_main_stash(void) about not iterating on it, and not adding tie magic to it. It is properly deallocated in perl_destruct() */ PL_strtab = newHV(); +#ifdef USE_THREADS + MUTEX_INIT(&PL_strtab_mutex); +#endif HvSHAREKEYS_off(PL_strtab); /* mandatory */ hv_ksplit(PL_strtab, 512); @@ -1913,7 +1937,7 @@ init_main_stash(void) PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)); PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV)); /* We must init $/ before switches are processed. */ - sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1); + sv_setpvn(perl_get_sv("/", TRUE), "\n", 1); } STATIC void @@ -2056,6 +2080,71 @@ sed %s -e \"/^[^#]/b\" \ } } +#ifdef IAMSUID +static int +fd_on_nosuid_fs(int fd) +{ + int on_nosuid = 0; + int check_okay = 0; +/* + * Preferred order: fstatvfs(), fstatfs(), getmntent(). + * fstatvfs() is UNIX98. + * fstatfs() is BSD. + * getmntent() is O(number-of-mounted-filesystems) and can hang. + */ + +# ifdef HAS_FSTATVFS + struct statvfs stfs; + check_okay = fstatvfs(fd, &stfs) == 0; + on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID); +# else +# if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS) + struct statfs stfs; + check_okay = fstatfs(fd, &stfs) == 0; +# undef PERL_MOUNT_NOSUID +# if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID) +# define PERL_MOUNT_NOSUID MNT_NOSUID +# endif +# if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID) +# define PERL_MOUNT_NOSUID MS_NOSUID +# endif +# if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID) +# define PERL_MOUNT_NOSUID M_NOSUID +# endif +# ifdef PERL_MOUNT_NOSUID + on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID); +# endif +# else +# if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID) + FILE *mtab = fopen("/etc/mtab", "r"); + struct mntent *entry; + struct stat stb, fsb; + + if (mtab && (fstat(fd, &stb) == 0)) { + while (entry = getmntent(mtab)) { + if (stat(entry->mnt_dir, &fsb) == 0 + && fsb.st_dev == stb.st_dev) + { + /* found the filesystem */ + check_okay = 1; + if (hasmntopt(entry, MNTOPT_NOSUID)) + on_nosuid = 1; + break; + } /* A single fs may well fail its stat(). */ + } + } + if (mtab) + fclose(mtab); +# endif /* mntent */ +# endif /* statfs */ +# endif /* statvfs */ + if (!check_okay) + croak("Can't check filesystem of script \"%s\" for nosuid", + PL_origfilename); + return on_nosuid; +} +#endif /* IAMSUID */ + STATIC void validate_suid(char *validarg, char *scriptname, int fdscript) { @@ -2089,6 +2178,7 @@ validate_suid(char *validarg, char *scriptname, int fdscript) croak("Can't stat script \"%s\"",PL_origfilename); if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) { I32 len; + STRLEN n_a; #ifdef IAMSUID #ifndef HAS_SETREUID @@ -2123,6 +2213,10 @@ validate_suid(char *validarg, char *scriptname, int fdscript) croak("Can't swap uid and euid"); /* really paranoid */ if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0) croak("Permission denied"); /* testing full pathname here */ +#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK) + if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) + croak("Permission denied"); +#endif if (tmpstatbuf.st_dev != PL_statbuf.st_dev || tmpstatbuf.st_ino != PL_statbuf.st_ino) { (void)PerlIO_close(PL_rsfp); @@ -2161,12 +2255,12 @@ validate_suid(char *validarg, char *scriptname, int fdscript) PL_doswitches = FALSE; /* -s is insecure in suid */ PL_curcop->cop_line++; if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch || - strnNE(SvPV(PL_linestr,PL_na),"#!",2) ) /* required even on Sys V */ + strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */ croak("No #! line"); - s = SvPV(PL_linestr,PL_na)+2; + s = SvPV(PL_linestr,n_a)+2; if (*s == ' ') s++; while (!isSPACE(*s)) s++; - for (s2 = s; (s2 > SvPV(PL_linestr,PL_na)+2 && + for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 && (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ; if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */ croak("Not a perl script"); @@ -2705,7 +2799,7 @@ incpush(char *p, int addsubdirs) char *unix; STRLEN len; - if ((unix = tounixspec_ts(SvPV(libdir,PL_na),Nullch)) != Nullch) { + if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) { len = strlen(unix); while (unix[len-1] == '/') len--; /* Cosmetic */ sv_usepvn(libdir,unix,len); @@ -2713,7 +2807,7 @@ incpush(char *p, int addsubdirs) else PerlIO_printf(PerlIO_stderr(), "Failed to unixify @INC element \"%s\"\n", - SvPV(libdir,PL_na)); + SvPV(libdir,len)); #endif /* .../archname/version if -d .../archname/version/auto */ sv_setsv(subdir, libdir); diff --git a/contrib/perl5/perl.h b/contrib/perl5/perl.h index 6a063b8..cab0bbc 100644 --- a/contrib/perl5/perl.h +++ b/contrib/perl5/perl.h @@ -1,6 +1,6 @@ /* perl.h * - * Copyright (c) 1987-1997, Larry Wall + * Copyright (c) 1987-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -209,6 +209,12 @@ register struct op *op asm(stringify(OP_IN_REGISTER)); # define LIBERAL 1 #endif +#if 'A' == 65 && 'I' == 73 && 'J' == 74 && 'Z' == 90 +#define ASCIIish +#else +#undef ASCIIish +#endif + /* * The following contortions are brought to you on behalf of all the * standards, semi-standards, de facto standards, not-so-de-facto standards @@ -244,7 +250,7 @@ register struct op *op asm(stringify(OP_IN_REGISTER)); #define TAINT_NOT (PL_tainted = FALSE) #define TAINT_IF(c) if (c) { PL_tainted = TRUE; } #define TAINT_ENV() if (PL_tainting) { taint_env(); } -#define TAINT_PROPER(s) if (PL_tainting) { taint_proper(no_security, s); } +#define TAINT_PROPER(s) if (PL_tainting) { taint_proper(Nullch, s); } /* XXX All process group stuff is handled in pp_sys.c. Should these defines move there? If so, I could simplify this a lot. --AD 9/96. @@ -585,7 +591,7 @@ Free_t Perl_free _((Malloc_t where)); set_vaxc_errno(vmserrcode); \ } STMT_END #else -# define SETERRNO(errcode,vmserrcode) errno = (errcode) +# define SETERRNO(errcode,vmserrcode) (errno = (errcode)) #endif #ifdef USE_THREADS @@ -1109,7 +1115,11 @@ typedef I32 (*filter_t) _((int, SV *, int)); # if defined(MPE) # include "mpeix/mpeixish.h" # else -# include "unixish.h" +# if defined(__VOS__) +# include "vosish.h" +# else +# include "unixish.h" +# endif # endif # endif # endif @@ -1140,11 +1150,22 @@ typedef I32 (*filter_t) _((int, SV *, int)); # ifdef OS2 # include "os2thread.h" # else -# include <pthread.h> -typedef pthread_t perl_os_thread; -typedef pthread_mutex_t perl_mutex; -typedef pthread_cond_t perl_cond; -typedef pthread_key_t perl_key; +# ifdef I_MACH_CTHREADS +# include <mach/cthreads.h> +# ifdef NeXT +# define MUTEX_INIT_CALLS_MALLOC +# endif +typedef cthread_t perl_os_thread; +typedef mutex_t perl_mutex; +typedef condition_t perl_cond; +typedef void * perl_key; +# else /* Posix threads */ +# include <pthread.h> +typedef pthread_t perl_os_thread; +typedef pthread_mutex_t perl_mutex; +typedef pthread_cond_t perl_cond; +typedef pthread_key_t perl_key; +# endif /* I_MACH_CTHREADS */ # endif /* OS2 */ # endif /* WIN32 */ # endif /* FAKE_THREADS */ @@ -1360,7 +1381,7 @@ EXT char Error[1]; # define HAS_VTOHS # define HAS_HTOVL # define HAS_HTOVS -# if BYTEORDER == 0x4321 +# if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 # define vtohl(x) ((((x)&0xFF)<<24) \ +(((x)>>24)&0xFF) \ +(((x)&0x0000FF00)<<8) \ @@ -1545,7 +1566,7 @@ char *getlogin _((void)); #define UNLINK unlnk I32 unlnk _((char*)); #else -#define UNLINK unlink +#define UNLINK PerlLIO_unlink #endif #ifndef HAS_SETREUID @@ -1585,8 +1606,22 @@ typedef Sighandler_t Sigsave_t; #endif #ifdef MYMALLOC -# define MALLOC_INIT MUTEX_INIT(&PL_malloc_mutex) -# define MALLOC_TERM MUTEX_DESTROY(&PL_malloc_mutex) +# ifdef MUTEX_INIT_CALLS_MALLOC +# define MALLOC_INIT \ + STMT_START { \ + PL_malloc_mutex = NULL; \ + MUTEX_INIT(&PL_malloc_mutex); \ + } STMT_END +# define MALLOC_TERM \ + STMT_START { \ + perl_mutex tmp = PL_malloc_mutex; \ + PL_malloc_mutex = NULL; \ + MUTEX_DESTROY(&tmp); \ + } STMT_END +# else +# define MALLOC_INIT MUTEX_INIT(&PL_malloc_mutex) +# define MALLOC_TERM MUTEX_DESTROY(&PL_malloc_mutex) +# endif #else # define MALLOC_INIT # define MALLOC_TERM @@ -1903,6 +1938,39 @@ typedef enum { XTERMBLOCK } expectation; +enum { /* pass one of these to get_vtbl */ + want_vtbl_sv, + want_vtbl_env, + want_vtbl_envelem, + want_vtbl_sig, + want_vtbl_sigelem, + want_vtbl_pack, + want_vtbl_packelem, + want_vtbl_dbline, + want_vtbl_isa, + want_vtbl_isaelem, + want_vtbl_arylen, + want_vtbl_glob, + want_vtbl_mglob, + want_vtbl_nkeys, + want_vtbl_taint, + want_vtbl_substr, + want_vtbl_vec, + want_vtbl_pos, + want_vtbl_bm, + want_vtbl_fm, + want_vtbl_uvar, + want_vtbl_defelem, + want_vtbl_regexp, + want_vtbl_collxfrm, + want_vtbl_amagic, + want_vtbl_amagicelem +#ifdef USE_THREADS + , + want_vtbl_mutex +#endif +}; + /* Note: the lowest 8 bits are reserved for stuffing into op->op_private */ @@ -2075,6 +2143,50 @@ typedef void *Thread; #endif #ifdef PERL_OBJECT +/* from perly.c */ +#undef yydebug +#undef yynerrs +#undef yyerrflag +#undef yychar +#undef yyssp +#undef yyvsp +#undef yyval +#undef yylval +#define yydebug PL_yydebug +#define yynerrs PL_yynerrs +#define yyerrflag PL_yyerrflag +#define yychar PL_yychar +#define yyssp PL_yyssp +#define yyvsp PL_yyvsp +#define yyval PL_yyval +#define yylval PL_yylval +PERLVAR(yydebug, int) +PERLVAR(yynerrs, int) +PERLVAR(yyerrflag, int) +PERLVAR(yychar, int) +PERLVAR(yyssp, short*) +PERLVAR(yyvsp, YYSTYPE*) +PERLVAR(yyval, YYSTYPE) +PERLVAR(yylval, YYSTYPE) + +#define efloatbuf PL_efloatbuf +#define efloatsize PL_efloatsize +PERLVAR(efloatbuf, char *) +PERLVAR(efloatsize, STRLEN) + +#define glob_index PL_glob_index +#define srand_called PL_srand_called +#define uudmap PL_uudmap +#define bitcount PL_bitcount +#define filter_debug PL_filter_debug +PERLVAR(glob_index, int) +PERLVAR(srand_called, bool) +PERLVAR(uudmap[256], char) +PERLVAR(bitcount, char*) +PERLVAR(filter_debug, int) +PERLVAR(super_bufptr, char*) /* PL_bufptr that was */ +PERLVAR(super_bufend, char*) /* PL_bufend that was */ + /* * The following is a buffer where new variables must * be defined to maintain binary compatibility with PERL_OBJECT @@ -2449,4 +2561,18 @@ enum { # endif #endif +#ifdef IAMSUID + +#ifdef I_SYS_STATVFS +# include <sys/statvfs.h> /* for f?statvfs() */ +#endif +#ifdef I_SYS_MOUNT +# include <sys/mount.h> /* for *BSD f?statfs() */ +#endif +#ifdef I_MNTENT +# include <mntent.h> /* for getmntent() */ +#endif + +#endif /* IAMSUID */ + #endif /* Include guard */ diff --git a/contrib/perl5/perl_exp.SH b/contrib/perl5/perl_exp.SH index b8b2907..d8ae949 100755 --- a/contrib/perl5/perl_exp.SH +++ b/contrib/perl5/perl_exp.SH @@ -49,8 +49,10 @@ rm -f perl.exp echo "#!" > perl.exp # No compat3 since 5.004_50. -# perlio.sym will added below if needed. -syms="global.sym interp.sym thread.sym" +# No interp.sym since 5.005_03. +# perlio.sym will added later if needed. + +syms="global.sym thread.sym" sed -n '/^[A-Za-z]/ s/^/Perl_/p' $syms >> perl.exp @@ -59,7 +61,7 @@ sed -n 's/^PERLVAR.*(I\([^[,]*\).*/PL_\1/p' intrpvar.h >> perl.exp sed -n 's/^PERLVAR.*(T\([^[,]*\).*/PL_\1/p' thrdvar.h >> perl.exp # -# If we use the PerlIO abstraction layer, add its symbols +# If we use the PerlIO abstraction layer, add its symbols. # if [ $useperlio = "define" ] @@ -72,7 +74,7 @@ fi # not actually be defined, but there's no harm in that). # -cat <<END >> perl.exp +cat >> perl.exp <<END perl_init_i18nl10n perl_init_i18nl14n perl_new_collate @@ -97,15 +99,32 @@ perl_call_sv perl_eval_pv perl_eval_sv perl_require_pv +cast_i32 +cast_iv +cast_uv +END + +case "$ccflags" in +*-DHIDEMYMALLOC*) + cat >>perl.exp <<END Mymalloc Mycalloc Myremalloc Myfree +END + ;; +esac + +case "$ccflags" in +*-DEMBEDMYMALLOC*) + cat >>perl.exp <<END Perl_malloc Perl_calloc Perl_realloc Perl_free END + ;; +esac # The shebang line nicely sorts as the first one. sort -o perl.exp -u perl.exp diff --git a/contrib/perl5/perlio.c b/contrib/perl5/perlio.c index 314881e..f18f5a3 100644 --- a/contrib/perl5/perlio.c +++ b/contrib/perl5/perlio.c @@ -55,13 +55,13 @@ PerlIO_tmpfile(void) #undef PerlIO_tmpfile PerlIO * -PerlIO_tmpfile() +PerlIO_tmpfile(void) { return sftmp(0); } void -PerlIO_init() +PerlIO_init(void) { /* Force this file to be included in perl binary. Which allows * this file to force inclusion of other functions that may be @@ -84,29 +84,28 @@ PerlIO_init() #undef PerlIO_stderr PerlIO * -PerlIO_stderr() +PerlIO_stderr(void) { return (PerlIO *) stderr; } #undef PerlIO_stdin PerlIO * -PerlIO_stdin() +PerlIO_stdin(void) { return (PerlIO *) stdin; } #undef PerlIO_stdout PerlIO * -PerlIO_stdout() +PerlIO_stdout(void) { return (PerlIO *) stdout; } #undef PerlIO_fast_gets int -PerlIO_fast_gets(f) -PerlIO *f; +PerlIO_fast_gets(PerlIO *f) { #if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) return 1; @@ -117,8 +116,7 @@ PerlIO *f; #undef PerlIO_has_cntptr int -PerlIO_has_cntptr(f) -PerlIO *f; +PerlIO_has_cntptr(PerlIO *f) { #if defined(USE_STDIO_PTR) return 1; @@ -129,8 +127,7 @@ PerlIO *f; #undef PerlIO_canset_cnt int -PerlIO_canset_cnt(f) -PerlIO *f; +PerlIO_canset_cnt(PerlIO *f) { #if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) return 1; @@ -141,9 +138,7 @@ PerlIO *f; #undef PerlIO_set_cnt void -PerlIO_set_cnt(f,cnt) -PerlIO *f; -int cnt; +PerlIO_set_cnt(PerlIO *f, int cnt) { if (cnt < -1) warn("Setting cnt to %d\n",cnt); @@ -156,10 +151,7 @@ int cnt; #undef PerlIO_set_ptrcnt void -PerlIO_set_ptrcnt(f,ptr,cnt) -PerlIO *f; -STDCHAR *ptr; -int cnt; +PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt) { #ifdef FILE_bufsiz STDCHAR *e = FILE_base(f) + FILE_bufsiz(f); @@ -183,8 +175,7 @@ int cnt; #undef PerlIO_get_cnt int -PerlIO_get_cnt(f) -PerlIO *f; +PerlIO_get_cnt(PerlIO *f) { #ifdef FILE_cnt return FILE_cnt(f); @@ -196,8 +187,7 @@ PerlIO *f; #undef PerlIO_get_bufsiz int -PerlIO_get_bufsiz(f) -PerlIO *f; +PerlIO_get_bufsiz(PerlIO *f) { #ifdef FILE_bufsiz return FILE_bufsiz(f); @@ -209,8 +199,7 @@ PerlIO *f; #undef PerlIO_get_ptr STDCHAR * -PerlIO_get_ptr(f) -PerlIO *f; +PerlIO_get_ptr(PerlIO *f) { #ifdef FILE_ptr return FILE_ptr(f); @@ -222,8 +211,7 @@ PerlIO *f; #undef PerlIO_get_base STDCHAR * -PerlIO_get_base(f) -PerlIO *f; +PerlIO_get_base(PerlIO *f) { #ifdef FILE_base return FILE_base(f); @@ -235,8 +223,7 @@ PerlIO *f; #undef PerlIO_has_base int -PerlIO_has_base(f) -PerlIO *f; +PerlIO_has_base(PerlIO *f) { #ifdef FILE_base return 1; @@ -247,62 +234,49 @@ PerlIO *f; #undef PerlIO_puts int -PerlIO_puts(f,s) -PerlIO *f; -const char *s; +PerlIO_puts(PerlIO *f, const char *s) { return fputs(s,f); } #undef PerlIO_open PerlIO * -PerlIO_open(path,mode) -const char *path; -const char *mode; +PerlIO_open(const char *path, const char *mode) { return fopen(path,mode); } #undef PerlIO_fdopen PerlIO * -PerlIO_fdopen(fd,mode) -int fd; -const char *mode; +PerlIO_fdopen(int fd, const char *mode) { return fdopen(fd,mode); } #undef PerlIO_reopen PerlIO * -PerlIO_reopen(name, mode, f) -const char *name; -const char *mode; -PerlIO *f; +PerlIO_reopen(const char *name, const char *mode, PerlIO *f) { return freopen(name,mode,f); } #undef PerlIO_close int -PerlIO_close(f) -PerlIO *f; +PerlIO_close(PerlIO *f) { return fclose(f); } #undef PerlIO_eof int -PerlIO_eof(f) -PerlIO *f; +PerlIO_eof(PerlIO *f) { return feof(f); } #undef PerlIO_getname char * -PerlIO_getname(f,buf) -PerlIO *f; -char *buf; +PerlIO_getname(PerlIO *f, char *buf) { #ifdef VMS return fgetname(f,buf); @@ -314,48 +288,42 @@ char *buf; #undef PerlIO_getc int -PerlIO_getc(f) -PerlIO *f; +PerlIO_getc(PerlIO *f) { return fgetc(f); } #undef PerlIO_error int -PerlIO_error(f) -PerlIO *f; +PerlIO_error(PerlIO *f) { return ferror(f); } #undef PerlIO_clearerr void -PerlIO_clearerr(f) -PerlIO *f; +PerlIO_clearerr(PerlIO *f) { clearerr(f); } #undef PerlIO_flush int -PerlIO_flush(f) -PerlIO *f; +PerlIO_flush(PerlIO *f) { return Fflush(f); } #undef PerlIO_fileno int -PerlIO_fileno(f) -PerlIO *f; +PerlIO_fileno(PerlIO *f) { return fileno(f); } #undef PerlIO_setlinebuf void -PerlIO_setlinebuf(f) -PerlIO *f; +PerlIO_setlinebuf(PerlIO *f) { #ifdef HAS_SETLINEBUF setlinebuf(f); @@ -370,75 +338,57 @@ PerlIO *f; #undef PerlIO_putc int -PerlIO_putc(f,ch) -PerlIO *f; -int ch; +PerlIO_putc(PerlIO *f, int ch) { return putc(ch,f); } #undef PerlIO_ungetc int -PerlIO_ungetc(f,ch) -PerlIO *f; -int ch; +PerlIO_ungetc(PerlIO *f, int ch) { return ungetc(ch,f); } #undef PerlIO_read SSize_t -PerlIO_read(f,buf,count) -PerlIO *f; -void *buf; -Size_t count; +PerlIO_read(PerlIO *f, void *buf, Size_t count) { return fread(buf,1,count,f); } #undef PerlIO_write SSize_t -PerlIO_write(f,buf,count) -PerlIO *f; -const void *buf; -Size_t count; +PerlIO_write(PerlIO *f, const void *buf, Size_t count) { return fwrite1(buf,1,count,f); } #undef PerlIO_vprintf int -PerlIO_vprintf(f,fmt,ap) -PerlIO *f; -const char *fmt; -va_list ap; +PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap) { return vfprintf(f,fmt,ap); } #undef PerlIO_tell -long -PerlIO_tell(f) -PerlIO *f; +Off_t +PerlIO_tell(PerlIO *f) { return ftell(f); } #undef PerlIO_seek int -PerlIO_seek(f,offset,whence) -PerlIO *f; -off_t offset; -int whence; +PerlIO_seek(PerlIO *f, Off_t offset, int whence) { return fseek(f,offset,whence); } #undef PerlIO_rewind void -PerlIO_rewind(f) -PerlIO *f; +PerlIO_rewind(PerlIO *f) { rewind(f); } @@ -469,47 +419,40 @@ PerlIO_stdoutf(const char *fmt,...) #undef PerlIO_tmpfile PerlIO * -PerlIO_tmpfile() +PerlIO_tmpfile(void) { return tmpfile(); } #undef PerlIO_importFILE PerlIO * -PerlIO_importFILE(f,fl) -FILE *f; -int fl; +PerlIO_importFILE(FILE *f, int fl) { return f; } #undef PerlIO_exportFILE FILE * -PerlIO_exportFILE(f,fl) -PerlIO *f; -int fl; +PerlIO_exportFILE(PerlIO *f, int fl) { return f; } #undef PerlIO_findFILE FILE * -PerlIO_findFILE(f) -PerlIO *f; +PerlIO_findFILE(PerlIO *f) { return f; } #undef PerlIO_releaseFILE void -PerlIO_releaseFILE(p,f) -PerlIO *p; -FILE *f; +PerlIO_releaseFILE(PerlIO *p, FILE *f) { } void -PerlIO_init() +PerlIO_init(void) { /* Does nothing (yet) except force this file to be included in perl binary. That allows this file to force inclusion @@ -524,9 +467,7 @@ PerlIO_init() #ifndef HAS_FSETPOS #undef PerlIO_setpos int -PerlIO_setpos(f,pos) -PerlIO *f; -const Fpos_t *pos; +PerlIO_setpos(PerlIO *f, const Fpos_t *pos) { return PerlIO_seek(f,*pos,0); } @@ -534,9 +475,7 @@ const Fpos_t *pos; #ifndef PERLIO_IS_STDIO #undef PerlIO_setpos int -PerlIO_setpos(f,pos) -PerlIO *f; -const Fpos_t *pos; +PerlIO_setpos(PerlIO *f, const Fpos_t *pos) { return fsetpos(f, pos); } @@ -546,9 +485,7 @@ const Fpos_t *pos; #ifndef HAS_FGETPOS #undef PerlIO_getpos int -PerlIO_getpos(f,pos) -PerlIO *f; -Fpos_t *pos; +PerlIO_getpos(PerlIO *f, Fpos_t *pos) { *pos = PerlIO_tell(f); return 0; @@ -557,9 +494,7 @@ Fpos_t *pos; #ifndef PERLIO_IS_STDIO #undef PerlIO_getpos int -PerlIO_getpos(f,pos) -PerlIO *f; -Fpos_t *pos; +PerlIO_getpos(PerlIO *f, Fpos_t *pos) { return fgetpos(f, pos); } @@ -569,17 +504,14 @@ Fpos_t *pos; #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF) int -vprintf(pat, args) -char *pat, *args; +vprintf(char *pat, char *args) { _doprnt(pat, args, stdout); return 0; /* wrong, but perl doesn't use the return value */ } int -vfprintf(fd, pat, args) -FILE *fd; -char *pat, *args; +vfprintf(FILE *fd, char *pat, char *args) { _doprnt(pat, args, fd); return 0; /* wrong, but perl doesn't use the return value */ diff --git a/contrib/perl5/perlvars.h b/contrib/perl5/perlvars.h index 4e9d3b8..ffb3fe6 100644 --- a/contrib/perl5/perlvars.h +++ b/contrib/perl5/perlvars.h @@ -173,8 +173,11 @@ PERLVARI(Gnumeric_local, bool, TRUE) /* constants (these are not literals to facilitate pointer comparisons) */ PERLVARIC(GYes, char *, "1") PERLVARIC(GNo, char *, "") -PERLVARIC(Ghexdigit, char *, "0123456789abcdef0123456789ABCDEFx") +PERLVARIC(Ghexdigit, char *, "0123456789abcdef0123456789ABCDEF") PERLVARIC(Gpatleave, char *, "\\.^$@dDwWsSbB+*?|()-nrtfeaxc0123456789[{]}") PERLVAR(Gspecialsv_list[4],SV *) /* from byterun.h */ +#ifdef USE_THREADS +PERLVAR(Gcred_mutex, perl_mutex) /* altered credentials in effect */ +#endif diff --git a/contrib/perl5/perly.c b/contrib/perl5/perly.c index 7a53d4b..f1c7691 100644 --- a/contrib/perl5/perly.c +++ b/contrib/perl5/perly.c @@ -1276,6 +1276,7 @@ char *yyrule[] = { #define YYMAXDEPTH 500 #endif #endif +#ifndef PERL_OBJECT int yydebug; int yynerrs; int yyerrflag; @@ -1284,6 +1285,7 @@ short *yyssp; YYSTYPE *yyvsp; YYSTYPE yyval; YYSTYPE yylval; +#endif #line 643 "perly.y" /* PROGRAM */ #line 1353 "perly.c" @@ -1405,9 +1407,9 @@ yyloop: int yypv_index = (yyvsp - yyvs); yystacksize += YYSTACKSIZE; ysave->yyvs = yyvs = - (YYSTYPE*)realloc((char*)yyvs,yystacksize * sizeof(YYSTYPE)); + (YYSTYPE*)PerlMem_realloc((char*)yyvs,yystacksize * sizeof(YYSTYPE)); ysave->yyss = yyss = - (short*)realloc((char*)yyss,yystacksize * sizeof(short)); + (short*)PerlMem_realloc((char*)yyss,yystacksize * sizeof(short)); if (!yyvs || !yyss) goto yyoverflow; yyssp = yyss + yyps_index; @@ -1460,9 +1462,9 @@ yyinrecovery: int yyps_index = (yyssp - yyss); int yypv_index = (yyvsp - yyvs); yystacksize += YYSTACKSIZE; - ysave->yyvs = yyvs = (YYSTYPE*)realloc((char*)yyvs, + ysave->yyvs = yyvs = (YYSTYPE*)PerlMem_realloc((char*)yyvs, yystacksize * sizeof(YYSTYPE)); - ysave->yyss = yyss = (short*)realloc((char*)yyss, + ysave->yyss = yyss = (short*)PerlMem_realloc((char*)yyss, yystacksize * sizeof(short)); if (!yyvs || !yyss) goto yyoverflow; @@ -1772,10 +1774,10 @@ case 56: break; case 57: #line 302 "perly.y" -{ char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv, PL_na); +{ STRLEN n_a; char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv, n_a); if (strEQ(name, "BEGIN") || strEQ(name, "END") || strEQ(name, "INIT")) - CvUNIQUE_on(PL_compcv); + CvSPECIAL_on(PL_compcv); yyval.opval = yyvsp[0].opval; } break; case 58: @@ -1800,7 +1802,7 @@ case 63: break; case 64: #line 325 "perly.y" -{ CvUNIQUE_on(PL_compcv); /* It's a BEGIN {} */ } +{ CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ } break; case 65: #line 327 "perly.y" @@ -2109,7 +2111,7 @@ case 134: break; case 135: #line 515 "perly.y" -{ yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); } +{ yyval.opval = dofile(yyvsp[0].opval); } break; case 136: #line 517 "perly.y" @@ -2346,9 +2348,9 @@ break; int yypv_index = (yyvsp - yyvs); yystacksize += YYSTACKSIZE; ysave->yyvs = yyvs = - (YYSTYPE*)realloc((char*)yyvs,yystacksize * sizeof(YYSTYPE)); + (YYSTYPE*)PerlMem_realloc((char*)yyvs,yystacksize * sizeof(YYSTYPE)); ysave->yyss = yyss = - (short*)realloc((char*)yyss,yystacksize * sizeof(short)); + (short*)PerlMem_realloc((char*)yyss,yystacksize * sizeof(short)); if (!yyvs || !yyss) goto yyoverflow; yyssp = yyss + yyps_index; diff --git a/contrib/perl5/perly.y b/contrib/perl5/perly.y index e016cf4..41c6acd 100644 --- a/contrib/perl5/perly.y +++ b/contrib/perl5/perly.y @@ -1,6 +1,6 @@ /* perly.y * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -299,10 +299,10 @@ startformsub: /* NULL */ /* start a format subroutine scope */ { $$ = start_subparse(TRUE, 0); } ; -subname : WORD { char *name = SvPV(((SVOP*)$1)->op_sv, PL_na); +subname : WORD { STRLEN n_a; char *name = SvPV(((SVOP*)$1)->op_sv, n_a); if (strEQ(name, "BEGIN") || strEQ(name, "END") || strEQ(name, "INIT")) - CvUNIQUE_on(PL_compcv); + CvSPECIAL_on(PL_compcv); $$ = $1; } ; @@ -322,7 +322,7 @@ package : PACKAGE WORD ';' ; use : USE startsub - { CvUNIQUE_on(PL_compcv); /* It's a BEGIN {} */ } + { CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ } WORD WORD listexpr ';' { utilize($1, $2, $4, $5, $6); } ; @@ -512,7 +512,7 @@ term : term ASSIGNOP term { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, $3, scalar($2))); } | DO term %prec UNIOP - { $$ = newUNOP(OP_DOFILE, 0, scalar($2)); } + { $$ = dofile($2); } | DO block %prec '(' { $$ = newUNOP(OP_NULL, OPf_SPECIAL, scope($2)); } | DO WORD '(' ')' diff --git a/contrib/perl5/perly_c.diff b/contrib/perl5/perly_c.diff index aa0555b..5107901 100644 --- a/contrib/perl5/perly_c.diff +++ b/contrib/perl5/perly_c.diff @@ -1,23 +1,12 @@ -*** perly.c.orig Tue Jul 28 15:02:41 1998 ---- perly.c Tue Jul 28 15:14:54 1998 +*** perly.c.old Wed Jan 06 20:03:41 1999 +--- perly.c Wed Jan 06 18:51:20 1999 *************** -*** 7,11 **** ---- 7,19 ---- +*** 7,86 **** #include "perl.h" -+ #ifdef PERL_OBJECT static void -+ Dep(CPerlObj *pPerl) -+ { -+ pPerl->deprecate("\"do\" to call subroutines"); -+ } -+ #define dep() Dep(this) -+ #else -+ static void dep(void) { -*************** -*** 12,86 **** deprecate("\"do\" to call subroutines"); } @@ -93,7 +82,20 @@ - #define ARROW 314 #define YYERRCODE 256 short yylhs[] = { -1, ---- 20,26 ---- +--- 7,26 ---- + #include "perl.h" + ++ #ifdef PERL_OBJECT + static void ++ Dep(CPerlObj *pPerl) ++ { ++ pPerl->deprecate("\"do\" to call subroutines"); ++ } ++ #define dep() Dep(this) ++ #else ++ static void + dep(void) + { deprecate("\"do\" to call subroutines"); } + #endif @@ -102,12 +104,20 @@ #define YYERRCODE 256 short yylhs[] = { -1, *************** +*** 1337,1340 **** +--- 1277,1281 ---- + #endif + #endif ++ #ifndef PERL_OBJECT + int yydebug; + int yynerrs; +*************** *** 1345,1365 **** YYSTYPE yyval; YYSTYPE yylval; -- short yyss[YYSTACKSIZE]; -- YYSTYPE yyvs[YYSTACKSIZE]; -- #define yystacksize YYSTACKSIZE +! short yyss[YYSTACKSIZE]; +! YYSTYPE yyvs[YYSTACKSIZE]; +! #define yystacksize YYSTACKSIZE #line 643 "perly.y" /* PROGRAM */ ! #line 1353 "y.tab.c" @@ -124,9 +134,10 @@ if (yys = getenv("YYDEBUG")) { ---- 1285,1349 ---- +--- 1286,1351 ---- YYSTYPE yyval; YYSTYPE yylval; +! #endif #line 643 "perly.y" /* PROGRAM */ ! #line 1353 "perly.c" @@ -176,7 +187,7 @@ extern char *getenv(); + #endif + #endif - ++ + struct ysv *ysave; + New(73, ysave, 1, struct ysv); + SAVEDESTRUCTOR(yydestruct, ysave); @@ -186,13 +197,13 @@ + ysave->oldyychar = yychar; + ysave->oldyyval = yyval; + ysave->oldyylval = yylval; -+ + + #if YYDEBUG if (yys = getenv("YYDEBUG")) { *************** *** 1374,1377 **** ---- 1358,1371 ---- +--- 1360,1373 ---- yychar = (-1); + /* @@ -214,33 +225,30 @@ ! printf("yydebug: state %d, reading %d (%s)\n", yystate, yychar, yys); } ---- 1383,1387 ---- +--- 1385,1389 ---- if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", yystate, yychar, yys); } *************** -*** 1399,1403 **** +*** 1399,1408 **** #if YYDEBUG if (yydebug) ! printf("yydebug: state %d, shifting to state %d\n", yystate, yytable[yyn]); #endif ---- 1393,1397 ---- - #if YYDEBUG - if (yydebug) -! PerlIO_printf(Perl_debug_log, "yydebug: state %d, shifting to state %d\n", - yystate, yytable[yyn]); - #endif -*************** -*** 1404,1408 **** if (yyssp >= yyss + yystacksize - 1) { ! goto yyoverflow; } *++yyssp = yystate = yytable[yyn]; ---- 1398,1416 ---- +--- 1395,1418 ---- + #if YYDEBUG + if (yydebug) +! PerlIO_printf(Perl_debug_log, "yydebug: state %d, shifting to state %d\n", + yystate, yytable[yyn]); + #endif if (yyssp >= yyss + yystacksize - 1) { ! /* @@ -251,9 +259,9 @@ ! int yypv_index = (yyvsp - yyvs); ! yystacksize += YYSTACKSIZE; ! ysave->yyvs = yyvs = -! (YYSTYPE*)realloc((char*)yyvs,yystacksize * sizeof(YYSTYPE)); +! (YYSTYPE*)PerlMem_realloc((char*)yyvs,yystacksize * sizeof(YYSTYPE)); ! ysave->yyss = yyss = -! (short*)realloc((char*)yyss,yystacksize * sizeof(short)); +! (short*)PerlMem_realloc((char*)yyss,yystacksize * sizeof(short)); ! if (!yyvs || !yyss) ! goto yyoverflow; ! yyssp = yyss + yyps_index; @@ -272,7 +280,7 @@ ! goto yyoverflow; } *++yyssp = yystate = yytable[yyn]; ---- 1448,1472 ---- +--- 1450,1474 ---- #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, @@ -288,9 +296,9 @@ ! int yyps_index = (yyssp - yyss); ! int yypv_index = (yyvsp - yyvs); ! yystacksize += YYSTACKSIZE; -! ysave->yyvs = yyvs = (YYSTYPE*)realloc((char*)yyvs, +! ysave->yyvs = yyvs = (YYSTYPE*)PerlMem_realloc((char*)yyvs, ! yystacksize * sizeof(YYSTYPE)); -! ysave->yyss = yyss = (short*)realloc((char*)yyss, +! ysave->yyss = yyss = (short*)PerlMem_realloc((char*)yyss, ! yystacksize * sizeof(short)); ! if (!yyvs || !yyss) ! goto yyoverflow; @@ -306,7 +314,7 @@ ! *yyssp); #endif if (yyssp <= yyss) goto yyabort; ---- 1478,1484 ---- +--- 1480,1486 ---- #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, @@ -322,7 +330,7 @@ ! yystate, yychar, yys); } #endif ---- 1497,1503 ---- +--- 1499,1505 ---- if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! PerlIO_printf(Perl_debug_log, @@ -337,7 +345,7 @@ ! printf("yydebug: state %d, reducing by rule %d (%s)\n", yystate, yyn, yyrule[yyn]); #endif ---- 1508,1512 ---- +--- 1510,1514 ---- #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, "yydebug: state %d, reducing by rule %d (%s)\n", @@ -350,7 +358,7 @@ ! #line 2270 "y.tab.c" } yyssp -= yym; ---- 2292,2296 ---- +--- 2294,2298 ---- { yyval.opval = yyvsp[0].opval; } break; ! #line 2270 "perly.c" @@ -364,7 +372,7 @@ ! state %d\n", YYFINAL); #endif yystate = YYFINAL; ---- 2302,2308 ---- +--- 2304,2310 ---- #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, @@ -379,7 +387,7 @@ ! printf("yydebug: state %d, reading %d (%s)\n", YYFINAL, yychar, yys); } ---- 2318,2322 ---- +--- 2320,2324 ---- if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", @@ -397,7 +405,7 @@ ! goto yyoverflow; } *++yyssp = yystate; ---- 2333,2357 ---- +--- 2335,2359 ---- #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, @@ -414,9 +422,9 @@ ! int yypv_index = (yyvsp - yyvs); ! yystacksize += YYSTACKSIZE; ! ysave->yyvs = yyvs = -! (YYSTYPE*)realloc((char*)yyvs,yystacksize * sizeof(YYSTYPE)); +! (YYSTYPE*)PerlMem_realloc((char*)yyvs,yystacksize * sizeof(YYSTYPE)); ! ysave->yyss = yyss = -! (short*)realloc((char*)yyss,yystacksize * sizeof(short)); +! (short*)PerlMem_realloc((char*)yyss,yystacksize * sizeof(short)); ! if (!yyvs || !yyss) ! goto yyoverflow; ! yyssp = yyss + yyps_index; @@ -433,7 +441,7 @@ yyaccept: ! return (0); } ---- 2359,2366 ---- +--- 2361,2368 ---- goto yyloop; yyoverflow: ! yyerror("Out of memory for yacc stack"); diff --git a/contrib/perl5/pod/Makefile b/contrib/perl5/pod/Makefile index 9187c84..eb3fcfe 100644 --- a/contrib/perl5/pod/Makefile +++ b/contrib/perl5/pod/Makefile @@ -16,12 +16,14 @@ REALPERL = ../perl POD = \ perl.pod \ perldelta.pod \ + perl5004delta.pod \ perldata.pod \ perlsyn.pod \ perlop.pod \ perlre.pod \ perlrun.pod \ perlfunc.pod \ + perlopentut.pod \ perlvar.pod \ perlsub.pod \ perlmod.pod \ @@ -30,6 +32,7 @@ POD = \ perlform.pod \ perllocale.pod \ perlref.pod \ + perlreftut.pod \ perldsc.pod \ perllol.pod \ perltoot.pod \ @@ -37,6 +40,7 @@ POD = \ perltie.pod \ perlbot.pod \ perlipc.pod \ + perlthrtut.pod \ perldebug.pod \ perldiag.pod \ perlsec.pod \ @@ -51,6 +55,7 @@ POD = \ perlxstut.pod \ perlguts.pod \ perlcall.pod \ + perlhist.pod \ perlfaq.pod \ perlfaq1.pod \ perlfaq2.pod \ @@ -66,12 +71,14 @@ POD = \ MAN = \ perl.man \ perldelta.man \ + perl5004delta.man \ perldata.man \ perlsyn.man \ perlop.man \ perlre.man \ perlrun.man \ perlfunc.man \ + perlopentut.man \ perlvar.man \ perlsub.man \ perlmod.man \ @@ -80,6 +87,7 @@ MAN = \ perlform.man \ perllocale.man \ perlref.man \ + perlreftut.man \ perldsc.man \ perllol.man \ perltoot.man \ @@ -87,6 +95,7 @@ MAN = \ perltie.man \ perlbot.man \ perlipc.man \ + perlthrtut.man \ perldebug.man \ perldiag.man \ perlsec.man \ @@ -101,6 +110,7 @@ MAN = \ perlxstut.man \ perlguts.man \ perlcall.man \ + perlhist.man \ perlfaq.man \ perlfaq1.man \ perlfaq2.man \ @@ -116,12 +126,14 @@ MAN = \ HTML = \ perl.html \ perldelta.html \ + perl5004delta.html \ perldata.html \ perlsyn.html \ perlop.html \ perlre.html \ perlrun.html \ perlfunc.html \ + perlopentut.html \ perlvar.html \ perlsub.html \ perlmod.html \ @@ -130,6 +142,7 @@ HTML = \ perlform.html \ perllocale.html \ perlref.html \ + perlreftut.html \ perldsc.html \ perllol.html \ perltoot.html \ @@ -137,6 +150,7 @@ HTML = \ perltie.html \ perlbot.html \ perlipc.html \ + perlthrtut.html \ perldebug.html \ perldiag.html \ perlsec.html \ @@ -151,6 +165,7 @@ HTML = \ perlxstut.html \ perlguts.html \ perlcall.html \ + perlhist.html \ perlfaq.html \ perlfaq1.html \ perlfaq2.html \ @@ -166,12 +181,14 @@ HTML = \ TEX = \ perl.tex \ perldelta.tex \ + perl5004delta.tex \ perldata.tex \ perlsyn.tex \ perlop.tex \ perlre.tex \ perlrun.tex \ perlfunc.tex \ + perlopentut.tex \ perlvar.tex \ perlsub.tex \ perlmod.tex \ @@ -180,6 +197,8 @@ TEX = \ perlform.tex \ perllocale.tex \ perlref.tex \ + perlreftut.tex \ + perlopentut.tex \ perldsc.tex \ perllol.tex \ perltoot.tex \ @@ -187,6 +206,7 @@ TEX = \ perltie.tex \ perlbot.tex \ perlipc.tex \ + perlthrtut.tex \ perldebug.tex \ perldiag.tex \ perlsec.tex \ @@ -201,6 +221,7 @@ TEX = \ perlxstut.tex \ perlguts.tex \ perlcall.tex \ + perlhist.tex \ perlfaq.tex \ perlfaq1.tex \ perlfaq2.tex \ diff --git a/contrib/perl5/pod/buildtoc b/contrib/perl5/pod/buildtoc index 80ca2ec..a4b9d5a 100644 --- a/contrib/perl5/pod/buildtoc +++ b/contrib/perl5/pod/buildtoc @@ -6,10 +6,10 @@ sub output ($); @pods = qw( perl perlfaq perlfaq1 perlfaq2 perlfaq3 perlfaq4 perlfaq5 - perlfaq6 perlfaq7 perlfaq8 perlfaq9 perldelta perldata - perlsyn perlop perlre perlrun perlfunc perlvar perlsub + perlfaq6 perlfaq7 perlfaq8 perlfaq9 perldelta perldata perlopentut + perlsyn perlop perlre perlreftut perlrun perlfunc perlvar perlsub perlmod perlmodlib perlmodinstall perlform perllocale perlref perldsc - perllol perltoot perlobj perltie perlbot perlipc perldebug + perllol perltoot perlobj perltie perlthrtut perlbot perlipc perldebug perldiag perlsec perltrap perlport perlstyle perlpod perlbook perlembed perlapio perlxs perlxstut perlguts perlcall perlhist diff --git a/contrib/perl5/pod/perl.pod b/contrib/perl5/pod/perl.pod index 0b9e9fa..6e218cd 100644 --- a/contrib/perl5/pod/perl.pod +++ b/contrib/perl5/pod/perl.pod @@ -20,6 +20,7 @@ of sections: perl Perl overview (this section) perldelta Perl changes since previous version + perl5004delta Perl changes in version 5.004 perlfaq Perl frequently asked questions perltoc Perl documentation table of contents @@ -29,6 +30,7 @@ of sections: perlre Perl regular expressions perlrun Perl execution and options perlfunc Perl builtin functions + perlopentut Perl open() tutorial perlvar Perl predefined variables perlsub Perl subroutines perlmod Perl modules: how they work @@ -38,6 +40,7 @@ of sections: perllocale Perl locale support perlref Perl references + perlreftut Perl references short introduction perldsc Perl data structures intro perllol Perl data structures: lists of lists perltoot Perl OO tutorial @@ -45,6 +48,7 @@ of sections: perltie Perl objects hidden behind simple variables perlbot Perl OO tricks and examples perlipc Perl interprocess communication + perlthrtut Perl threads tutorial perldebug Perl debugging perldiag Perl diagnostic messages @@ -68,8 +72,8 @@ of sections: (If you're intending to read these straight through for the first time, the suggested order will tend to reduce the number of forward references.) -By default, all of the above manpages are installed in the -F</usr/local/man/> directory. +By default, all of the above manpages are installed in the +F</usr/local/man/> directory. Extensive additional documentation for Perl modules is available. The default configuration for perl will place this additional documentation @@ -116,9 +120,9 @@ BASIC-PLUS.) Expression syntax corresponds quite closely to C expression syntax. Unlike most Unix utilities, Perl does not arbitrarily limit the size of your data--if you've got the memory, Perl can slurp in your whole file as a single string. Recursion is of -unlimited depth. And the tables used by hashes (previously called +unlimited depth. And the tables used by hashes (sometimes called "associative arrays") grow as necessary to prevent degraded -performance. Perl uses sophisticated pattern matching techniques to +performance. Perl can use sophisticated pattern matching techniques to scan large amounts of data very quickly. Although optimized for scanning text, Perl can also deal with binary data, and can make dbm files look like hashes. Setuid Perl scripts are safer than C programs @@ -239,6 +243,79 @@ optimized C code. Okay, that's I<definitely> enough hype. +=head1 AVAILABILITY + +Perl is available for the vast majority of operating system platforms, +including most Unix-like platforms. The following situation is as of +February 1999 and Perl 5.005_03. + +The following platforms are able to build Perl from the standard +source code distribution available at +F<http://www.perl.com/CPAN/src/index.html> + + AIX Linux SCO ODT/OSR + A/UX MachTen Solaris + BeOS MPE/iX SunOS + BSD/OS NetBSD SVR4 + DG/UX NextSTEP Tru64 UNIX 3) + DomainOS OpenBSD Ultrix + DOS DJGPP 1) OpenSTEP UNICOS + DYNIX/ptx OS/2 VMS + FreeBSD OS390 2) VOS + HP-UX PowerMAX Windows 3.1 1) + Hurd QNX Windows 95 1) 4) + IRIX Windows 98 1) 4) + Windows NT 1) 4) + + 1) in DOS mode either the DOS or OS/2 ports can be used + 2) formerly known as MVS + 3) formerly known as Digital UNIX and before that DEC OSF/1 + 4) compilers: Borland, Cygwin32, Mingw32 EGCS/GCC, VC++ + +The following platforms have been known to build Perl from the source +but for the Perl release 5.005_03 we haven't been able to verify them, +either because the hardware/software platforms are rather rare or +because we don't have an active champion on these platforms, or both. + + 3b1 FPS Plan 9 + AmigaOS GENIX PowerUX + ConvexOS Greenhills RISC/os + CX/UX ISC Stellar + DC/OSx MachTen 68k SVR2 + DDE SMES MiNT TI1500 + DOS EMX MPC TitanOS + Dynix NEWS-OS UNICOS/mk + EP/IX Opus Unisys Dynix + ESIX Unixware + +The following platforms are planned to be supported in the standard +source code distribution of the Perl release 5.006 but are not +supported in the Perl release 5.005_03: + + BS2000 + Netware + Rhapsody + VM/ESA + +The following platforms have their own source code distributions and +binaries available via F<http://www.perl.com/CPAN/ports/index.html>. + + Perl release + + AS/400 5.003 + MacOS 5.004 + Netware 5.003_07 + Tandem Guardian 5.004 + +The following platforms have only binaries available via +F<http://www.perl.com/CPAN/ports/index.html>. + + Perl release + + Acorn RISCOS 5.005_02 + AOS 5.002 + LynxOS 5.004_02 + =head1 ENVIRONMENT See L<perlrun>. @@ -247,14 +324,13 @@ See L<perlrun>. Larry Wall <F<larry@wall.org>>, with the help of oodles of other folks. -If your Perl success stories and testimonials may be of help to others -who wish to advocate the use of Perl in their applications, -or if you wish to simply express your gratitude to Larry and the +If your Perl success stories and testimonials may be of help to others +who wish to advocate the use of Perl in their applications, +or if you wish to simply express your gratitude to Larry and the Perl developers, please write to <F<perl-thanks@perl.org>>. =head1 FILES - "/tmp/perl-e$$" temporary file for -e commands "@INC" locations of perl libraries =head1 SEE ALSO @@ -296,9 +372,10 @@ and syswrite().) While none of the built-in data types have any arbitrary size limits (apart from memory size), there are still a few arbitrary limits: a -given variable name may not be longer than 255 characters, and no -component of your PATH may be longer than 255 if you use B<-S>. A regular -expression may not compile to more than 32767 bytes internally. +given variable name may not be longer than 251 characters. Line numbers +displayed by diagnostics are internally stored as short integers, +so they are limited to a maximum of 65535 (higher numbers usually being +affected by wraparound). You may mail your bug reports (be sure to include full configuration information as output by the myconfig program in the perl source tree, diff --git a/contrib/perl5/pod/perl5004delta.pod b/contrib/perl5/pod/perl5004delta.pod index f1b6c8f..323830b 100644 --- a/contrib/perl5/pod/perl5004delta.pod +++ b/contrib/perl5/pod/perl5004delta.pod @@ -1432,7 +1432,7 @@ subscript, which can do weird things if you're expecting only one subscript. =item Stub found while resolving method `%s' overloading `%s' in package `%s' (P) Overloading resolution over @ISA tree may be broken by importing stubs. -Stubs should never be implicitely created, but explicit calls to C<can> +Stubs should never be implicitly created, but explicit calls to C<can> may break this. =item Too late for "B<-T>" option diff --git a/contrib/perl5/pod/perlcall.pod b/contrib/perl5/pod/perlcall.pod index c239cfe..2b83780 100644 --- a/contrib/perl5/pod/perlcall.pod +++ b/contrib/perl5/pod/perlcall.pod @@ -72,7 +72,7 @@ Each of the functions will now be discussed in turn. =over 5 -=item B<perl_call_sv> +=item perl_call_sv I<perl_call_sv> takes two parameters, the first, C<sv>, is an SV*. This allows you to specify the Perl subroutine to be called either as a @@ -80,7 +80,7 @@ C string (which has first been converted to an SV) or a reference to a subroutine. The section, I<Using perl_call_sv>, shows how you can make use of I<perl_call_sv>. -=item B<perl_call_pv> +=item perl_call_pv The function, I<perl_call_pv>, is similar to I<perl_call_sv> except it expects its first parameter to be a C char* which identifies the Perl @@ -88,7 +88,7 @@ subroutine you want to call, e.g., C<perl_call_pv("fred", 0)>. If the subroutine you want to call is in another package, just include the package name in the string, e.g., C<"pkg::fred">. -=item B<perl_call_method> +=item perl_call_method The function I<perl_call_method> is used to call a method from a Perl class. The parameter C<methname> corresponds to the name of the method @@ -99,7 +99,7 @@ object (for a virtual method). See L<perlobj> for more information on static and virtual methods and L<Using perl_call_method> for an example of using I<perl_call_method>. -=item B<perl_call_argv> +=item perl_call_argv I<perl_call_argv> calls the Perl subroutine specified by the C string stored in the C<subname> parameter. It also takes the usual C<flags> @@ -971,7 +971,8 @@ and some C to call it /* Check the eval first */ if (SvTRUE(ERRSV)) { - printf ("Uh oh - %s\n", SvPV(ERRSV, PL_na)) ; + STRLEN n_a; + printf ("Uh oh - %s\n", SvPV(ERRSV, n_a)) ; POPs ; } else @@ -1013,7 +1014,8 @@ The code if (SvTRUE(ERRSV)) { - printf ("Uh oh - %s\n", SvPV(ERRSV, PL_na)) ; + STRLEN n_a; + printf ("Uh oh - %s\n", SvPV(ERRSV, n_a)) ; POPs ; } @@ -1923,8 +1925,8 @@ refers to the last. =head2 Creating and calling an anonymous subroutine in C As we've already shown, C<perl_call_sv> can be used to invoke an -anonymous subroutine. However, our example showed how Perl script -invoking an XSUB to preform this operation. Let's see how it can be +anonymous subroutine. However, our example showed a Perl script +invoking an XSUB to perform this operation. Let's see how it can be done inside our C code: ... diff --git a/contrib/perl5/pod/perldata.pod b/contrib/perl5/pod/perldata.pod index 58c1123..9e41c2c 100644 --- a/contrib/perl5/pod/perldata.pod +++ b/contrib/perl5/pod/perldata.pod @@ -253,7 +253,7 @@ literals are subject to backslash and variable substitution; single-quoted strings are not (except for "C<\'>" and "C<\\>"). The usual Unix backslash rules apply for making characters such as newline, tab, etc., as well as some more exotic forms. See -L<perlop/Quote and Quotelike Operators> for a list. +L<perlop/"Quote and Quotelike Operators"> for a list. Octal or hex representations in string literals (e.g. '0xffff') are not automatically converted to their integer representation. The hex() and @@ -471,7 +471,7 @@ is legal to assign to: ($map{'red'}, $map{'blue'}, $map{'green'}) = (0x00f, 0x0f0, 0xf00); -Array assignment in a scalar context returns the number of elements +List assignment in a scalar context returns the number of elements produced by the expression on the right side of the assignment: $x = (($foo,$bar) = (3,2,1)); # set $x to 3, not 2 diff --git a/contrib/perl5/pod/perldebug.pod b/contrib/perl5/pod/perldebug.pod index 7a6e814..760d517 100644 --- a/contrib/perl5/pod/perldebug.pod +++ b/contrib/perl5/pod/perldebug.pod @@ -1109,7 +1109,7 @@ or B<pop>, the stack backtrace will not show the original values. Perl is I<very> frivolous with memory. There is a saying that to estimate memory usage of Perl, assume a reasonable algorithm of -allocation, and multiply your estimages by 10. This is not absolutely +allocation, and multiply your estimates by 10. This is not absolutely true, but may give you a good grasp of what happens. Say, an integer cannot take less than 20 bytes of memory, a float @@ -1161,7 +1161,7 @@ in the following example: Total sbrk(): 215040/47:145. Odd ends: pad+heads+chain+tail: 0+2192+0+6144. It is possible to ask for such a statistic at arbitrary moment by -usind Devel::Peek::mstats() (module Devel::Peek is available on CPAN). +using Devel::Peek::mstats() (module Devel::Peek is available on CPAN). Here is the explanation of different parts of the format: @@ -1195,7 +1195,7 @@ memory footprints of the buckets are between memory footprints of two buckets "above". Say, with the above example the memory footprints are (with current -algorith) +algorithm) free: 8 16 32 64 128 256 512 1024 2048 4096 8192 4 12 24 48 80 @@ -1328,7 +1328,7 @@ though the subroutine itself is not defined yet). It also creates C arrays to keep data for the stash (this is one HV, but it grows, thus there are 4 big allocations: the big chunks are not -freeed, but are kept as additional arenas for C<SV> allocations). +freed, but are kept as additional arenas for C<SV> allocations). =item C<054> diff --git a/contrib/perl5/pod/perldelta.pod b/contrib/perl5/pod/perldelta.pod index a3c6b6c..a0af1e1 100644 --- a/contrib/perl5/pod/perldelta.pod +++ b/contrib/perl5/pod/perldelta.pod @@ -85,7 +85,7 @@ begin with C<perl> be referenced with a C<Perl_> prefix. The bare function names without the C<Perl_> prefix are supported with macros, but this support may cease in a future release. -See L<perlguts/API LISTING>. +See L<perlguts/"API LISTING">. =item Enabling threads has source compatibility issues @@ -100,7 +100,7 @@ directly accessing perl globals as C<GvSV(errgv)>. The API call is backward compatible with existing perls and provides source compatibility with threading is enabled. -See L<API Changes for more information>. +See L<"C Source Compatibility"> for more information. =back @@ -153,6 +153,9 @@ and some bugs. These are expected to be fixed in future versions. See L<README.threads>. +Mach cthreads (NEXTSTEP, OPENSTEP, Rhapsody) are now supported by +the Thread extension. + =head2 Compiler WARNING: The Compiler and related tools are considered B<experimental>. @@ -310,7 +313,7 @@ and in XSUBs. Perl used to complain if it encountered literal carriage returns in scripts. Now they are mostly treated like whitespace within program text. Inside string literals and here documents, literal carriage returns are -ignored if they occur paired with newlines, or get interpreted as newlines +ignored if they occur paired with linefeeds, or get interpreted as whitespace if they stand alone. This behavior means that literal carriage returns in files should be avoided. You can get the older, more compatible (but less generous) behavior by defining the preprocessor symbol @@ -488,6 +491,30 @@ If C<$/> is a referenence to an integer, or a scalar that holds an integer, E<lt>E<gt> will read in records instead of lines. For more info, see L<perlvar/$/>. +=head2 pack() format 'Z' supported + +The new format type 'Z' is useful for packing and unpacking null-terminated +strings. See L<perlfunc/"pack">. + +=head1 Significant bug fixes + +=head2 E<lt>HANDLEE<gt> on empty files + +With C<$/> set to C<undef>, slurping an empty file returns a string of +zero length (instead of C<undef>, as it used to) for the first time the +HANDLE is read. Subsequent reads yield C<undef>. + +This means that the following will append "foo" to an empty file (it used +to not do anything before): + + perl -0777 -pi -e 's/^/foo/' empty_file + +Note that the behavior of: + + perl -pi -e 's/^/foo/' empty_file + +is unchanged (it continues to leave the file empty). + =head1 Supported Platforms Configure has many incremental improvements. Site-wide policy for building @@ -500,9 +527,15 @@ BeOS is now supported. See L<README.beos>. DOS is now supported under the DJGPP tools. See L<README.dos>. +GNU/Hurd is now supported. + +MiNT is now supported. See L<README.mint>. + MPE/iX is now supported. See L<README.mpeix>. -MVS (OS390) is now supported. See L<README.os390>. +MVS (aka OS390, aka Open Edition) is now supported. See L<README.os390>. + +Stratus VOS is now supported. See L<README.vos>. =head2 Changes in existing support @@ -528,6 +561,10 @@ Perl compiler and tools. See L<B>. A module to pretty print Perl data. See L<Data::Dumper>. +=item Dumpvalue + +A module to dump perl values to the screen. See L<Dumpvalue>. + =item Errno A module to look up errors more conveniently. See L<Errno>. @@ -587,10 +624,52 @@ Various pragmata to control behavior of regular expressions. =over +=item Benchmark + +You can now run tests for I<n> seconds instead of guessing the right +number of tests to run: e.g. timethese(-5, ...) will run each of the +codes for at least 5 CPU seconds. Zero as the "number of repetitions" +means "for at least 3 CPU seconds". The output format has also +changed. For example: + +use Benchmark;$x=3;timethese(-5,{a=>sub{$x*$x},b=>sub{$x**2}}) + +will now output something like this: + +Benchmark: running a, b, each for at least 5 CPU seconds... + a: 5 wallclock secs ( 5.77 usr + 0.00 sys = 5.77 CPU) @ 200551.91/s (n=1156516) + b: 4 wallclock secs ( 5.00 usr + 0.02 sys = 5.02 CPU) @ 159605.18/s (n=800686) + +New features: "each for at least N CPU seconds...", "wallclock secs", +and the "@ operations/CPU second (n=operations)". + +=item Carp + +Carp has a new function cluck(). cluck() warns, like carp(), but also adds +a stack backtrace to the error message, like confess(). + =item CGI CGI has been updated to version 2.42. +=item Fcntl + +More Fcntl constants added: F_SETLK64, F_SETLKW64, O_LARGEFILE for +large (more than 4G) file access (the 64-bit support is not yet +working, though, so no need to get overly excited), Free/Net/OpenBSD +locking behaviour flags F_FLOCK, F_POSIX, Linux F_SHLCK, and +O_ACCMODE: the mask of O_RDONLY, O_WRONLY, and O_RDWR. + +=item Math::Complex + +The accessor methods Re, Im, arg, abs, rho, and theta, can now also +act as mutators (accessor $z->Re(), mutator $z->Re(3)). + +=item Math::Trig + +A little bit of radial trigonometry (cylindrical and spherical) added: +radial coordinate conversions and the great circle distance. + =item POSIX POSIX now has its own platform-specific hints files. @@ -655,6 +734,12 @@ sites. Some more Perl traps are documented now. See L<perltrap>. +L<perlopentut> gives a tutorial on using open(). + +L<perlreftut> gives a tutorial on references. + +L<perlthrtut> gives a tutorial on threads. + =head1 New Diagnostics =over @@ -697,6 +782,10 @@ Something like this will reproduce the error: process $BADREF 1,2,3; $BADREF->process(1,2,3); +=item Can't check filesystem of script "%s" for nosuid + +(P) For some reason you can't check the filesystem of the script for nosuid. + =item Can't coerce array into hash (F) You used an array where a hash was expected, but the array has no @@ -776,7 +865,7 @@ See L<perlre/(?{ code })>. (W) You are blessing a reference to a zero length string. This has the effect of blessing the reference into the package main. This is usually not what you want. Consider providing a default target -package, e.g. bless($ref, $p or 'MyPackage'); +package, e.g. bless($ref, $p || 'MyPackage'); =item Illegal hex digit ignored @@ -860,7 +949,7 @@ not use those settings. This was not dead serious, fortunately: there is a "default locale" called "C" that Perl can and will use, the script will be run. Before you really fix the problem, however, you will get the same error message each time you run Perl. How to really -fix the problem can be found in L<perllocale> section B<LOCALE PROBLEMS>. +fix the problem can be found in L<perllocale/"LOCALE PROBLEMS">. =back @@ -874,18 +963,39 @@ fix the problem can be found in L<perllocale> section B<LOCALE PROBLEMS>. (F) The mktemp() routine failed for some reason while trying to process a B<-e> switch. Maybe your /tmp partition is full, or clobbered. +Removed because B<-e> doesn't use temporary files any more. + =item Can't write to temp file for B<-e>: %s (F) The write routine failed for some reason while trying to process a B<-e> switch. Maybe your /tmp partition is full, or clobbered. +Removed because B<-e> doesn't use temporary files any more. + =item Cannot open temporary file (F) The create routine failed for some reason while trying to process a B<-e> switch. Maybe your /tmp partition is full, or clobbered. +Removed because B<-e> doesn't use temporary files any more. + +=item regexp too big + +(F) The current implementation of regular expressions uses shorts as +address offsets within a string. Unfortunately this means that if +the regular expression compiles to longer than 32767, it'll blow up. +Usually when you want a regular expression this big, there is a better +way to do it with multiple statements. See L<perlre>. + =back +=head1 Configuration Changes + +You can use "Configure -Uinstallusrbinperl" which causes installperl +to skip installing perl also as /usr/bin/perl. This is useful if you +prefer not to modify /usr/bin for some reason or another but harmful +because many scripts assume to find Perl in /usr/bin/perl. + =head1 BUGS If you find what you think is a bug, you might check the headers of diff --git a/contrib/perl5/pod/perldiag.pod b/contrib/perl5/pod/perldiag.pod index 8d21323..fe31991 100644 --- a/contrib/perl5/pod/perldiag.pod +++ b/contrib/perl5/pod/perldiag.pod @@ -33,11 +33,11 @@ The symbols C<"%(-?@> sort before the letters, while C<[> and C<\> sort after. to try to declare one with a package qualifier on the front. Use local() if you want to localize a package variable. -=item "my" variable %s masks earlier declaration in same scope +=item "my" variable %s masks earlier declaration in same %s -(W) A lexical variable has been redeclared in the same scope, effectively -eliminating all access to the previous instance. This is almost always -a typographical error. Note that the earlier variable will still exist +(W) A lexical variable has been redeclared in the current scope or statement, +effectively eliminating all access to the previous instance. This is almost +always a typographical error. Note that the earlier variable will still exist until the end of the scope or until all closure referents to it are destroyed. @@ -143,6 +143,18 @@ Perl yourself. instead of Perl. Check the #! line, or manually feed your script into Perl yourself. +=item (in cleanup) %s + +(W) This prefix usually indicates that a DESTROY() method raised +the indicated exception. Since destructors are usually called by +the system at arbitrary points during execution, and often a vast +number of times, the warning is issued only once for any number +of failures that would otherwise result in the same message being +repeated. + +Failure of user callbacks dispatched using the C<G_KEEPERR> flag +could also result in this warning. See L<perlcall/G_KEEPERR>. + =item (Missing semicolon on previous line?) (S) This is an educated guess made in conjunction with the message "%s @@ -376,7 +388,7 @@ Perl yourself. =item Bareword "%s" not allowed while "strict subs" in use (F) With "strict subs" in use, a bareword is only allowed as a -subroutine identifier, in curly braces or to the left of the "=>" symbol. +subroutine identifier, in curly brackets or to the left of the "=>" symbol. Perhaps you need to predeclare a subroutine? =item Bareword "%s" refers to nonexistent package @@ -499,6 +511,10 @@ Something like this will reproduce the error: (F) You called C<perl -x/foo/bar>, but C</foo/bar> is not a directory that you can chdir to, possibly because it doesn't exist. +=item Can't check filesystem of script "%s" for nosuid + +(P) For some reason you can't check the filesystem of the script for nosuid. + =item Can't coerce %s to integer in %s (F) Certain types of SVs, in particular real symbol table entries @@ -1002,6 +1018,14 @@ for information on I<Mastering Regular Expressions>.) (W) You tried to do a connect on a closed socket. Did you forget to check the return value of your socket() call? See L<perlfunc/connect>. +=item Constant is not %s reference + +(F) A constant value (perhaps declared using the C<use constant> pragma) +is being dereferenced, but it amounts to the wrong type of reference. The +message indicates the type of reference that was expected. This usually +indicates a syntax error in dereferencing the constant value. +See L<perlsub/"Constant Functions"> and L<constant>. + =item Constant subroutine %s redefined (S) You redefined a subroutine which had previously been eligible for @@ -1162,7 +1186,7 @@ a return, a goto, or a loop control statement. (W) You are blessing a reference to a zero length string. This has the effect of blessing the reference into the package main. This is usually not what you want. Consider providing a default target -package, e.g. bless($ref, $p or 'MyPackage'); +package, e.g. bless($ref, $p || 'MyPackage'); =item Fatal VMS error at %s, line %d @@ -1258,7 +1282,6 @@ Did you forget to check the return value of your socket() call? (S) A warning peculiar to VMS. The call to C<sys$getuai> underlying the C<getpwnam> operator returned an invalid UIC. - =item Glob not terminated (F) The lexer saw a left angle bracket in a place where it was expecting @@ -1404,7 +1427,7 @@ architecture. On a 32-bit architecture the largest octal literal is (S) A warning peculiar to VMS. Perl keeps track of the number of times you've called C<fork> and C<exec>, to determine whether the current call to C<exec> should affect the current -script or a subprocess (see L<perlvms/exec>). Somehow, this count +script or a subprocess (see L<perlvms/"exec LIST">). Somehow, this count has become scrambled, so Perl is making a guess and treating this C<exec> as a request to terminate the Perl script and execute the specified command. @@ -1413,16 +1436,19 @@ and execute the specified command. (P) Something went badly wrong in the regular expression parser. -=item internal error: glob failed +=item glob failed (%s) -(P) Something went wrong with the external program(s) used for C<glob> -and C<E<lt>*.cE<gt>>. This may mean that your csh (C shell) is -broken. If so, you should change all of the csh-related variables in -config.sh: If you have tcsh, make the variables refer to it as if it -were csh (e.g. C<full_csh='/usr/bin/tcsh'>); otherwise, make them all -empty (except that C<d_csh> should be C<'undef'>) so that Perl will -think csh is missing. In either case, after editing config.sh, run -C<./Configure -S> and rebuild Perl. +(W) Something went wrong with the external program(s) used for C<glob> +and C<E<lt>*.cE<gt>>. Usually, this means that you supplied a C<glob> +pattern that caused the external program to fail and exit with a nonzero +status. If the message indicates that the abnormal exit resulted in a +coredump, this may also mean that your csh (C shell) is broken. If so, +you should change all of the csh-related variables in config.sh: If you +have tcsh, make the variables refer to it as if it were csh (e.g. +C<full_csh='/usr/bin/tcsh'>); otherwise, make them all empty (except that +C<d_csh> should be C<'undef'>) so that Perl will think csh is missing. +In either case, after editing config.sh, run C<./Configure -S> and +rebuild Perl. =item internal urp in regexp at /%s/ @@ -2322,12 +2348,14 @@ from the user it isn't running under, and isn't in a location where the CGI server can't find it, basically, more or less. Please see the following for more information: - http://www.perl.com/perl/faq/idiots-guide.html - http://www.perl.com/perl/faq/perl-cgi-faq.html + http://www.perl.com/CPAN/doc/FAQs/cgi/idiots-guide.html + http://www.perl.com/CPAN/doc/FAQs/cgi/perl-cgi-faq.html ftp://rtfm.mit.edu/pub/usenet/news.answers/www/cgi-faq http://hoohoo.ncsa.uiuc.edu/cgi/interface.html http://www-genome.wi.mit.edu/WWW/faqs/www-security-faq.html +You should also look at L<perlfaq9>. + =item setegid() not implemented (F) You tried to assign to C<$)>, and your operating system doesn't support @@ -2405,6 +2433,14 @@ there was a failure. You probably wanted to use system() instead, which does return. To suppress this warning, put the exec() in a block by itself. +=item Strange *+?{} on zero-length expression + +(W) You applied a regular expression quantifier in a place where it +makes no sense, such as on a zero-width assertion. +Try putting the quantifier inside the assertion instead. For example, +the way to match "abc" provided that it is followed by three +repetitions of "xyz" is C</abc(?=(?:xyz){3})/>, not C</abc(?=xyz){3}/>. + =item Stub found while resolving method `%s' overloading `%s' in package `%s' (P) Overloading resolution over @ISA tree may be broken by importation stubs. diff --git a/contrib/perl5/pod/perldsc.pod b/contrib/perl5/pod/perldsc.pod index d0cc335..ef3ae75 100644 --- a/contrib/perl5/pod/perldsc.pod +++ b/contrib/perl5/pod/perldsc.pod @@ -690,7 +690,7 @@ many different sorts: print $rec->{TEXT}; - print $rec->{LIST}[0]; + print $rec->{SEQUENCE}[0]; $last = pop @ { $rec->{SEQUENCE} }; print $rec->{LOOKUP}{"key"}; diff --git a/contrib/perl5/pod/perlembed.pod b/contrib/perl5/pod/perlembed.pod index c09d6e3..03c5507 100644 --- a/contrib/perl5/pod/perlembed.pod +++ b/contrib/perl5/pod/perlembed.pod @@ -141,7 +141,7 @@ you: If the B<ExtUtils::Embed> module isn't part of your Perl distribution, you can retrieve it from -http://www.perl.com/perl/CPAN/modules/by-module/ExtUtils::Embed. (If +http://www.perl.com/perl/CPAN/modules/by-module/ExtUtils/. (If this documentation came from your Perl distribution, then you're running 5.004 or better and you already have it.) @@ -285,6 +285,7 @@ the first, a C<float> from the second, and a C<char *> from the third. main (int argc, char **argv, char **env) { + STRLEN n_a; char *embedding[] = { "", "-e", "0" }; my_perl = perl_alloc(); @@ -303,7 +304,7 @@ the first, a C<float> from the second, and a C<char *> from the third. /** Treat $a as a string **/ perl_eval_pv("$a = 'rekcaH lreP rehtonA tsuJ'; $a = reverse($a);", TRUE); - printf("a = %s\n", SvPV(perl_get_sv("a", FALSE), PL_na)); + printf("a = %s\n", SvPV(perl_get_sv("a", FALSE), n_a)); perl_destruct(my_perl); perl_free(my_perl); @@ -325,8 +326,9 @@ possible and in most cases a better strategy to fetch the return value from I<perl_eval_pv()> instead. Example: ... + STRLEN n_a; SV *val = perl_eval_pv("reverse 'rekcaH lreP rehtonA tsuJ'", TRUE); - printf("%s\n", SvPV(val,PL_na)); + printf("%s\n", SvPV(val,n_a)); ... This way, we avoid namespace pollution by not creating global @@ -371,6 +373,7 @@ been wrapped here): { dSP; SV* retval; + STRLEN n_a; PUSHMARK(SP); perl_eval_sv(sv, G_SCALAR); @@ -380,7 +383,7 @@ been wrapped here): PUTBACK; if (croak_on_error && SvTRUE(ERRSV)) - croak(SvPVx(ERRSV, PL_na)); + croak(SvPVx(ERRSV, n_a)); return retval; } @@ -395,9 +398,10 @@ been wrapped here): I32 match(SV *string, char *pattern) { SV *command = NEWSV(1099, 0), *retval; + STRLEN n_a; sv_setpvf(command, "my $string = '%s'; $string =~ %s", - SvPV(string,PL_na), pattern); + SvPV(string,n_a), pattern); retval = my_perl_eval_sv(command, TRUE); SvREFCNT_dec(command); @@ -416,9 +420,10 @@ been wrapped here): I32 substitute(SV **string, char *pattern) { SV *command = NEWSV(1099, 0), *retval; + STRLEN n_a; sv_setpvf(command, "$string = '%s'; ($string =~ %s)", - SvPV(*string,PL_na), pattern); + SvPV(*string,n_a), pattern); retval = my_perl_eval_sv(command, TRUE); SvREFCNT_dec(command); @@ -439,9 +444,10 @@ been wrapped here): { SV *command = NEWSV(1099, 0); I32 num_matches; + STRLEN n_a; sv_setpvf(command, "my $string = '%s'; @array = ($string =~ %s)", - SvPV(string,PL_na), pattern); + SvPV(string,n_a), pattern); my_perl_eval_sv(command, TRUE); SvREFCNT_dec(command); @@ -459,6 +465,7 @@ been wrapped here): AV *match_list; I32 num_matches, i; SV *text = NEWSV(1099,0); + STRLEN n_a; perl_construct(my_perl); perl_parse(my_perl, NULL, 3, embedding, NULL); @@ -480,7 +487,7 @@ been wrapped here): printf("matches: m/(wi..)/g found %d matches...\n", num_matches); for (i = 0; i < num_matches; i++) - printf("match: %s\n", SvPV(*av_fetch(match_list, i, FALSE),PL_na)); + printf("match: %s\n", SvPV(*av_fetch(match_list, i, FALSE),n_a)); printf("\n"); /** Remove all vowels from text **/ @@ -488,7 +495,7 @@ been wrapped here): if (num_matches) { printf("substitute: s/[aeiou]//gi...%d substitutions made.\n", num_matches); - printf("Now text is: %s\n\n", SvPV(text,PL_na)); + printf("Now text is: %s\n\n", SvPV(text,n_a)); } /** Attempt a substitution **/ @@ -726,6 +733,7 @@ with L<perlfunc/my> whenever possible. char *args[] = { "", DO_CLEAN, NULL }; char filename [1024]; int exitstatus = 0; + STRLEN n_a; if((perl = perl_alloc()) == NULL) { fprintf(stderr, "no memory!"); @@ -747,7 +755,7 @@ with L<perlfunc/my> whenever possible. /* check $@ */ if(SvTRUE(ERRSV)) - fprintf(stderr, "eval error: %s\n", SvPV(ERRSV,PL_na)); + fprintf(stderr, "eval error: %s\n", SvPV(ERRSV,n_a)); } } @@ -955,7 +963,7 @@ Interfacing to ActiveState's Perl library is quite different from the examples in this documentation, as significant changes were made to the internal Perl API. However, it is possible to embed ActiveState's Perl runtime. For details, see the Perl for Win32 FAQ at -http://www.perl.com/perl/faq/win32/Perl_for_Win32_FAQ.html. +http://www.perl.com/CPAN/doc/FAQs/win32/perlwin32faq.html. With the "official" Perl version 5.004 or higher, all the examples within this documentation will compile and run untouched, although diff --git a/contrib/perl5/pod/perlfaq.pod b/contrib/perl5/pod/perlfaq.pod index e6be112..cb35493 100644 --- a/contrib/perl5/pod/perlfaq.pod +++ b/contrib/perl5/pod/perlfaq.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq - frequently asked questions about Perl ($Date: 1998/08/05 12:09:32 $) +perlfaq - frequently asked questions about Perl ($Date: 1999/01/08 05:54:52 $) =head1 DESCRIPTION @@ -16,42 +16,682 @@ This document. Very general, high-level information about Perl. +=over 4 + +=item * What is Perl? + +=item * Who supports Perl? Who develops it? Why is it free? + +=item * Which version of Perl should I use? + +=item * What are perl4 and perl5? + +=item * What is perl6? + +=item * How stable is Perl? + +=item * Is Perl difficult to learn? + +=item * How does Perl compare with other languages like Java, Python, REXX, Scheme, or Tcl? + +=item * Can I do [task] in Perl? + +=item * When shouldn't I program in Perl? + +=item * What's the difference between "perl" and "Perl"? + +=item * Is it a Perl program or a Perl script? + +=item * What is a JAPH? + +=item * Where can I get a list of Larry Wall witticisms? + +=item * How can I convince my sysadmin/supervisor/employees to use version (5/5.005/Perl instead of some other language)? + +=back + + =item L<perlfaq2>: Obtaining and Learning about Perl Where to find source and documentation to Perl, support, and related matters. +=over 4 + +=item * What machines support Perl? Where do I get it? + +=item * How can I get a binary version of Perl? + +=item * I don't have a C compiler on my system. How can I compile perl? + +=item * I copied the Perl binary from one machine to another, but scripts don't work. + +=item * I grabbed the sources and tried to compile but gdbm/dynamic loading/malloc/linking/... failed. How do I make it work? + +=item * What modules and extensions are available for Perl? What is CPAN? What does CPAN/src/... mean? + +=item * Is there an ISO or ANSI certified version of Perl? + +=item * Where can I get information on Perl? + +=item * What are the Perl newsgroups on USENET? Where do I post questions? + +=item * Where should I post source code? + +=item * Perl Books + +=item * Perl in Magazines + +=item * Perl on the Net: FTP and WWW Access + +=item * What mailing lists are there for perl? + +=item * Archives of comp.lang.perl.misc + +=item * Where can I buy a commercial version of Perl? + +=item * Where do I send bug reports? + +=item * What is perl.com? + +=back + + =item L<perlfaq3>: Programming Tools Programmer tools and programming support. +=over 4 + +=item * How do I do (anything)? + +=item * How can I use Perl interactively? + +=item * Is there a Perl shell? + +=item * How do I debug my Perl programs? + +=item * How do I profile my Perl programs? + +=item * How do I cross-reference my Perl programs? + +=item * Is there a pretty-printer (formatter) for Perl? + +=item * Is there a ctags for Perl? + +=item * Is there an IDE or Windows Perl Editor? + +=item * Where can I get Perl macros for vi? + +=item * Where can I get perl-mode for emacs? + +=item * How can I use curses with Perl? + +=item * How can I use X or Tk with Perl? + +=item * How can I generate simple menus without using CGI or Tk? + +=item * What is undump? + +=item * How can I make my Perl program run faster? + +=item * How can I make my Perl program take less memory? + +=item * Is it unsafe to return a pointer to local data? + +=item * How can I free an array or hash so my program shrinks? + +=item * How can I make my CGI script more efficient? + +=item * How can I hide the source for my Perl program? + +=item * How can I compile my Perl program into byte code or C? + +=item * How can I compile Perl into Java? + +=item * How can I get C<#!perl> to work on [MS-DOS,NT,...]? + +=item * Can I write useful perl programs on the command line? + +=item * Why don't perl one-liners work on my DOS/Mac/VMS system? + +=item * Where can I learn about CGI or Web programming in Perl? + +=item * Where can I learn about object-oriented Perl programming? + +=item * Where can I learn about linking C with Perl? [h2xs, xsubpp] + +=item * I've read perlembed, perlguts, etc., but I can't embed perl in +my C program, what am I doing wrong? + +=item * When I tried to run my script, I got this message. What does it +mean? + +=item * What's MakeMaker? + +=back + + =item L<perlfaq4>: Data Manipulation Manipulating numbers, dates, strings, arrays, hashes, and miscellaneous data issues. +=over 4 + +=item * Why am I getting long decimals (eg, 19.9499999999999) instead of the numbers I should be getting (eg, 19.95)? + +=item * Why isn't my octal data interpreted correctly? + +=item * Does Perl have a round() function? What about ceil() and floor()? Trig functions? + +=item * How do I convert bits into ints? + +=item * Why doesn't & work the way I want it to? + +=item * How do I multiply matrices? + +=item * How do I perform an operation on a series of integers? + +=item * How can I output Roman numerals? + +=item * Why aren't my random numbers random? + +=item * How do I find the week-of-the-year/day-of-the-year? + +=item * How can I compare two dates and find the difference? + +=item * How can I take a string and turn it into epoch seconds? + +=item * How can I find the Julian Day? + +=item * How do I find yesterday's date? + +=item * Does Perl have a year 2000 problem? Is Perl Y2K compliant? + +=item * How do I validate input? + +=item * How do I unescape a string? + +=item * How do I remove consecutive pairs of characters? + +=item * How do I expand function calls in a string? + +=item * How do I find matching/nesting anything? + +=item * How do I reverse a string? + +=item * How do I expand tabs in a string? + +=item * How do I reformat a paragraph? + +=item * How can I access/change the first N letters of a string? + +=item * How do I change the Nth occurrence of something? + +=item * How can I count the number of occurrences of a substring within a string? + +=item * How do I capitalize all the words on one line? + +=item * How can I split a [character] delimited string except when inside +[character]? (Comma-separated files) + +=item * How do I strip blank space from the beginning/end of a string? + +=item * How do I pad a string with blanks or pad a number with zeroes? + +=item * How do I extract selected columns from a string? + +=item * How do I find the soundex value of a string? + +=item * How can I expand variables in text strings? + +=item * What's wrong with always quoting "$vars"? + +=item * Why don't my E<lt>E<lt>HERE documents work? + +=item * What is the difference between a list and an array? + +=item * What is the difference between $array[1] and @array[1]? + +=item * How can I extract just the unique elements of an array? + +=item * How can I tell whether a list or array contains a certain element? + +=item * How do I compute the difference of two arrays? How do I compute the intersection of two arrays? + +=item * How do I test whether two arrays or hashes are equal? + +=item * How do I find the first array element for which a condition is true? + +=item * How do I handle linked lists? + +=item * How do I handle circular lists? + +=item * How do I shuffle an array randomly? + +=item * How do I process/modify each element of an array? + +=item * How do I select a random element from an array? + +=item * How do I permute N elements of a list? + +=item * How do I sort an array by (anything)? + +=item * How do I manipulate arrays of bits? + +=item * Why does defined() return true on empty arrays and hashes? + +=item * How do I process an entire hash? + +=item * What happens if I add or remove keys from a hash while iterating over it? + +=item * How do I look up a hash element by value? + +=item * How can I know how many entries are in a hash? + +=item * How do I sort a hash (optionally by value instead of key)? + +=item * How can I always keep my hash sorted? + +=item * What's the difference between "delete" and "undef" with hashes? + +=item * Why don't my tied hashes make the defined/exists distinction? + +=item * How do I reset an each() operation part-way through? + +=item * How can I get the unique keys from two hashes? + +=item * How can I store a multidimensional array in a DBM file? + +=item * How can I make my hash remember the order I put elements into it? + +=item * Why does passing a subroutine an undefined element in a hash create it? + +=item * How can I make the Perl equivalent of a C structure/C++ class/hash or array of hashes or arrays? + +=item * How can I use a reference as a hash key? + +=item * How do I handle binary data correctly? + +=item * How do I determine whether a scalar is a number/whole/integer/float? + +=item * How do I keep persistent data across program calls? + +=item * How do I print out or copy a recursive data structure? + +=item * How do I define methods for every class/object? + +=item * How do I verify a credit card checksum? + +=item * How do I pack arrays of doubles or floats for XS code? + +=back + + =item L<perlfaq5>: Files and Formats I/O and the "f" issues: filehandles, flushing, formats and footers. +=over 4 + +=item * How do I flush/unbuffer an output filehandle? Why must I do this? + +=item * How do I change one line in a file/delete a line in a file/insert a line in the middle of a file/append to the beginning of a file? + +=item * How do I count the number of lines in a file? + +=item * How do I make a temporary file name? + +=item * How can I manipulate fixed-record-length files? + +=item * How can I make a filehandle local to a subroutine? How do I pass filehandles between subroutines? How do I make an array of filehandles? + +=item * How can I use a filehandle indirectly? + +=item * How can I set up a footer format to be used with write()? + +=item * How can I write() into a string? + +=item * How can I output my numbers with commas added? + +=item * How can I translate tildes (~) in a filename? + +=item * How come when I open a file read-write it wipes it out? + +=item * Why do I sometimes get an "Argument list too long" when I use E<lt>*E<gt>? + +=item * Is there a leak/bug in glob()? + +=item * How can I open a file with a leading "E<gt>" or trailing blanks? + +=item * How can I reliably rename a file? + +=item * How can I lock a file? + +=item * Why can't I just open(FH, ">file.lock")? + +=item * I still don't get locking. I just want to increment the number in the file. How can I do this? + +=item * How do I randomly update a binary file? + +=item * How do I get a file's timestamp in perl? + +=item * How do I set a file's timestamp in perl? + +=item * How do I print to more than one file at once? + +=item * How can I read in a file by paragraphs? + +=item * How can I read a single character from a file? From the keyboard? + +=item * How can I tell whether there's a character waiting on a filehandle? + +=item * How do I do a C<tail -f> in perl? + +=item * How do I dup() a filehandle in Perl? + +=item * How do I close a file descriptor by number? + +=item * Why can't I use "C:\temp\foo" in DOS paths? What doesn't `C:\temp\foo.exe` work? + +=item * Why doesn't glob("*.*") get all the files? + +=item * Why does Perl let me delete read-only files? Why does C<-i> clobber protected files? Isn't this a bug in Perl? + +=item * How do I select a random line from a file? + +=item * Why do I get weird spaces when I print an array of lines? + +=back + + =item L<perlfaq6>: Regexps Pattern matching and regular expressions. +=over 4 + +=item * How can I hope to use regular expressions without creating illegible and unmaintainable code? + +=item * I'm having trouble matching over more than one line. What's wrong? + +=item * How can I pull out lines between two patterns that are themselves on different lines? + +=item * I put a regular expression into $/ but it didn't work. What's wrong? + +=item * How do I substitute case insensitively on the LHS, but preserving case on the RHS? + +=item * How can I make C<\w> match national character sets? + +=item * How can I match a locale-smart version of C</[a-zA-Z]/>? + +=item * How can I quote a variable to use in a regexp? + +=item * What is C</o> really for? + +=item * How do I use a regular expression to strip C style comments from a file? + +=item * Can I use Perl regular expressions to match balanced text? + +=item * What does it mean that regexps are greedy? How can I get around it? + +=item * How do I process each word on each line? + +=item * How can I print out a word-frequency or line-frequency summary? + +=item * How can I do approximate matching? + +=item * How do I efficiently match many regular expressions at once? + +=item * Why don't word-boundary searches with C<\b> work for me? + +=item * Why does using $&, $`, or $' slow my program down? + +=item * What good is C<\G> in a regular expression? + +=item * Are Perl regexps DFAs or NFAs? Are they POSIX compliant? + +=item * What's wrong with using grep or map in a void context? + +=item * How can I match strings with multibyte characters? + +=item * How do I match a pattern that is supplied by the user? + +=back + + =item L<perlfaq7>: General Perl Language Issues General Perl language issues that don't clearly fit into any of the other sections. +=over 4 + +=item * Can I get a BNF/yacc/RE for the Perl language? + +=item * What are all these $@%* punctuation signs, and how do I know when to use them? + +=item * Do I always/never have to quote my strings or use semicolons and commas? + +=item * How do I skip some return values? + +=item * How do I temporarily block warnings? + +=item * What's an extension? + +=item * Why do Perl operators have different precedence than C operators? + +=item * How do I declare/create a structure? + +=item * How do I create a module? + +=item * How do I create a class? + +=item * How can I tell if a variable is tainted? + +=item * What's a closure? + +=item * What is variable suicide and how can I prevent it? + +=item * How can I pass/return a {Function, FileHandle, Array, Hash, Method, Regexp}? + +=item * How do I create a static variable? + +=item * What's the difference between dynamic and lexical (static) scoping? Between local() and my()? + +=item * How can I access a dynamic variable while a similarly named lexical is in scope? + +=item * What's the difference between deep and shallow binding? + +=item * Why doesn't "my($foo) = E<lt>FILEE<gt>;" work right? + +=item * How do I redefine a builtin function, operator, or method? + +=item * What's the difference between calling a function as &foo and foo()? + +=item * How do I create a switch or case statement? + +=item * How can I catch accesses to undefined variables/functions/methods? + +=item * Why can't a method included in this same file be found? + +=item * How can I find out my current package? + +=item * How can I comment out a large block of perl code? + +=item * How do I clear a package? + +=back + + =item L<perlfaq8>: System Interaction Interprocess communication (IPC), control over the user-interface (keyboard, screen and pointing devices). +=over 4 + +=item * How do I find out which operating system I'm running under? + +=item * How come exec() doesn't return? + +=item * How do I do fancy stuff with the keyboard/screen/mouse? + +=item * How do I print something out in color? + +=item * How do I read just one key without waiting for a return key? + +=item * How do I check whether input is ready on the keyboard? + +=item * How do I clear the screen? + +=item * How do I get the screen size? + +=item * How do I ask the user for a password? + +=item * How do I read and write the serial port? + +=item * How do I decode encrypted password files? + +=item * How do I start a process in the background? + +=item * How do I trap control characters/signals? + +=item * How do I modify the shadow password file on a Unix system? + +=item * How do I set the time and date? + +=item * How can I sleep() or alarm() for under a second? + +=item * How can I measure time under a second? + +=item * How can I do an atexit() or setjmp()/longjmp()? (Exception handling) + +=item * Why doesn't my sockets program work under System V (Solaris)? What does the error message "Protocol not supported" mean? + +=item * How can I call my system's unique C functions from Perl? + +=item * Where do I get the include files to do ioctl() or syscall()? + +=item * Why do setuid perl scripts complain about kernel problems? + +=item * How can I open a pipe both to and from a command? + +=item * Why can't I get the output of a command with system()? + +=item * How can I capture STDERR from an external command? + +=item * Why doesn't open() return an error when a pipe open fails? + +=item * What's wrong with using backticks in a void context? + +=item * How can I call backticks without shell processing? + +=item * Why can't my script read from STDIN after I gave it EOF (^D on Unix, ^Z on MS-DOS)? + +=item * How can I convert my shell script to perl? + +=item * Can I use perl to run a telnet or ftp session? + +=item * How can I write expect in Perl? + +=item * Is there a way to hide perl's command line from programs such as "ps"? + +=item * I {changed directory, modified my environment} in a perl script. How come the change disappeared when I exited the script? How do I get my changes to be visible? + +=item * How do I close a process's filehandle without waiting for it to complete? + +=item * How do I fork a daemon process? + +=item * How do I make my program run with sh and csh? + +=item * How do I find out if I'm running interactively or not? + +=item * How do I timeout a slow event? + +=item * How do I set CPU limits? + +=item * How do I avoid zombies on a Unix system? + +=item * How do I use an SQL database? + +=item * How do I make a system() exit on control-C? + +=item * How do I open a file without blocking? + +=item * How do I install a CPAN module? + +=item * What's the difference between require and use? + +=item * How do I keep my own module/library directory? + +=item * How do I add the directory my program lives in to the module/library search path? + +=item * How do I add a directory to my include path at runtime? + +=item * What is socket.ph and where do I get it? + +=back + + =item L<perlfaq9>: Networking Networking, the Internet, and a few on the web. +=over 4 + +=item * My CGI script runs from the command line but not the browser. (500 Server Error) + +=item * How can I get better error messages from a CGI program? + +=item * How do I remove HTML from a string? + +=item * How do I extract URLs? + +=item * How do I download a file from the user's machine? How do I open a file on another machine? + +=item * How do I make a pop-up menu in HTML? + +=item * How do I fetch an HTML file? + +=item * How do I automate an HTML form submission? + +=item * How do I decode or create those %-encodings on the web? + +=item * How do I redirect to another page? + +=item * How do I put a password on my web pages? + +=item * How do I edit my .htpasswd and .htgroup files with Perl? + +=item * How do I make sure users can't enter values into a form that cause my CGI script to do bad things? + +=item * How do I parse a mail header? + +=item * How do I decode a CGI form? + +=item * How do I check a valid mail address? + +=item * How do I decode a MIME/BASE64 string? + +=item * How do I return the user's mail address? + +=item * How do I send mail? + +=item * How do I read mail? + +=item * How do I find out my hostname/domainname/IP address? + +=item * How do I fetch a news article or the active newsgroups? + +=item * How do I fetch/put an FTP file? + +=item * How can I do RPC in Perl? + +=back + + =back =head2 Where to get this document @@ -66,6 +706,7 @@ at http://www.perl.com/perl/faq/ . You may mail corrections, additions, and suggestions to perlfaq-suggestions@perl.com . This alias should not be used to I<ask> FAQs. It's for fixing the current FAQ. +Send questions to the comp.lang.perl.misc newsgroup. =head2 What will happen if you mail your Perl programming problems to the authors @@ -88,7 +729,7 @@ Perl Porters. =head1 Author and Copyright Information -Copyright (c) 1997, 1998 Tom Christiansen and Nathan Torkington. +Copyright (c) 1997-1999 Tom Christiansen and Nathan Torkington. All rights reserved. =head2 Bundled Distributions @@ -117,6 +758,11 @@ in respect of this information or its use. =over 4 +=item 7/January/99 + +Small touchups here and there. Added all questions in this +document as a sort of table of contents. + =item 22/June/98 Significant changes throughout in preparation for the 5.005 @@ -170,3 +816,4 @@ This is the initial release of version 3 of the FAQ; consequently there have been no changes since its initial release. =back + diff --git a/contrib/perl5/pod/perlfaq1.pod b/contrib/perl5/pod/perlfaq1.pod index 5a95f19..d4cac42 100644 --- a/contrib/perl5/pod/perlfaq1.pod +++ b/contrib/perl5/pod/perlfaq1.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq1 - General Questions About Perl ($Revision: 1.15 $, $Date: 1998/08/05 11:52:24 $) +perlfaq1 - General Questions About Perl ($Revision: 1.20 $, $Date: 1999/01/08 04:22:09 $) =head1 DESCRIPTION @@ -32,12 +32,14 @@ the personal note at the end of the README file in the perl source distribution for more details. See L<perlhist> (new as of 5.005) for Perl's milestone releases. -In particular, the core development team (known as the Perl -Porters) are a rag-tag band of highly altruistic individuals -committed to producing better software for free than you -could hope to purchase for money. You may snoop on pending -developments via news://genetics.upenn.edu/perl.porters-gw/ and -http://www.frii.com/~gnat/perl/porters/summary.html. +In particular, the core development team (known as the Perl Porters) +are a rag-tag band of highly altruistic individuals committed +to producing better software for free than you could hope to +purchase for money. You may snoop on pending developments via +nntp://news.perl.com/perl.porters-gw/ and the Deja News archive at +http://www.dejanews.com/ using the perl.porters-gw newsgroup, or you can +subscribe to the mailing list by sending perl5-porters-request@perl.org +a subscription request. While the GNU project includes Perl in its distributions, there's no such thing as "GNU Perl". Perl is not produced nor maintained by the @@ -51,12 +53,16 @@ users the informal support will more than suffice. See the answer to =head2 Which version of Perl should I use? You should definitely use version 5. Version 4 is old, limited, and -no longer maintained; its last patch (4.036) was in 1992. The most -recent production release is 5.005_01. Further references to the Perl -language in this document refer to this production release unless -otherwise specified. There may be one or more official bug fixes for -5.005_01 by the time you read this, and also perhaps some experimental -versions on the way to the next release. +no longer maintained; its last patch (4.036) was in 1992, long ago and +far away. Sure, it's stable, but so is anything that's dead; in fact, +perl4 had been called a dead, flea-bitten camel carcass. The most recent +production release is 5.005_02 (although 5.004_04 is still supported). +The most cutting-edge development release is 5.005_54. Further references +to the Perl language in this document refer to the production release +unless otherwise specified. There may be one or more official bug +fixes for 5.005_02 by the time you read this, and also perhaps some +experimental versions on the way to the next release. All releases +prior to 5.004 were subject to buffer overruns, a grave security issue. =head2 What are perl4 and perl5? @@ -68,11 +74,12 @@ Perl5 is merely the popular name for the fifth major release (October 1994), while perl4 was the fourth major release (March 1991). There was also a perl1 (in January 1988), a perl2 (June 1988), and a perl3 (October 1989). -The 5.0 release is, essentially, a complete rewrite of the perl source -code from the ground up. It has been modularized, object-oriented, -tweaked, trimmed, and optimized until it almost doesn't look like the -old code. However, the interface is mostly the same, and compatibility -with previous releases is very high. +The 5.0 release is, essentially, a ground-up rewrite of the original +perl source code from releases 1 through 4. It has been modularized, +object-oriented, tweaked, trimmed, and optimized until it almost doesn't +look like the old code. However, the interface is mostly the same, and +compatibility with previous releases is very high. See L<perltrap/"Perl4 +to Perl5 Traps">. To avoid the "what language is perl5?" confusion, some people prefer to simply use "perl" to refer to the latest version of perl and avoid using @@ -80,6 +87,27 @@ simply use "perl" to refer to the latest version of perl and avoid using See L<perlhist> for a history of Perl revisions. +=head2 What is perl6? + +Perl6 is a semi-jocular reference to the Topaz project. Headed by Chip +Salzenberg, Topaz is yet-another ground-up rewrite of the current release +of Perl, one whose major goal is to create a more maintainable core than +found in release 5. Written in nominally portable C++, Topaz hopes to +maintain 100% source-compatibility with previous releases of Perl but to +run significantly faster and smaller. The Topaz team hopes to provide +an XS compatibility interface to allow most XS modules to work unchanged, +albeit perhaps without the efficiency that the new interface uowld allow. +New features in Topaz are as yet undetermined, and will be addressed +once compatibility and performance goals are met. + +If you are a hard-working C++ wizard with a firm command of Perl's +internals, and you would like to work on the project, send a request to +perl6-porters-request@perl.org to subscribe to the Topaz mailing list. + +There is no ETA for Topaz. It is expected to be several years before it +achieves enough robustness, compatibility, portability, and performance +to replace perl5 for ordinary use by mere mortals. + =head2 How stable is Perl? Production releases, which incorporate bug fixes and new functionality, @@ -106,18 +134,18 @@ to do it" (TMTOWTDI, sometimes pronounced "tim toady"). Perl's learning curve is therefore shallow (easy to learn) and long (there's a whole lot you can do if you really want). -Finally, Perl is (frequently) an interpreted language. This means -that you can write your programs and test them without an intermediate -compilation step, allowing you to experiment and test/debug quickly -and easily. This ease of experimentation flattens the learning curve -even more. +Finally, because Perl is frequently (but not always, and certainly not by +definition) an interpreted language, you can write your programs and test +them without an intermediate compilation step, allowing you to experiment +and test/debug quickly and easily. This ease of experimentation flattens +the learning curve even more. Things that make Perl easier to learn: Unix experience, almost any kind of programming experience, an understanding of regular expressions, and the ability to understand other people's code. If there's something you need to do, then it's probably already been done, and a working example is usually available for free. Don't forget the new perl modules, either. -They're discussed in Part 3 of this FAQ, along with the CPAN, which is +They're discussed in Part 3 of this FAQ, along with CPAN, which is discussed in Part 2. =head2 How does Perl compare with other languages like Java, Python, REXX, Scheme, or Tcl? @@ -130,22 +158,25 @@ Probably the best thing to do is try to write equivalent code to do a set of tasks. These languages have their own newsgroups in which you can learn about (but hopefully not argue about) them. +Some comparison documents can be found at http://language.perl.com/versus/ +if you really can't stop yourself. + =head2 Can I do [task] in Perl? -Perl is flexible and extensible enough for you to use on almost any -task, from one-line file-processing tasks to complex systems. For -many people, Perl serves as a great replacement for shell scripting. -For others, it serves as a convenient, high-level replacement for most -of what they'd program in low-level languages like C or C++. It's -ultimately up to you (and possibly your management ...) which tasks -you'll use Perl for and which you won't. +Perl is flexible and extensible enough for you to use on virtually any +task, from one-line file-processing tasks to large, elaborate systems. +For many people, Perl serves as a great replacement for shell scripting. +For others, it serves as a convenient, high-level replacement for most of +what they'd program in low-level languages like C or C++. It's ultimately +up to you (and possibly your management) which tasks you'll use Perl +for and which you won't. If you have a library that provides an API, you can make any component of it available as just another Perl function or variable using a Perl extension written in C or C++ and dynamically linked into your main perl interpreter. You can also go the other direction, and write your main program in C or C++, and then link in some Perl code on the fly, -to create a powerful application. +to create a powerful application. See L<perlembed>. That said, there will always be small, focused, special-purpose languages dedicated to a specific problem domain that are simply more @@ -164,17 +195,16 @@ certain task (e.g. prolog, make). For various reasons, Perl is probably not well-suited for real-time embedded systems, low-level operating systems development work like -device drivers or context-switching code, complex multithreaded +device drivers or context-switching code, complex multi-threaded shared-memory applications, or extremely large applications. You'll notice that perl is not itself written in Perl. -The new native-code compiler for Perl may reduce the limitations given -in the previous statement to some degree, but understand that Perl -remains fundamentally a dynamically typed language, and not a -statically typed one. You certainly won't be chastized if you don't -trust nuclear-plant or brain-surgery monitoring code to it. And -Larry will sleep easier, too -- Wall Street programs not -withstanding. :-) +The new, native-code compiler for Perl may eventually reduce the +limitations given in the previous statement to some degree, but understand +that Perl remains fundamentally a dynamically typed language, not +a statically typed one. You certainly won't be chastised if you don't +trust nuclear-plant or brain-surgery monitoring code to it. And Larry +will sleep easier, too -- Wall Street programs not withstanding. :-) =head2 What's the difference between "perl" and "Perl"? @@ -183,33 +213,58 @@ signify the language proper and "perl" the implementation of it, i.e. the current interpreter. Hence Tom's quip that "Nothing but perl can parse Perl." You may or may not choose to follow this usage. For example, parallelism means "awk and perl" and "Python and Perl" look -ok, while "awk and Perl" and "Python and perl" do not. +ok, while "awk and Perl" and "Python and perl" do not. But never +write "PERL", because perl isn't really an acronym, aprocryphal +folklore and post-facto expansions notwithstanding. =head2 Is it a Perl program or a Perl script? -It doesn't matter. - -In "standard terminology" a I<program> has been compiled to physical -machine code once, and can then be be run multiple times, whereas a -I<script> must be translated by a program each time it's used. Perl -programs, however, are usually neither strictly compiled nor strictly -interpreted. They can be compiled to a byte code form (something of a +Larry doesn't really care. He says (half in jest) that "a script is +what you give the actors. A program is what you give the audience." + +Originally, a script was a canned sequence of normally interactive +commands, that is, a chat script. Something like a uucp or ppp chat +script or an expect script fits the bill nicely, as do configuration +scripts run by a program at its start up, such F<.cshrc> or F<.ircrc>, +for example. Chat scripts were just drivers for existing programs, +not stand-alone programs in their own right. + +A computer scientist will correctly explain that all programs are +interpreted, and that the only question is at what level. But if you +ask this question of someone who isn't a computer scientist, they might +tell you that a I<program> has been compiled to physical machine code +once, and can then be run multiple times, whereas a I<script> must be +translated by a program each time it's used. + +Perl programs are (usually) neither strictly compiled nor strictly +interpreted. They can be compiled to a byte-code form (something of a Perl virtual machine) or to completely different languages, like C or -assembly language. You can't tell just by looking whether the source -is destined for a pure interpreter, a parse-tree interpreter, a byte -code interpreter, or a native-code compiler, so it's hard to give a -definitive answer here. +assembly language. You can't tell just by looking at it whether the +source is destined for a pure interpreter, a parse-tree interpreter, +a byte-code interpreter, or a native-code compiler, so it's hard to give +a definitive answer here. + +Now that "script" and "scripting" are terms that have been seized by +unscrupulous or unknowing marketeers for their own nefarious purposes, +they have begun to take on strange and often pejorative meanings, +like "non serious" or "not real programming". Consequently, some perl +programmers prefer to avoid them altogether. =head2 What is a JAPH? These are the "just another perl hacker" signatures that some people -sign their postings with. About 100 of the of the earlier ones are -available from http://www.perl.com/CPAN/misc/japh . +sign their postings with. Randal Schwartz made these famous. About +100 of the earlier ones are available from +http://www.perl.com/CPAN/misc/japh . =head2 Where can I get a list of Larry Wall witticisms? Over a hundred quips by Larry, from postings of his or source code, -can be found at http://www.perl.com/CPAN/misc/lwall-quotes . +can be found at http://www.perl.com/CPAN/misc/lwall-quotes.txt.gz . + +Newer examples can be found by perusing Larry's postings: + + http://x1.dejanews.com/dnquery.xp?QRY=*&DBS=2&ST=PS&defaultOp=AND&LNG=ALL&format=terse&showsort=date&maxhits=100&subjects=&groups=&authors=larry@*wall.org&fromdate=&todate= =head2 How can I convince my sysadmin/supervisor/employees to use version (5/5.005/Perl instead of some other language)? @@ -232,32 +287,33 @@ many Unix vendors now ship Perl by default, and support is usually just a news-posting away, if you can't find the answer in the I<comprehensive> documentation, including this FAQ. +See http://www.perl.org/advocacy/ for more information. + If you face reluctance to upgrading from an older version of perl, then point out that version 4 is utterly unmaintained and unsupported by the Perl Development Team. Another big sell for Perl5 is the large number of modules and extensions which greatly reduce development time for any given task. Also mention that the difference between version 4 and version 5 of Perl is like the difference between awk and C++. -(Well, ok, maybe not quite that distinct, but you get the idea.) If -you want support and a reasonable guarantee that what you're -developing will continue to work in the future, then you have to run -the supported version. That probably means running the 5.005 release, -although 5.004 isn't that bad (it's just one year and one release -behind). Several important bugs were fixed from the 5.000 through +(Well, ok, maybe not quite that distinct, but you get the idea.) If you +want support and a reasonable guarantee that what you're developing +will continue to work in the future, then you have to run the supported +version. That probably means running the 5.005 release, although 5.004 +isn't that bad. Several important bugs were fixed from the 5.000 through 5.003 versions, though, so try upgrading past them if possible. Of particular note is the massive bughunt for buffer overflow problems that went into the 5.004 release. All releases prior to that, including perl4, are considered insecure and should be upgraded -as soon as possible. +as soon as possible. =head1 AUTHOR AND COPYRIGHT -Copyright (c) 1997, 1998 Tom Christiansen and Nathan Torkington. +Copyright (c) 1997-1999 Tom Christiansen and Nathan Torkington. All rights reserved. When included as an integrated part of the Standard Distribution -of Perl or of its documentation (printed or otherwise), this works is +of Perl or of its documentation (printed or otherwise), this work is covered under Perl's Artistic Licence. For separate distributions of all or part of this FAQ outside of that, see L<perlfaq>. @@ -266,3 +322,4 @@ domain. You are permitted and encouraged to use this code and any derivatives thereof in your own programs for fun or for profit as you see fit. A simple comment in the code giving credit to the FAQ would be courteous but is not required. + diff --git a/contrib/perl5/pod/perlfaq2.pod b/contrib/perl5/pod/perlfaq2.pod index 918e936..32970af 100644 --- a/contrib/perl5/pod/perlfaq2.pod +++ b/contrib/perl5/pod/perlfaq2.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq2 - Obtaining and Learning about Perl ($Revision: 1.25 $, $Date: 1998/08/05 11:47:25 $) +perlfaq2 - Obtaining and Learning about Perl ($Revision: 1.30 $, $Date: 1998/12/29 19:43:32 $) =head1 DESCRIPTION @@ -12,7 +12,7 @@ related matters. The standard release of Perl (the one maintained by the perl development team) is distributed only in source code form. You -can find this at http://www.perl.com/CPAN/src/latest.tar.gz, which +can find this at http://www.perl.com/CPAN/src/latest.tar.gz , which in standard Internet format (a gzipped archive in POSIX tar format). Perl builds and runs on a bewildering number of platforms. Virtually @@ -22,7 +22,7 @@ QNX, BeOS, and the Amiga. There are also the beginnings of support for MPE/iX. Binary distributions for some proprietary platforms, including -Apple systems can be found http://www.perl.com/CPAN/ports/ directory. +Apple systems, can be found http://www.perl.com/CPAN/ports/ directory. Because these are not part of the standard distribution, they may and in fact do differ from the base Perl port in a variety of ways. You'll have to check their respective release notes to see just @@ -31,22 +31,23 @@ what the differences are. These differences can be either positive are not supported in the source release of perl) or negative (e.g. might be based upon a less current source release of perl). -A useful FAQ for Win32 Perl users is -http://www.endcontsw.com/people/evangelo/Perl_for_Win32_FAQ.html - =head2 How can I get a binary version of Perl? -If you don't have a C compiler because for whatever reasons your -vendor did not include one with your system, the best thing to do is +If you don't have a C compiler because your vendor for whatever +reasons did not include one with your system, the best thing to do is grab a binary version of gcc from the net and use that to compile perl with. CPAN only has binaries for systems that are terribly hard to get free compilers for, not for Unix systems. -Your first stop should be http://www.perl.com/CPAN/ports to see what -information is already available. A simple installation guide for -MS-DOS is available at http://www.cs.ruu.nl/~piet/perl5dos.html , and -similarly for Windows 3.1 at http://www.cs.ruu.nl/~piet/perlwin3.html -. +Some URLs that might help you are: + + http://language.perl.com/info/software.html + http://www.perl.com/latest/ + http://www.perl.com/CPAN/ports/ + +If you want information on proprietary systems. A simple installation +guide for MS-DOS is available at http://www.cs.ruu.nl/~piet/perl5dos.html +and similarly for Windows 3.1 at http://www.cs.ruu.nl/~piet/perlwin3.html . =head2 I don't have a C compiler on my system. How can I compile perl? @@ -67,11 +68,14 @@ approaches are doomed to failure. One simple way to check that things are in the right place is to print out the hard-coded @INC which perl is looking for. - perl -e 'print join("\n",@INC)' + % perl -e 'print join("\n",@INC)' If this command lists any paths which don't exist on your system, then you may need to move the appropriate libraries to these locations, or create -symlinks, aliases, or shortcuts appropriately. +symlinks, aliases, or shortcuts appropriately. @INC is also printed as +part of the output of + + % perl -V You might also want to check out L<perlfaq8/"How do I keep my own module/library directory?">. @@ -79,7 +83,7 @@ module/library directory?">. =head2 I grabbed the sources and tried to compile but gdbm/dynamic loading/malloc/linking/... failed. How do I make it work? Read the F<INSTALL> file, which is part of the source distribution. -It describes in detail how to cope with most idiosyncracies that the +It describes in detail how to cope with most idiosyncrasies that the Configure script can't work around for any given system or architecture. @@ -141,6 +145,16 @@ http://www.perl.com/perl/info/documentation.html that might help. Many good books have been written about Perl -- see the section below for more details. +Tutorial documents are included in current or upcoming Perl releases +include L<perltoot> for objects, L<perlopentut> for file opening +semantics, L<perlreftut> for managing references, and L<perlxstut> +for linking C and Perl together. There may be more by the +time you read this. The following URLs might also be of +assistance: + + http://language.perl.com/info/documentation.html + http://reference.perl.com/query.cgi?tutorials + =head2 What are the Perl newsgroups on USENET? Where do I post questions? The now defunct comp.lang.perl newsgroup has been superseded by the @@ -154,20 +168,17 @@ following groups: comp.infosystems.www.authoring.cgi Writing CGI scripts for the Web. -Actually, the moderated group hasn't passed yet, but we're -keeping our fingers crossed. - There is also USENET gateway to the mailing list used by the crack Perl development team (perl5-porters) at news://news.perl.com/perl.porters-gw/ . =head2 Where should I post source code? -You should post source code to whichever group is most appropriate, -but feel free to cross-post to comp.lang.perl.misc. If you want to -cross-post to alt.sources, please make sure it follows their posting -standards, including setting the Followup-To header line to NOT -include alt.sources; see their FAQ for details. +You should post source code to whichever group is most appropriate, but +feel free to cross-post to comp.lang.perl.misc. If you want to cross-post +to alt.sources, please make sure it follows their posting standards, +including setting the Followup-To header line to NOT include alt.sources; +see their FAQ (http://www.faqs.org/faqs/alt-sources-intro/) for details. If you're just looking for software, first use Alta Vista, Deja News, and search CPAN. This is faster and more productive than just posting @@ -184,7 +195,7 @@ The incontestably definitive reference book on Perl, written by the creator of Perl, is now in its second edition: Programming Perl (the "Camel Book"): - Authors: Larry Wall, Tom Christiansen, and Randal Schwartz + by Larry Wall, Tom Christiansen, and Randal Schwartz ISBN 1-56592-149-6 (English) ISBN 4-89052-384-7 (Japanese) URL: http://www.oreilly.com/catalog/pperl2/ @@ -196,7 +207,7 @@ of real-world examples, mini-tutorials, and complete programs (first premiering at the 1998 Perl Conference), is: The Perl Cookbook (the "Ram Book"): - Authors: Tom Christiansen and Nathan Torkington, + by Tom Christiansen and Nathan Torkington, with Foreword by Larry Wall ISBN: 1-56592-243-3 URL: http://perl.oreilly.com/cookbook/ @@ -206,7 +217,7 @@ might suffice for you to learn Perl from. But if you're not, check out: Learning Perl (the "Llama Book"): - Authors: Randal Schwartz and Tom Christiansen + by Randal Schwartz and Tom Christiansen with Foreword by Larry Wall ISBN: 1-56592-284-0 URL: http://www.oreilly.com/catalog/lperl2/ @@ -230,7 +241,7 @@ See http://www.ora.com/ on the Web. What follows is a list of the books that the FAQ authors found personally useful. Your mileage may (but, we hope, probably won't) vary. -Recommended books on (or muchly on) Perl follow; those marked with +Recommended books on (or mostly on) Perl follow; those marked with a star may be ordered from O'Reilly. =over @@ -262,7 +273,7 @@ a star may be ordered from O'Reilly. MacPerl: Power and Ease by Vicki Brown and Chris Nandor, foreword by Matthias Neeracher -=item Task-Oriented +=item Task-Oriented *The Perl Cookbook by Tom Christiansen and Nathan Torkington @@ -296,7 +307,7 @@ development, databases, Win32 Perl, graphical programming, regular expressions, and networking, and sponsors the Obfuscated Perl Contest. It is published quarterly under the gentle hand of its editor, Jon Orwant. See http://www.tpj.com/ or send mail to -subscriptions@tpj.com. +subscriptions@tpj.com . Beyond this, magazines that frequently carry high-quality articles on Perl are I<Web Techniques> (see http://www.webtechniques.com/), @@ -309,10 +320,11 @@ http://www.stonehenge.com/merlyn/WebTechniques/. To get the best (and possibly cheapest) performance, pick a site from the list below and use it to grab the complete list of mirror sites. -From there you can find the quickest site for you. Remember, the +>From there you can find the quickest site for you. Remember, the following list is I<not> the complete list of CPAN mirrors. - http://www.perl.com/CPAN (redirects to another mirror) + http://www.perl.com/CPAN-local + http://www.perl.com/CPAN (redirects to an ftp mirror) http://www.perl.org/CPAN ftp://ftp.funet.fi/pub/languages/perl/CPAN/ http://www.cs.ruu.nl/pub/PERL/CPAN/ @@ -322,69 +334,19 @@ 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 following are a list of mailing lists -related to perl itself. - -If you subscribe to a mailing list, it behooves you to know how to -unsubscribe from it. Strident pleas to the list itself to get you off -will not be favorably received. - -=over 4 - -=item MacPerl - -There is a mailing list for discussing Macintosh Perl. Contact -"mac-perl-request@iis.ee.ethz.ch". - -Also see Matthias Neeracher's (the creator and maintainer of MacPerl) -webpage at http://www.iis.ee.ethz.ch/~neeri/macintosh/perl.html for -many links to interesting MacPerl sites, and the applications/MPW -tools, precompiled. - -=item Perl5-Porters - -The core development team have a mailing list for discussing fixes and -changes to the language. Send mail to -"perl5-porters-request@perl.org" with help in the body of the message -for information on subscribing. - -=item NTPerl +subscription information. The Perl Institute attempts to maintain a +list of mailing lists at: -This list is used to discuss issues involving Win32 Perl 5 (Windows NT -and Win95). Subscribe by mailing ListManager@ActiveWare.com with the -message body: + http://www.perl.org/maillist.html - subscribe Perl-Win32-Users - -The list software, also written in perl, will automatically determine -your address, and subscribe you automatically. To unsubscribe, mail -the following in the message body to the same address like so: - - unsubscribe Perl-Win32-Users - -You can also check http://www.activeware.com/ and select "Mailing Lists" -to join or leave this list. - -=item Perl-Packrats - -Discussion related to archiving of perl materials, particularly the -Comprehensive Perl Archive Network (CPAN). Subscribe by emailing -majordomo@cis.ufl.edu: - - subscribe perl-packrats - -The list software, also written in perl, will automatically determine -your address, and subscribe you automatically. To unsubscribe, simple -prepend the same command with an "un", and mail to the same address -like so: - - unsubscribe perl-packrats +=head2 Archives of comp.lang.perl.misc -=back +Have you tried Deja News or Alta Vista? Those are the +best archives. Just look up "*perl*" as a newsgroup. -=head2 Archives of comp.lang.perl.misc + http://www.dejanews.com/dnquery.xp?QRY=&DBS=2&ST=PS&defaultOp=AND&LNG=ALL&format=terse&showsort=date&maxhits=25&subjects=&groups=*perl*&authors=&fromdate=&todate= -Have you tried Deja News or Alta Vista? +You'll probably want to trim that down a bit, though. ftp.cis.ufl.edu:/pub/perl/comp.lang.perl.*/monthly has an almost complete collection dating back to 12/89 (missing 08/91 through @@ -402,21 +364,24 @@ let perlfaq-suggestions@perl.com know. =head2 Where can I buy a commercial version of Perl? -In a sense, Perl already I<is> commercial software: It has a licence -that you can grab and carefully read to your manager. It is -distributed in releases and comes in well-defined packages. There is a -very large user community and an extensive literature. The -comp.lang.perl.* newsgroups and several of the mailing lists provide -free answers to your questions in near real-time. Perl has -traditionally been supported by Larry, dozens of software designers -and developers, and thousands of programmers, all working for free -to create a useful thing to make life better for everyone. +In a real sense, Perl already I<is> commercial software: It has a licence +that you can grab and carefully read to your manager. It is distributed +in releases and comes in well-defined packages. There is a very large +user community and an extensive literature. The comp.lang.perl.* +newsgroups and several of the mailing lists provide free answers to your +questions in near real-time. Perl has traditionally been supported by +Larry, scores of software designers and developers, and myriads of +programmers, all working for free to create a useful thing to make life +better for everyone. However, these answers may not suffice for managers who require a -purchase order from a company whom they can sue should anything go -wrong. Or maybe they need very serious hand-holding and contractual -obligations. Shrink-wrapped CDs with perl on them are available from -several sources if that will help. +purchase order from a company whom they can sue should anything go awry. +Or maybe they need very serious hand-holding and contractual obligations. +Shrink-wrapped CDs with perl on them are available from several sources if +that will help. For example, many perl books carry a perl distribution +on them, as do the O'Reily Perl Resource Kits (in both the Unix flavor +and in the proprietary Microsoft flavor); the free Unix distributions +also all come with Perl. Or you can purchase a real support contract. Although Cygnus historically provided this service, they no longer sell support contracts for Perl. @@ -438,20 +403,20 @@ Oraperl and related modules (which Oracle is planning to ship as part of Oracle Web Server 3). 20% of the profit from our Perl support work will be donated to The Perl Institute." -For more information, contact the The Perl Clinic: +For more information, contact The Perl Clinic: Tel: +44 1483 424424 Fax: +44 1483 419419 Web: http://www.perl.co.uk/ Email: perl-support-info@perl.co.uk or Tim.Bunce@ig.co.uk -See also www.perl.com for updates on training and support. +See also www.perl.com for updates on tutorials, training, and support. =head2 Where do I send bug reports? If you are reporting a bug in the perl interpreter or the modules shipped with perl, use the I<perlbug> program in the perl distribution or -mail your report to perlbug@perl.com. +mail your report to perlbug@perl.com . If you are posting a bug with a non-standard port (see the answer to "What platforms is Perl available for?"), a binary distribution, or a @@ -461,34 +426,28 @@ bugs. Read the perlbug(1) man page (perl5.004 or later) for more information. -=head2 What is perl.com? perl.org? The Perl Institute? +=head2 What is perl.com? -The perl.com domain is managed by Tom Christiansen, who created it as a +The perl.com domain is owned by Tom Christiansen, who created it as a public service long before perl.org came about. Despite the name, it's a pretty non-commercial site meant to be a clearinghouse for information about all things Perlian, accepting no paid advertisements, bouncy happy gifs, or silly java applets on its pages. The Perl Home Page at http://www.perl.com/ is currently hosted on a T3 line courtesy of Songline Systems, a software-oriented subsidiary of O'Reilly and Associates. +Other starting points include -perl.org is the official vehicle for The Perl Institute. The motto of -TPI is "helping people help Perl help people" (or something like -that). It's a non-profit organization supporting development, -documentation, and dissemination of perl. - -=head2 How do I learn about object-oriented Perl programming? - -L<perltoot> (distributed with 5.004 or later) is a good place to start. -Also, L<perlobj>, L<perlref>, and L<perlmod> are useful references, -while L<perlbot> has some excellent tips and tricks. + http://language.perl.com/ + http://conference.perl.com/ + http://reference.perl.com/ =head1 AUTHOR AND COPYRIGHT -Copyright (c) 1997, 1998 Tom Christiansen and Nathan Torkington. +Copyright (c) 1997-1999 Tom Christiansen and Nathan Torkington. All rights reserved. When included as an integrated part of the Standard Distribution -of Perl or of its documentation (printed or otherwise), this works is +of Perl or of its documentation (printed or otherwise), this work is covered under Perl's Artistic Licence. For separate distributions of all or part of this FAQ outside of that, see L<perlfaq>. @@ -497,3 +456,4 @@ domain. You are permitted and encouraged to use this code and any derivatives thereof in your own programs for fun or for profit as you see fit. A simple comment in the code giving credit to the FAQ would be courteous but is not required. + diff --git a/contrib/perl5/pod/perlfaq3.pod b/contrib/perl5/pod/perlfaq3.pod index d06f2be..a811c3c 100644 --- a/contrib/perl5/pod/perlfaq3.pod +++ b/contrib/perl5/pod/perlfaq3.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq3 - Programming Tools ($Revision: 1.29 $, $Date: 1998/08/05 11:57:04 $) +perlfaq3 - Programming Tools ($Revision: 1.33 $, $Date: 1998/12/29 20:12:12 $) =head1 DESCRIPTION @@ -102,6 +102,10 @@ on your hardware, operating system, and the load on your machine): for: 4 secs ( 3.97 usr 0.01 sys = 3.98 cpu) map: 6 secs ( 4.97 usr 0.00 sys = 4.97 cpu) +Be aware that a good benchmark is very hard to write. It only tests the +data you give it, and really proves little about differing complexities +of contrasting algorithms. + =head2 How do I cross-reference my Perl programs? The B::Xref module, shipped with the new, alpha-release Perl compiler @@ -122,23 +126,57 @@ shouldn't need to reformat. The habit of formatting your code as you write it will help prevent bugs. Your editor can and should help you with this. The perl-mode for emacs can provide a remarkable amount of help with most (but not all) code, and even less programmable editors -can provide significant assistance. +can provide significant assistance. Tom swears by the following +settings in vi and its clones: + + set ai sw=4 + map ^O {^M}^[O^T -If you are used to using I<vgrind> program for printing out nice code +Now put that in your F<.exrc> file (replacing the caret characters +with control characters) and away you go. In insert mode, ^T is +for indenting, ^D is for undenting, and ^O is for blockdenting -- +as it were. If you haven't used the last one, you're missing +a lot. A more complete example, with comments, can be found at +http://www.perl.com/CPAN-local/authors/id/TOMC/scripts/toms.exrc.gz + +If you are used to using the I<vgrind> program for printing out nice code to a laser printer, you can take a stab at this using http://www.perl.com/CPAN/doc/misc/tips/working.vgrind.entry, but the results are not particularly satisfying for sophisticated code. -=head2 Is there a ctags for Perl? +The a2ps at http://www.infres.enst.fr/~demaille/a2ps/ does lots of things +related to generating nicely printed output of documents. + +=head2 Is there a etags/ctags for perl? -There's a simple one at +With respect to the source code for the Perl interpreter, yes. +There has been support for etags in the source for a long time. +Ctags was introduced in v5.005_54 (and probably 5.005_03). +After building perl, type 'make etags' or 'make ctags' and both +sets of tag files will be built. + +Now, if you're looking to build a tag file for perl code, then there's +a simple one at http://www.perl.com/CPAN/authors/id/TOMC/scripts/ptags.gz which may do -the trick. +the trick. And if not, it's easy to hack into what you want. + +=head2 Is there an IDE or Windows Perl Editor? + +If you're on Unix, you already have an IDE -- Unix itself. +You just have to learn the toolbox. If you're not, then you +probably don't have a toolbox, so may need something else. + +PerlBuilder (XXX URL to follow) is an integrated development +environment for Windows that supports Perl development. Perl programs +are just plain text, though, so you could download emacs for Windows +(XXX) or vim for win32 (http://www.cs.vu.nl/~tmgil/vi.html). If +you're transferring Windows files to Unix, be sure to transfer in +ASCII mode so the ends of lines are appropriately converted. =head2 Where can I get Perl macros for vi? For a complete version of Tom Christiansen's vi configuration file, -see http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/toms.exrc, +see http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/toms.exrc.gz, the standard benchmark file for vi emulators. This runs best with nvi, the current version of vi out of Berkeley, which incidentally can be built with an embedded Perl interpreter -- see http://www.perl.com/CPAN/src/misc. @@ -155,7 +193,7 @@ context-sensitive help, and other nifty things. Note that the perl-mode of emacs will have fits with C<"main'foo"> (single quote), and mess up the indentation and hilighting. You -should be using C<"main::foo"> in new Perl code anyway, so this +are probably using C<"main::foo"> in new Perl code anyway, so this shouldn't be an issue. =head2 How can I use curses with Perl? @@ -236,7 +274,7 @@ wasn't a good solution anyway. When it comes to time-space tradeoffs, Perl nearly always prefers to throw memory at a problem. Scalars in Perl use more memory than -strings in C, arrays take more that, and hashes use even more. While +strings in C, arrays take more than that, and hashes use even more. While there's still a lot to be done, recent releases have been addressing these issues. For example, as of 5.004, duplicate hash keys are shared amongst all hashes using them, so require no reallocation. @@ -278,10 +316,15 @@ No, Perl's garbage collection system takes care of this. You can't. On most operating systems, memory allocated to a program can never be returned to the system. That's why long-running programs -sometimes re-exec themselves. Some operating systems (notably, FreeBSD) -allegedly reclaim large chunks of memory that is no longer used, but -it doesn't appear to happen with Perl (yet). The Mac appears to be the -only platform that will reliably (albeit, slowly) return memory to the OS. +sometimes re-exec themselves. Some operating systems (notably, +FreeBSD and Linux) allegedly reclaim large chunks of memory that is no +longer used, but it doesn't appear to happen with Perl (yet). The Mac +appears to be the only platform that will reliably (albeit, slowly) +return memory to the OS. + +We've had reports that on Linux (Redhat 5.1) on Intel, C<undef +$scalar> will return memory to the system, while on Solaris 2.6 it +won't. In general, try it yourself and see. However, judicious use of my() on your variables will help make sure that they go out of scope so that Perl can free up their storage for @@ -314,8 +357,7 @@ the internal server API, so modules written in Perl can do just about anything a module written in C can. For more on mod_perl, see http://perl.apache.org/ -With the FCGI module (from CPAN), a Perl executable compiled with sfio -(see the F<INSTALL> file in the distribution) and the mod_fastcgi +With the FCGI module (from CPAN) and the mod_fastcgi module (available from http://www.fastcgi.com/) each of your perl scripts becomes a permanent CGI daemon process. @@ -325,8 +367,8 @@ care. See http://www.perl.com/CPAN/modules/by-category/15_World_Wide_Web_HTML_HTTP_CGI/ . -A non-free, commerical product, ``The Velocity Engine for Perl'', -(http://www.binevolve.com/ or http://www.binevolve.com/bine/vep) might +A non-free, commercial product, ``The Velocity Engine for Perl'', +(http://www.binevolve.com/ or also be worth looking at. It will allow you to increase the performance of your perl scripts, upto 25 times faster than normal CGI perl by running in persistent perl mode, or 4 to 5 times faster without any @@ -353,12 +395,12 @@ source. Security through obscurity, the name for hiding your bugs instead of fixing them, is little security indeed. You can try using encryption via source filters (Filter::* from CPAN), -but crackers might be able to decrypt it. You can try using the byte -code compiler and interpreter described below, but crackers might be -able to de-compile it. You can try using the native-code compiler -described below, but crackers might be able to disassemble it. These -pose varying degrees of difficulty to people wanting to get at your -code, but none can definitively conceal it (this is true of every +but any decent programmer will be able to decrypt it. You can try using +the byte code compiler and interpreter described below, but the curious +might still be able to de-compile it. You can try using the native-code +compiler described below, but crackers might be able to disassemble it. +These pose varying degrees of difficulty to people wanting to get at +your code, but none can definitively conceal it (this is true of every language, not just Perl). If you're concerned about people profiting from your code, then the @@ -407,6 +449,14 @@ packaging, and once you see the size of what it makes (well, unless you use a shared I<libperl.so>), you'll probably want a complete Perl install anyway. +=head2 How can I compile Perl into Java? + +You can't. Not yet, anyway. You can integrate Java and Perl with the +Perl Resource Kit from O'Reilly and Associates. See +http://www.oreilly.com/catalog/prkunix/ for more information. +The Java interface will be supported in the core 5.006 release +of Perl. + =head2 How can I get C<#!perl> to work on [MS-DOS,NT,...]? For OS/2 just use @@ -420,12 +470,15 @@ F<INSTALL> file in the source distribution for more information). 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 (Gurusaramy Sarathy's -is the recommended Win95/NT port), or (eventually) build your own -Win95/NT Perl using WinGCC, then you'll have to modify the Registry -yourself. - -Macintosh perl scripts will have the the appropriate Creator and +perl interpreter. If you install another port (Gurusamy Sarathy's is +the recommended Win95/NT port), or (eventually) build your own +Win95/NT Perl using a Windows port of gcc (e.g., with cygwin32 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>. + +Macintosh perl scripts will have the appropriate Creator and Type, so that double-clicking them will invoke the perl application. I<IMPORTANT!>: Whatever you do, PLEASE don't get frustrated, and just @@ -494,6 +547,9 @@ shell, or MPW, is much like Unix shells in its support for several quoting variants, except that it makes free use of the Mac's non-ASCII characters as control characters. +Using qq(), q(), and qx(), instead of "double quotes", 'single +quotes', and `backticks`, may make one-liners easier to write. + There is no general solution to all of this. It is a mess, pure and simple. Sucks to be away from Unix, huh? :-) @@ -514,7 +570,7 @@ when it runs fine on the command line'', see these sources: http://www.boutell.com/faq/ CGI FAQ - http://www.webthing.com/page.cgi/cgifaq + http://www.webthing.com/tutorials/cgifaq.html HTTP Spec http://www.w3.org/pub/WWW/Protocols/HTTP/ @@ -529,6 +585,7 @@ when it runs fine on the command line'', see these sources: CGI Security FAQ http://www.go2net.com/people/paulp/cgi-security/safe-cgi.txt +Also take a look at L<perlfaq9> =head2 Where can I learn about object-oriented Perl programming? @@ -580,11 +637,11 @@ information, see L<ExtUtils::MakeMaker>. =head1 AUTHOR AND COPYRIGHT -Copyright (c) 1997, 1998 Tom Christiansen and Nathan Torkington. +Copyright (c) 1997-1999 Tom Christiansen and Nathan Torkington. All rights reserved. When included as an integrated part of the Standard Distribution -of Perl or of its documentation (printed or otherwise), this works is +of Perl or of its documentation (printed or otherwise), this work is covered under Perl's Artistic Licence. For separate distributions of all or part of this FAQ outside of that, see L<perlfaq>. @@ -593,3 +650,4 @@ domain. You are permitted and encouraged to use this code and any derivatives thereof in your own programs for fun or for profit as you see fit. A simple comment in the code giving credit to the FAQ would be courteous but is not required. + diff --git a/contrib/perl5/pod/perlfaq4.pod b/contrib/perl5/pod/perlfaq4.pod index 633f5f1..92aee2c 100644 --- a/contrib/perl5/pod/perlfaq4.pod +++ b/contrib/perl5/pod/perlfaq4.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq4 - Data Manipulation ($Revision: 1.26 $, $Date: 1998/08/05 12:04:00 $) +perlfaq4 - Data Manipulation ($Revision: 1.40 $, $Date: 1999/01/08 04:26:39 $) =head1 DESCRIPTION @@ -41,7 +41,7 @@ are consequently slower. To get rid of the superfluous digits, just use a format (eg, C<printf("%.2f", 19.95)>) to get the required precision. -See L<perlop/"Floating-point Arithmetic">. +See L<perlop/"Floating-point Arithmetic">. =head2 Why isn't my octal data interpreted correctly? @@ -59,7 +59,7 @@ umask(), or sysopen(), which all want permissions in octal. chmod(644, $file); # WRONG -- perl -w catches this chmod(0644, $file); # right -=head2 Does perl have a round function? What about ceil() and floor()? Trig functions? +=head2 Does Perl have a round() function? What about ceil() and floor()? Trig functions? Remember that int() merely truncates toward 0. For rounding to a certain number of digits, sprintf() or printf() is usually the easiest @@ -88,6 +88,19 @@ cases, it probably pays not to trust whichever system rounding is being used by Perl, but to instead implement the rounding function you need yourself. +To see why, notice how you'll still have an issue on half-way-point +alternation: + + for ($i = 0; $i < 1.01; $i += 0.05) { printf "%.1f ",$i} + + 0.0 0.1 0.1 0.2 0.2 0.2 0.3 0.3 0.4 0.4 0.5 0.5 0.6 0.7 0.7 + 0.8 0.8 0.9 0.9 1.0 1.0 + +Don't blame Perl. It's the same as in C. IEEE says we have to do this. +Perl numbers whose absolute values are integers under 2**31 (on 32 bit +machines) will work pretty much like mathematical integers. Other numbers +are not guaranteed. + =head2 How do I convert bits into ints? To turn a string of 1s and 0s like C<10110110> into a scalar containing @@ -100,6 +113,33 @@ Here's an example of going the other way: $binary_string = join('', unpack('B*', "\x29")); +=head2 Why doesn't & work the way I want it to? + +The behavior of binary arithmetic operators depends on whether they're +used on numbers or strings. The operators treat a string as a series +of bits and work with that (the string C<"3"> is the bit pattern +C<00110011>). The operators work with the binary form of a number +(the number C<3> is treated as the bit pattern C<00000011>). + +So, saying C<11 & 3> performs the "and" operation on numbers (yielding +C<1>). Saying C<"11" & "3"> performs the "and" operation on strings +(yielding C<"1">). + +Most problems with C<&> and C<|> arise because the programmer thinks +they have a number but really it's a string. The rest arise because +the programmer says: + + if ("\020\020" & "\101\101") { + # ... + } + +but a string consisting of two null bytes (the result of C<"\020\020" +& "\101\101">) is not a false value in Perl. You need: + + if ( ("\020\020" & "\101\101") !~ /[^\000]/) { + # ... + } + =head2 How do I multiply matrices? Use the Math::Matrix or Math::MatrixReal modules (available from CPAN) @@ -120,12 +160,12 @@ To call a function on each element of an array, but ignore the results: foreach $iterator (@array) { - &my_func($iterator); + some_func($iterator); } To call a function on each integer in a (small) range, you B<can> use: - @results = map { &my_func($_) } (5 .. 25); + @results = map { some_func($_) } (5 .. 25); but you should be aware that the C<..> operator creates an array of all integers in the range. This can take a lot of memory for large @@ -133,7 +173,7 @@ ranges. Instead use: @results = (); for ($i=5; $i < 500_005; $i++) { - push(@results, &my_func($i)); + push(@results, some_func($i)); } =head2 How can I output Roman numerals? @@ -142,20 +182,25 @@ Get the http://www.perl.com/CPAN/modules/by-module/Roman module. =head2 Why aren't my random numbers random? -The short explanation is that you're getting pseudorandom numbers, not -random ones, because computers are good at being predictable and bad -at being random (despite appearances caused by bugs in your programs -:-). A longer explanation is available on -http://www.perl.com/CPAN/doc/FMTEYEWTK/random, courtesy of Tom -Phoenix. John von Neumann said, ``Anyone who attempts to generate -random numbers by deterministic means is, of course, living in a state -of sin.'' +If you're using a version of Perl before 5.004, you must call C<srand> +once at the start of your program to seed the random number generator. +5.004 and later automatically call C<srand> at the beginning. Don't +call C<srand> more than once--you make your numbers less random, rather +than more. -You should also check out the Math::TrulyRandom module from CPAN. It -uses the imperfections in your system's timer to generate random -numbers, but this takes quite a while. If you want a better +Computers are good at being predictable and bad at being random +(despite appearances caused by bugs in your programs :-). +http://www.perl.com/CPAN/doc/FMTEYEWTK/random, courtesy of Tom +Phoenix, talks more about this.. John von Neumann said, ``Anyone who +attempts to generate random numbers by deterministic means is, of +course, living in a state of sin.'' + +If you want numbers that are more random than C<rand> with C<srand> +provides, you should also check out the Math::TrulyRandom module from +CPAN. It uses the imperfections in your system's timer to generate +random numbers, but this takes quite a while. If you want a better pseudorandom generator than comes with your operating system, look at -``Numerical Recipes in C'' at http://nr.harvard.edu/nr/bookc.html . +``Numerical Recipes in C'' at http://www.nr.com/ . =head1 Data: Dates @@ -178,10 +223,10 @@ You can find the week of the year by dividing this by 7: Of course, this believes that weeks start at zero. The Date::Calc module from CPAN has a lot of date calculation functions, including day of the year, week of the year, and so on. Note that not -all business consider ``week 1'' to be the same; for example, -American business often consider the first week with a Monday -in it to be Work Week #1, despite ISO 8601, which consider -WW1 to be the frist week with a Thursday in it. +all businesses consider ``week 1'' to be the same; for example, +American businesses often consider the first week with a Monday +in it to be Work Week #1, despite ISO 8601, which considers +WW1 to be the first week with a Thursday in it. =head2 How can I compare two dates and find the difference? @@ -201,23 +246,38 @@ and Date::Manip modules from CPAN. Neither Date::Manip nor Date::Calc deal with Julian days. Instead, there is an example of Julian date calculation that should help you in -http://www.perl.com/CPAN/authors/David_Muir_Sharnoff/modules/Time/JulianDay.pm.gz -. +Time::JulianDay (part of the Time-modules bundle) which can be found at +http://www.perl.com/CPAN/modules/by-module/Time/. + + +=head2 How do I find yesterday's date? + +The C<time()> function returns the current time in seconds since the +epoch. Take one day off that: + + $yesterday = time() - ( 24 * 60 * 60 ); + +Then you can pass this to C<localtime()> and get the individual year, +month, day, hour, minute, seconds values. =head2 Does Perl have a year 2000 problem? Is Perl Y2K compliant? -Short answer: No, Perl does not have a Year 2000 problem. Yes, -Perl is Y2K compliant. The programmers you're hired to use it, -however, probably are not. +Short answer: No, Perl does not have a Year 2000 problem. Yes, Perl is +Y2K compliant (whatever that means). The programmers you've hired to +use it, however, probably are not. + +Long answer: The question belies a true understanding of the issue. +Perl is just as Y2K compliant as your pencil--no more, and no less. +Can you use your pencil to write a non-Y2K-compliant memo? Of course +you can. Is that the pencil's fault? Of course it isn't. -Long answer: Perl is just as Y2K compliant as your pencil--no more, -and no less. The date and time functions supplied with perl (gmtime -and localtime) supply adequate information to determine the year well -beyond 2000 (2038 is when trouble strikes for 32-bit machines). The -year returned by these functions when used in an array context is the -year minus 1900. For years between 1910 and 1999 this I<happens> to -be a 2-digit decimal number. To avoid the year 2000 problem simply do -not treat the year as a 2-digit number. It isn't. +The date and time functions supplied with perl (gmtime and localtime) +supply adequate information to determine the year well beyond 2000 +(2038 is when trouble strikes for 32-bit machines). The year returned +by these functions when used in an array context is the year minus 1900. +For years between 1910 and 1999 this I<happens> to be a 2-digit decimal +number. To avoid the year 2000 problem simply do not treat the year as +a 2-digit number. It isn't. When gmtime() and localtime() are used in scalar context they return a timestamp string that contains a fully-expanded year. For example, @@ -286,8 +346,9 @@ parser. If you are serious about writing a parser, there are a number of modules or oddities that will make your life a lot easier. There is the CPAN module Parse::RecDescent, the standard module Text::Balanced, -the byacc program, and Mark-Jason Dominus's excellent I<py> tool at -http://www.plover.com/~mjd/perl/py/ . +the byacc program, the CPAN module Parse::Yapp, and Mark-Jason +Dominus's excellent I<py> tool at http://www.plover.com/~mjd/perl/py/ +. One simple destructive, inside-out approach that you might try is to pull out the smallest nesting parts one at a time: @@ -296,6 +357,21 @@ pull out the smallest nesting parts one at a time: # do something with $1 } +A more complicated and sneaky approach is to make Perl's regular +expression engine do it for you. This is courtesy Dean Inada, and +rather has the nature of an Obfuscated Perl Contest entry, but it +really does work: + + # $_ contains the string to parse + # BEGIN and END are the opening and closing markers for the + # nested text. + + @( = ('(',''); + @) = (')',''); + ($re=$_)=~s/((BEGIN)|(END)|.)/$)[!$3]\Q$1\E$([!$2]/gs; + @$ = (eval{/$re/},$@!~/unmatched/); + print join("\n",@$[0..$#$]) if( $$[-1] ); + =head2 How do I reverse a string? Use reverse() in scalar context, as documented in @@ -378,7 +454,7 @@ There are a number of ways, with varying efficiency: If you want a count of a certain single character (X) within a string, you can use the C<tr///> function like so: - $string = "ThisXlineXhasXsomeXx'sXinXit": + $string = "ThisXlineXhasXsomeXx'sXinXit"; $count = ($string =~ tr/X//); print "There are $count X charcters in the string"; @@ -422,6 +498,11 @@ You can (and probably should) enable locale awareness of those characters by placing a C<use locale> pragma in your program. See L<perllocale> for endless details on locales. +This is sometimes referred to as putting something into "title +case", but that's not quite accurate. Consdier the proper +capitalization of the movie I<Dr. Strangelove or: How I Learned to +Stop Worrying and Love the Bomb>, for example. + =head2 How can I split a [character] delimited string except when inside [character]? (Comma-separated files) @@ -457,13 +538,15 @@ distribution) lets you say: use Text::ParseWords; @new = quotewords(",", 0, $text); +There's also a Text::CSV module on CPAN. + =head2 How do I strip blank space from the beginning/end of a string? Although the simplest approach would seem to be: $string =~ s/^\s*(.*?)\s*$/$1/; -This is unneccesarily slow, destructive, and fails with embedded newlines. +This is unnecessarily slow, destructive, and fails with embedded newlines. It is much better faster to do this in two steps: $string =~ s/^\s+//; @@ -488,6 +571,44 @@ values of a hash if you use a slide: s/\s+$//; } +=head2 How do I pad a string with blanks or pad a number with zeroes? + +(This answer contributed by Uri Guttman) + +In the following examples, C<$pad_len> is the length to which you wish +to pad the string, C<$text> or C<$num> contains the string to be +padded, and C<$pad_char> contains the padding character. You can use a +single character string constant instead of the C<$pad_char> variable +if you know what it is in advance. + +The simplest method use the C<sprintf> function. It can pad on the +left or right with blanks and on the left with zeroes. + + # Left padding with blank: + $padded = sprintf( "%${pad_len}s", $text ) ; + + # Right padding with blank: + $padded = sprintf( "%${pad_len}s", $text ) ; + + # Left padding with 0: + $padded = sprintf( "%0${pad_len}d", $num ) ; + +If you need to pad with a character other than blank or zero you can use +one of the following methods. + +These methods generate a pad string with the C<x> operator and +concatenate that with the original text. + +Left and right padding with any character: + + $padded = $pad_char x ( $pad_len - length( $text ) ) . $text ; + $padded = $text . $pad_char x ( $pad_len - length( $text ) ) ; + +Or you can left or right pad $text directly: + + $text .= $pad_char x ( $pad_len - length( $text ) ) ; + substr( $text, 0, 0 ) = $pad_char x ( $pad_len - length( $text ) ) ; + =head2 How do I extract selected columns from a string? Use substr() or unpack(), both documented in L<perlfunc>. @@ -523,13 +644,13 @@ Let's assume that you have a string like: If those were both global variables, then this would suffice: - $text =~ s/\$(\w+)/${$1}/g; + $text =~ s/\$(\w+)/${$1}/g; # no /e needed But since they are probably lexicals, or at least, they could be, you'd have to do this: $text =~ s/(\$\w+)/$1/eeg; - die if $@; # needed on /ee, not /e + die if $@; # needed /ee, not /e It's probably better in the general case to treat those variables as entries in some special hash. For example: @@ -547,7 +668,9 @@ of the FAQ. The problem is that those double-quotes force stringification, coercing numbers and references into strings, even when you -don't want them to be. +don't want them to be. Think of it this way: double-quote +expansion is used to produce new strings. If you already +have a string, why do you need more? If you get used to writing odd things like these: @@ -583,7 +706,7 @@ Stringification also destroys arrays. print "@lines"; # WRONG - extra blanks print @lines; # right -=head2 Why don't my <<HERE documents work? +=head2 Why don't my E<lt>E<lt>HERE documents work? Check for these three things: @@ -665,6 +788,27 @@ indentation correctly preserved: =head1 Data: Arrays +=head2 What is the difference between a list and an array? + +An array has a changeable length. A list does not. An array is something +you can push or pop, while a list is a set of values. Some people make +the distinction that a list is a value while an array is a variable. +Subroutines are passed and return lists, you put things into list +context, you initialize arrays with lists, and you foreach() across +a list. C<@> variables are arrays, anonymous arrays are arrays, arrays +in scalar context behave like the number of elements in them, subroutines +access their arguments through the array C<@_>, push/pop/shift only work +on arrays. + +As a side note, there's no such thing as a list in scalar context. +When you say + + $scalar = (2, 5, 7, 9); + +you're using the comma operator in scalar context, so it evaluates the +left hand side, then evaluates and returns the left hand side. This +causes the last value to be returned: 9. + =head2 What is the difference between $array[1] and @array[1]? The former is a scalar value, the latter an array slice, which makes @@ -724,6 +868,8 @@ nice in that it won't work with false values like undef, 0, or ""; =back +But perhaps you should have been using a hash all along, eh? + =head2 How can I tell whether a list or array contains a certain element? Hearing the word "in" is an I<in>dication that you probably should have @@ -770,7 +916,17 @@ or worse yet These are slow (checks every element even if the first matches), inefficient (same reason), and potentially buggy (what if there are -regexp characters in $whatever?). +regexp characters in $whatever?). If you're only testing once, then +use: + + $is_there = 0; + foreach $elt (@array) { + if ($elt eq $elt_to_find) { + $is_there = 1; + last; + } + } + if ($is_there) { ... } =head2 How do I compute the difference of two arrays? How do I compute the intersection of two arrays? @@ -785,11 +941,60 @@ each element is unique in a given array: push @{ $count{$element} > 1 ? \@intersection : \@difference }, $element; } +=head2 How do I test whether two arrays or hashes are equal? + +The following code works for single-level arrays. It uses a stringwise +comparison, and does not distinguish defined versus undefined empty +strings. Modify if you have other needs. + + $are_equal = compare_arrays(\@frogs, \@toads); + + sub compare_arrays { + my ($first, $second) = @_; + local $^W = 0; # silence spurious -w undef complaints + return 0 unless @$first == @$second; + for (my $i = 0; $i < @$first; $i++) { + return 0 if $first->[$i] ne $second->[$i]; + } + return 1; + } + +For multilevel structures, you may wish to use an approach more +like this one. It uses the CPAN module FreezeThaw: + + use FreezeThaw qw(cmpStr); + @a = @b = ( "this", "that", [ "more", "stuff" ] ); + + printf "a and b contain %s arrays\n", + cmpStr(\@a, \@b) == 0 + ? "the same" + : "different"; + +This approach also works for comparing hashes. Here +we'll demonstrate two different answers: + + use FreezeThaw qw(cmpStr cmpStrHard); + + %a = %b = ( "this" => "that", "extra" => [ "more", "stuff" ] ); + $a{EXTRA} = \%b; + $b{EXTRA} = \%a; + + printf "a and b contain %s hashes\n", + cmpStr(\%a, \%b) == 0 ? "the same" : "different"; + + printf "a and b contain %s hashes\n", + cmpStrHard(\%a, \%b) == 0 ? "the same" : "different"; + + +The first reports that both those the hashes contain the same data, +while the second reports that they do not. Which you prefer is left as +an exercise to the reader. + =head2 How do I find the first array element for which a condition is true? You can use this if you care about the index: - for ($i=0; $i < @array; $i++) { + for ($i= 0; $i < @array; $i++) { if ($array[$i] eq "Waldo") { $found_index = $i; last; @@ -810,7 +1015,42 @@ need to copy pointers each time. If you really, really wanted, you could use structures as described in L<perldsc> or L<perltoot> and do just what the algorithm book tells you -to do. +to do. For example, imagine a list node like this: + + $node = { + VALUE => 42, + LINK => undef, + }; + +You could walk the list this way: + + print "List: "; + for ($node = $head; $node; $node = $node->{LINK}) { + print $node->{VALUE}, " "; + } + print "\n"; + +You could grow the list this way: + + my ($head, $tail); + $tail = append($head, 1); # grow a new head + for $value ( 2 .. 10 ) { + $tail = append($tail, $value); + } + + sub append { + my($list, $value) = @_; + my $node = { VALUE => $value }; + if ($list) { + $node->{LINK} = $list->{LINK}; + $list->{LINK} = $node; + } else { + $_[0] = $node; # replace caller's version + } + return $node; + } + +But again, Perl's built-in are virtually always good enough. =head2 How do I handle circular lists? @@ -1006,9 +1246,54 @@ get those bits into your @ints array: This method gets faster the more sparse the bit vector is. (Courtesy of Tim Bunce and Winfried Koenig.) +Here's a demo on how to use vec(): + + # vec demo + $vector = "\xff\x0f\xef\xfe"; + print "Ilya's string \\xff\\x0f\\xef\\xfe represents the number ", + unpack("N", $vector), "\n"; + $is_set = vec($vector, 23, 1); + print "Its 23rd bit is ", $is_set ? "set" : "clear", ".\n"; + pvec($vector); + + set_vec(1,1,1); + set_vec(3,1,1); + set_vec(23,1,1); + + set_vec(3,1,3); + set_vec(3,2,3); + set_vec(3,4,3); + set_vec(3,4,7); + set_vec(3,8,3); + set_vec(3,8,7); + + set_vec(0,32,17); + set_vec(1,32,17); + + sub set_vec { + my ($offset, $width, $value) = @_; + my $vector = ''; + vec($vector, $offset, $width) = $value; + print "offset=$offset width=$width value=$value\n"; + pvec($vector); + } + + sub pvec { + my $vector = shift; + my $bits = unpack("b*", $vector); + my $i = 0; + my $BASE = 8; + + print "vector length in bytes: ", length($vector), "\n"; + @bytes = unpack("A8" x length($vector), $bits); + print "bits are: @bytes\n\n"; + } + =head2 Why does defined() return true on empty arrays and hashes? -See L<perlfunc/defined> in the 5.004 release or later of Perl. +The short story is that you should probably only use defined on scalars or +functions, not on aggregates (arrays and hashes). See L<perlfunc/defined> +in the 5.004 release or later of Perl for more detail. =head1 Data: Hashes (Associative Arrays) @@ -1243,9 +1528,21 @@ awk's behavior. =head2 How can I make the Perl equivalent of a C structure/C++ class/hash or array of hashes or arrays? -Use references (documented in L<perlref>). Examples of complex data -structures are given in L<perldsc> and L<perllol>. Examples of -structures and object-oriented classes are in L<perltoot>. +Usually a hash ref, perhaps like this: + + $record = { + NAME => "Jason", + EMPNO => 132, + TITLE => "deputy peon", + AGE => 23, + SALARY => 37_000, + PALS => [ "Norbert", "Rhys", "Phineas"], + }; + +References are documented in L<perlref> and the upcoming L<perlreftut>. +Examples of complex data structures are given in L<perldsc> and +L<perllol>. Examples of structures and object-oriented classes are +in L<perltoot>. =head2 How can I use a reference as a hash key? @@ -1263,8 +1560,9 @@ this works fine (assuming the files are found): print "Your kernel is GNU-zip enabled!\n"; } -On some systems, however, you have to play tedious games with "text" -versus "binary" files. See L<perlfunc/"binmode">. +On some legacy systems, however, you have to play tedious games with +"text" versus "binary" files. See L<perlfunc/"binmode">, or the upcoming +L<perlopentut> manpage. If you're concerned about 8-bit ASCII data, then see L<perllocale>. @@ -1276,14 +1574,14 @@ some gotchas. See the section on Regular Expressions. Assuming that you don't care about IEEE notations like "NaN" or "Infinity", you probably just want to use a regular expression. - warn "has nondigits" if /\D/; - warn "not a natural number" unless /^\d+$/; # rejects -3 - warn "not an integer" unless /^-?\d+$/; # rejects +3 - warn "not an integer" unless /^[+-]?\d+$/; - warn "not a decimal number" unless /^-?\d+\.?\d*$/; # rejects .2 - warn "not a decimal number" unless /^-?(?:\d+(?:\.\d*)?|\.\d+)$/; - warn "not a C float" - unless /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/; + if (/\D/) { print "has nondigits\n" } + if (/^\d+$/) { print "is a whole number\n" } + if (/^-?\d+$/) { print "is an integer\n" } + if (/^[+-]?\d+$/) { print "is a +/- integer\n" } + if (/^-?\d+\.?\d*$/) { print "is a real number\n" } + if (/^-?(?:\d+(?:\.\d*)?|\.\d+)$/) { print "is a decimal number" } + if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) + { print "a C float" } If you're on a POSIX system, Perl's supports the C<POSIX::strtod> function. Its semantics are somewhat cumbersome, so here's a C<getnum> @@ -1308,28 +1606,41 @@ if you just want to say, ``Is this a float?'' sub is_numeric { defined &getnum } -Or you could check out -http://www.perl.com/CPAN/modules/by-module/String/String-Scanf-1.1.tar.gz -instead. The POSIX module (part of the standard Perl distribution) -provides the C<strtol> and C<strtod> for converting strings to double +Or you could check out String::Scanf which can be found at +http://www.perl.com/CPAN/modules/by-module/String/. +The POSIX module (part of the standard Perl distribution) provides +the C<strtol> and C<strtod> for converting strings to double and longs, respectively. =head2 How do I keep persistent data across program calls? For some specific applications, you can use one of the DBM modules. -See L<AnyDBM_File>. More generically, you should consult the -FreezeThaw, Storable, or Class::Eroot modules from CPAN. +See L<AnyDBM_File>. More generically, you should consult the FreezeThaw, +Storable, or Class::Eroot modules from CPAN. Here's one example using +Storable's C<store> and C<retrieve> functions: + + use Storable; + store(\%hash, "filename"); + + # later on... + $href = retrieve("filename"); # by ref + %hash = %{ retrieve("filename") }; # direct to hash =head2 How do I print out or copy a recursive data structure? -The Data::Dumper module on CPAN is nice for printing out -data structures, and FreezeThaw for copying them. For example: +The Data::Dumper module on CPAN (or the 5.005 release of Perl) is great +for printing out data structures. The Storable module, found on CPAN, +provides a function called C<dclone> that recursively copies its argument. + + use Storable qw(dclone); + $r2 = dclone($r1); - use FreezeThaw qw(freeze thaw); - $new = thaw freeze $old; +Where $r1 can be a reference to any kind of data structure you'd like. +It will be deeply copied. Because C<dclone> takes and returns references, +you'd have to add extra punctuation if you had a hash of arrays that +you wanted to copy. -Where $old can be (a reference to) any kind of data structure you'd like. -It will be deeply copied. + %newhash = %{ dclone(\%oldhash) }; =head2 How do I define methods for every class/object? @@ -1339,14 +1650,20 @@ Use the UNIVERSAL class (see L<UNIVERSAL>). Get the Business::CreditCard module from CPAN. +=head2 How do I pack arrays of doubles or floats for XS code? + +The kgbpack.c code in the PGPLOT module on CPAN does just this. +If you're doing a lot of float or double processing, consider using +the PDL module from CPAN instead--it makes number-crunching easy. + =head1 AUTHOR AND COPYRIGHT -Copyright (c) 1997, 1998 Tom Christiansen and Nathan Torkington. +Copyright (c) 1997-1999 Tom Christiansen and Nathan Torkington. All rights reserved. When included as part of the Standard Version of Perl, or as part of its complete documentation whether printed or otherwise, this work -may be distributed only under the terms of Perl's Artistic License. +may be distributed only under the terms of Perl's Artistic Licence. Any distribution of this file or derivatives thereof I<outside> of that package require that special arrangements be made with copyright holder. @@ -1356,3 +1673,4 @@ are hereby placed into the public domain. You are permitted and encouraged to use this code in your own programs for fun or for profit as you see fit. A simple comment in the code giving credit would be courteous but is not required. + diff --git a/contrib/perl5/pod/perlfaq5.pod b/contrib/perl5/pod/perlfaq5.pod index 98e706a..99c25b7 100644 --- a/contrib/perl5/pod/perlfaq5.pod +++ b/contrib/perl5/pod/perlfaq5.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq5 - Files and Formats ($Revision: 1.24 $, $Date: 1998/07/05 15:07:20 $) +perlfaq5 - Files and Formats ($Revision: 1.34 $, $Date: 1999/01/08 05:46:13 $) =head1 DESCRIPTION @@ -78,12 +78,15 @@ See L<perlfaq9> for other examples of fetching URLs over the web. =head2 How do I change one line in a file/delete a line in a file/insert a line in the middle of a file/append to the beginning of a file? +Those are operations of a text editor. Perl is not a text editor. +Perl is a programming language. You have to decompose the problem into +low-level calls to read, write, open, close, and seek. + Although humans have an easy time thinking of a text file as being a -sequence of lines that operates much like a stack of playing cards -- -or punch cards -- computers usually see the text file as a sequence of -bytes. In general, there's no direct way for Perl to seek to a -particular line of a file, insert text into a file, or remove text -from a file. +sequence of lines that operates much like a stack of playing cards -- or +punch cards -- computers usually see the text file as a sequence of bytes. +In general, there's no direct way for Perl to seek to a particular line +of a file, insert text into a file, or remove text from a file. (There are exceptions in special circumstances. You can add or remove at the very end of the file. Another is replacing a sequence of bytes with @@ -97,7 +100,7 @@ no locking. $old = $file; $new = "$file.tmp.$$"; - $bak = "$file.bak"; + $bak = "$file.orig"; open(OLD, "< $old") or die "can't open $old: $!"; open(NEW, "> $new") or die "can't open $new: $!"; @@ -124,7 +127,7 @@ platform-specific documentation that came with your port. perl -pi -e 's/(^\s+test\s+)\d+/ $1 . ++$count /e' t/op/taint.t # form a script - local($^I, @ARGV) = ('.bak', glob("*.c")); + local($^I, @ARGV) = ('.orig', glob("*.c")); while (<>) { if ($. == 1) { print "This line should appear at the top of each file\n"; @@ -174,9 +177,9 @@ Use the C<new_tmpfile> class method from the IO::File module to get a filehandle opened for reading and writing. Use this if you don't need to know the file's name. - use IO::File; + use IO::File; $fh = IO::File->new_tmpfile() - or die "Unable to make new temporary file: $!"; + or die "Unable to make new temporary file: $!"; Or you can use the C<tmpnam> function from the POSIX module to get a filename that you then open yourself. Use this if you do need to know @@ -222,7 +225,7 @@ one process, use a counter: =head2 How can I manipulate fixed-record-length files? The most efficient way is using pack() and unpack(). This is faster than -using substr() when take many, many strings. It is slower for just a few. +using substr() when taking many, many strings. It is slower for just a few. Here is a sample chunk of code to break up and put back together again some fixed-format input lines, in this case from the output of a normal, @@ -289,10 +292,10 @@ pair to make it easy to sort the hash in insertion order. } For passing filehandles to functions, the easiest way is to -prefer them with a star, as in func(*STDIN). See L<perlfaq7/"Passing +preface them with a star, as in func(*STDIN). See L<perlfaq7/"Passing Filehandles"> for details. -If you want to create many, anonymous handles, you should check out the +If you want to create many anonymous handles, you should check out the Symbol, FileHandle, or IO::Handle (etc.) modules. Here's the equivalent code with Symbol::gensym, which is reasonably light-weight: @@ -303,8 +306,8 @@ code with Symbol::gensym, which is reasonably light-weight: $file{$filename} = [ $i++, $fh ]; } -Or here using the semi-object-oriented FileHandle, which certainly isn't -light-weight: +Or here using the semi-object-oriented FileHandle module, which certainly +isn't light-weight: use FileHandle; @@ -343,7 +346,7 @@ and use it as though it were a normal filehandle. Then use any of those as you would a normal filehandle. Anywhere that Perl is expecting a filehandle, an indirect filehandle may be used instead. An indirect filehandle is just a scalar variable that contains -a filehandle. Functions like C<print>, C<open>, C<seek>, or the functions or +a filehandle. Functions like C<print>, C<open>, C<seek>, or the C<E<lt>FHE<gt>> diamond operator will accept either a read filehandle or a scalar variable containing one: @@ -352,7 +355,7 @@ or a scalar variable containing one: $got = <$ifh> print $efh "What was that: $got"; -Of you're passing a filehandle to a function, you can write +If you're passing a filehandle to a function, you can write the function in two ways: sub accept_fh { @@ -422,7 +425,7 @@ techniques to make it possible for the intrepid hacker. =head2 How can I write() into a string? -See L<perlform> for an swrite() function. +See L<perlform/"Accessing Formatting Internals"> for an swrite() function. =head2 How can I output my numbers with commas added? @@ -430,7 +433,7 @@ This one will do it for you: sub commify { local $_ = shift; - 1 while s/^(-?\d+)(\d{3})/$1,$2/; + 1 while s/^([-+]?\d+)(\d{3})/$1,$2/; return $_; } @@ -441,7 +444,7 @@ This one will do it for you: You can't just: - s/^(-?\d+)(\d{3})/$1,$2/g; + s/^([-+]?\d+)(\d{3})/$1,$2/g; because you have to put the comma in and then recalculate your position. @@ -455,7 +458,7 @@ whatever: my $input = shift; $input = reverse $input; $input =~ s<(\d\d\d)(?=\d)(?!\d*\.)><$1,>g; - return reverse $input; + return scalar reverse $input; } =head2 How can I translate tildes (~) in a filename? @@ -547,7 +550,9 @@ be an atomic operation over NFS. That is, two processes might both successful create or unlink the same file! Therefore O_EXCL isn't so exclusive as you might wish. -=head2 Why do I sometimes get an "Argument list too long" when I use <*>? +See also the new L<perlopentut> if you have it (new for 5.006). + +=head2 Why do I sometimes get an "Argument list too long" when I use E<lt>*E<gt>? The C<E<lt>E<gt>> operator performs a globbing operation (see above). By default glob() forks csh(1) to do the actual glob expansion, but @@ -555,9 +560,9 @@ csh can't handle more than 127 items and so gives the error message C<Argument list too long>. People who installed tcsh as csh won't have this problem, but their users may be surprised by it. -To get around this, either do the glob yourself with C<Dirhandle>s and +To get around this, either do the glob yourself with readdir() and patterns, or use a module like Glob::KGlob, one that doesn't use the -shell to do globbing. +shell to do globbing. This is expected to be fixed soon. =head2 Is there a leak/bug in glob()? @@ -576,15 +581,28 @@ trailing null byte on the name to make perl leave it alone: sub safe_filename { local $_ = shift; - return m#^/# - ? "$_\0" - : "./$_\0"; + s#^([^./])#./$1#; + $_ .= "\0"; + return $_; } - $fn = safe_filename("<<<something really wicked "); - open(FH, "> $fn") or "couldn't open $fn: $!"; + $badpath = "<<<something really wicked "; + $fn = safe_filename($badpath"); + open(FH, "> $fn") or "couldn't open $badpath: $!"; + +This assumes that you are using POSIX (portable operating systems +interface) paths. If you are on a closed, non-portable, proprietary +system, you may have to adjust the C<"./"> above. + +It would be a lot clearer to use sysopen(), though: + + use Fcntl; + $badpath = "<<<something really wicked "; + open (FH, $badpath, O_WRONLY | O_CREAT | O_TRUNC) + or die "can't open $badpath: $!"; -You could also use the sysopen() function (see L<perlfunc/sysopen>). +For more information, see also the new L<perlopentut> if you have it +(new for 5.006). =head2 How can I reliably rename a file? @@ -601,7 +619,7 @@ then delete the old one. This isn't really the same semantics as a real rename(), though, which preserves metainformation like permissions, timestamps, inode info, etc. -The newer version of File::Copy export a move() function. +The newer version of File::Copy exports a move() function. =head2 How can I lock a file? @@ -631,9 +649,12 @@ build Perl. See the flock entry of L<perlfunc>, and the F<INSTALL> file in the source distribution for information on building Perl to do this. +For more information on file locking, see also L<perlopentut/"File +Locking"> if you have it (new for 5.006). + =back -=head2 What can't I just open(FH, ">file.lock")? +=head2 Why can't I just open(FH, ">file.lock")? A common bit of code B<NOT TO USE> is this: @@ -649,7 +670,7 @@ atomic test-and-set instruction. In theory, this "ought" to work: except that lamentably, file creation (and deletion) is not atomic over NFS, so this won't work (at least, not every time) over the net. -Various schemes involving involving link() have been suggested, but +Various schemes involving link() have been suggested, but these tend to involve busy-wait, which is also subdesirable. =head2 I still don't get locking. I just want to increment the number in the file. How can I do this? @@ -661,14 +682,15 @@ It's more realistic. Anyway, this is what you can do if you can't help yourself. - use Fcntl; + use Fcntl ':flock'; sysopen(FH, "numfile", O_RDWR|O_CREAT) or die "can't open numfile: $!"; - flock(FH, 2) or die "can't flock numfile: $!"; + flock(FH, LOCK_EX) or die "can't flock numfile: $!"; $num = <FH> || 0; seek(FH, 0, 0) or die "can't rewind numfile: $!"; truncate(FH, 0) or die "can't truncate numfile: $!"; (print FH $num+1, "\n") or die "can't write numfile: $!"; - # DO NOT UNLOCK THIS UNTIL YOU CLOSE + # Perl as of 5.004 automatically flushes before unlocking + flock(FH, LOCK_UN) or die "can't flock numfile: $!"; close FH or die "can't close numfile: $!"; Here's a much better web-page hit counter: @@ -693,7 +715,7 @@ like this: seek(FH, $recno * $RECSIZE, 0); read(FH, $record, $RECSIZE) == $RECSIZE || die "can't read record $recno: $!"; # munge the record - seek(FH, $recno * $RECSIZE, 0); + seek(FH, -$RECSIZE, 1); print FH $record; close FH; @@ -720,12 +742,15 @@ Here's an example: If you prefer something more legible, use the File::stat module (part of the standard distribution in version 5.004 and later): + # error checking left as an exercise for reader. use File::stat; use Time::localtime; $date_string = ctime(stat($file)->mtime); print "file $file updated at $date_string\n"; -Error checking is left as an exercise for the reader. +The POSIX::strftime() approach has the benefit of being, +in theory, independent of the current locale. See L<perllocale> +for details. =head2 How do I set a file's timestamp in perl? @@ -741,7 +766,7 @@ of them. ($atime, $mtime) = (stat($timestamp))[8,9]; utime $atime, $mtime, @ARGV; -Error checking is left as an exercise for the reader. +Error checking is, as usual, left as an exercise for the reader. Note that utime() currently doesn't work correctly with Win95/NT ports. A bug has been reported. Check it carefully before using @@ -774,11 +799,14 @@ than the stock version. =head2 How can I read in a file by paragraphs? -Use the C<$\> variable (see L<perlvar> for details). You can either +Use the C<$/> variable (see L<perlvar> for details). You can either set it to C<""> to eliminate empty paragraphs (C<"abc\n\n\n\ndef">, for instance, gets treated as two paragraphs and not three), or C<"\n\n"> to accept empty paragraphs. +Note that a blank line must have no blanks in it. Thus C<"fred\n +\nstuff\n\n"> is one paragraph, but C<"fred\n\nstuff\n\n"> is two. + =head2 How can I read a single character from a file? From the keyboard? You can use the builtin C<getc()> function for most filehandles, but @@ -786,8 +814,9 @@ it won't (easily) work on a terminal device. For STDIN, either use the Term::ReadKey module from CPAN, or use the sample code in L<perlfunc/getc>. -If your system supports POSIX, you can use the following code, which -you'll note turns off echo processing as well. +If your system supports the portable operating system programming +interface (POSIX), you can use the following code, which you'll note +turns off echo processing as well. #!/usr/bin/perl -w use strict; @@ -838,7 +867,8 @@ you'll note turns off echo processing as well. END { cooked() } -The Term::ReadKey module from CPAN may be easier to use: +The Term::ReadKey module from CPAN may be easier to use. Recent version +include also support for non-portable systems as well. use Term::ReadKey; open(TTY, "</dev/tty"); @@ -849,7 +879,7 @@ The Term::ReadKey module from CPAN may be easier to use: printf "\nYou said %s, char number %03d\n", $key, ord $key; -For DOS systems, Dan Carson <dbc@tc.fluke.COM> reports the following: +For legacy DOS systems, Dan Carson <dbc@tc.fluke.COM> reports the following: To put the PC in "raw" mode, use ioctl with some magic numbers gleaned from msdos.c (Perl source file) and Ralf Brown's interrupt list (comes @@ -895,11 +925,12 @@ table: This is all trial and error I did a long time ago, I hope I'm reading the file that worked. -=head2 How can I tell if there's a character waiting on a filehandle? +=head2 How can I tell whether there's a character waiting on a filehandle? The very first thing you should do is look into getting the Term::ReadKey -extension from CPAN. It now even has limited support for closed, proprietary -(read: not open systems, not POSIX, not Unix, etc) systems. +extension from CPAN. As we mentioned earlier, it now even has limited +support for non-portable (read: not open systems, closed, proprietary, +not POSIX, not Unix, etc) systems. You should also check out the Frequently Asked Questions list in comp.unix.* for things like this: the answer is essentially the same. @@ -912,12 +943,11 @@ systems: return $nfd = select($rin,undef,undef,0); } -If you want to find out how many characters are waiting, -there's also the FIONREAD ioctl call to be looked at. - -The I<h2ph> tool that comes with Perl tries to convert C include -files to Perl code, which can be C<require>d. FIONREAD ends -up defined as a function in the I<sys/ioctl.ph> file: +If you want to find out how many characters are waiting, there's +also the FIONREAD ioctl call to be looked at. The I<h2ph> tool that +comes with Perl tries to convert C include files to Perl code, which +can be C<require>d. FIONREAD ends up defined as a function in the +I<sys/ioctl.ph> file: require 'sys/ioctl.ph'; @@ -939,7 +969,7 @@ Or write a small C program using the editor of champions: printf("%#08x\n", FIONREAD); } ^D - % cc -o fionread fionread + % cc -o fionread fionread.c % ./fionread 0x4004667f @@ -980,6 +1010,8 @@ the clearerr() method, which can remove the end of file condition on a filehandle. The method: read until end of file, clearerr(), read some more. Lather, rinse, repeat. +There's also a File::Tail module from CPAN. + =head2 How do I dup() a filehandle in Perl? If you check L<perlfunc/open>, you'll see that several of the ways @@ -1018,19 +1050,22 @@ Remember that within double quoted strings ("like\this"), the backslash is an escape character. The full list of these is in L<perlop/Quote and Quote-like Operators>. Unsurprisingly, you don't have a file called "c:(tab)emp(formfeed)oo" or -"c:(tab)emp(formfeed)oo.exe" on your DOS filesystem. +"c:(tab)emp(formfeed)oo.exe" on your legacy DOS filesystem. Either single-quote your strings, or (preferably) use forward slashes. Since all DOS and Windows versions since something like MS-DOS 2.0 or so have treated C</> and C<\> the same in a path, you might as well use the one that doesn't clash with Perl -- or the POSIX shell, ANSI C and C++, -awk, Tcl, Java, or Python, just to mention a few. +awk, Tcl, Java, or Python, just to mention a few. POSIX paths +are more portable, too. =head2 Why doesn't glob("*.*") get all the files? Because even on non-Unix ports, Perl's glob function follows standard Unix globbing semantics. You'll need C<glob("*")> to get all (non-hidden) -files. This makes glob() portable. +files. This makes glob() portable even to legacy systems. Your +port may include proprietary globbing functions as well. Check its +documentation for details. =head2 Why does Perl let me delete read-only files? Why does C<-i> clobber protected files? Isn't this a bug in Perl? @@ -1057,13 +1092,36 @@ This has a significant advantage in space over reading the whole file in. A simple proof by induction is available upon request if you doubt its correctness. +=head2 Why do I get weird spaces when I print an array of lines? + +Saying + + print "@lines\n"; + +joins together the elements of C<@lines> with a space between them. +If C<@lines> were C<("little", "fluffy", "clouds")> then the above +statement would print: + + little fluffy clouds + +but if each element of C<@lines> was a line of text, ending a newline +character C<("little\n", "fluffy\n", "clouds\n")> then it would print: + + little + fluffy + clouds + +If your array contains lines, just print them: + + print @lines; + =head1 AUTHOR AND COPYRIGHT -Copyright (c) 1997, 1998 Tom Christiansen and Nathan Torkington. +Copyright (c) 1997-1999 Tom Christiansen and Nathan Torkington. All rights reserved. When included as an integrated part of the Standard Distribution -of Perl or of its documentation (printed or otherwise), this works is +of Perl or of its documentation (printed or otherwise), this work is covered under Perl's Artistic Licence. For separate distributions of all or part of this FAQ outside of that, see L<perlfaq>. @@ -1072,3 +1130,4 @@ domain. You are permitted and encouraged to use this code and any derivatives thereof in your own programs for fun or for profit as you see fit. A simple comment in the code giving credit to the FAQ would be courteous but is not required. + diff --git a/contrib/perl5/pod/perlfaq6.pod b/contrib/perl5/pod/perlfaq6.pod index 488a27c..234570d 100644 --- a/contrib/perl5/pod/perlfaq6.pod +++ b/contrib/perl5/pod/perlfaq6.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq6 - Regexps ($Revision: 1.22 $, $Date: 1998/07/16 14:01:07 $) +perlfaq6 - Regexps ($Revision: 1.25 $, $Date: 1999/01/08 04:50:47 $) =head1 DESCRIPTION @@ -128,7 +128,7 @@ L<perlop>): If you wanted text and not lines, you would use - perl -0777 -pe 'print "$1\n" while /START(.*?)END/gs' file1 file2 ... + perl -0777 -ne 'print "$1\n" while /START(.*?)END/gs' file1 file2 ... But if you want nested occurrences of C<START> through C<END>, you'll run up against the problem described in the question in this section @@ -387,48 +387,31 @@ See the module String::Approx available from CPAN. =head2 How do I efficiently match many regular expressions at once? -The following is super-inefficient: +The following is extremely inefficient: - while (<FH>) { - foreach $pat (@patterns) { - if ( /$pat/ ) { - # do something - } - } - } - -Instead, you either need to use one of the experimental Regexp extension -modules from CPAN (which might well be overkill for your purposes), -or else put together something like this, inspired from a routine -in Jeffrey Friedl's book: - - sub _bm_build { - my $condition = shift; - my @regexp = @_; # this MUST not be local(); need my() - my $expr = join $condition => map { "m/\$regexp[$_]/o" } (0..$#regexp); - my $match_func = eval "sub { $expr }"; - die if $@; # propagate $@; this shouldn't happen! - return $match_func; - } - - sub bm_and { _bm_build('&&', @_) } - sub bm_or { _bm_build('||', @_) } - - $f1 = bm_and qw{ - xterm - (?i)window - }; - - $f2 = bm_or qw{ - \b[Ff]ree\b - \bBSD\B - (?i)sys(tem)?\s*[V5]\b - }; - - # feed me /etc/termcap, prolly - while ( <> ) { - print "1: $_" if &$f1; - print "2: $_" if &$f2; + # slow but obvious way + @popstates = qw(CO ON MI WI MN); + while (defined($line = <>)) { + for $state (@popstates) { + if ($line =~ /\b$state\b/i) { + print $line; + last; + } + } + } + +That's because Perl has to recompile all those patterns for each of +the lines of the file. As of the 5.005 release, there's a much better +approach, one which makes use of the new C<qr//> operator: + + # use spiffy new qr// operator, with /i flag even + use 5.005; + @popstates = qw(CO ON MI WI MN); + @poppats = map { qr/\b$_\b/i } @popstates; + while (defined($line = <>)) { + for $patobj (@poppats) { + print $line if $line =~ /$patobj/; + } } =head2 Why don't word-boundary searches with C<\b> work for me? @@ -460,22 +443,24 @@ not "this" or "island". =head2 Why does using $&, $`, or $' slow my program down? -Because once Perl sees that you need one of these variables anywhere -in the program, it has to provide them on each and every pattern -match. The same mechanism that handles these provides for the use of -$1, $2, etc., so you pay the same price for each regexp that contains -capturing parentheses. But if you never use $&, etc., in your script, -then regexps I<without> capturing parentheses won't be penalized. So -avoid $&, $', and $` if you can, but if you can't (and some algorithms -really appreciate them), once you've used them once, use them at will, -because you've already paid the price. +Because once Perl sees that you need one of these variables anywhere in +the program, it has to provide them on each and every pattern match. +The same mechanism that handles these provides for the use of $1, $2, +etc., so you pay the same price for each regexp that contains capturing +parentheses. But if you never use $&, etc., in your script, then regexps +I<without> capturing parentheses won't be penalized. So avoid $&, $', +and $` if you can, but if you can't, once you've used them at all, use +them at will because you've already paid the price. Remember that some +algorithms really appreciate them. As of the 5.005 release. the $& +variable is no longer "expensive" the way the other two are. =head2 What good is C<\G> in a regular expression? The notation C<\G> is used in a match or substitution in conjunction the C</g> modifier (and ignored if there's no C</g>) to anchor the regular expression to the point just past where the last match occurred, i.e. the -pos() point. +pos() point. A failed match resets the position of C<\G> unless the +C</c> modifier is in effect. For example, suppose you had a line of text quoted in standard mail and Usenet notation, (that is, with leading C<E<gt>> characters), and @@ -596,25 +581,46 @@ Or like this: Or like this: - die "sorry, Perl doesn't (yet) have Martian support )-:\n"; - -In addition, a sample program which converts half-width to full-width -katakana (in Shift-JIS or EUC encoding) is available from CPAN as - -=for Tom make it so + die "sorry, Perl doesn't (yet) have Martian support )-:\n"; There are many double- (and multi-) byte encodings commonly used these days. Some versions of these have 1-, 2-, 3-, and 4-byte characters, all mixed. +=head2 How do I match a pattern that is supplied by the user? + +Well, if it's really a pattern, then just use + + chomp($pattern = <STDIN>); + if ($line =~ /$pattern/) { } + +Or, since you have no guarantee that your user entered +a valid regular expression, trap the exception this way: + + if (eval { $line =~ /$pattern/ }) { } + +But if all you really want to search for a string, not a pattern, +then you should either use the index() function, which is made for +string searching, or if you can't be disabused of using a pattern +match on a non-pattern, then be sure to use C<\Q>...C<\E>, documented +in L<perlre>. + + $pattern = <STDIN>; + + open (FILE, $input) or die "Couldn't open input $input: $!; aborting"; + while (<FILE>) { + print if /\Q$pattern\E/; + } + close FILE; + =head1 AUTHOR AND COPYRIGHT -Copyright (c) 1997, 1998 Tom Christiansen and Nathan Torkington. +Copyright (c) 1997-1999 Tom Christiansen and Nathan Torkington. All rights reserved. When included as part of the Standard Version of Perl, or as part of its complete documentation whether printed or otherwise, this work -may be distributed only under the terms of Perl's Artistic License. +may be distributed only under the terms of Perl's Artistic Licence. Any distribution of this file or derivatives thereof I<outside> of that package require that special arrangements be made with copyright holder. @@ -624,3 +630,4 @@ are hereby placed into the public domain. You are permitted and encouraged to use this code in your own programs for fun or for profit as you see fit. A simple comment in the code giving credit would be courteous but is not required. + diff --git a/contrib/perl5/pod/perlfaq7.pod b/contrib/perl5/pod/perlfaq7.pod index e1bccc8..a4ea872 100644 --- a/contrib/perl5/pod/perlfaq7.pod +++ b/contrib/perl5/pod/perlfaq7.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq7 - Perl Language Issues ($Revision: 1.21 $, $Date: 1998/06/22 15:20:07 $) +perlfaq7 - Perl Language Issues ($Revision: 1.24 $, $Date: 1999/01/08 05:32:11 $) =head1 DESCRIPTION @@ -180,7 +180,7 @@ own module. Make sure to change the names appropriately. # if using RCS/CVS, this next line may be preferred, # but beware two-digit versions. - $VERSION = do{my@r=q$Revision: 1.21 $=~/\d+/g;sprintf '%d.'.'%02d'x$#r,@r}; + $VERSION = do{my@r=q$Revision: 1.24 $=~/\d+/g;sprintf '%d.'.'%02d'x$#r,@r}; @ISA = qw(Exporter); @EXPORT = qw(&func1 &func2 &func3); @@ -229,6 +229,10 @@ own module. Make sure to change the names appropriately. 1; # modules must return true +The h2xs program will create stubs for all the important stuff for you: + + % h2xs -XA -n My::Module + =head2 How do I create a class? See L<perltoot> for an introduction to classes and objects, as well as @@ -313,7 +317,7 @@ caller's scope. Variable suicide is when you (temporarily or permanently) lose the value of a variable. It is caused by scoping through my() and local() -interacting with either closures or aliased foreach() interator +interacting with either closures or aliased foreach() iterator variables and subroutine arguments. It used to be easy to inadvertently lose a variable's value this way, but now it's much harder. Take this code: @@ -344,7 +348,7 @@ reference to an existing or anonymous variable or function: func( \$some_scalar ); - func( \$some_array ); + func( \@some_array ); func( [ 1 .. 10 ] ); func( \%some_hash ); @@ -392,7 +396,7 @@ If you're planning on generating new filehandles, you could do this: To pass regexps around, you'll need to either use one of the highly experimental regular expression modules from CPAN (Nick Ing-Simmons's Regexp or Ilya Zakharevich's Devel::Regexp), pass around strings -and use an exception-trapping eval, or else be be very, very clever. +and use an exception-trapping eval, or else be very, very clever. Here's an example of how to pass in a string to be regexp compared: sub compare($$) { @@ -484,7 +488,7 @@ could conceivably have several packages in that same file all accessing the same private variable, but another file with the same package couldn't get to it. -See L<perlsub/"Peristent Private Variables"> for details. +See L<perlsub/"Persistent Private Variables"> for details. =head2 What's the difference between dynamic and lexical (static) scoping? Between local() and my()? @@ -563,7 +567,7 @@ However, dynamic variables (aka global, local, or package variables) are effectively shallowly bound. Consider this just one more reason not to use them. See the answer to L<"What's a closure?">. -=head2 Why doesn't "my($foo) = <FILE>;" work right? +=head2 Why doesn't "my($foo) = E<lt>FILEE<gt>;" work right? C<my()> and C<local()> give list context to the right hand side of C<=>. The E<lt>FHE<gt> read operation, like so many of Perl's @@ -797,14 +801,39 @@ This can't go just anywhere. You have to put a pod directive where the parser is expecting a new statement, not just in the middle of an expression or some other arbitrary yacc grammar production. +=head2 How do I clear a package? + +Use this code, provided by Mark-Jason Dominus: + + sub scrub_package { + no strict 'refs'; + my $pack = shift; + die "Shouldn't delete main package" + if $pack eq "" || $pack eq "main"; + my $stash = *{$pack . '::'}{HASH}; + my $name; + foreach $name (keys %$stash) { + my $fullname = $pack . '::' . $name; + # Get rid of everything with that name. + undef $$fullname; + undef @$fullname; + undef %$fullname; + undef &$fullname; + undef *$fullname; + } + } + +Or, if you're using a recent release of Perl, you can +just use the Symbol::delete_package() function instead. + =head1 AUTHOR AND COPYRIGHT -Copyright (c) 1997, 1998 Tom Christiansen and Nathan Torkington. +Copyright (c) 1997-1999 Tom Christiansen and Nathan Torkington. All rights reserved. When included as part of the Standard Version of Perl, or as part of its complete documentation whether printed or otherwise, this work -may be distributed only under the terms of Perl's Artistic License. +may be distributed only under the terms of Perl's Artistic Licence. Any distribution of this file or derivatives thereof I<outside> of that package require that special arrangements be made with copyright holder. @@ -814,3 +843,4 @@ are hereby placed into the public domain. You are permitted and encouraged to use this code in your own programs for fun or for profit as you see fit. A simple comment in the code giving credit would be courteous but is not required. + diff --git a/contrib/perl5/pod/perlfaq8.pod b/contrib/perl5/pod/perlfaq8.pod index c4036ff..9ef41af 100644 --- a/contrib/perl5/pod/perlfaq8.pod +++ b/contrib/perl5/pod/perlfaq8.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq8 - System Interaction ($Revision: 1.26 $, $Date: 1998/08/05 12:20:28 $) +perlfaq8 - System Interaction ($Revision: 1.36 $, $Date: 1999/01/08 05:36:34 $) =head1 DESCRIPTION @@ -325,7 +325,6 @@ go bump in the night, finally came up with this: } } - =head2 How do I decode encrypted password files? You spend lots and lots of money on dedicated hardware, but this is @@ -452,9 +451,9 @@ http://www.perl.com/CPAN/doc/misc/ancient/tutorial/eg/itimers.pl . In general, you may not be able to. The Time::HiRes module (available from CPAN) provides this functionality for some systems. -In general, you may not be able to. But if your system supports both the -syscall() function in Perl as well as a system call like gettimeofday(2), -then you may be able to do something like this: +If your system supports both the syscall() function in Perl as well as +a system call like gettimeofday(2), then you may be able to do +something like this: require 'sys/syscall.ph'; @@ -462,7 +461,7 @@ then you may be able to do something like this: $done = $start = pack($TIMEVAL_T, ()); - syscall( &SYS_gettimeofday, $start, 0)) != -1 + syscall( &SYS_gettimeofday, $start, 0) != -1 or die "gettimeofday: $!"; ########################## @@ -674,19 +673,26 @@ there, and the old standard error shows up on the old standard out. =head2 Why doesn't open() return an error when a pipe open fails? -It does, but probably not how you expect it to. On systems that -follow the standard fork()/exec() paradigm (such as Unix), it works like -this: open() causes a fork(). In the parent, open() returns with the -process ID of the child. The child exec()s the command to be piped -to/from. The parent can't know whether the exec() was successful or -not - all it can return is whether the fork() succeeded or not. To -find out if the command succeeded, you have to catch SIGCHLD and -wait() to get the exit status. You should also catch SIGPIPE if -you're writing to the child -- you may not have found out the exec() +Because the pipe open takes place in two steps: first Perl calls +fork() to start a new process, then this new process calls exec() to +run the program you really wanted to open. The first step reports +success or failure to your process, so open() can only tell you +whether the fork() succeeded or not. + +To find out if the exec() step succeeded, you have to catch SIGCHLD +and wait() to get the exit status. You should also catch SIGPIPE if +you're writing to the child--you may not have found out the exec() failed by the time you write. This is documented in L<perlipc>. +In some cases, even this won't work. If the second argument to a +piped open() contains shell metacharacters, perl fork()s, then exec()s +a shell to decode the metacharacters and eventually run the desired +program. Now when you call wait(), you only learn whether or not the +I<shell> could be successfully started. Best to avoid shell +metacharacters. + On systems that follow the spawn() paradigm, open() I<might> do what -you expect - unless perl uses a shell to start your command. In this +you expect--unless perl uses a shell to start your command. In this case the fork()/exec() description still applies. =head2 What's wrong with using backticks in a void context? @@ -869,7 +875,7 @@ module for other solutions. =item * -Open /dev/tty and use the the TIOCNOTTY ioctl on it. See L<tty(4)> +Open /dev/tty and use the TIOCNOTTY ioctl on it. See L<tty(4)> for details. Or better yet, you can just use the POSIX::setsid() function, so you don't have to worry about process groups. @@ -890,6 +896,9 @@ Background yourself like this: =back +The Proc::Daemon module, available from CPAN, provides a function to +perform these actions for you. + =head2 How do I make my program run with sh and csh? See the F<eg/nih> script (part of the perl source distribution). @@ -908,7 +917,7 @@ the current process group of your controlling terminal as follows: use POSIX qw/getpgrp tcgetpgrp/; open(TTY, "/dev/tty") or die $!; - $tpgrp = tcgetpgrp(TTY); + $tpgrp = tcgetpgrp(fileno(*TTY)); $pgrp = getpgrp(); if ($tpgrp == $pgrp) { print "foreground\n"; @@ -1034,6 +1043,13 @@ scripts that use the modules/libraries (see L<perlrun>) or say use lib '/u/mydir/perl'; +This is almost the same as: + + BEGIN { + unshift(@INC, '/u/mydir/perl'); + } + +except that the lib module checks for machine-dependent subdirectories. See Perl's L<lib> for more information. =head2 How do I add the directory my program lives in to the module/library search path? @@ -1048,7 +1064,7 @@ Here are the suggested ways of modifying your include path: the PERLLIB environment variable the PERL5LIB environment variable - the perl -Idir commpand line flag + the perl -Idir command line flag the use lib pragma, as in use lib "$ENV{HOME}/myown_perllib"; @@ -1056,14 +1072,20 @@ The latter is particularly useful because it knows about machine dependent architectures. The lib.pm pragmatic module was first included with the 5.002 release of Perl. +=head2 What is socket.ph and where do I get it? + +It's a perl4-style file defining values for system networking +constants. Sometimes it is built using h2ph when Perl is installed, +but other times it is not. Modern programs C<use Socket;> instead. + =head1 AUTHOR AND COPYRIGHT -Copyright (c) 1997, 1998 Tom Christiansen and Nathan Torkington. +Copyright (c) 1997-1999 Tom Christiansen and Nathan Torkington. All rights reserved. When included as part of the Standard Version of Perl, or as part of its complete documentation whether printed or otherwise, this work -may be distributed only under the terms of Perl's Artistic License. +may be distributed only under the terms of Perl's Artistic Licence. Any distribution of this file or derivatives thereof I<outside> of that package require that special arrangements be made with copyright holder. @@ -1073,3 +1095,4 @@ are hereby placed into the public domain. You are permitted and encouraged to use this code in your own programs for fun or for profit as you see fit. A simple comment in the code giving credit would be courteous but is not required. + diff --git a/contrib/perl5/pod/perlfaq9.pod b/contrib/perl5/pod/perlfaq9.pod index 330158b..6536064 100644 --- a/contrib/perl5/pod/perlfaq9.pod +++ b/contrib/perl5/pod/perlfaq9.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq9 - Networking ($Revision: 1.20 $, $Date: 1998/06/22 18:31:09 $) +perlfaq9 - Networking ($Revision: 1.24 $, $Date: 1999/01/08 05:39:48 $) =head1 DESCRIPTION @@ -20,7 +20,7 @@ may not be so well received. The useful FAQs and related documents are: CGI FAQ - http://www.webthing.com/page.cgi/cgifaq + http://www.webthing.com/tutorials/cgifaq.html Web FAQ http://www.boutell.com/faq/ @@ -77,8 +77,7 @@ stamp prepended. =head2 How do I remove HTML from a string? The most correct way (albeit not the fastest) is to use HTML::Parse -from CPAN (part of the libwww-perl distribution, which is a must-have -module for all web hackers). +from CPAN (part of the HTML-Tree package on CPAN). Many folks attempt a simple-minded regular expression approach, like C<s/E<lt>.*?E<gt>//g>, but that fails in many cases because the tags @@ -172,6 +171,7 @@ do this. They work through proxies, and don't require lynx: getprint "http://www.sn.no/libwww-perl/"; # or print ASCII from HTML from a URL + # also need HTML-Tree package from CPAN use LWP::Simple; use HTML::Parse; use HTML::FormatText; @@ -213,7 +213,7 @@ Here's an example of decoding: $string =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/ge; Encoding is a bit harder, because you can't just blindly change -all the non-alphanumunder character (C<\W>) into their hex escapes. +all the non-alphanumeric characters (C<\W>) into their hex escapes. It's important that characters with special meaning like C</> and C<?> I<not> be translated. Probably the easiest way to get this right is to avoid reinventing the wheel and just use the URI::Escape module, @@ -303,7 +303,7 @@ In short, they're bad hacks. Resist them at all costs. Please do not be tempted to reinvent the wheel. Instead, use the CGI.pm or CGI_Lite.pm (available from CPAN), or if you're trapped in the module-free land of perl1 .. perl4, you might look into cgi-lib.pl (available from -http://www.bio.cam.ac.uk/web/form.html). +http://cgi-lib.stanford.edu/cgi-lib/ ). Make sure you know whether to use a GET or a POST in your form. GETs should only be used for something that doesn't update the server. @@ -411,7 +411,8 @@ Use the C<sendmail> program directly: To: Final Destination <you\@otherhost> Subject: A relevant subject line - Body of the message goes here, in as many lines as you like. + Body of the message goes here after the blank line + in as many lines as you like. EOF close(SENDMAIL) or warn "sendmail didn't close nicely"; @@ -442,9 +443,8 @@ include queueing, MX records, and security. =head2 How do I read mail? -Use the Mail::Folder module from CPAN -(part of the MailFolder package) or the Mail::Internet module from -CPAN (also part of the MailTools package). +Use the Mail::Folder module from CPAN (part of the MailFolder package) or +the Mail::Internet module from CPAN (also part of the MailTools package). # sending mail use Mail::Internet; @@ -504,7 +504,7 @@ give you the hostname after which you can find out the IP address use Socket; use Sys::Hostname; my $host = hostname(); - my $addr = inet_ntoa(scalar(gethostbyname($name)) || 'localhost'); + my $addr = inet_ntoa(scalar gethostbyname($host || 'localhost')); Probably the simplest way to learn your DNS domain name is to grok it out of /etc/resolv.conf, at least under Unix. Of course, this @@ -531,16 +531,17 @@ available from CPAN) is more complex but can put as well as fetch. A DCE::RPC module is being developed (but is not yet available), and will be released as part of the DCE-Perl package (available from -CPAN). No ONC::RPC module is known. +CPAN). The rpcgen suite, available from CPAN/authors/id/JAKE/, is +an RPC stub generator and includes an RPC::ONC module. =head1 AUTHOR AND COPYRIGHT -Copyright (c) 1997, 1998 Tom Christiansen and Nathan Torkington. +Copyright (c) 1997-1999 Tom Christiansen and Nathan Torkington. All rights reserved. When included as part of the Standard Version of Perl, or as part of its complete documentation whether printed or otherwise, this work -may be distributed only under the terms of Perl's Artistic License. +may be distributed only under the terms of Perl's Artistic Licence. Any distribution of this file or derivatives thereof I<outside> of that package require that special arrangements be made with copyright holder. @@ -550,3 +551,4 @@ are hereby placed into the public domain. You are permitted and encouraged to use this code in your own programs for fun or for profit as you see fit. A simple comment in the code giving credit would be courteous but is not required. + diff --git a/contrib/perl5/pod/perlform.pod b/contrib/perl5/pod/perlform.pod index 6b65e04..b2c87fa 100644 --- a/contrib/perl5/pod/perlform.pod +++ b/contrib/perl5/pod/perlform.pod @@ -335,3 +335,12 @@ cannot be controlled by C<use locale> because the pragma is tied to the block structure of the program, and, for historical reasons, formats exist outside that block structure. See L<perllocale> for further discussion of locale handling. + +Inside of an expression, the whitespace characters \n, \t and \f are +considered to be equivalent to a single space. Thus, you could think +of this filter being applied to each value in the format: + + $value =~ tr/\n\t\f/ /; + +The remaining whitespace character, \r, forces the printing of a new +line if allowed by the picture line. diff --git a/contrib/perl5/pod/perlfunc.pod b/contrib/perl5/pod/perlfunc.pod index 4eac093..5fb7863 100644 --- a/contrib/perl5/pod/perlfunc.pod +++ b/contrib/perl5/pod/perlfunc.pod @@ -12,11 +12,12 @@ operators take more than one argument, while unary operators can never take more than one argument. Thus, a comma terminates the argument of a unary operator, but merely separates the arguments of a list operator. A unary operator generally provides a scalar context to its -argument, while a list operator may provide either scalar and list +argument, while a list operator may provide either scalar or list contexts for its arguments. If it does both, the scalar arguments will be first, and the list argument will follow. (Note that there can ever -be only one list argument.) For instance, splice() has three scalar -arguments followed by a list. +be only one such list argument.) For instance, splice() has three scalar +arguments followed by a list, whereas gethostbyname() has four scalar +arguments. In the syntax descriptions that follow, list operators that expect a list (and provide list context for the elements of the list) are shown @@ -47,6 +48,11 @@ example, the third line above produces: print (...) interpreted as function at - line 1. Useless use of integer addition in void context at - line 1. +A few functions take no arguments at all, and therefore work as neither +unary nor list operators. These include such functions as C<time> +and C<endpwent>. For example, C<time+86_400> always means +C<time() + 86_400>. + For functions that can be used in either a scalar or list context, nonabortive failure is generally indicated in a scalar context by returning the undefined value, and in a list context by returning the @@ -56,7 +62,7 @@ Remember the following important rule: There is B<no rule> that relates the behavior of an expression in list context to its behavior in scalar context, or vice versa. It might do two totally different things. Each operator and function decides which sort of value it would be most -appropriate to return in a scalar context. Some operators return the +appropriate to return in scalar context. Some operators return the length of the list that would have been returned in list context. Some operators return the first value in the list. Some operators return the last value in the list. Some operators return a count of successful @@ -129,8 +135,9 @@ C<pack>, C<read>, C<syscall>, C<sysread>, C<syswrite>, C<unpack>, C<vec> =item Functions for filehandles, files, or directories C<-I<X>>, C<chdir>, C<chmod>, C<chown>, C<chroot>, C<fcntl>, C<glob>, -C<ioctl>, C<link>, C<lstat>, C<mkdir>, C<open>, C<opendir>, C<readlink>, -C<rename>, C<rmdir>, C<stat>, C<symlink>, C<umask>, C<unlink>, C<utime> +C<ioctl>, C<link>, C<lstat>, C<mkdir>, C<open>, C<opendir>, +C<readlink>, C<rename>, C<rmdir>, C<stat>, C<symlink>, C<umask>, +C<unlink>, C<utime> =item Keywords related to the control flow of your perl program @@ -206,6 +213,34 @@ C<dbmclose>, C<dbmopen> =back +=head2 Portability + +Perl was born in Unix and can therefore access all common Unix +system calls. In non-Unix environments, the functionality of some +Unix system calls may not be available, or details of the available +functionality may differ slightly. The Perl functions affected +by this are: + +C<-X>, C<binmode>, C<chmod>, C<chown>, C<chroot>, C<crypt>, +C<dbmclose>, C<dbmopen>, C<dump>, C<endgrent>, C<endhostent>, +C<endnetent>, C<endprotoent>, C<endpwent>, C<endservent>, C<exec>, +C<fcntl>, C<flock>, C<fork>, C<getgrent>, C<getgrgid>, C<gethostent>, +C<getlogin>, C<getnetbyaddr>, C<getnetbyname>, C<getnetent>, +C<getppid>, C<getprgp>, C<getpriority>, C<getprotobynumber>, +C<getprotoent>, C<getpwent>, C<getpwnam>, C<getpwuid>, +C<getservbyport>, C<getservent>, C<getsockopt>, C<glob>, C<ioctl>, +C<kill>, C<link>, C<lstat>, C<msgctl>, C<msgget>, C<msgrcv>, +C<msgsnd>, C<open>, C<pipe>, C<readlink>, C<rename>, C<select>, C<semctl>, +C<semget>, C<semop>, C<setgrent>, C<sethostent>, C<setnetent>, +C<setpgrp>, C<setpriority>, C<setprotoent>, C<setpwent>, +C<setservent>, C<setsockopt>, C<shmctl>, C<shmget>, C<shmread>, +C<shmwrite>, C<socket>, C<socketpair>, C<stat>, C<symlink>, C<syscall>, +C<sysopen>, C<system>, C<times>, C<truncate>, C<umask>, C<unlink>, +C<utime>, C<wait>, C<waitpid> + +For more information about the portability of these functions, see +L<perlport> and other available platform-specific documentation. + =head2 Alphabetical Listing of Perl Functions =over 8 @@ -262,15 +297,6 @@ X<-S>X<-b>X<-c>X<-t>X<-u>X<-g>X<-k>X<-T>X<-B>X<-M>X<-A>X<-C> -A Same for access time. -C Same for inode change time. -The interpretation of the file permission operators C<-r>, C<-R>, C<-w>, -C<-W>, C<-x>, and C<-X> is based solely on the mode of the file and the -uids and gids of the user. There may be other reasons you can't actually -read, write, or execute the file, such as AFS access control lists. Also note that, for the superuser, -C<-r>, C<-R>, C<-w>, and C<-W> always return C<1>, and C<-x> and C<-X> return -C<1> if any execute bit is set in the mode. Scripts run by the superuser may -thus need to do a C<stat()> to determine the actual mode of the -file, or temporarily set the uid to something else. - Example: while (<>) { @@ -279,6 +305,20 @@ Example: #... } +The interpretation of the file permission operators C<-r>, C<-R>, +C<-w>, C<-W>, C<-x>, and C<-X> is by default based solely on the mode +of the file and the uids and gids of the user. There may be other +reasons you can't actually read, write, or execute the file. Such +reasons may be for example network filesystem access controls, ACLs +(access control lists), read-only filesystems, and unrecognized +executable formats. + +Also note that, for the superuser on the local filesystems, the C<-r>, +C<-R>, C<-w>, and C<-W> tests always return 1, and C<-x> and C<-X> return 1 +if any execute bit is set in the mode. Scripts run by the superuser +may thus need to do a stat() to determine the actual mode of the file, +or temporarily set their effective uid to something else. + Note that C<-s/a/b/> does not do a negated substitution. Saying C<-exp($foo)> still works as expected, however--only single letters following a minus are interpreted as file tests. @@ -324,7 +364,7 @@ If VALUE is omitted, uses C<$_>. Accepts an incoming socket connect, just as the accept(2) system call does. Returns the packed address if it succeeded, FALSE otherwise. -See example in L<perlipc/"Sockets: Client/Server Communication">. +See the example in L<perlipc/"Sockets: Client/Server Communication">. =item alarm SECONDS @@ -341,8 +381,12 @@ starting a new one. The returned value is the amount of time remaining on the previous timer. For delays of finer granularity than one second, you may use Perl's -C<syscall()> interface to access setitimer(2) if your system supports it, -or else see L</select()>. It is usually a mistake to intermix C<alarm()> +four-arugment version of select() leaving the first three arguments +undefined, or you might be able to use the C<syscall()> interface to +access setitimer(2) if your system supports it. The Time::HiRes module +from CPAN may also prove useful. + +It is usually a mistake to intermix C<alarm()> and C<sleep()> calls. If you want to use C<alarm()> to time out a system call you need to use an @@ -384,28 +428,42 @@ L<perlipc/"Sockets: Client/Server Communication">. =item binmode FILEHANDLE Arranges for the file to be read or written in "binary" mode in operating -systems that distinguish between binary and text files. Files that are -not in binary mode have CR LF sequences translated to LF on input and LF -translated to CR LF on output. Binmode has no effect under Unix; in MS-DOS -and similarly archaic systems, it may be imperative--otherwise your -MS-DOS-damaged C library may mangle your file. The key distinction between -systems that need C<binmode()> and those that don't is their text file -formats. Systems like Unix, MacOS, and Plan9 that delimit lines with a single -character, and that encode that character in C as C<"\n">, do not need -C<binmode()>. The rest need it. If FILEHANDLE is an expression, the value -is taken as the name of the filehandle. +systems that distinguish between binary and text files. Files that +are not in binary mode have CR LF sequences translated to LF on input +and LF translated to CR LF on output. Binmode has no effect under +many sytems, but in MS-DOS and similarly archaic systems, it may be +imperative--otherwise your MS-DOS-damaged C library may mangle your file. +The key distinction between systems that need C<binmode()> and those +that don't is their text file formats. Systems like Unix, MacOS, and +Plan9 that delimit lines with a single character, and that encode that +character in C as C<"\n">, do not need C<binmode()>. The rest may need it. +If FILEHANDLE is an expression, the value is taken as the name of the +filehandle. + +If the system does care about it, using it when you shouldn't is just as +perilous as failing to use it when you should. Fortunately for most of +us, you can't go wrong using binmode() on systems that don't care about +it, though. =item bless REF,CLASSNAME =item bless REF -This function tells the thingy referenced by REF that it is now -an object in the CLASSNAME package--or the current package if no CLASSNAME -is specified, which is often the case. It returns the reference for -convenience, because a C<bless()> is often the last thing in a constructor. -Always use the two-argument version if the function doing the blessing -might be inherited by a derived class. See L<perltoot> and L<perlobj> -for more about the blessing (and blessings) of objects. +This function tells the thingy referenced by REF that it is now an object +in the CLASSNAME package. If CLASSNAME is omitted, the current package +is used. Because a C<bless()> is often the last thing in a constructor. +it returns the reference for convenience. Always use the two-argument +version if the function doing the blessing might be inherited by a +derived class. See L<perltoot> and L<perlobj> for more about the blessing +(and blessings) of objects. + +Consider always blessing objects in CLASSNAMEs that are mixed case. +Namespaces with all lowercase names are considered reserved for +Perl pragmata. Builtin types have all uppercase names, so to prevent +confusion, you may wish to avoid such package names as well. Make sure +that CLASSNAME is a true value. + +See L<perlmod/"Perl Modules">. =item caller EXPR @@ -446,9 +504,9 @@ previous time C<caller()> was called. =item chdir EXPR -Changes the working directory to EXPR, if possible. If EXPR is -omitted, changes to home directory. Returns TRUE upon success, FALSE -otherwise. See example under C<die()>. +Changes the working directory to EXPR, if possible. If EXPR is omitted, +changes to the user's home directory. Returns TRUE upon success, +FALSE otherwise. See the example under C<die()>. =item chmod LIST @@ -471,14 +529,14 @@ successfully changed. See also L</oct>, if all you have is a string. =item chomp -This is a slightly safer version of L</chop>. It removes any -line ending that corresponds to the current value of C<$/> (also known as +This safer version of L</chop> removes any trailing string +that corresponds to the current value of C<$/> (also known as $INPUT_RECORD_SEPARATOR in the C<English> module). It returns the total number of characters removed from all its arguments. It's often used to remove the newline from the end of an input record when you're worried -that the final record may be missing its newline. When in paragraph mode -(C<$/ = "">), it removes all trailing newlines from the string. If -VARIABLE is omitted, it chomps C<$_>. Example: +that the final record may be missing its newline. When in paragraph +mode (C<$/ = "">), it removes all trailing newlines from the string. +If VARIABLE is omitted, it chomps C<$_>. Example: while (<>) { chomp; # avoid \n on last field @@ -587,10 +645,10 @@ counter (C<$.>), while the implicit close done by C<open()> does not. If the file handle came from a piped open C<close()> will additionally return FALSE if one of the other system calls involved fails or if the program exits with non-zero status. (If the only problem was that the -program exited non-zero C<$!> will be set to C<0>.) Also, closing a pipe -waits for the process executing on the pipe to complete, in case you -want to look at the output of the pipe afterwards. Closing a pipe -explicitly also puts the exit status value of the command into C<$?>. +program exited non-zero C<$!> will be set to C<0>.) Closing a pipe +also waits for the process executing on the pipe to complete, in case you +want to look at the output of the pipe afterwards, and +implicitly puts the exit status value of that command into C<$?>. Example: @@ -673,19 +731,25 @@ eggs to make an omelette. There is no (known) corresponding decrypt function. As a result, this function isn't all that useful for cryptography. (For that, see your nearby CPAN mirror.) +When verifying an existing encrypted string you should use the encrypted +text as the salt (like C<crypt($plain, $crypted) eq $crypted>). This +allows your code to work with the standard C<crypt()> and with more +exotic implementations. When choosing a new salt create a random two +character string whose characters come from the set C<[./0-9A-Za-z]> +(like C<join '', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]>). + Here's an example that makes sure that whoever runs this program knows their own password: $pwd = (getpwuid($<))[1]; - $salt = substr($pwd, 0, 2); system "stty -echo"; print "Password: "; - chop($word = <STDIN>); + chomp($word = <STDIN>); print "\n"; system "stty echo"; - if (crypt($word, $salt) ne $pwd) { + if (crypt($word, $pwd) ne $pwd) { die "Sorry...\n"; } else { print "ok\n"; @@ -696,13 +760,13 @@ for it is unwise. =item dbmclose HASH -[This function has been superseded by the C<untie()> function.] +[This function has been largely superseded by the C<untie()> function.] Breaks the binding between a DBM file and a hash. =item dbmopen HASH,DBNAME,MODE -[This function has been superseded by the C<tie()> function.] +[This function has been largely superseded by the C<tie()> function.] This binds a dbm(3), ndbm(3), sdbm(3), gdbm(3), or Berkeley DB file to a hash. HASH is the name of the hash. (Unlike normal C<open()>, the first @@ -735,6 +799,13 @@ See also L<AnyDBM_File> for a more general description of the pros and cons of the various dbm approaches, as well as L<DB_File> for a particularly rich implementation. +You can control which DBM library you use by loading that library +before you call dbmopen(): + + use DB_File; + dbmopen(%NS_Hist, "$ENV{HOME}/.netscape/history.db") + or die "Can't open netscape history file: $!"; + =item defined EXPR =item defined @@ -779,7 +850,7 @@ defined values. For example, if you say The pattern match succeeds, and C<$1> is defined, despite the fact that it matched "nothing". But it didn't really match nothing--rather, it -matched something that happened to be C<0> characters long. This is all +matched something that happened to be zero characters long. This is all very above-board and honest. When a function returns an undefined value, it's an admission that it couldn't give you an honest answer. So you should use C<defined()> only when you're questioning the integrity of what @@ -825,9 +896,14 @@ And so does this: delete @HASH{keys %HASH} -(But both of these are slower than just assigning the empty list, or -using C<undef()>.) Note that the EXPR can be arbitrarily complicated as -long as the final operation is a hash element lookup or hash slice: +But both of these are slower than just assigning the empty list +or undefining it: + + %hash = (); # completely empty %hash + undef %hash; # forget %hash every existed + +Note that the EXPR can be arbitrarily complicated as long as the final +operation is a hash element lookup or hash slice: delete $ref->[$x][$y]{$key}; delete @{$ref->[$x][$y]}{$key1, $key2, @morekeys}; @@ -848,7 +924,12 @@ Equivalent examples: If the value of EXPR does not end in a newline, the current script line number and input line number (if any) are also printed, and a newline -is supplied. Hint: sometimes appending C<", stopped"> to your message +is supplied. Note that the "input line number" (also known as "chunk") +is subject to whatever notion of "line" happens to be currently in +effect, and is also available as the special variable C<$.>. +See L<perlvar/"$/"> and L<perlvar/"$.">. + +Hint: sometimes appending C<", stopped"> to your message will cause it to make better sense when the string C<"at foo line 123"> is appended. Suppose you are running script "canasta". @@ -860,7 +941,7 @@ produce, respectively /etc/games is no good at canasta line 123. /etc/games is no good, stopped at canasta line 123. -See also C<exit()> and C<warn()>. +See also exit(), warn(), and the Carp module. If LIST is empty and C<$@> already contains a value (typically from a previous eval) that value is reused after appending C<"\t...propagated">. @@ -871,19 +952,42 @@ This is useful for propagating exceptions: If C<$@> is empty then the string C<"Died"> is used. +die() can also be called with a reference argument. If this happens to be +trapped within an eval(), $@ contains the reference. This behavior permits +a more elaborate exception handling implementation using objects that +maintain arbitary state about the nature of the exception. Such a scheme +is sometimes preferable to matching particular string values of $@ using +regular expressions. Here's an example: + + eval { ... ; die Some::Module::Exception->new( FOO => "bar" ) }; + if ($@) { + if (ref($@) && UNIVERSAL::isa($@,"Some::Module::Exception")) { + # handle Some::Module::Exception + } + else { + # handle all other possible exceptions + } + } + +Since perl will stringify uncaught exception messages before displaying +them, you may want to overload stringification operations on such custom +exception objects. See L<overload> for details about that. + You can arrange for a callback to be run just before the C<die()> does its deed, by setting the C<$SIG{__DIE__}> hook. The associated handler will be called with the error text and can change the error message, if it sees fit, by calling C<die()> again. See L<perlvar/$SIG{expr}> for details on setting C<%SIG> entries, and L<"eval BLOCK"> for some examples. -Note that the C<$SIG{__DIE__}> hook is called even inside eval()ed -blocks/strings. If one wants the hook to do nothing in such +Note that the C<$SIG{__DIE__}> hook is currently called even inside +eval()ed blocks/strings! If one wants the hook to do nothing in such situations, put die @_ if $^S; -as the first line of the handler (see L<perlvar/$^S>). +as the first line of the handler (see L<perlvar/$^S>). Because this +promotes action at a distance, this counterintuitive behavior may be fixed +in a future release. =item do BLOCK @@ -892,6 +996,10 @@ sequence of commands indicated by BLOCK. When modified by a loop modifier, executes the BLOCK once before testing the loop condition. (On other statements the loop modifiers test the conditional first.) +C<do BLOCK> does I<not> count as a loop, so the loop control statements +C<next>, C<last>, or C<redo> cannot be used to leave or restart the block. +See L<perlsyn> for alternative strategies. + =item do SUBROUTINE(LIST) A deprecated form of subroutine call. See L<perlsub>. @@ -908,17 +1016,16 @@ is just like scalar eval `cat stat.pl`; -except that it's more efficient and concise, keeps track of the -current filename for error messages, and searches all the B<-I> -libraries if the file isn't in the current directory (see also the @INC -array in L<perlvar/Predefined Names>). It is also different in how -code evaluated with C<do FILENAME> doesn't see lexicals in the enclosing -scope like C<eval STRING> does. It's the same, however, in that it does -reparse the file every time you call it, so you probably don't want to -do this inside a loop. +except that it's more efficient and concise, keeps track of the current +filename for error messages, searches the @INC libraries, and updates +C<%INC> if the file is found. See L<perlvar/Predefined Names> for these +variables. It also differs in that code evaluated with C<do FILENAME> +cannot see lexicals in the enclosing scope; C<eval STRING> does. It's the +same, however, in that it does reparse the file every time you call it, +so you probably don't want to do this inside a loop. If C<do> cannot read the file, it returns undef and sets C<$!> to the -error. If C<do> can read the file but cannot compile it, it +error. If C<do> can read the file but cannot compile it, it returns undef and sets an error message in C<$@>. If the file is successfully compiled, C<do> returns the value of the last expression evaluated. @@ -932,7 +1039,8 @@ file. Manual error checking can be done this way: # read in config files: system first, then user for $file ("/share/prog/defaults.rc", - "$ENV{HOME}/.someprogrc") { + "$ENV{HOME}/.someprogrc") + { unless ($return = do $file) { warn "couldn't parse $file: $@" if $@; warn "couldn't do $file: $!" unless defined $return; @@ -942,6 +1050,8 @@ file. Manual error checking can be done this way: =item dump LABEL +=item dump + This causes an immediate core dump. Primarily this is so that you can use the B<undump> program to turn your core dump into an executable binary after having initialized all your variables at the beginning of the @@ -986,9 +1096,13 @@ element in the hash. (Note: Keys may be C<"0"> or C<"">, which are logically false; you may wish to avoid constructs like C<while ($k = each %foo) {}> for this reason.) -Entries are returned in an apparently random order. When the hash is -entirely read, a null array is returned in list context (which when -assigned produces a FALSE (C<0>) value), and C<undef> in +Entries are returned in an apparently random order. The actual random +order is subject to change in future versions of perl, but it is guaranteed +to be in the same order as either the C<keys()> or C<values()> function +would produce on the same (unmodified) hash. + +When the hash is entirely read, a null array is returned in list context +(which when assigned produces a FALSE (C<0>) value), and C<undef> in scalar context. The next call to C<each()> after that will start iterating again. There is a single iterator for each hash, shared by all C<each()>, C<keys()>, and C<values()> function calls in the program; it can be reset by @@ -1003,7 +1117,7 @@ only in a different order: print "$key=$value\n"; } -See also C<keys()> and C<values()>. +See also C<keys()>, C<values()> and C<sort()>. =item eof FILEHANDLE @@ -1020,11 +1134,11 @@ C<eof(FILEHANDLE)> on it) after end-of-file is reached. Filetypes 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 eof without the parentheses to test -I<EACH> file in a while (E<lt>E<gt>) loop. Examples: +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 eof without the +parentheses to test I<EACH> file in a while (E<lt>E<gt>) loop. Examples: # reset line numbering on each input file while (<>) { @@ -1038,7 +1152,7 @@ I<EACH> file in a while (E<lt>E<gt>) loop. Examples: while (<>) { if (eof()) { # check for end of current file print "--------------\n"; - close(ARGV); # close or break; is needed if we + close(ARGV); # close or last; is needed if we # are reading from the terminal } print; @@ -1107,10 +1221,11 @@ Examples: # a run-time error eval '$answer ='; # sets $@ -When using the C<eval{}> form as an exception trap in libraries, you may -wish not to trigger any C<__DIE__> hooks that user code may have -installed. You can use the C<local $SIG{__DIE__}> construct for this -purpose, as shown in this example: +Due to the current arguably broken state of C<__DIE__> hooks, when using +the C<eval{}> form as an exception trap in libraries, you may wish not +to trigger any C<__DIE__> hooks that user code may have installed. +You can use the C<local $SIG{__DIE__}> construct for this purpose, +as shown in this example: # a very private exception trap for divide-by-zero eval { local $SIG{'__DIE__'}; $answer = $a / $b; }; @@ -1127,6 +1242,9 @@ C<die()> again, which has the effect of changing their error messages: print $@ if $@; # prints "bar lives here" } +Because this promotes action at a distance, this counterintuive behavior +may be fixed in a future release. + With an C<eval()>, you should be especially careful to remember what's being looked at when: @@ -1150,6 +1268,9 @@ normally you I<WOULD> like to use double quotes, except that in this particular situation, you can just use symbolic references instead, as in case 6. +C<eval BLOCK> does I<not> count as a loop, so the loop control statements +C<next>, C<last>, or C<redo> cannot be used to leave or restart the block. + =item exec LIST =item exec PROGRAM LIST @@ -1207,9 +1328,9 @@ shell expanding wildcards or splitting up words with whitespace in them. @args = ( "echo surprise" ); - system @args; # subject to shell escapes + exec @args; # subject to shell escapes # if @args == 1 - system { $args[0] } @args; # safe even with one-arg list + exec { $args[0] } @args; # safe even with one-arg list The first version, the one without the indirect object, ran the I<echo> program, passing it C<"surprise"> an argument. The second version @@ -1224,9 +1345,9 @@ any C<DESTROY> methods in your objects. Returns TRUE if the specified hash key exists in its hash array, even if the corresponding value is undefined. - 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 $array{$key}; + print "Defined\n" if defined $array{$key}; + print "True\n" if $array{$key}; A hash element can be TRUE only if it's defined, and defined if it exists, but the reverse doesn't necessarily hold true. @@ -1234,40 +1355,53 @@ 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: - if (exists $ref->{"A"}{"B"}{$key}) { ... } + 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"}> -C<$ref-E<gt>{"B"}> will spring into existence due to the existence -test for a $key element. This autovivification may be fixed in a later +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 + + undef $ref; + if (exists $ref->{"Some key"}) { } + print $ref; # prints HASH(0x80d3d5c) + +This surprising autovivification in what does not at first--or even +second--glance appear to be an lvalue context may be fixed in a future release. =item exit EXPR -Evaluates EXPR and exits immediately with that value. (Actually, it -calls any defined C<END> routines first, but the C<END> routines may not -abort the exit. Likewise any object destructors that need to be called -are called before exit.) Example: +Evaluates EXPR and exits immediately with that value. Example: $ans = <STDIN>; exit 0 if $ans =~ /^[Xx]/; See also C<die()>. If EXPR is omitted, exits with C<0> status. The only -universally portable values for EXPR are C<0> for success and C<1> for error; -all other values are subject to unpredictable interpretation depending -on the environment in which the Perl program is running. +universally recognized values for EXPR are C<0> for success and C<1> +for error; other values are subject to interpretation depending on the +environment in which the Perl program is running. For example, exiting +69 (EX_UNAVAILABLE) from a I<sendmail> incoming-mail filter will cause +the mailer to return the item undelivered, but that's not true everywhere. -You shouldn't use C<exit()> to abort a subroutine if there's any chance that +Don't use C<exit()> to abort a subroutine if there's any chance that someone might want to trap whatever error happened. Use C<die()> instead, which can be trapped by an C<eval()>. -All C<END{}> blocks are run at exit time. See L<perlsub> for details. +The exit() function does not always exit immediately. It calls any +defined C<END> routines first, but these C<END> routines may not +themselves abort the exit. Likewise any object destructors that need to +be called are called before the real exit. If this is a problem, you +can call C<POSIX:_exit($status)> to avoid END and destructor processing. +See L<perlsub> for details. =item exp EXPR =item exp -Returns I<e> (the natural logarithm base) to the power of EXPR. +Returns I<e> (the natural logarithm base) to the power of EXPR. If EXPR is omitted, gives C<exp($_)>. =item fcntl FILEHANDLE,FUNCTION,SCALAR @@ -1284,22 +1418,23 @@ For example: fcntl($filehandle, F_GETFL, $packed_return_buffer) 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> in numeric context. It is also -exempt from the normal B<-w> warnings on improper numeric -conversions. +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> +in numeric context. It is also exempt from the normal B<-w> warnings +on improper numeric conversions. Note that C<fcntl()> will produce a fatal error if used on a machine that -doesn't implement fcntl(2). +doesn't implement fcntl(2). See the Fcntl module or your fcntl(2) +manpage to learn what functions are available on your system. =item fileno FILEHANDLE -Returns the file descriptor for a filehandle. This is useful for -constructing bitmaps for C<select()> and low-level POSIX tty-handling -operations. If FILEHANDLE is an expression, the value is taken as -an indirect filehandle, generally its name. +Returns the file descriptor for a filehandle, or undefined if the +filehandle is not open. This is mainly useful for constructing +bitmaps for C<select()> and low-level POSIX tty-handling operations. +If FILEHANDLE is an expression, the value is taken as an indirect +filehandle, generally its name. You can use this to find out whether two handles refer to the same underlying descriptor: @@ -1310,18 +1445,23 @@ same underlying descriptor: =item flock FILEHANDLE,OPERATION -Calls flock(2), or an emulation of it, on FILEHANDLE. Returns TRUE for -success, FALSE on failure. Produces a fatal error if used on a machine -that doesn't implement flock(2), fcntl(2) locking, or lockf(3). C<flock()> -is Perl's portable file locking interface, although it locks only entire -files, not records. - -On many platforms (including most versions or clones of Unix), locks -established by C<flock()> are B<merely advisory>. Such discretionary locks -are more flexible, but offer fewer guarantees. This means that files -locked with C<flock()> may be modified by programs that do not also use -C<flock()>. Windows NT and OS/2 are among the platforms which -enforce mandatory locking. See your local documentation for details. +Calls flock(2), or an emulation of it, on FILEHANDLE. Returns TRUE +for success, FALSE on failure. Produces a fatal error if used on a +machine that doesn't implement flock(2), fcntl(2) locking, or lockf(3). +C<flock()> is Perl's portable file locking interface, although it locks +only entire files, not records. + +Two potentially non-obvious but traditional C<flock> semantics are +that it waits indefinitely until the lock is granted, and that its locks +B<merely advisory>. Such discretionary locks are more flexible, but offer +fewer guarantees. This means that files locked with C<flock()> may be +modified by programs that do not also use C<flock()>. See L<perlport>, +your port's specific documentation, or your system-specific local manpages +for details. It's best to assume traditional behavior if you're writing +portable programs. (But if you're not, you should as always feel perfectly +free to write for your own system's idiosyncrasies (sometimes called +"features"). Slavish adherence to portability concerns shouldn't get +in the way of your getting your job done.) OPERATION is one of LOCK_SH, LOCK_EX, or LOCK_UN, possibly combined with LOCK_NB. These constants are traditionally valued 1, 2, 8 and 4, but @@ -1332,12 +1472,12 @@ releases a previously requested lock. If LOCK_NB is added to LOCK_SH or LOCK_EX then C<flock()> will return immediately rather than blocking waiting for the lock (check the return status to see if you got it). -To avoid the possibility of mis-coordination, Perl flushes FILEHANDLE -before (un)locking it. +To avoid the possibility of miscoordination, Perl now flushes FILEHANDLE +before locking or unlocking it. Note that the emulation built with lockf(3) doesn't provide shared locks, and it requires that FILEHANDLE be open with write intent. These -are the semantics that lockf(3) implements. Most (all?) systems +are the semantics that lockf(3) implements. Most if not all systems implement lockf(3) in terms of fcntl(2) locking, though, so the differing semantics shouldn't bite too many people. @@ -1370,44 +1510,37 @@ Here's a mailbox appender for BSD systems. print MBOX $msg,"\n\n"; unlock(); +On systems that support a real flock(), locks are inherited across fork() +calls, whereas those that must resort to the more capricious fcntl() +function lose the locks, making it harder to write servers. + See also L<DB_File> for other flock() examples. =item fork -Does a fork(2) system call. Returns the child pid to the parent process, -C<0> to the child process, or C<undef> if the fork is unsuccessful. +Does a fork(2) system call to create a new process running the +same program at the same point. It returns the child pid to the +parent process, C<0> to the child process, or C<undef> if the fork is +unsuccessful. File descriptors (and sometimes locks on those descriptors) +are shared, while everything else is copied. On most systems supporting +fork(), great care has gone into making it extremely efficient (for +example, using copy-on-write technology on data pages), making it the +dominant paradigm for multitasking over the last few decades. Note: unflushed buffers remain unflushed in both processes, which means you may need to set C<$|> ($AUTOFLUSH in English) or call the C<autoflush()> method of C<IO::Handle> to avoid duplicate output. -If you C<fork()> without ever waiting on your children, you will accumulate -zombies: - - $SIG{CHLD} = sub { wait }; - -There's also the double-fork trick (error checking on -C<fork()> returns omitted); - - unless ($pid = fork) { - unless (fork) { - exec "what you really wanna do"; - die "no exec"; - # ... or ... - ## (some_perl_code_here) - exit 0; - } - exit 0; - } - waitpid($pid,0); - -See also L<perlipc> for more examples of forking and reaping -moribund children. +If you C<fork()> without ever waiting on your children, you will +accumulate zombies. On some systems, you can avoid this by setting +C<$SIG{CHLD}> to C<"IGNORE">. See also L<perlipc> for more examples of +forking and reaping moribund children. Note that if your forked child inherits system file descriptors like STDIN and STDOUT that are actually connected by a pipe or socket, even -if you exit, then the remote server (such as, say, httpd or rsh) won't think -you're done. You should reopen those to F</dev/null> if it's any issue. +if you exit, then the remote server (such as, say, a CGI script or a +backgrounded job launced from a remote shell) won't think you're done. +You should reopen those to F</dev/null> if it's any issue. =item format @@ -1450,10 +1583,11 @@ C<formline()> always returns TRUE. See L<perlform> for other examples. =item getc Returns the next character from the input file attached to FILEHANDLE, -or the undefined value at end of file, or if there was an error. If -FILEHANDLE is omitted, reads from STDIN. This is not particularly -efficient. It cannot be used to get unbuffered single-characters, -however. For that, try something more like: +or the undefined value at end of file, or if there was an error. +If FILEHANDLE is omitted, reads from STDIN. This is not particularly +efficient. However, it cannot be used by itself to fetch single +characters without waiting for the user to hit enter. For that, try +something more like: if ($BSD_STYLE) { system "stty cbreak </dev/tty >/dev/tty 2>&1"; @@ -1475,10 +1609,10 @@ however. For that, try something more like: Determination of whether $BSD_STYLE should be set is left as an exercise to the reader. -The C<POSIX::getattr()> function can do this more portably on systems -purporting POSIX compliance. -See also the C<Term::ReadKey> module from your nearest CPAN site; -details on CPAN can be found on L<perlmod/CPAN>. +The C<POSIX::getattr()> function can do this more portably on +systems purporting POSIX compliance. See also the C<Term::ReadKey> +module from your nearest CPAN site; details on CPAN can be found on +L<perlmodlib/CPAN>. =item getlogin @@ -1606,21 +1740,26 @@ lookup by name, in which case you get the other thing, whatever it is. $name = getgrent(); #etc. -In I<getpw*()> the fields C<$quota>, C<$comment>, and C<$expire> are special -cases in the sense that in many systems they are unsupported. If the -C<$quota> is unsupported, it is an empty scalar. If it is supported, it -usually encodes the disk quota. If the C<$comment> field is unsupported, -it is an empty scalar. If it is supported it usually encodes some -administrative comment about the user. In some systems the $quota -field may be C<$change> or C<$age>, fields that have to do with password -aging. In some systems the C<$comment> field may be C<$class>. The C<$expire> -field, if present, encodes the expiration period of the account or the -password. For the availability and the exact meaning of these fields -in your system, please consult your getpwnam(3) documentation and your -F<pwd.h> file. You can also find out from within Perl which meaning -your C<$quota> and C<$comment> fields have and whether you have the C<$expire> -field by using the C<Config> module and the values C<d_pwquota>, C<d_pwage>, -C<d_pwchange>, C<d_pwcomment>, and C<d_pwexpire>. +In I<getpw*()> the fields C<$quota>, C<$comment>, and C<$expire> are +special cases in the sense that in many systems they are unsupported. +If the C<$quota> is unsupported, it is an empty scalar. If it is +supported, it usually encodes the disk quota. If the C<$comment> +field is unsupported, it is an empty scalar. If it is supported it +usually encodes some administrative comment about the user. In some +systems the $quota field may be C<$change> or C<$age>, fields that have +to do with password aging. In some systems the C<$comment> field may +be C<$class>. The C<$expire> field, if present, encodes the expiration +period of the account or the password. For the availability and the +exact meaning of these fields in your system, please consult your +getpwnam(3) documentation and your F<pwd.h> file. You can also find +out from within Perl what your C<$quota> and C<$comment> fields mean +and whether you have the C<$expire> field by using the C<Config> module +and the values C<d_pwquota>, C<d_pwage>, C<d_pwchange>, C<d_pwcomment>, +and C<d_pwexpire>. Shadow password files are only supported if your +vendor has implemented them in the intuitive fashion that calling the +regular C library routines gets the shadow versions if you're running +under privilege. Those that incorrectly implement a separate library +call are not supported. The C<$members> value returned by I<getgr*()> is a space separated list of the login names of the members of the group. @@ -1634,6 +1773,15 @@ by saying something like: ($a,$b,$c,$d) = unpack('C4',$addr[0]); +The Socket library makes this slightly easier: + + use Socket; + $iaddr = inet_aton("127.1"); # or whatever address + $name = gethostbyaddr($iaddr, AF_INET); + + # or going the other way + $straddr = inet_ntoa($iaddr"); + If you get tired of remembering which element of the return list contains which return value, by-name interfaces are also provided in modules: C<File::stat>, C<Net::hostent>, C<Net::netent>, C<Net::protoent>, C<Net::servent>, @@ -1664,11 +1812,11 @@ Returns the socket option requested, or undef if there is an error. =item glob -Returns the value of EXPR with filename expansions such as the standard Unix shell F</bin/sh> would -do. This is the internal function implementing the C<E<lt>*.cE<gt>> -operator, but you can use it directly. If EXPR is omitted, C<$_> is used. -The C<E<lt>*.cE<gt>> operator is discussed in more detail in -L<perlop/"I/O Operators">. +Returns the value of EXPR with filename expansions such as the +standard Unix shell F</bin/csh> would do. This is the internal function +implementing the C<E<lt>*.cE<gt>> operator, but you can use it directly. +If EXPR is omitted, C<$_> is used. The C<E<lt>*.cE<gt>> operator is +discussed in more detail in L<perlop/"I/O Operators">. =item gmtime EXPR @@ -1681,9 +1829,12 @@ Typically used as follows: gmtime(time); All array elements are numeric, and come straight out of a struct tm. -In particular this means that C<$mon> has the range C<0..11> and C<$wday> has -the range C<0..6> with sunday as day C<0>. Also, C<$year> is the number of -years since 1900, that is, C<$year> is C<123> in year 2023, I<not> simply the last two digits of the year. +In particular this means that C<$mon> has the range C<0..11> and C<$wday> +has the range C<0..6> with sunday as day C<0>. Also, C<$year> is the +number of years since 1900, that is, C<$year> is C<123> in year 2023, +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? If EXPR is omitted, does C<gmtime(time())>. @@ -1694,18 +1845,19 @@ In scalar context, returns the ctime(3) value: Also see the C<timegm()> function provided by the C<Time::Local> module, and the strftime(3) function available via the POSIX module. -This scalar value is B<not> locale dependent, see L<perllocale>, but -instead a Perl builtin. Also see the C<Time::Local> module, and the -strftime(3) and mktime(3) function available via the POSIX module. To +This scalar value is B<not> locale dependent (see L<perllocale>), but +is instead a Perl builtin. Also see the C<Time::Local> module, and the +strftime(3) and mktime(3) functions available via the POSIX module. To get somewhat similar but locale dependent date strings, set up your locale environment variables appropriately (please see L<perllocale>) and try for example: use POSIX qw(strftime); - $now_string = strftime "%a %b %e %H:%M:%S %Y", gmtime; + $now_string = strftime "%a %b %e %H:%M:%S %Y", gmtime; -Note that the C<%a> and C<%b>, the short forms of the day of the week -and the month of the year, may not necessarily be three characters wide. +Note that the C<%a> and C<%b> escapes, which represent the short forms +of the day of the week and the month of the year, may not necessarily +be three characters wide in all locales. =item goto LABEL @@ -1741,13 +1893,12 @@ will be able to tell that this routine was called first. =item grep EXPR,LIST -This is similar in spirit to, but not the same as, grep(1) -and its relatives. In particular, it is not limited to using -regular expressions. +This is similar in spirit to, but not the same as, grep(1) and its +relatives. In particular, it is not limited to using regular expressions. Evaluates the BLOCK or EXPR for each element of LIST (locally setting C<$_> to each element) and returns the list value consisting of those -elements for which the expression evaluated to TRUE. In a scalar +elements for which the expression evaluated to TRUE. In scalar context, returns the number of times the expression was TRUE. @foo = grep(!/^#/, @bar); # weed out comments @@ -1756,14 +1907,14 @@ or equivalently, @foo = grep {!/^#/} @bar; # weed out comments -Note that, because C<$_> is a reference into the list value, it can be used -to modify the elements of the array. While this is useful and -supported, it can cause bizarre results if the LIST is not a named -array. Similarly, grep returns aliases into the original list, -much like the way that a for loop's index variable aliases the list -elements. That is, modifying an element of a list returned by grep -(for example, in a C<foreach>, C<map()> or another C<grep()>) -actually modifies the element in the original list. +Note that, because C<$_> is a reference into the list value, it can +be used to modify the elements of the array. While this is useful and +supported, it can cause bizarre results if the LIST is not a named array. +Similarly, grep returns aliases into the original list, much as a for +loop's index variable aliases the list elements. That is, modifying an +element of a list returned by grep (for example, in a C<foreach>, C<map()> +or another C<grep()>) actually modifies the element in the original list. +This is usually something to be avoided when writing clear code. See also L</map> for an array composed of the results of the BLOCK or EXPR. @@ -1771,9 +1922,9 @@ See also L</map> for an array composed of the results of the BLOCK or EXPR. =item hex -Interprets EXPR as a hex string and returns the corresponding -value. (To convert strings that might start with either 0 or 0x -see L</oct>.) If EXPR is omitted, uses C<$_>. +Interprets EXPR as a hex string and returns the corresponding value. +(To convert strings that might start with either 0, 0x, or 0b, see +L</oct>.) If EXPR is omitted, uses C<$_>. print hex '0xAf'; # prints '175' print hex 'aF'; # same @@ -1789,29 +1940,34 @@ for the package used. See also L</use()>, L<perlmod>, and L<Exporter>. =item index STR,SUBSTR -Returns the position of the first occurrence of SUBSTR in STR at or after -POSITION. If POSITION is omitted, starts searching from the beginning of -the string. The return value is based at C<0> (or whatever you've set the C<$[> -variable to--but don't do that). If the substring is not found, returns -one less than the base, ordinarily C<-1>. +The index function searches for one string within another, but without +the wildcard-like behavior of a full regular-expression pattern match. +It returns the position of the first occurrence of SUBSTR in STR at +or after POSITION. If POSITION is omitted, starts searching from the +beginning of the string. The return value is based at C<0> (or whatever +you've set the C<$[> variable to--but don't do that). If the substring +is not found, returns one less than the base, ordinarily C<-1>. =item int EXPR =item int Returns the integer portion of EXPR. If EXPR is omitted, uses C<$_>. -You should not use this for rounding, because it truncates -towards C<0>, and because machine representations of floating point -numbers can sometimes produce counterintuitive results. Usually C<sprintf()> or C<printf()>, -or the C<POSIX::floor> or C<POSIX::ceil> functions, would serve you better. +You should not use this function for rounding: one because it truncates +towards C<0>, and two because machine representations of floating point +numbers can sometimes produce counterintuitive results. For example, +C<int(-6.725/0.025)> produces -268 rather than the correct -269; that's +because it's really more like -268.99999999999994315658 instead. Usually, +the C<sprintf()>, C<printf()>, or the C<POSIX::floor> and C<POSIX::ceil> +functions will serve you better than will int(). =item ioctl FILEHANDLE,FUNCTION,SCALAR -Implements the ioctl(2) function. You'll probably have to say +Implements the ioctl(2) function. You'll probably first have to say require "ioctl.ph"; # probably in /usr/local/lib/perl/ioctl.ph -first to get the correct function definitions. If F<ioctl.ph> doesn't +to get the correct function definitions. If F<ioctl.ph> doesn't exist or doesn't have the correct definitions you'll have to roll your own, based on your C header files such as F<E<lt>sys/ioctl.hE<gt>>. (There is a Perl script called B<h2ph> that comes with the Perl kit that @@ -1847,19 +2003,18 @@ Thus Perl returns TRUE on success and FALSE on failure, yet you can still easily determine the actual value returned by the operating system: - ($retval = ioctl(...)) || ($retval = -1); + $retval = ioctl(...) || -1; printf "System returned %d\n", $retval; -The special string "C<0> but true" is excempt from B<-w> complaints +The special string "C<0> but true" is exempt from B<-w> complaints about improper numeric conversions. =item join EXPR,LIST -Joins the separate strings of LIST into a single string with -fields separated by the value of EXPR, and returns the string. -Example: +Joins the separate strings of LIST into a single string with fields +separated by the value of EXPR, and returns that new string. Example: - $_ = join(':', $login,$passwd,$uid,$gid,$gcos,$home,$shell); + $rec = join(':', $login,$passwd,$uid,$gid,$gcos,$home,$shell); See L</split>. @@ -1867,9 +2022,11 @@ See L</split>. Returns a list consisting of all the keys of the named hash. (In a scalar context, returns the number of keys.) The keys are returned in -an apparently random order, but it is the same order as either the -C<values()> or C<each()> function produces (given that the hash has not been -modified). As a side effect, it resets HASH's iterator. +an apparently random order. The actual random order is subject to +change in future versions of perl, but it is guaranteed to be the same +order as either the C<values()> or C<each()> function produces (given +that the hash has not been modified). As a side effect, it resets +HASH's iterator. Here is yet another way to print your environment: @@ -1885,7 +2042,7 @@ or how about sorted by key: print $key, '=', $ENV{$key}, "\n"; } -To sort an array by value, you'll need to use a C<sort()> function. +To sort a hash by value, you'll need to use a C<sort()> function. Here's a descending numeric sort of a hash by its values: foreach $key (sort { $hash{$b} <=> $hash{$a} } keys %hash) { @@ -1899,14 +2056,16 @@ an array by assigning a larger number to $#array.) If you say keys %hash = 200; -then C<%hash> will have at least 200 buckets allocated for it--256 of them, in fact, since -it rounds up to the next power of two. These +then C<%hash> will have at least 200 buckets allocated for it--256 of them, +in fact, since it rounds up to the next power of two. These buckets will be retained even if you do C<%hash = ()>, use C<undef %hash> if you want to free the storage while C<%hash> is still in scope. You can't shrink the number of buckets allocated for the hash using C<keys()> in this way (but you needn't worry about doing this by accident, as trying has no effect). +See also C<each()>, C<values()> and C<sort()>. + =item kill LIST Sends a signal to a list of processes. The first element of @@ -1936,6 +2095,10 @@ C<continue> block, if any, is not executed: #... } +C<last> cannot be used to exit a block which returns a value such as +C<eval {}>, C<sub {}> or C<do {}>, and should not be used to exit +a grep() or map() operation. + See also L</continue> for an illustration of how C<last>, C<next>, and C<redo> work. @@ -1945,7 +2108,7 @@ C<redo> work. Returns an lowercased version of EXPR. This is the internal function implementing the C<\L> escape in double-quoted strings. -Respects current C<LC_CTYPE> locale if C<use locale> in force. See L<perllocale>. +Respects current LC_CTYPE locale if C<use locale> in force. See L<perllocale>. If EXPR is omitted, uses C<$_>. @@ -1955,7 +2118,7 @@ If EXPR is omitted, uses C<$_>. Returns the value of EXPR with the first character lowercased. This is the internal function implementing the C<\l> escape in double-quoted strings. -Respects current C<LC_CTYPE> locale if C<use locale> in force. See L<perllocale>. +Respects current LC_CTYPE locale if C<use locale> in force. See L<perllocale>. If EXPR is omitted, uses C<$_>. @@ -1963,30 +2126,32 @@ If EXPR is omitted, uses C<$_>. =item length -Returns the length in bytes of the value of EXPR. If EXPR is -omitted, returns length of C<$_>. +Returns the length in characters of the value of EXPR. If EXPR is +omitted, returns length of C<$_>. Note that this cannot be used on +an entire array or hash to find out how many elements these have. +For that, use C<scalar @array> and C<scalar keys %hash> respectively. =item link OLDFILE,NEWFILE Creates a new filename linked to the old filename. Returns TRUE for -success, FALSE otherwise. +success, FALSE otherwise. =item listen SOCKET,QUEUESIZE Does the same thing that the listen system call does. Returns TRUE if -it succeeded, FALSE otherwise. See example in L<perlipc/"Sockets: Client/Server Communication">. +it succeeded, FALSE otherwise. See the example in L<perlipc/"Sockets: Client/Server Communication">. =item local EXPR +You really probably want to be using C<my()> instead, because C<local()> isn't +what most people think of as "local". See L<perlsub/"Private Variables +via my()"> for details. + A local modifies the listed variables to be local to the enclosing block, file, or eval. If more than one value is listed, the list must be placed in parentheses. See L<perlsub/"Temporary Values via local()"> for details, including issues with tied arrays and hashes. -You really probably want to be using C<my()> instead, because C<local()> isn't -what most people think of as "local". See L<perlsub/"Private Variables -via my()"> for details. - =item localtime EXPR Converts a time as returned by the time function to a 9-element array @@ -1998,9 +2163,12 @@ follows: localtime(time); All array elements are numeric, and come straight out of a struct tm. -In particular this means that C<$mon> has the range C<0..11> and C<$wday> has -the range C<0..6> with sunday as day C<0>. Also, C<$year> is the number of -years since 1900, that is, C<$year> is C<123> in year 2023, and I<not> simply the last two digits of the year. +In particular this means that C<$mon> has the range C<0..11> and C<$wday> +has the range C<0..6> with sunday as day C<0>. Also, C<$year> is the +number of years since 1900, that is, C<$year> is C<123> in year 2023, +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? If EXPR is omitted, uses the current time (C<localtime(time)>). @@ -2016,7 +2184,7 @@ locale environment variables appropriately (please see L<perllocale>) and try for example: use POSIX qw(strftime); - $now_string = strftime "%a %b %e %H:%M:%S %Y", localtime; + $now_string = strftime "%a %b %e %H:%M:%S %Y", localtime; Note that the C<%a> and C<%b>, the short forms of the day of the week and the month of the year, may not necessarily be three characters wide. @@ -2025,8 +2193,17 @@ and the month of the year, may not necessarily be three characters wide. =item log -Returns the natural logarithm (base I<e>) of EXPR. If EXPR is omitted, returns log -of C<$_>. +Returns the natural logarithm (base I<e>) of EXPR. If EXPR is omitted, +returns log of C<$_>. To get the log of another base, use basic algebra: +The base-N log of a number is is equal to the natural log of that number +divided by the natural log of N. For example: + + sub log10 { + my $n = shift; + return log($n)/log(10); + } + +See also L</exp> for the inverse operation. =item lstat FILEHANDLE @@ -2054,6 +2231,8 @@ element) and returns the list value composed of the results of each such evaluation. Evaluates BLOCK or EXPR in a list context, so each element of LIST may produce zero, one, or more elements in the returned value. +In scalar context, returns the total number of elements so generated. + @chars = map(chr, @nums); translates a list of numbers to the corresponding characters. And @@ -2067,17 +2246,25 @@ is just a funny way to write $hash{getkey($_)} = $_; } -Note that, because C<$_> is a reference into the list value, it can be used -to modify the elements of the array. While this is useful and -supported, it can cause bizarre results if the LIST is not a named -array. See also L</grep> for an array composed of those items of the -original list for which the BLOCK or EXPR evaluates to true. +Note that, because C<$_> is a reference into the list value, it can +be used to modify the elements of the array. While this is useful and +supported, it can cause bizarre results if the LIST is not a named array. +Using a regular C<foreach> loop for this purpose would be clearer in +most cases. See also L</grep> for an array composed of those items of +the original list for which the BLOCK or EXPR evaluates to true. =item mkdir FILENAME,MODE -Creates the directory specified by FILENAME, with permissions specified -by MODE (as modified by umask). If it succeeds it returns TRUE, otherwise -it returns FALSE and sets C<$!> (errno). +Creates the directory specified by FILENAME, with permissions +specified by MODE (as modified by C<umask>). If it succeeds it +returns TRUE, otherwise it returns FALSE and sets C<$!> (errno). + +In general, it is better to create directories with permissive MODEs, +and let the user modify that with their C<umask>, than it is to supply +a restrictive MODE and give the user no way to be more permissive. +The exceptions to this rule are when the file or directory should be +kept private (mail files, for instance). The perlfunc(1) entry on +C<umask> discusses the choice of MODE in more detail. =item msgctl ID,CMD,ARG @@ -2137,6 +2324,10 @@ Note that if there were a C<continue> block on the above, it would get executed even on discarded lines. If the LABEL is omitted, the command refers to the innermost enclosing loop. +C<next> cannot be used to exit a block which returns a value such as +C<eval {}>, C<sub {}> or C<do {}>, and should not be used to exit +a grep() or map() operation. + See also L</continue> for an illustration of how C<last>, C<next>, and C<redo> work. @@ -2149,8 +2340,9 @@ See the L</use> function, which C<no> is the opposite of. =item oct Interprets EXPR as an octal string and returns the corresponding -value. (If EXPR happens to start off with C<0x>, interprets it as -a hex string instead.) The following will handle decimal, octal, and +value. (If EXPR happens to start off with C<0x>, interprets it as a +hex string. If EXPR starts off with C<0b>, it is interpreted as a +binary string.) The following will handle decimal, binary, octal, and hex in the standard Perl or C notation: $val = oct($val) if $val =~ /^0/; @@ -2170,7 +2362,8 @@ name of the real filehandle wanted. If EXPR is omitted, the scalar variable of the same name as the FILEHANDLE contains the filename. (Note that lexical variables--those declared with C<my()>--will not work for this purpose; so if you're using C<my()>, specify EXPR in your call -to open.) +to open.) See L<perlopentut> for a kinder, gentler explanation of opening +files. If the filename begins with C<'E<lt>'> or nothing, the file is opened for input. If the filename begins with C<'E<gt>'>, the file is truncated and opened for @@ -2181,7 +2374,8 @@ you want both read and write access to the file; thus C<'+E<lt>'> is almost always preferred for read/write updates--the C<'+E<gt>'> mode would clobber the file first. You can't usually use either read-write mode for updating textfiles, since they have variable length records. See the B<-i> -switch in L<perlrun> for a better approach. +switch in L<perlrun> for a better approach. The file is created with +permissions of C<0666> modified by the process' C<umask> value. The prefix and the filename may be separated with spaces. These various prefixes correspond to the fopen(3) modes of C<'r'>, C<'r+'>, C<'w'>, @@ -2189,7 +2383,8 @@ C<'w+'>, C<'a'>, and C<'a+'>. If the filename begins with C<'|'>, the filename is interpreted as a command to which output is to be piped, and if the filename ends with a -C<'|'>, the filename is interpreted See L<perlipc/"Using open() for IPC"> +C<'|'>, the filename is interpreted as a command which pipes output to +us. See L<perlipc/"Using open() for IPC"> for more examples of this. (You are not allowed to C<open()> to a command that pipes both in I<and> out, but see L<IPC::Open2>, L<IPC::Open3>, and L<perlipc/"Bidirectional Communication"> for alternatives.) @@ -2290,7 +2485,6 @@ STDERR: print STDOUT "stdout 2\n"; print STDERR "stderr 2\n"; - If you specify C<'E<lt>&=N'>, where C<N> is a number, then Perl will do an equivalent of C's C<fdopen()> of that file descriptor; this is more parsimonious of file descriptors. For example: @@ -2320,7 +2514,9 @@ See L<perlipc/"Safe Pipe Opens"> for more examples of this. NOTE: On any operation that may do a fork, any unflushed buffers remain unflushed in both processes, which means you may need to set C<$|> to -avoid duplicate output. +avoid duplicate output. On systems that support a close-on-exec flag on +files, the flag will be set for the newly opened file descriptor as +determined by the value of $^F. See L<perlvar/$^F>. Closing any piped filehandle causes the parent process to wait for the child to finish, and returns the status value in C<$?>. @@ -2370,7 +2566,7 @@ them, and automatically close whenever and however you leave that scope: $first; # Or here. } -See L</seek()> for some details about mixing reading and writing. +See L</seek> for some details about mixing reading and writing. =item opendir DIRHANDLE,EXPR @@ -2392,8 +2588,10 @@ returning the string containing the structure. The TEMPLATE is a sequence of characters that give the order and type of values, as follows: + a A string with arbitrary binary data, will be null padded. A An ascii string, will be space padded. - a An ascii string, will be null padded. + Z A null terminated (asciz) string, will be null padded. + b A bit string (ascending bit order, like vec()). B A bit string (descending bit order). h A hex string (low nybble first). @@ -2409,7 +2607,7 @@ follows: i A signed integer value. I An unsigned integer value. - (This 'integer' is _at_least_ 32 bits wide. Its exact + (This 'integer' is _at least_ 32 bits wide. Its exact size depends on what a local C compiler calls 'int', and may even be larger than the 'long' described in the next item.) @@ -2426,6 +2624,12 @@ follows: (These 'shorts' and 'longs' are _exactly_ 16 bits and _exactly_ 32 bits, respectively.) + q A signed quad (64-bit) value. + Q An unsigned quad value. + (Available only if your system supports 64-bit integer values + _and_ if Perl has been compiled to support those. + Causes a fatal error otherwise.) + f A single-precision float in the native format. d A double-precision float in the native format. @@ -2443,36 +2647,107 @@ follows: X Back up a byte. @ Null fill to absolute position. +The following rules apply: + +=over 8 + +=item * + Each letter may optionally be followed by a number giving a repeat -count. With all types except C<"a">, C<"A">, 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. The C<"a"> and C<"A"> -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, but C<"a"> does not.) Likewise, the C<"b"> and C<"B"> -fields pack a string that many bits long. The C<"h"> and C<"H"> fields pack a -string that many nybbles long. 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"> 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>. -Real numbers (floats and doubles) are -in the native machine format only; due to the multiplicity of floating -formats around, and the lack of a standard "network" representation, no -facility for interchange has been made. This means that packed floating -point data written on one machine may not be readable on another - even if -both use IEEE floating point arithmetic (as the endian-ness of the memory -representation is not part of the IEEE spec). Note that Perl uses doubles -internally for all numeric calculation, and converting from double into -float and thence back to double again will lose precision (i.e., -C<unpack("f", pack("f", $foo)>) will not in general equal C<$foo>). +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. + +=item * + +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. + +=item * + +Likewise, the C<"b"> and C<"B"> fields pack a string that many bits long. + +=item * + +The C<"h"> and C<"H"> fields pack a string that many nybbles long. + +=item * + +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>. + +=item * + +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 0x87654321 (2271560481 decimal) be ordered natively +(arranged in and handled by the CPU registers) into bytes as + + 0x12 0x34 0x56 0x78 # little-endian + 0x78 0x56 0x34 0x12 # big-endian + +Basically, the Intel, Alpha, and VAX CPUs and little-endian, while +everybody else, for example Motorola m68k/88k, PPC, Sparc, HP PA, +Power, and Cray are big-endian. MIPS can be either: Digital used it +in little-endian mode, SGI uses it in big-endian mode. + +The names `big-endian' and `little-endian' are joking references to +the classic "Gulliver's Travels" (via the paper "On Holy Wars and a +Plea for Peace" by Danny Cohen, USC/ISI IEN 137, April 1, 1980) and +the egg-eating habits of the lilliputs. + +Some systems may even have weird byte orders such as + + 0x56 0x78 0x12 0x34 + 0x34 0x12 0x78 0x56 + +You can see your system's preference with + + print join(" ", map { sprintf "%#02x", $_ } + unpack("C*",pack("L",0x12345678))), "\n"; + +The byteorder on the platform where Perl was built is also available +via L<Config>: + + use Config; + print $Config{byteorder}, "\n"; + +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. + +=item * + +Real numbers (floats and doubles) are in the native machine format only; +due to the multiplicity of floating formats around, and the lack of a +standard "network" representation, no facility for interchange has been +made. This means that packed floating point data written on one machine +may not be readable on another - even if both use IEEE floating point +arithmetic (as the endian-ness of the memory representation is not part +of the IEEE spec). + +Note that Perl uses doubles internally for all numeric calculation, and +converting from double into float and thence back to double again will +lose precision (i.e., C<unpack("f", pack("f", $foo)>) will not in general +equal C<$foo>). + +=back Examples: - $foo = pack("cccc",65,66,67,68); + $foo = pack("CCCC",65,66,67,68); # foo eq "ABCD" - $foo = pack("c4",65,66,67,68); + $foo = pack("C4",65,66,67,68); # same thing $foo = pack("ccxxcc",65,66,67,68); @@ -2494,29 +2769,38 @@ Examples: $foo = pack("i9pl", gmtime); # a real struct tm (on my system anyway) + $utmp_template = "Z8 Z8 Z16 L"; + $utmp = pack($utmp_template, @utmp1); + # a struct utmp (BSDish) + + @utmp2 = unpack($utmp_template, $utmp); + # "@utmp1" eq "@utmp2" + sub bintodec { unpack("N", pack("B32", substr("0" x 32 . shift, -32))); } -The same template may generally also be used in the unpack function. +The same template may generally also be used in unpack(). =item package =item package NAMESPACE Declares the compilation unit as being in the given namespace. The scope -of the package declaration is from the declaration itself through the end of -the enclosing block (the same scope as the C<local()> operator). All further -unqualified dynamic identifiers will be in this namespace. A package -statement affects only dynamic variables--including those you've used -C<local()> on--but I<not> lexical variables created with C<my()>. Typically it -would be the first declaration in a file to be included by the C<require> -or C<use> operator. You can switch into a package in more than one place; -it merely influences which symbol table is used by the compiler for the -rest of that block. You can refer to variables and filehandles in other -packages by prefixing the identifier with the package name and a double -colon: C<$Package::Variable>. If the package name is null, the C<main> -package as assumed. That is, C<$::sail> is equivalent to C<$main::sail>. +of the package declaration is from the declaration itself through the end +of the enclosing block, file, or eval (the same as the C<my()> operator). +All further unqualified dynamic identifiers will be in this namespace. +A package statement affects only dynamic variables--including those +you've used C<local()> on--but I<not> lexical variables, which are created +with C<my()>. Typically it would be the first declaration in a file to +be included by the C<require> or C<use> operator. You can switch into a +package in more than one place; it merely influences which symbol table +is used by the compiler for the rest of that block. You can refer to +variables and filehandles in other packages by prefixing the identifier +with the package name and a double colon: C<$Package::Variable>. +If the package name is null, the C<main> package as assumed. That is, +C<$::sail> is equivalent to C<$main::sail> (as well as to C<$main'sail>, +still seen in older code). If NAMESPACE is omitted, then there is no current package, and all identifiers must be fully qualified or lexicals. This is stricter @@ -2536,19 +2820,22 @@ after each command, depending on the application. See L<IPC::Open2>, L<IPC::Open3>, and L<perlipc/"Bidirectional Communication"> for examples of such things. +On systems that support a close-on-exec flag on files, the flag will be set +for the newly opened file descriptors as determined by the value of $^F. +See L<perlvar/$^F>. + =item pop ARRAY =item pop Pops and returns the last value of the array, shortening the array by -1. Has a similar effect to +one element. Has a similar effect to $tmp = $ARRAY[$#ARRAY--]; If there are no elements in the array, returns the undefined value. -If ARRAY is omitted, pops the -C<@ARGV> array in the main program, and the C<@_> array in subroutines, just -like C<shift()>. +If ARRAY is omitted, pops the C<@ARGV> array in the main program, and +the C<@_> array in subroutines, just like C<shift()>. =item pos SCALAR @@ -2568,20 +2855,20 @@ L<perlop>. Prints a string or a comma-separated list of strings. Returns TRUE if successful. FILEHANDLE may be a scalar variable name, in which case -the variable contains the name of or a reference to the filehandle, thus introducing one -level of indirection. (NOTE: If FILEHANDLE is a variable and the next -token is a term, it may be misinterpreted as an operator unless you -interpose a C<+> or put parentheses around the arguments.) If FILEHANDLE is -omitted, prints by default to standard output (or to the last selected -output channel--see L</select>). If LIST is also omitted, prints C<$_> to -the currently selected output channel. To set the default output channel to something other than -STDOUT use the select operation. Note that, because print takes a -LIST, anything in the LIST is evaluated in list context, and any -subroutine that you call will have one or more of its expressions -evaluated in list context. Also be careful not to follow the print -keyword with a left parenthesis unless you want the corresponding right -parenthesis to terminate the arguments to the print--interpose a C<+> or -put parentheses around all the arguments. +the variable contains the name of or a reference to the filehandle, thus +introducing one level of indirection. (NOTE: If FILEHANDLE is a variable +and the next token is a term, it may be misinterpreted as an operator +unless you interpose a C<+> or put parentheses around the arguments.) +If FILEHANDLE is omitted, prints by default to standard output (or to the +last selected output channel--see L</select>). If LIST is also omitted, +prints C<$_> to the currently selected output channel. To set the default +output channel to something other than STDOUT use the select operation. +Note that, because print takes a LIST, anything in the LIST is evaluated +in list context, and any subroutine that you call will have one or +more of its expressions evaluated in list context. Also be careful +not to follow the print keyword with a left parenthesis unless you want +the corresponding right parenthesis to terminate the arguments to the +print--interpose a C<+> or put parentheses around all the arguments. Note that if you're storing FILEHANDLES in an array or other expression, you will have to use a block returning its value instead: @@ -2609,12 +2896,12 @@ Returns the prototype of a function as a string (or C<undef> if the function has no prototype). FUNCTION is a reference to, or the name of, the function whose prototype you want to retrieve. -If FUNCTION is a string starting with C<CORE::>, the rest is taken as -a name for Perl builtin. If builtin is not I<overridable> (such as +If FUNCTION is a string starting with C<CORE::>, the rest is taken as a +name for Perl builtin. If the builtin is not I<overridable> (such as C<qw//>) or its arguments cannot be expressed by a prototype (such as -C<system()>) - in other words, the builtin does not behave like a Perl -function - returns C<undef>. Otherwise, the string describing the -equivalent prototype is returned. +C<system()>) returns C<undef> because the builtin does not really behave +like a Perl function. Otherwise, the string describing the equivalent +prototype is returned. =item push ARRAY,LIST @@ -2638,7 +2925,7 @@ but is more efficient. Returns the new number of elements in the array. =item qw/STRING/ -Generalized quotes. See L<perlop>. +Generalized quotes. See L<perlop/"Regexp Quote-Like Operators">. =item quotemeta EXPR @@ -2695,10 +2982,17 @@ C<chdir()> there, it would have been testing the wrong file. =item readline EXPR -Reads from the filehandle whose typeglob is contained in EXPR. In scalar context, a single line -is read and returned. In list context, reads until end-of-file is -reached and returns a list of lines (however you've defined lines -with C<$/> or C<$INPUT_RECORD_SEPARATOR>). +Reads from the filehandle whose typeglob is contained in EXPR. In scalar +context, each call reads and returns the next line, until end-of-file is +reached, whereupon the subsequent call returns undef. In list context, +reads until end-of-file is reached and returns a list of lines. Note that +the notion of "line" used here is however you may have defined it +with C<$/> or C<$INPUT_RECORD_SEPARATOR>). See L<perlvar/"$/">. + +When C<$/> is set to C<undef>, when readline() is in scalar +context (i.e. file slurp mode), and when an empty file is read, it +returns C<''> the first time, followed by C<undef> subsequently. + This is the internal function implementing the C<E<lt>EXPRE<gt>> operator, but you can use it directly. The C<E<lt>EXPRE<gt>> operator is discussed in more detail in L<perlop/"I/O Operators">. @@ -2726,7 +3020,7 @@ This is the internal function implementing the C<qx/EXPR/> operator, but you can use it directly. The C<qx/EXPR/> operator is discussed in more detail in L<perlop/"I/O Operators">. -=item recv SOCKET,SCALAR,LEN,FLAGS +=item recv SOCKET,SCALAR,LENGTH,FLAGS Receives a message on a socket. Attempts to receive LENGTH bytes of data into variable SCALAR from the specified SOCKET filehandle. @@ -2763,6 +3057,10 @@ themselves about what was just input: print; } +C<redo> cannot be used to retry a block which returns a value such as +C<eval {}>, C<sub {}> or C<do {}>, and should not be used to exit +a grep() or map() operation. + See also L</continue> for an illustration of how C<last>, C<next>, and C<redo> work. @@ -2788,16 +3086,24 @@ name is returned instead. You can think of C<ref()> as a C<typeof()> operator. if (ref($r) eq "HASH") { print "r is a reference to a hash.\n"; } - if (!ref($r)) { + unless (ref($r)) { print "r is not a reference at all.\n"; } + if (UNIVERSAL::isa($r, "HASH")) { # for subclassing + print "r is a reference to something that isa hash.\n"; + } See also L<perlref>. =item rename OLDNAME,NEWNAME -Changes the name of a file. Returns C<1> for success, C<0> otherwise. Will -not work across file system boundaries. +Changes the name of a file. Returns C<1> for success, C<0> otherwise. +Behavior of this function varies wildly depending on your system +implementation. For example, it will usually not work across file system +boundaries, even though the system I<mv> command sometimes compensates +for this. Other restrictions include whether it works on directories, +open files, or pre-existing files. Check L<perlport> and either the +rename(2) manpage or equivalent system documentation for details. =item require EXPR @@ -2880,12 +3186,13 @@ only variables or searches in the current package. Always returns reset 'X'; # reset all X variables reset 'a-z'; # reset lower case variables - reset; # just reset ?? searches + reset; # just reset ?one-time? searches Resetting C<"A-Z"> is not recommended because you'll wipe out your -C<@ARGV> and C<@INC> arrays and your C<%ENV> hash. Resets only package variables--lexical variables -are unaffected, but they clean themselves up on scope exit anyway, -so you'll probably want to use them instead. See L</my>. +C<@ARGV> and C<@INC> arrays and your C<%ENV> hash. Resets only package +variables--lexical variables are unaffected, but they clean themselves +up on scope exit anyway, so you'll probably want to use them instead. +See L</my>. =item return EXPR @@ -2895,29 +3202,30 @@ Returns from a subroutine, C<eval()>, or C<do FILE> with the value given in EXPR. Evaluation of EXPR may be in list, scalar, or void context, depending on how the return value will be used, and the context may vary from one execution to the next (see C<wantarray()>). If no EXPR -is given, returns an empty list in list context, an undefined value in -scalar context, or nothing in a void context. +is given, returns an empty list in list context, the undefined value in +scalar context, and (of course) nothing at all in a void context. -(Note that in the absence of a return, a subroutine, eval, or do FILE -will automatically return the value of the last expression evaluated.) +(Note that in the absence of a explicit C<return>, a subroutine, eval, +or do FILE will automatically return the value of the last expression +evaluated.) =item reverse LIST In list context, returns a list value consisting of the elements of LIST in the opposite order. In scalar context, concatenates the -elements of LIST, and returns a string value consisting of those bytes, -but in the opposite order. +elements of LIST and returns a string value with all characters +in the opposite order. print reverse <>; # line tac, last line first undef $/; # for efficiency of <> - print scalar reverse <>; # byte tac, last line tsrif + print scalar reverse <>; # character tac, last line tsrif This operator is also handy for inverting a hash, although there are some caveats. If a value is duplicated in the original hash, only one of those can be represented as a key in the inverted hash. Also, this has to unwind one hash and build a whole new one, which may take some time -on a large hash. +on a large hash, such as from a DBM file. %by_name = reverse %by_address; # Invert the hash @@ -2930,7 +3238,7 @@ C<readdir()> routine on DIRHANDLE. =item rindex STR,SUBSTR -Works just like index except that it returns the position of the LAST +Works just like index() except that it returns the position of the LAST occurrence of SUBSTR in STR. If POSITION is specified, returns the last occurrence at or before that position. @@ -2954,11 +3262,27 @@ of EXPR. @counts = ( scalar @a, scalar @b, scalar @c ); There is no equivalent operator to force an expression to -be interpolated in list context because it's in practice never +be interpolated in list context because in practice, this is never needed. If you really wanted to do so, however, you could use the construction C<@{[ (some expression) ]}>, but usually a simple C<(some expression)> suffices. +Since C<scalar> is a unary operator, if you accidentally use for EXPR a +parenthesized list, this behaves as a scalar comma expression, evaluating +all but the last element in void context and returning the final element +evaluated in scalar context. This is seldom what you want. + +The following single statement: + + print uc(scalar(&foo,$bar)),$baz; + +is the moral equivalent of these two: + + &foo; + print(uc($bar),$baz); + +See L<perlop> for more details on unary operators and the comma operator. + =item seek FILEHANDLE,POSITION,WHENCE Sets FILEHANDLE's position, just like the C<fseek()> call of C<stdio()>. @@ -2973,10 +3297,10 @@ If you want to position file for C<sysread()> or C<syswrite()>, don't use C<seek()> -- buffering makes its effect on the file's system position unpredictable and non-portable. Use C<sysseek()> instead. -On some systems you have to do a seek whenever you switch between reading -and writing. Amongst other things, this may have the effect of calling -stdio's clearerr(3). A WHENCE of C<1> (C<SEEK_CUR>) is useful for not moving -the file position: +Due to the rules and rigors of ANSI C, on some systems you have to do a +seek whenever you switch between reading and writing. Amongst other +things, this may have the effect of calling stdio's clearerr(3). +A WHENCE of C<1> (C<SEEK_CUR>) is useful for not moving the file position: seek(TEST,0,1); @@ -3123,7 +3447,7 @@ Sends a message on a socket. Takes the same flags as the system call of the same name. On unconnected sockets you must specify a destination to send TO, in which case it does a C C<sendto()>. Returns the number of characters sent, or the undefined value if there is an -error. +error. The C system call sendmsg(2) is currently unimplemented. See L<perlipc/"UDP: Message Passing"> for examples. =item setpgrp PID,PGRP @@ -3132,7 +3456,7 @@ Sets the current process group for the specified PID, C<0> for the current process. Will produce a fatal error if used on a machine that doesn't implement setpgrp(2). If the arguments are omitted, it defaults to C<0,0>. Note that the POSIX version of C<setpgrp()> does not accept any -arguments, so only setpgrp C<0,0> is portable. +arguments, so only C<setpgrp(0,0)> is portable. See also C<POSIX::setsid()>. =item setpriority WHICH,WHO,PRIORITY @@ -3188,7 +3512,8 @@ detaching from it. When reading, VAR must be a variable that will hold the data read. When writing, if STRING is too long, only SIZE bytes are used; if STRING is too short, nulls are written to fill out SIZE bytes. Return TRUE if successful, or FALSE if there is an error. -See also C<IPC::SysV> documentation. +See also C<IPC::SysV> documentation and the C<IPC::Shareable> module +from CPAN. =item shutdown SOCKET,HOW @@ -3235,7 +3560,7 @@ busy multitasking system. For delays of finer granularity than one second, you may use Perl's C<syscall()> interface to access setitimer(2) if your system supports it, -or else see L</select()> above. +or else see L</select> above. See also the POSIX module's C<sigpause()> function. @@ -3244,7 +3569,7 @@ See also the POSIX module's C<sigpause()> function. Opens a socket of the specified kind and attaches it to filehandle SOCKET. DOMAIN, TYPE, and PROTOCOL are specified the same as for the system call of the same name. You should "C<use Socket;>" first to get -the proper definitions imported. See the example in L<perlipc/"Sockets: Client/Server Communication">. +the proper definitions imported. See the examples in L<perlipc/"Sockets: Client/Server Communication">. =item socketpair SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL @@ -3583,14 +3908,19 @@ See L<perllocale>. =item sqrt Return the square root of EXPR. If EXPR is omitted, returns square -root of C<$_>. +root of C<$_>. Only works on non-negative operands, unless you've +loaded the standard Math::Complex module. + + use Math::Complex; + print sqrt(-2); # prints 1.4142135623731i =item srand EXPR =item srand Sets the random number seed for the C<rand()> operator. If EXPR is -omitted, uses a semi-random value based on the current time and process +omitted, uses a semi-random value supplied by the kernel (if it supports +the F</dev/urandom> device) or based on the current time and process ID, among other things. In versions of Perl prior to 5.004 the default seed was just the current C<time()>. This isn't a particularly good seed, so many old programs supply their own seed value (often C<time ^ $$> or @@ -3672,10 +4002,26 @@ last stat or filetest are returned. Example: (This works on machines only for which the device number is negative under NFS.) +Because the mode contains both the file type and its permissions, you +should mask off the file type portion and (s)printf using a C<"%o"> +if you want to see the real permissions. + + $mode = (stat($filename))[2]; + printf "Permissions are %04o\n", $mode & 07777; + + In scalar context, C<stat()> returns a boolean value indicating success or failure, and, if successful, sets the information associated with the special filehandle C<_>. +The File::stat module provides a convenient, by-name access mechanism: + + use File::stat; + $sb = stat($filename); + printf "File is %s, size is %s, perm %04o, mtime %s\n", + $filename, $sb->size, $sb->mode & 07777, + scalar localtime $sb->mtime; + =item study SCALAR =item study @@ -3701,9 +4047,9 @@ before any line containing a certain pattern: while (<>) { study; - print ".IX foo\n" if /\bfoo\b/; - print ".IX bar\n" if /\bbar\b/; - print ".IX blurfl\n" if /\bblurfl\b/; + print ".IX foo\n" if /\bfoo\b/; + print ".IX bar\n" if /\bbar\b/; + print ".IX blurfl\n" if /\bblurfl\b/; # ... print; } @@ -3764,16 +4110,16 @@ If you specify a substring that is partly outside the string, the part within the string is returned. If the substring is totally outside the string a warning is produced. -You can use the C<substr()> function -as an lvalue, in which case EXPR must be an lvalue. If you assign -something shorter than LEN, the string will shrink, and if you assign -something longer than LEN, the string will grow to accommodate it. To -keep the string the same length you may need to pad or chop your value -using C<sprintf()>. +You can use the substr() function as an lvalue, in which case EXPR +must itself be an lvalue. If you assign something shorter than LEN, +the string will shrink, and if you assign something longer than LEN, +the string will grow to accommodate it. To keep the string the same +length you may need to pad or chop your value using C<sprintf()>. -An alternative to using C<substr()> as an lvalue is to specify the +An alternative to using substr() as an lvalue is to specify the replacement string as the 4th argument. This allows you to replace -parts of the EXPR and return what was there before in one operation. +parts of the EXPR and return what was there before in one operation, +just as you can with splice(). =item symlink OLDFILE,NEWFILE @@ -3782,7 +4128,7 @@ Returns C<1> for success, C<0> otherwise. On systems that don't support symbolic links, produces a fatal error at run time. To check for that, use eval: - $symlink_exists = eval { symlink("",""); 1 }; + $symlink_exists = eval { symlink("",""); 1 }; =item syscall LIST @@ -3833,44 +4179,35 @@ system-dependent; they are available via the standard module C<Fcntl>. For historical reasons, some values work on almost every system supported by perl: zero means read-only, one means write-only, and two means read/write. We know that these values do I<not> work under -OS/390 Unix and on the Macintosh; you probably don't want to use them -in new code. +OS/390 & VM/ESA Unix and on the Macintosh; you probably don't want to +use them in new code. If the file named by FILENAME does not exist and the C<open()> call creates it (typically because MODE includes the C<O_CREAT> flag), then the value of PERMS specifies the permissions of the newly created file. If you omit the PERMS argument to C<sysopen()>, Perl uses the octal value C<0666>. These permission values need to be in octal, and are modified by your -process's current C<umask>. The C<umask> value is a number representing -disabled permissions bits--if your C<umask> were C<027> (group can't write; -others can't read, write, or execute), then passing C<sysopen()> C<0666> would -create a file with mode C<0640> (C<0666 &~ 027> is C<0640>). - -If you find this C<umask()> talk confusing, here's some advice: supply a -creation mode of C<0666> for regular files and one of C<0777> for directories -(in C<mkdir()>) and executable files. This gives users the freedom of -choice: if they want protected files, they might choose process umasks -of C<022>, C<027>, or even the particularly antisocial mask of C<077>. Programs -should rarely if ever make policy decisions better left to the user. -The exception to this is when writing files that should be kept private: -mail files, web browser cookies, I<.rhosts> files, and so on. In short, -seldom if ever use C<0644> as argument to C<sysopen()> because that takes -away the user's option to have a more permissive umask. Better to omit it. +process's current C<umask>. + +You should seldom if ever use C<0644> as argument to C<sysopen()>, because +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. -The C<IO::File> module provides a more object-oriented approach, if you're -into that kind of thing. +See L<perlopentut> for a kinder, gentler explanation of opening files. =item sysread FILEHANDLE,SCALAR,LENGTH,OFFSET =item sysread FILEHANDLE,SCALAR,LENGTH Attempts to read LENGTH bytes of data into variable SCALAR from the -specified FILEHANDLE, using the system call read(2). It bypasses -stdio, so mixing this with other kinds of reads, C<print()>, C<write()>, -C<seek()>, or C<tell()> can cause confusion because stdio usually buffers -data. Returns the number of bytes actually read, C<0> at end of file, -or undef if there was an error. SCALAR will be grown or shrunk so that -the last byte actually read is the last byte of the scalar after the read. +specified FILEHANDLE, using the system call read(2). It bypasses stdio, +so mixing this with other kinds of reads, C<print()>, C<write()>, +C<seek()>, C<tell()>, or C<eof()> can cause confusion because stdio +usually buffers data. Returns the number of bytes actually read, C<0> +at end of file, or undef if there was an error. SCALAR will be grown or +shrunk so that the last byte actually read is the last byte of the +scalar after the read. An OFFSET may be specified to place the read data at some place in the string other than the beginning. A negative OFFSET specifies @@ -3879,17 +4216,21 @@ string. A positive OFFSET greater than the length of SCALAR results in the string being padded to the required size with C<"\0"> bytes before the result of the read is appended. +There is no syseof() function, which is ok, since eof() doesn't work +very well on device files (like ttys) anyway. Use sysread() and check +for a return value for 0 to decide whether you're done. + =item sysseek FILEHANDLE,POSITION,WHENCE Sets FILEHANDLE's system position using the system call lseek(2). It bypasses stdio, so mixing this with reads (other than C<sysread()>), -C<print()>, C<write()>, C<seek()>, or C<tell()> may cause confusion. FILEHANDLE may -be an expression whose value gives the name of the filehandle. The -values for WHENCE are C<0> to set the new position to POSITION, C<1> to set -the it to the current position plus POSITION, and C<2> to set it to EOF -plus POSITION (typically negative). For WHENCE, you may use the -constants C<SEEK_SET>, C<SEEK_CUR>, and C<SEEK_END> from either the C<IO::Seekable> -or the POSIX module. +C<print()>, C<write()>, C<seek()>, C<tell()>, or C<eof()> may cause +confusion. FILEHANDLE may be an expression whose value gives the name +of the filehandle. The values for WHENCE are C<0> to set the new +position to POSITION, C<1> to set the it to the current position plus +POSITION, and C<2> to set it to EOF plus POSITION (typically negative). +For WHENCE, you may use the constants C<SEEK_SET>, C<SEEK_CUR>, and +C<SEEK_END> from either the C<IO::Seekable> or the POSIX module. Returns the new position, or the undefined value on failure. A position of zero is returned as the string "C<0> but true"; thus C<sysseek()> returns @@ -3900,7 +4241,7 @@ the new position. =item system PROGRAM LIST -Does exactly the same thing as "C<exec LIST>" except that a fork is done +Does exactly the same thing as "C<exec LIST>", except that a fork is done first, and the parent process waits for the child process to complete. Note that argument processing varies depending on the number of arguments. If there is more than one argument in LIST, or if LIST is @@ -3944,14 +4285,17 @@ See L<perlop/"`STRING`"> and L</exec> for details. =item syswrite FILEHANDLE,SCALAR,LENGTH +=item syswrite FILEHANDLE,SCALAR + Attempts to write LENGTH bytes of data from variable SCALAR to the -specified FILEHANDLE, using the system call write(2). It bypasses +specified FILEHANDLE, using the system call write(2). If LENGTH is +not specified, writes whole SCALAR. It bypasses stdio, so mixing this with reads (other than C<sysread())>, C<print()>, -C<write()>, C<seek()>, or C<tell()> may cause confusion because stdio usually -buffers data. Returns the number of bytes actually written, or C<undef> -if there was an error. If the LENGTH is greater than the available -data in the SCALAR after the OFFSET, only as much data as is available -will be written. +C<write()>, C<seek()>, C<tell()>, or C<eof()> may cause confusion +because stdio usually buffers data. Returns the number of bytes +actually written, or C<undef> if there was an error. If the LENGTH is +greater than the available data in the SCALAR after the OFFSET, only as +much data as is available will be written. An OFFSET may be specified to write the data from some part of the string other than the beginning. A negative OFFSET specifies writing @@ -3964,7 +4308,9 @@ case the SCALAR is empty you can use OFFSET but only zero offset. Returns the current position for FILEHANDLE. FILEHANDLE may be an expression whose value gives the name of the actual filehandle. If -FILEHANDLE is omitted, assumes the file last read. +FILEHANDLE is omitted, assumes the file last read. + +There is no C<systell()> function. Use C<sysseek(FH, 0, 1)> for that. =item telldir DIRHANDLE @@ -3979,11 +4325,11 @@ This function binds a variable to a package class that will provide the implementation for the variable. VARIABLE is the name of the variable to be enchanted. CLASSNAME is the name of a class implementing objects of correct type. Any additional arguments are passed to the "C<new()>" -method of the class (meaning C<TIESCALAR>, C<TIEARRAY>, or C<TIEHASH>). -Typically these are arguments such as might be passed to the C<dbm_open()> -function of C. The object returned by the "C<new()>" method is also -returned by the C<tie()> function, which would be useful if you want to -access other methods in CLASSNAME. +method of the class (meaning C<TIESCALAR>, C<TIEHANDLE>, C<TIEARRAY>, +or C<TIEHASH>). Typically these are arguments such as might be passed +to the C<dbm_open()> function of C. The object returned by the "C<new()>" +method is also returned by the C<tie()> function, which would be useful +if you want to access other methods in CLASSNAME. Note that functions such as C<keys()> and C<values()> may return huge lists when used on large objects, like DBM files. You may prefer to use the @@ -4000,34 +4346,58 @@ C<each()> function to iterate over such. Example: A class implementing a hash should have the following methods: TIEHASH classname, LIST - DESTROY this FETCH this, key STORE this, key, value DELETE this, key + CLEAR this EXISTS this, key FIRSTKEY this NEXTKEY this, lastkey + DESTROY this A class implementing an ordinary array should have the following methods: TIEARRAY classname, LIST - DESTROY this FETCH this, key STORE this, key, value - [others TBD] + FETCHSIZE this + STORESIZE this, count + CLEAR this + PUSH this, LIST + POP this + SHIFT this + UNSHIFT this, LIST + SPLICE this, offset, length, LIST + EXTEND this, count + DESTROY this + +A class implementing a file handle should have the following methods: + + TIEHANDLE classname, LIST + READ this, scalar, length, offset + READLINE this + GETC this + WRITE this, scalar, length, offset + PRINT this, LIST + PRINTF this, format, LIST + CLOSE this + DESTROY this A class implementing a scalar should have the following methods: TIESCALAR classname, LIST - DESTROY this FETCH this, STORE this, value + DESTROY this + +Not all methods indicated above need be implemented. See L<perltie>, +L<Tie::Hash>, L<Tie::Array>, L<Tie::Scalar>, and L<Tie::Handle>. Unlike C<dbmopen()>, the C<tie()> function will not use or require a module for you--you need to do that explicitly yourself. See L<DB_File> or the F<Config> module for interesting C<tie()> implementations. -For further details see L<perltie>, L<tied VARIABLE>. +For further details see L<perltie>, L<"tied VARIABLE">. =item tied VARIABLE @@ -4070,6 +4440,7 @@ otherwise. Returns an uppercased version of EXPR. This is the internal function implementing the C<\U> escape in double-quoted strings. Respects current LC_CTYPE locale if C<use locale> in force. See L<perllocale>. +(It does not attempt to do titlecase mapping on initial letters. See C<ucfirst()> for that.) If EXPR is omitted, uses C<$_>. @@ -4077,7 +4448,7 @@ If EXPR is omitted, uses C<$_>. =item ucfirst -Returns the value of EXPR with the first character uppercased. This is +Returns the value of EXPR with the first character in uppercase. This is the internal function implementing the C<\u> escape in double-quoted strings. Respects current LC_CTYPE locale if C<use locale> in force. See L<perllocale>. @@ -4090,6 +4461,28 @@ If EXPR is omitted, uses C<$_>. Sets the umask for the process to EXPR and returns the previous value. If EXPR is omitted, merely returns the current umask. +The Unix permission C<rwxr-x---> is represented as three sets of three +bits, or three octal digits: C<0750> (the leading 0 indicates octal +and isn't one of the digits). The C<umask> value is such a number +representing disabled permissions bits. The permission (or "mode") +values you pass C<mkdir> or C<sysopen> are modified by your umask, so +even if you tell C<sysopen> to create a file with permissions C<0777>, +if your umask is C<0022> then the file will actually be created with +permissions C<0755>. If your C<umask> were C<0027> (group can't +write; others can't read, write, or execute), then passing +C<sysopen()> C<0666> would create a file with mode C<0640> (C<0666 &~ +027> is C<0640>). + +Here's some advice: supply a creation mode of C<0666> for regular +files (in C<sysopen()>) and one of C<0777> for directories (in +C<mkdir()>) and executable files. This gives users the freedom of +choice: if they want protected files, they might choose process umasks +of C<022>, C<027>, or even the particularly antisocial mask of C<077>. +Programs should rarely if ever make policy decisions better left to +the user. The exception to this is when writing files that should be +kept private: mail files, web browser cookies, I<.rhosts> files, and +so on. + If umask(2) is not implemented on your system and you are trying to restrict access for I<yourself> (i.e., (EXPR & 0700) > 0), produces a fatal error at run time. If umask(2) is not implemented and you are @@ -4165,14 +4558,16 @@ themselves. Default is a 16-bit checksum. For example, the following computes the same number as the System V sum program: while (<>) { - $checksum += unpack("%16C*", $_); + $checksum += unpack("%32C*", $_); } - $checksum %= 65536; + $checksum %= 65535; The following efficiently counts the number of set bits in a bit vector: $setbits = unpack("%32b*", $selectmask); +See L</pack> for more examples. + =item untie VARIABLE Breaks the binding between a variable and a package. (See C<tie()>.) @@ -4280,10 +4675,20 @@ command if the files already exist: Returns a list consisting of all the values of the named hash. (In a scalar context, returns the number of values.) The values are -returned in an apparently random order, but it is the same order as -either the C<keys()> or C<each()> function would produce on the same hash. -As a side effect, it resets HASH's iterator. See also C<keys()>, C<each()>, -and C<sort()>. +returned in an apparently random order. The actual random order is +subject to change in future versions of perl, but it is guaranteed to +be the same order as either the C<keys()> or C<each()> function would +produce on the same (unmodified) hash. + +Note that you cannot modify the values of a hash this way, because the +returned list is just a copy. You need to use a hash slice for that, +since it's lvaluable in a way that values() is not. + + for (values %hash) { s/foo/bar/g } # FAILS! + for (@hash{keys %hash}) { s/foo/bar/g } # ok + +As a side effect, calling values() resets the HASH's internal iterator. +See also C<keys()>, C<each()>, and C<sort()>. =item vec EXPR,OFFSET,BITS @@ -4298,7 +4703,7 @@ the correct precedence as in Vectors created with C<vec()> can also be manipulated with the logical operators C<|>, C<&>, and C<^>, which will assume a bit vector operation is -desired when both operands are strings. +desired when both operands are strings. See L<perlop/"Bitwise String Operators">. The following code will build up an ASCII string saying C<'PerlPerlPerl'>. The comments show the string after each step. Note that this code works @@ -4327,28 +4732,35 @@ If you know the exact length in bits, it can be used in place of the C<*>. =item wait -Waits for a child process to terminate and returns the pid of the -deceased process, or C<-1> if there are no child processes. The status is -returned in C<$?>. +Behaves like the wait(2) system call on your system: it waits for a child +process to terminate and returns the pid of the deceased process, or +C<-1> if there are no child processes. The status is rketurned in C<$?>. +Note that a return value of C<-1> could mean that child processes are +being automatically reaped, as described in L<perlipc>. =item waitpid PID,FLAGS -Waits for a particular child process to terminate and returns the pid -of the deceased process, or C<-1> if there is no such child process. The -status is returned in C<$?>. If you say +Waits for a particular child process to terminate and returns the pid of +the deceased process, or C<-1> if there is no such child process. On some +systems, a value of 0 indicates that there are processes still running. +The status is returned in C<$?>. If you say use POSIX ":sys_wait_h"; #... - waitpid(-1,&WNOHANG); + do { + $kid = waitpid(-1,&WNOHANG); + } until $kid == -1; -then you can do a non-blocking wait for any process. Non-blocking wait -is available on machines supporting either the waitpid(2) or -wait4(2) system calls. However, waiting for a particular pid with -FLAGS of C<0> is implemented everywhere. (Perl emulates the system call -by remembering the status values of processes that have exited but have -not been harvested by the Perl script yet.) +then you can do a non-blocking wait for all pending zombie processes. +Non-blocking wait is available on machines supporting either the +waitpid(2) or wait4(2) system calls. However, waiting for a particular +pid with FLAGS of C<0> is implemented everywhere. (Perl emulates the +system call by remembering the status values of processes that have +exited but have not been harvested by the Perl script yet.) -See L<perlipc> for other examples. +Note that on some systems, a return value of C<-1> could mean that child +processes are being automatically reaped. See L<perlipc> for details, +and for other examples. =item wantarray @@ -4401,7 +4813,8 @@ warnings (even the so-called mandatory ones). An example: warn "\$foo is alive and $foo!"; # does show up See L<perlvar> for details on setting C<%SIG> entries, and for more -examples. +examples. See the Carp module for other kinds of warnings using its +carp() and cluck() functions. =item write FILEHANDLE diff --git a/contrib/perl5/pod/perlguts.pod b/contrib/perl5/pod/perlguts.pod index 20a07d3..90bb716 100644 --- a/contrib/perl5/pod/perlguts.pod +++ b/contrib/perl5/pod/perlguts.pod @@ -48,8 +48,8 @@ To change the value of an *already-existing* SV, there are seven routines: void sv_setiv(SV*, IV); void sv_setuv(SV*, UV); void sv_setnv(SV*, double); - void sv_setpv(SV*, char*); - void sv_setpvn(SV*, char*, int) + void sv_setpv(SV*, const char*); + void sv_setpvn(SV*, const char*, int) void sv_setpvf(SV*, const char*, ...); void sv_setpvfn(SV*, const char*, STRLEN, va_list *, SV **, I32, bool); void sv_setsv(SV*, SV*); @@ -68,7 +68,7 @@ C<sv_setpvfn> is an analogue of C<vsprintf>, but it allows you to specify either a pointer to a variable argument list or the address and length of an array of SVs. The last argument points to a boolean; on return, if that boolean is true, then locale-specific information has been used to format -the string, and the string's contents are therefore untrustworty (see +the string, and the string's contents are therefore untrustworthy (see L<perlsec>). This pointer may be NULL if that information is not important. Note that this function requires you to specify the length of the format. @@ -95,9 +95,20 @@ or string. In the C<SvPV> macro, the length of the string returned is placed into the variable C<len> (this is a macro, so you do I<not> use C<&len>). If you do not -care what the length of the data is, use the global variable C<PL_na>. Remember, -however, that Perl allows arbitrary strings of data that may both contain -NULs and might not be terminated by a NUL. +care what the length of the data is, use the global variable C<PL_na> or a +local variable of type C<STRLEN>. However using C<PL_na> can be quite +inefficient because C<PL_na> must be accessed in thread-local storage in +threaded Perl. In any case, remember that Perl allows arbitrary strings of +data that may both contain NULs and might not be terminated by a NUL. + +Also remember that C doesn't allow you to safely say C<foo(SvPV(s, len), +len);>. It might work with your compiler, but it won't work for everyone. +Break this sort of statement up into separate assignments: + + STRLEN len; + char * ptr; + ptr = SvPV(len); + foo(ptr, len); If you want to know if the scalar value is TRUE, you can use: @@ -138,7 +149,7 @@ If you want to append something to the end of string stored in an C<SV*>, you can use the following functions: void sv_catpv(SV*, char*); - void sv_catpvn(SV*, char*, int); + void sv_catpvn(SV*, char*, STRLEN); void sv_catpvf(SV*, const char*, ...); void sv_catpvfn(SV*, const char*, STRLEN, va_list *, SV **, I32, bool); void sv_catsv(SV*, SV*); @@ -262,9 +273,9 @@ return value. The C<av_clear> function deletes all the elements in the AV* array, but does not actually delete the array itself. The C<av_undef> function will delete all the elements in the array plus the array itself. The -C<av_extend> function extends the array so that it contains C<key> -elements. If C<key> is less than the current length of the array, then -nothing is done. +C<av_extend> function extends the array so that it contains at least C<key+1> +elements. If C<key+1> is less than the currently allocated length of the array, +then nothing is done. If you know the name of an array variable, you can get a pointer to its AV by using the following: @@ -350,11 +361,9 @@ This returns NULL if the variable does not exist. The hash algorithm is defined in the C<PERL_HASH(hash, key, klen)> macro: - i = klen; hash = 0; - s = key; - while (i--) - hash = hash * 33 + *s++; + while (klen--) + hash = (hash * 33) + *key++; See L<Understanding the Magic of Tied Hashes and Arrays> for more information on how to use the hash access functions on tied hashes. @@ -488,7 +497,7 @@ reference is rv. SV is blessed if C<classname> is non-null. Copies string into an SV whose reference is C<rv>. Set length to 0 to let Perl calculate the string length. SV is blessed if C<classname> is non-null. - SV* sv_setref_pvn(SV* rv, char* classname, PV iv, int length); + SV* sv_setref_pvn(SV* rv, char* classname, PV iv, STRLEN length); Tests whether the SV is blessed into the specified class. It does not check inheritance relationships. @@ -861,7 +870,20 @@ C<mg_ptr> field points to a C<ufuncs> structure: When the SV is read from or written to, the C<uf_val> or C<uf_set> function will be called with C<uf_index> as the first arg and a -pointer to the SV as the second. +pointer to the SV as the second. A simple example of how to add 'U' +magic is shown below. Note that the ufuncs structure is copied by +sv_magic, so you can safely allocate it on the stack. + + void + Umagic(sv) + SV *sv; + PREINIT: + struct ufuncs uf; + CODE: + uf.uf_val = &my_get_fn; + uf.uf_set = &my_set_fn; + uf.uf_index = 0; + sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf)); Note that because multiple extensions may be using '~' or 'U' magic, it is important for extensions to take extra care to avoid conflict. @@ -907,6 +929,33 @@ in later releases, and are bracketed with [MAYCHANGE] below. If you find yourself actually applying such information in this section, be aware that the behavior may change in the future, umm, without warning. +The perl tie function associates a variable with an object that implements +the various GET, SET etc methods. To perform the equivalent of the perl +tie function from an XSUB, you must mimic this behaviour. The code below +carries out the necessary steps - firstly it creates a new hash, and then +creates a second hash which it blesses into the class which will implement +the tie methods. Lastly it ties the two hashes together, and returns a +reference to the new tied hash. Note that the code below does NOT call the +TIEHASH method in the MyTie class - +see L<Calling Perl Routines from within C Programs> for details on how +to do this. + + SV* + mytie() + PREINIT: + HV *hash; + HV *stash; + SV *tie; + CODE: + hash = newHV(); + tie = newRV_noinc((SV*)newHV()); + stash = gv_stashpv("MyTie", TRUE); + sv_bless(tie, stash); + hv_magic(hash, tie, 'P'); + RETVAL = newRV_noinc(hash); + OUTPUT: + RETVAL + The C<av_store> function, when given a tied array argument, merely copies the magic of the array onto the value to be "stored", using C<mg_copy>. It may also return NULL, indicating that the value did not @@ -982,13 +1031,13 @@ There is a way to achieve a similar task from C via Perl API: create a I<pseudo-block>, and arrange for some changes to be automatically undone at the end of it, either explicit, or via a non-local exit (via die()). A I<block>-like construct is created by a pair of -C<ENTER>/C<LEAVE> macros (see L<perlcall/EXAMPLE/"Returning a -Scalar">). Such a construct may be created specially for some -important localized task, or an existing one (like boundaries of -enclosing Perl subroutine/block, or an existing pair for freeing TMPs) -may be used. (In the second case the overhead of additional -localization must be almost negligible.) Note that any XSUB is -automatically enclosed in an C<ENTER>/C<LEAVE> pair. +C<ENTER>/C<LEAVE> macros (see L<perlcall/"Returning a Scalar">). +Such a construct may be created specially for some important localized +task, or an existing one (like boundaries of enclosing Perl +subroutine/block, or an existing pair for freeing TMPs) may be +used. (In the second case the overhead of additional localization must +be almost negligible.) Note that any XSUB is automatically enclosed in +an C<ENTER>/C<LEAVE> pair. Inside such a I<pseudo-block> the following service is available: @@ -1193,7 +1242,12 @@ consult L<perlcall>. =head2 Memory Allocation -It is suggested that you use the version of malloc that is distributed +All memory meant to be used with the Perl API functions should be manipulated +using the macros described in this section. The macros provide the necessary +transparency between differences in the actual malloc implementation that is +used within perl. + +It is suggested that you enable the version of malloc that is distributed with Perl. It keeps pools of various sizes of unallocated memory in order to satisfy allocation requests more quickly. However, on some platforms, it may cause spurious malloc or free errors. @@ -1460,7 +1514,7 @@ It is strongly recommended that all Perl API functions that don't begin with C<perl> be referenced with an explicit C<Perl_> prefix. The sort order of the listing is case insensitive, with any -occurrences of '_' ignored for the the purpose of sorting. +occurrences of '_' ignored for the purpose of sorting. =over 8 @@ -1594,7 +1648,7 @@ the SV which holds the name of the sub being debugged. This is the C variable which corresponds to Perl's $DB::sub variable. See C<PL_DBsingle>. The sub name can be found by - SvPV( GvSV( PL_DBsub ), PL_na ) + SvPV( GvSV( PL_DBsub ), len ) =item PL_DBtrace @@ -1731,7 +1785,7 @@ method's CV, which can be obtained from the GV with the C<GvCV> macro. =item gv_fetchmethod_autoload Returns the glob which contains the subroutine to call to invoke the -method on the C<stash>. In fact in the presense of autoloading this may +method on the C<stash>. In fact in the presence of autoloading this may be the glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is already setup. @@ -1814,7 +1868,8 @@ Returns the key slot of the hash entry as a C<char*> value, doing any necessary dereferencing of possibly C<SV*> keys. The length of the string is placed in C<len> (this is a macro, so do I<not> use C<&len>). If you do not care about what the length of the key is, -you may use the global variable C<PL_na>. Remember though, that hash +you may use the global variable C<PL_na>, though this is rather less +efficient than using a local variable. Remember though, that hash keys in perl are free to contain embedded nulls, so using C<strlen()> or similar is not a good way to find the length of hash keys. This is very similar to the C<SvPV()> macro described elsewhere in @@ -1855,15 +1910,6 @@ Clears a hash, making it empty. void hv_clear (HV* tb) -=item hv_delayfree_ent - -Releases a hash entry, such as while iterating though the hash, but -delays actual freeing of key and value until the end of the current -statement (or thereabouts) with C<sv_2mortal>. See C<hv_iternext> -and C<hv_free_ent>. - - void hv_delayfree_ent (HV* hv, HE* entry) - =item hv_delete Deletes a key/value pair in the hash. The value SV is removed from the hash @@ -1923,13 +1969,6 @@ information on how to use this function on tied hashes. HE* hv_fetch_ent (HV* tb, SV* key, I32 lval, U32 hash) -=item hv_free_ent - -Releases a hash entry, such as while iterating though the hash. See -C<hv_iternext> and C<hv_delayfree_ent>. - - void hv_free_ent (HV* hv, HE* entry) - =item hv_iterinit Prepares a starting point to traverse a hash table. @@ -2143,6 +2182,14 @@ Do magic after a value is assigned to the SV. See C<sv_magic>. int mg_set (SV* sv) +=item modglobal + +C<modglobal> is a general purpose, interpreter global HV for use by +extensions that need to keep information on a per-interpreter basis. +In a pinch, it can also be used as a symbol table for extensions +to share data among each other. It is a good idea to use keys +prefixed by the package name of the extension that owns the data. + =item Move The XSUB-writer's interface to the C C<memmove> function. The C<s> is the @@ -2153,8 +2200,9 @@ the type. Can do overlapping moves. See also C<Copy>. =item PL_na -A variable which may be used with C<SvPV> to tell Perl to calculate the -string length. +A convenience variable which is typically used with C<SvPV> when one doesn't +care about the length of the string. It is usually more efficient to +declare a local variable and use that instead. =item New @@ -2632,7 +2680,7 @@ Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>. Like C<sv_catpv>, but also handles 'set' magic. - void sv_catpvn (SV* sv, char* ptr) + void sv_catpv_mg (SV* sv, const char* ptr) =item sv_catpvn @@ -2703,7 +2751,7 @@ Returns the length of the string which is in the SV. See C<SvLEN>. Set the length of the string which is in the SV. See C<SvCUR>. - void SvCUR_set (SV* sv, int val ) + void SvCUR_set (SV* sv, int val) =item sv_dec @@ -2713,13 +2761,6 @@ Auto-decrement of the value in the SV. =item sv_derived_from -Returns a boolean indicating whether the SV is a subclass of the -specified class. - - int sv_derived_from(SV* sv, char* class) - -=item sv_derived_from - Returns a boolean indicating whether the SV is derived from the specified class. This is the function that implements C<UNIVERSAL::isa>. It works for class names as well as for objects. @@ -2745,7 +2786,7 @@ identical. Invokes C<mg_get> on an SV if it has 'get' magic. This macro evaluates its argument more than once. - void SvGETMAGIC( SV *sv ) + void SvGETMAGIC(SV *sv) =item SvGROW @@ -2754,7 +2795,7 @@ indicated number of bytes (remember to reserve space for an extra trailing NUL character). Calls C<sv_grow> to perform the expansion if necessary. Returns a pointer to the character buffer. - char* SvGROW( SV* sv, int len ) + char* SvGROW(SV* sv, STRLEN len) =item sv_grow @@ -2825,13 +2866,13 @@ will return false. =item SvIV -Returns the integer which is in the SV. +Coerces the given SV to an integer and returns it. int SvIV (SV* sv) =item SvIVX -Returns the integer which is stored in the SV. +Returns the integer which is stored in the SV, assuming SvIOK is true. int SvIVX (SV* sv) @@ -2923,13 +2964,13 @@ B<private> setting. Use C<SvNOK>. =item SvNV -Returns the double which is stored in the SV. +Coerce the given SV to a double and return it. double SvNV (SV* sv) =item SvNVX -Returns the double which is stored in the SV. +Returns the double which is stored in the SV, assuming SvNOK is true. double SvNVX (SV* sv) @@ -2982,18 +3023,16 @@ Checks the B<private> setting. Use C<SvPOK>. =item SvPV Returns a pointer to the string in the SV, or a stringified form of the SV -if the SV does not contain a string. If C<len> is C<PL_na> then Perl will -handle the length on its own. Handles 'get' magic. +if the SV does not contain a string. Handles 'get' magic. - char* SvPV (SV* sv, int len ) + char* SvPV (SV* sv, STRLEN len) =item SvPV_force Like <SvPV> but will force the SV into becoming a string (SvPOK). You want force if you are going to update the SvPVX directly. - char* SvPV_force(SV* sv, int len) - + char* SvPV_force(SV* sv, STRLEN len) =item SvPVX @@ -3081,13 +3120,13 @@ Like C<sv_setnv>, but also handles 'set' magic. Copies a string into an SV. The string must be null-terminated. Does not handle 'set' magic. See C<sv_setpv_mg>. - void sv_setpv (SV* sv, char* ptr) + void sv_setpv (SV* sv, const char* ptr) =item sv_setpv_mg Like C<sv_setpv>, but also handles 'set' magic. - void sv_setpv_mg (SV* sv, char* ptr) + void sv_setpv_mg (SV* sv, const char* ptr) =item sv_setpviv @@ -3107,13 +3146,13 @@ Like C<sv_setpviv>, but also handles 'set' magic. Copies a string into an SV. The C<len> parameter indicates the number of bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>. - void sv_setpvn (SV* sv, char* ptr, STRLEN len) + void sv_setpvn (SV* sv, const char* ptr, STRLEN len) =item sv_setpvn_mg Like C<sv_setpvn>, but also handles 'set' magic. - void sv_setpvn_mg (SV* sv, char* ptr, STRLEN len) + void sv_setpvn_mg (SV* sv, const char* ptr, STRLEN len) =item sv_setpvf @@ -3361,13 +3400,13 @@ appending it. =item SvUV -Returns the unsigned integer which is in the SV. +Coerces the given SV to an unsigned integer and returns it. UV SvUV(SV* sv) =item SvUVX -Returns the unsigned integer which is stored in the SV. +Returns the unsigned integer which is stored in the SV, assuming SvIOK is true. UV SvUVX(SV* sv) diff --git a/contrib/perl5/pod/perlhist.pod b/contrib/perl5/pod/perlhist.pod index 9ed8b6f..5828ea4 100644 --- a/contrib/perl5/pod/perlhist.pod +++ b/contrib/perl5/pod/perlhist.pod @@ -4,10 +4,12 @@ perlhist - the Perl history records -=for RCS +=begin RCS + # -# $Id: perlhist.pod,v 1.48 1998/08/03 08:50:12 jhi Exp $ +# $Id: perlhist.pod,v 1.57 1999/01/26 17:38:07 jhi Exp $ # + =end RCS =head1 DESCRIPTION @@ -265,6 +267,10 @@ the strings?). 5.004_04-m3 1998-May-15 5.004_04-m4 1998-May-19 5.004_04-MT5 1998-Jul-21 + 5.004_04-MT6 1998-Oct-09 + 5.004_04-MT7 1998-Nov-22 + 5.004_04-MT8 1998-Dec-03 + 5.004_04-MT9 1999-***-** Malcolm 5.004_50 1997-Sep-09 The 5.005 development track. 5.004_51 1997-Oct-02 @@ -299,9 +305,21 @@ the strings?). 5.005_02-T1 1998-Aug-02 5.005_02-T2 1998-Aug-05 5.005_02 1998-Aug-08 - Graham 5.005_03 1998- + Graham 5.005_03-MT1 1998-Nov-30 + 5.005_03-MT2 1999-Jan-04 + 5.005_03-MT3 1999-Jan-17 + 5.005_03-MT4 1999-Jan-26 + 5.005_03-MT5 1999-Jan-28 + 5.005_03-MT6 1999-Mar-04 + 5.005_03 1999-Mar-28 Sarathy 5.005_50 1998-Jul-26 The 5.006 development track. + 5.005_51 1998-Aug-10 + 5.005_52 1998-Sep-25 + 5.005_53 1998-Oct-31 + 5.005_54 1998-Nov-30 + 5.005_55 1999-Feb-16 + 5.005_56 1999-Mar-01 =head2 SELECTED RELEASE SIZES @@ -447,11 +465,12 @@ The "diff lines kb" means that for example the patch 5.003_08, to be applied on top of the 5.003_07 (or whatever was before the 5.003_08) added lines for 110 kilobytes, it removed lines for 19 kilobytes, and changed lines for 424 kilobytes. Just the lines themselves are -counted, not their context. The "+ - !" become from the diff(1)s +counted, not their context. The "+ - !" become from the diff(1) context diff output format. Pump- Release Date diff lines kB - king + - ! + king ------------- + + - ! =========================================================================== Chip 5.003_08 1996-Nov-19 110 19 424 diff --git a/contrib/perl5/pod/perlipc.pod b/contrib/perl5/pod/perlipc.pod index 59c5ad9..2f99d10 100644 --- a/contrib/perl5/pod/perlipc.pod +++ b/contrib/perl5/pod/perlipc.pod @@ -56,7 +56,17 @@ So to check whether signal 17 and SIGALRM were the same, do just this: You may also choose to assign the strings C<'IGNORE'> or C<'DEFAULT'> as the handler, in which case Perl will try to discard the signal or do the -default thing. Some signals can be neither trapped nor ignored, such as +default thing. + +On most UNIX platforms, the C<CHLD> (sometimes also known as C<CLD>) signal +has special behavior with respect to a value of C<'IGNORE'>. +Setting C<$SIG{CHLD}> to C<'IGNORE'> on such a platform has the effect of +not creating zombie processes when the parent process fails to C<wait()> +on its child processes (i.e. child processes are automatically reaped). +Calling C<wait()> with C<$SIG{CHLD}> set to C<'IGNORE'> usually returns +C<-1> on such platforms. + +Some signals can be neither trapped nor ignored, such as the KILL and STOP (but not the TSTP) signals. One strategy for temporarily ignoring signals is to use a local() statement, which will be automatically restored once your block is exited. (Remember that local() @@ -317,46 +327,33 @@ details). =head2 Complete Dissociation of Child from Parent In some cases (starting server processes, for instance) you'll want to -complete dissociate the child process from the parent. The easiest -way is to use: - - use POSIX qw(setsid); - setsid() or die "Can't start a new session: $!"; - -However, you may not be on POSIX. The following process is reported -to work on most Unixish systems. Non-Unix users should check their -Your_OS::Process module for other solutions. - -=over 4 - -=item * - -Open /dev/tty and use the TIOCNOTTY ioctl on it. See L<tty(4)> -for details. - -=item * - -Change directory to / - -=item * - -Reopen STDIN, STDOUT, and STDERR so they're not connected to the old -tty. - -=item * - -Background yourself like this: - - fork && exit; - -=item * - -Ignore hangup signals in case you're running on a shell that doesn't -automatically no-hup you: +completely dissociate the child process from the parent. This is +often called daemonization. A well behaved daemon will also chdir() +to the root directory (so it doesn't prevent unmounting the filesystem +containing the directory from which it was launched) and redirect its +standard file descriptors from and to F</dev/null> (so that random +output doesn't wind up on the user's terminal). + + use POSIX 'setsid'; + + sub daemonize { + chdir '/' or die "Can't chdir to /: $!"; + open STDIN, '/dev/null' or die "Can't read /dev/null: $!"; + open STDOUT, '>/dev/null' + or die "Can't write to /dev/null: $!"; + defined(my $pid = fork) or die "Can't fork: $!"; + exit if $pid; + setsid or die "Can't start a new session: $!"; + open STDERR, '>&STDOUT' or die "Can't dup stdout: $!"; + } - $SIG{HUP} = 'IGNORE'; # or whatever you'd like +The fork() has to come before the setsid() to ensure that you aren't a +process group leader (the setsid() will fail if you are). If your +system doesn't have the setsid() function, open F</dev/tty> and use the +C<TIOCNOTTY> ioctl() on it instead. See L<tty(4)> for details. -=back +Non-Unix users should check their Your_OS::Process module for other +solutions. =head2 Safe Pipe Opens @@ -1194,7 +1191,7 @@ you'll have to use the C<sysread> variant of the interactive client above. This server accepts one of five different commands, sending output back to the client. Note that unlike most network servers, this one only handles one incoming client at a time. Multithreaded servers are -covered in Chapter 6 of the Camel as well as later in this manpage. +covered in Chapter 6 of the Camel. Here's the code. We'll diff --git a/contrib/perl5/pod/perllocale.pod b/contrib/perl5/pod/perllocale.pod index 4401be2..08b50e0 100644 --- a/contrib/perl5/pod/perllocale.pod +++ b/contrib/perl5/pod/perllocale.pod @@ -215,6 +215,8 @@ I<SEE ALSO> section). If that fails, try the following command lines: ls /usr/lib/nls + ls /usr/share/locale + and see whether they list something resembling these en_US.ISO8859-1 de_DE.ISO8859-1 ru_RU.ISO8859-5 @@ -225,18 +227,18 @@ and see whether they list something resembling these english.iso88591 german.iso88591 russian.iso88595 english.roman8 russian.koi8r -Sadly, even though the calling interface for setlocale() has -been standardized, names of locales and the directories where the +Sadly, even though the calling interface for setlocale() has been +standardized, names of locales and the directories where the configuration resides have not been. The basic form of the name is -I<language_country/territory>B<.>I<codeset>, but the latter parts after -I<language> are not always present. The I<language> and I<country> are -usually from the standards B<ISO 3166> and B<ISO 639>, the two-letter -abbreviations for the countries and the languages of the world, -respectively. The I<codeset> part often mentions some B<ISO 8859> -character set, the Latin codesets. For example, C<ISO 8859-1> is the -so-called "Western codeset" that can be used to encode most Western -European languages. Again, there are several ways to write even the -name of that one standard. Lamentably. +I<language_territory>B<.>I<codeset>, but the latter parts after +I<language> are not always present. The I<language> and I<country> +are usually from the standards B<ISO 3166> and B<ISO 639>, the +two-letter abbreviations for the countries and the languages of the +world, respectively. The I<codeset> part often mentions some B<ISO +8859> character set, the Latin codesets. For example, C<ISO 8859-1> +is the so-called "Western European codeset" that can be used to encode +most Western European languages adequately. Again, there are several +ways to write even the name of that one standard. Lamentably. Two special locales are worth particular mention: "C" and "POSIX". Currently these are effectively the same locale: the difference is @@ -276,10 +278,10 @@ The two quickest fixes are either to render Perl silent about any locale inconsistencies or to run Perl under the default locale "C". Perl's moaning about locale problems can be silenced by setting the -environment variable PERL_BADLANG to a non-zero value, for example -"1". This method really just sweeps the problem under the carpet: you -tell Perl to shut up even when Perl sees that something is wrong. Do -not be surprised if later something locale-dependent misbehaves. +environment variable PERL_BADLANG to a zero value, for example "0". +This method really just sweeps the problem under the carpet: you tell +Perl to shut up even when Perl sees that something is wrong. Do not +be surprised if later something locale-dependent misbehaves. Perl can be run under the "C" locale by setting the environment variable LC_ALL to "C". This method is perhaps a bit more civilized @@ -330,7 +332,7 @@ Second, if using the listed commands you see something B<exactly> (prefix matches do not count and case usually counts) like "En_US" without the quotes, then you should be okay because you are using a locale name that should be installed and available in your system. -In this case, see L<Fixing system locale configuration>. +In this case, see L<Permanently fixing system locale configuration>. =head2 Permanently fixing your locale configuration @@ -349,7 +351,7 @@ rules for matching locale names are a bit vague because standardization is weak in this area. See again the L<Finding locales> about general rules. -=head2 Permanently fixing system locale configuration +=head2 Fixing system locale configuration Contact a system administrator (preferably your own) and report the exact error message you get, and ask them to read this same documentation you @@ -710,7 +712,7 @@ case-mapping with C<\l>, C<\L>,C<\u> or C<\U>. =item B<In-memory formatting function> (sprintf()): -Result is tainted if "use locale" is in effect. +Result is tainted if C<use locale> is in effect. =item B<Output formatting functions> (printf() and write()): @@ -785,9 +787,10 @@ of a match involving C<\w> while C<use locale> is in effect. A string that can suppress Perl's warning about failed locale settings at startup. Failure can occur if the locale support in the operating system is lacking (broken) in some way--or if you mistyped the name of -a locale when you set up your environment. If this environment variable -is absent, or has a value that does not evaluate to integer zero--that -is, "0" or ""--Perl will complain about locale setting failures. +a locale when you set up your environment. If this environment +variable is absent, or has a value that does not evaluate to integer +zero--that is, "0" or ""-- Perl will complain about locale setting +failures. B<NOTE>: PERL_BADLANG only gives you a way to hide the warning message. The message tells about some problem in your system's locale support, @@ -806,6 +809,20 @@ for controlling an application's opinion on data. C<LC_ALL> is the "override-all" locale environment variable. If set, it overrides all the rest of the locale environment variables. +=item LANGUAGE + +B<NOTE>: C<LANGUAGE> is a GNU extension, it affects you only if you +are using the GNU libc. This is the case if you are using e.g. Linux. +If you are using "commercial" UNIXes you are most probably I<not> +using GNU libc and you can ignore C<LANGUAGE>. + +However, in the case you are using C<LANGUAGE>: it affects the +language of informational, warning, and error messages output by +commands (in other words, it's like C<LC_MESSAGES>) but it has higher +priority than L<LC_ALL>. Moreover, it's not a single value but +instead a "path" (":"-separated list) of I<languages> (not locales). +See the GNU C<gettext> library documentation for more information. + =item LC_CTYPE In the absence of C<LC_ALL>, C<LC_CTYPE> chooses the character type @@ -854,7 +871,7 @@ always in force, even if the program environment suggested otherwise (see L<The setlocale function>). By default, Perl still behaves this way for backward compatibility. If you want a Perl application to pay attention to locale information, you B<must> use the S<C<use locale>> -pragma (see L<The use locale Pragma>) to instruct it to do so. +pragma (see L<The use locale pragma>) to instruct it to do so. Versions of Perl from 5.002 to 5.003 did use the C<LC_CTYPE> information if available; that is, C<\w> did understand what diff --git a/contrib/perl5/pod/perllol.pod b/contrib/perl5/pod/perllol.pod index 0e6796b..56f08c2 100644 --- a/contrib/perl5/pod/perllol.pod +++ b/contrib/perl5/pod/perllol.pod @@ -34,7 +34,7 @@ but rather just a reference to it, you could do something more like this: $ref_to_LoL = [ [ "fred", "barney", "pebbles", "bambam", "dino", ], [ "homer", "bart", "marge", "maggie", ], - [ "george", "jane", "alroy", "judy", ], + [ "george", "jane", "elroy", "judy", ], ]; print $ref_to_LoL->[2][2]; diff --git a/contrib/perl5/pod/perlmod.pod b/contrib/perl5/pod/perlmod.pod index 6da31de..48ebf23 100644 --- a/contrib/perl5/pod/perlmod.pod +++ b/contrib/perl5/pod/perlmod.pod @@ -243,7 +243,7 @@ a file called Some/Module.pm and start with this template: # non-exported package globals go here use vars qw(@more $stuff); - # initalize package globals, first exported ones + # initialize package globals, first exported ones $Var1 = ''; %Hashit = (); diff --git a/contrib/perl5/pod/perlmodinstall.pod b/contrib/perl5/pod/perlmodinstall.pod index 1c65f1c..b6176f0 100644 --- a/contrib/perl5/pod/perlmodinstall.pod +++ b/contrib/perl5/pod/perlmodinstall.pod @@ -178,16 +178,27 @@ B<If you're using a Macintosh,> A. DECOMPRESS -You can either use StuffIt Expander ( http://www.aladdinsys.com/ ) in -combination with I<DropStuff with Expander Enhancer> -(shareware), or the freeware MacGzip ( +In general, all Macintosh decompression utilities mentioned here +can be found in the Info-Mac Hyperarchive +( http://hyperarchive.lcs.mit.edu/HyperArchive.html ). +Specificly the "Commpress & Translate" listing +( http://hyperarchive.lcs.mit.edu/HyperArchive/Abstracts/cmp/HyperArchive.html ). + + +You can either use the shareware StuffIt Expander +( http://hyperarchive.lcs.mit.edu/HyperArchive/Archive/cmp/stuffit-expander-401.hqx ) +in combination with I<DropStuff with Expander Enhancer> +( http://hyperarchive.lcs.mit.edu/HyperArchive/Archive/cmp/drop-stuff-with-ee-40.hqx ) +or the freeware MacGzip ( http://persephone.cps.unizar.es/general/gente/spd/gzip/gzip.html ). + B. UNPACK If you're using DropStuff or Stuffit, you can just extract the tar -archive. Otherwise, you can use the freeware I<suntar> ( -http://www.cirfid.unibo.it/~speranza ). +archive. Otherwise, you can use the freeware I<suntar> +( http://hyperarchive.lcs.mit.edu/HyperArchive/Archive/cmp/suntar-221.hqx ) +or I<Tar> ( http://hyperarchive.lcs.mit.edu/HyperArchive/Archive/cmp/tar-40b.hqx ). C. BUILD @@ -212,6 +223,15 @@ mail to mac-perl-request@iis.ee.ethz.ch. D. INSTALL Make sure the newlines for the modules are in Mac format, not Unix format. +If they are not then you might have decompressed them incorrectly. Check +your decompression and unpacking utilities settings to make sure they are +translating text files properly. +As a last resort, you can use the perl one-liner: + + perl -i.bak -pe 's/(?:\015)?\012/\015/g' filenames + +on the source files. + Move the files manually into the correct folders. Move the files to their final destination: This will diff --git a/contrib/perl5/pod/perlmodlib.pod b/contrib/perl5/pod/perlmodlib.pod index 5d0e5b0..d6c6b32 100644 --- a/contrib/perl5/pod/perlmodlib.pod +++ b/contrib/perl5/pod/perlmodlib.pod @@ -21,7 +21,7 @@ bulletproof. They work somewhat like pragmas in that they tend to affect the compilation of your program, and thus will usually work well only when used within a -C<use>, or C<no>. Most of these are locally scoped, so an inner BLOCK +C<use>, or C<no>. Most of these are lexically scoped, so an inner BLOCK may countermand any of these by saying: no integer; @@ -261,6 +261,14 @@ traverse a file tree create or remove a series of directories +=item File::Spec + +portably perform operations on file names + +=item File::Spec::Functions + +function call interface to File::Spec module + =item File::stat by-name interface to Perl's builtin stat() functions @@ -608,84 +616,133 @@ You should try to choose one close to you: =item * Africa - South Africa ftp://ftp.is.co.za/programming/perl/CPAN/ + South Africa ftp://ftp.is.co.za/programming/perl/CPAN/ + ftp://ftpza.co.za/pub/mirrors/cpan/ =item * Asia - Hong Kong ftp://ftp.hkstar.com/pub/CPAN/ - Japan ftp://ftp.jaist.ac.jp/pub/lang/perl/CPAN/ - ftp://ftp.lab.kdd.co.jp/lang/perl/CPAN/ - South Korea ftp://ftp.nuri.net/pub/CPAN/ - Taiwan ftp://dongpo.math.ncu.edu.tw/perl/CPAN/ - ftp://ftp.wownet.net/pub2/PERL/ + Armenia ftp://sunsite.aua.am/pub/CPAN/ + China ftp://freesoft.cei.gov.cn/pub/languages/perl/CPAN/ + Hong Kong ftp://ftp.hkstar.com/pub/CPAN/ + Israel ftp://bioinfo.weizmann.ac.il/pub/software/perl/CPAN/ + Japan ftp://ftp.dti.ad.jp/pub/lang/CPAN/ + ftp://ftp.jaist.ac.jp/pub/lang/perl/CPAN/ + ftp://ftp.lab.kdd.co.jp/lang/perl/CPAN/ + ftp://ftp.meisei-u.ac.jp/pub/CPAN/ + ftp://mirror.nucba.ac.jp/mirror/Perl/ + Singapore ftp://ftp.nus.edu.sg/pub/unix/perl/CPAN/ + South Korea ftp://ftp.bora.net/pub/CPAN/ + ftp://ftp.nuri.net/pub/CPAN/ + Taiwan ftp://ftp.wownet.net/pub2/PERL/ + ftp://ftp1.sinica.edu.tw/pub1/perl/CPAN/ + Thailand ftp://ftp.cs.riubon.ac.th/pub/mirrors/CPAN/ + ftp://ftp.nectec.or.th/pub/mirrors/CPAN/ =item * Australasia - Australia ftp://ftp.netinfo.com.au/pub/perl/CPAN/ - New Zealand ftp://ftp.tekotago.ac.nz/pub/perl/CPAN/ + Australia ftp://cpan.topend.com.au/pub/CPAN/ + ftp://ftp.labyrinth.net.au/pub/perl/CPAN/ + ftp://ftp.sage-au.org.au/pub/compilers/perl/CPAN/ + ftp://mirror.aarnet.edu.au/pub/perl/CPAN/ + New Zealand ftp://ftp.auckland.ac.nz/pub/perl/CPAN/ + ftp://sunsite.net.nz/pub/languages/perl/CPAN/ + +=item * +Central America + + Costa Rica ftp://ftp.ucr.ac.cr/pub/Unix/CPAN/ =item * Europe - Austria ftp://ftp.tuwien.ac.at/pub/languages/perl/CPAN/ - Belgium ftp://ftp.kulnet.kuleuven.ac.be/pub/mirror/CPAN/ - Czech Republic ftp://sunsite.mff.cuni.cz/Languages/Perl/CPAN/ - Denmark ftp://sunsite.auc.dk/pub/languages/perl/CPAN/ - Finland ftp://ftp.funet.fi/pub/languages/perl/CPAN/ - France ftp://ftp.ibp.fr/pub/perl/CPAN/ - ftp://ftp.pasteur.fr/pub/computing/unix/perl/CPAN/ - Germany ftp://ftp.gmd.de/packages/CPAN/ - ftp://ftp.leo.org/pub/comp/programming/languages/perl/CPAN/ - ftp://ftp.mpi-sb.mpg.de/pub/perl/CPAN/ - ftp://ftp.rz.ruhr-uni-bochum.de/pub/CPAN/ - ftp://ftp.uni-erlangen.de/pub/source/Perl/CPAN/ - ftp://ftp.uni-hamburg.de/pub/soft/lang/perl/CPAN/ - Greece ftp://ftp.ntua.gr/pub/lang/perl/ - Hungary ftp://ftp.kfki.hu/pub/packages/perl/CPAN/ - Italy ftp://cis.utovrm.it/CPAN/ - the Netherlands ftp://ftp.cs.ruu.nl/pub/PERL/CPAN/ - ftp://ftp.EU.net/packages/cpan/ - Norway ftp://ftp.uit.no/pub/languages/perl/cpan/ - Poland ftp://ftp.pk.edu.pl/pub/lang/perl/CPAN/ - ftp://sunsite.icm.edu.pl/pub/CPAN/ - Portugal ftp://ftp.ci.uminho.pt/pub/lang/perl/ - ftp://ftp.telepac.pt/pub/CPAN/ - Russia ftp://ftp.sai.msu.su/pub/lang/perl/CPAN/ - Slovenia ftp://ftp.arnes.si/software/perl/CPAN/ - Spain ftp://ftp.etse.urv.es/pub/mirror/perl/ - ftp://ftp.rediris.es/mirror/CPAN/ - Sweden ftp://ftp.sunet.se/pub/lang/perl/CPAN/ - UK ftp://ftp.demon.co.uk/pub/mirrors/perl/CPAN/ - ftp://sunsite.doc.ic.ac.uk/packages/CPAN/ - ftp://unix.hensa.ac.uk/mirrors/perl-CPAN/ + Austria ftp://ftp.tuwien.ac.at/pub/languages/perl/CPAN/ + Belgium ftp://ftp.kulnet.kuleuven.ac.be/pub/mirror/CPAN/ + Bulgaria ftp://ftp.ntrl.net/pub/mirrors/CPAN/ + Croatia ftp://ftp.linux.hr/pub/CPAN/ + Czech Republic ftp://ftp.fi.muni.cz/pub/perl/ + ftp://sunsite.mff.cuni.cz/Languages/Perl/CPAN/ + Denmark ftp://sunsite.auc.dk/pub/languages/perl/CPAN/ + Estonia ftp://ftp.ut.ee/pub/languages/perl/CPAN/ + Finland ftp://ftp.funet.fi/pub/languages/perl/CPAN/ + France ftp://ftp.lip6.fr/pub/perl/CPAN/ + ftp://ftp.oleane.net/pub/mirrors/CPAN/ + ftp://ftp.pasteur.fr/pub/computing/CPAN/ + Germany ftp://ftp.archive.de.uu.net/pub/CPAN/ + ftp://ftp.gmd.de/packages/CPAN/ + ftp://ftp.gwdg.de/pub/languages/perl/CPAN/ + ftp://ftp.leo.org/pub/comp/programming/languages/script/perl/CPAN/ + ftp://ftp.mpi-sb.mpg.de/pub/perl/CPAN/ + ftp://ftp.rz.ruhr-uni-bochum.de/pub/CPAN/ + ftp://ftp.uni-erlangen.de/pub/source/CPAN/ + ftp://ftp.uni-hamburg.de/pub/soft/lang/perl/CPAN/ + Greece ftp://ftp.ntua.gr/pub/lang/perl/ + Hungary ftp://ftp.kfki.hu/pub/packages/perl/CPAN/ + Ireland ftp://sunsite.compapp.dcu.ie/pub/perl/ + Italy ftp://cis.uniRoma2.it/CPAN/ + ftp://ftp.flashnet.it/pub/CPAN/ + ftp://ftp.unipi.it/pub/mirror/perl/CPAN/ + Netherlands ftp://ftp.cs.uu.nl/mirror/CPAN/ + ftp://ftp.nluug.nl/pub/languages/perl/CPAN/ + Norway ftp://ftp.uit.no/pub/languages/perl/cpan/ + ftp://sunsite.uio.no/pub/languages/perl/CPAN/ + Poland ftp://ftp.man.szczecin.pl/pub/perl/CPAN/ + ftp://ftp.man.torun.pl/pub/doc/CPAN/ + ftp://ftp.pk.edu.pl/pub/lang/perl/CPAN/ + ftp://sunsite.icm.edu.pl/pub/CPAN/ + Portugal ftp://ftp.ci.uminho.pt/pub/mirrors/cpan/ + ftp://ftp.ua.pt/pub/CPAN/ + Romania ftp://ftp.dntis.ro/pub/mirrors/perl-cpan/ + ftp://ftp.dnttm.ro/pub/CPAN/ + Russia ftp://cpan.npi.msu.su/CPAN/ + ftp://ftp.sai.msu.su/pub/lang/perl/CPAN/ + Slovakia ftp://ftp.entry.sk/pub/languages/perl/CPAN/ + Slovenia ftp://ftp.arnes.si/software/perl/CPAN/ + Spain ftp://ftp.etse.urv.es/pub/perl/ + ftp://ftp.rediris.es/mirror/CPAN/ + Sweden ftp://ftp.sunet.se/pub/lang/perl/CPAN/ + Switzerland ftp://sunsite.cnlab-switch.ch/mirror/CPAN/ + Turkey ftp://sunsite.bilkent.edu.tr/pub/languages/CPAN/ + United Kingdom ftp://ftp.demon.co.uk/pub/mirrors/perl/CPAN/ + ftp://ftp.flirble.org/pub/languages/perl/CPAN/ + ftp://ftp.plig.org/pub/CPAN/ + ftp://sunsite.doc.ic.ac.uk/packages/CPAN/ + ftp://unix.hensa.ac.uk/mirrors/perl-CPAN/ =item * North America - Ontario ftp://ftp.utilis.com/public/CPAN/ - ftp://enterprise.ic.gc.ca/pub/perl/CPAN/ - Manitoba ftp://theory.uwinnipeg.ca/pub/CPAN/ - California ftp://ftp.digital.com/pub/plan/perl/CPAN/ - ftp://ftp.cdrom.com/pub/perl/CPAN/ - Colorado ftp://ftp.cs.colorado.edu/pub/perl/CPAN/ - Florida ftp://ftp.cis.ufl.edu/pub/perl/CPAN/ - Illinois ftp://uiarchive.uiuc.edu/pub/lang/perl/CPAN/ - Massachusetts ftp://ftp.iguide.com/pub/mirrors/packages/perl/CPAN/ - New York ftp://ftp.rge.com/pub/languages/perl/ - North Carolina ftp://ftp.duke.edu/pub/perl/ - Oklahoma ftp://ftp.ou.edu/mirrors/CPAN/ - Oregon http://www.perl.org/CPAN/ - ftp://ftp.orst.edu/pub/packages/CPAN/ - Pennsylvania ftp://ftp.epix.net/pub/languages/perl/ - Texas ftp://ftp.sedl.org/pub/mirrors/CPAN/ - ftp://ftp.metronet.com/pub/perl/ + Alberta ftp://sunsite.ualberta.ca/pub/Mirror/CPAN/ + California ftp://ftp.cdrom.com/pub/perl/CPAN/ + ftp://ftp.digital.com/pub/plan/perl/CPAN/ + Colorado ftp://ftp.cs.colorado.edu/pub/perl/CPAN/ + Florida ftp://ftp.cise.ufl.edu/pub/perl/CPAN/ + Illinois ftp://uiarchive.uiuc.edu/pub/lang/perl/CPAN/ + Indiana ftp://csociety-ftp.ecn.purdue.edu/pub/CPAN/ + ftp://ftp.uwsg.indiana.edu/pub/perl/CPAN/ + Manitoba ftp://theory.uwinnipeg.ca/pub/CPAN/ + Massachusetts ftp://ftp.ccs.neu.edu/net/mirrors/ftp.funet.fi/pub/languages/perl/CPAN/ + ftp://ftp.iguide.com/pub/mirrors/packages/perl/CPAN/ + Mexico D.F. ftp://ftp.msg.com.mx/pub/CPAN/ + New York ftp://ftp.rge.com/pub/languages/perl/ + North Carolina ftp://ftp.duke.edu/pub/perl/ + Oklahoma ftp://ftp.ou.edu/mirrors/CPAN/ + Ontario ftp://ftp.crc.ca/pub/packages/perl/CPAN/ + Oregon ftp://ftp.orst.edu/pub/packages/CPAN/ + Pennsylvania ftp://ftp.epix.net/pub/languages/perl/ + Texas ftp://ftp.sedl.org/pub/mirrors/CPAN/ + Utah ftp://mirror.xmission.com/CPAN/ + Virginia ftp://ftp.perl.org/pub/perl/CPAN/ + ftp://ruff.cs.jmu.edu/pub/CPAN/ + Washington ftp://ftp.spu.edu/pub/CPAN/ =item * South America - Chile ftp://sunsite.dcc.uchile.cl/pub/Lang/perl/CPAN/ + Brazil ftp://cpan.if.usp.br/pub/mirror/CPAN/ + Chile ftp://ftp.ing.puc.cl/pub/unix/perl/CPAN/ + ftp://sunsite.dcc.uchile.cl/pub/Lang/perl/CPAN/ =back diff --git a/contrib/perl5/pod/perlobj.pod b/contrib/perl5/pod/perlobj.pod index f10fbdf..a997ae0 100644 --- a/contrib/perl5/pod/perlobj.pod +++ b/contrib/perl5/pod/perlobj.pod @@ -84,7 +84,7 @@ that wish to call methods in the class as part of the construction: } If you care about inheritance (and you should; see -L<perlmod/"Modules: Creation, Use, and Abuse">), +L<perlmodlib/"Modules: Creation, Use, and Abuse">), then you want to use the two-arg form of bless so that your constructors may be inherited: @@ -251,7 +251,7 @@ or in one statement, There are times when one syntax is more readable, and times when the other syntax is more readable. The indirect object syntax is less cluttered, but it has the same ambiguity as ordinary list operators. -Indirect object method calls are parsed using the same rule as list +Indirect object method calls are usually parsed using the same rule as list operators: "If it looks like a function, it is a function". (Presuming for the moment that you think two words in a row can look like a function name. C++ programmers seem to think so with some regularity, @@ -268,7 +268,20 @@ would be equivalent to Critter->new('Bam' x 2), 1.4, 45 -which is unlikely to do what you want. +which is unlikely to do what you want. Confusingly, however, this +rule applies only when the indirect object is a bareword package name, +not when it's a scalar, a BLOCK, or a C<Package::> qualified package name. +In those cases, the arguments are parsed in the same way as an +indirect object list operator like print, so + + new Critter:: ('Bam' x 2), 1.4, 45 + +is the same as + + Critter::->new(('Bam' x 2), 1.4, 45) + +For more reasons why the indirect object syntax is ambiguous, see +L<"WARNING"> below. There are times when you wish to specify which class's method to use. In this case, you can call your method as an ordinary subroutine diff --git a/contrib/perl5/pod/perlop.pod b/contrib/perl5/pod/perlop.pod index c7209fa..9f6d965 100644 --- a/contrib/perl5/pod/perlop.pod +++ b/contrib/perl5/pod/perlop.pod @@ -44,7 +44,7 @@ Many operators can be overloaded for objects. See L<overload>. =head2 Terms and List Operators (Leftward) -A TERM has the highest precedence in Perl. They includes variables, +A TERM has the highest precedence in Perl. They include variables, quote and quote-like operators, any expression in parentheses, and any function whose arguments are parenthesized. Actually, there aren't really functions in this sense, just list operators and unary @@ -620,9 +620,9 @@ the same character fore and aft, but the 4 sorts of brackets "" qq{} Literal yes `` qx{} Command yes (unless '' is delimiter) qw{} Word list no - // m{} Pattern match yes - qr{} Pattern yes - s{}{} Substitution yes + // m{} Pattern match yes (unless '' is delimiter) + qr{} Pattern yes (unless '' is delimiter) + s{}{} Substitution yes (unless '' is delimiter) tr{}{} Transliteration no (but see below) Note that there can be whitespace between the operator and the quoting @@ -645,8 +645,8 @@ a transliteration, the first ten of these sequences may be used. \b backspace (BS) \a alarm (bell) (BEL) \e escape (ESC) - \033 octal char - \x1b hex char + \033 octal char (ESC) + \x1b hex char (ESC) \c[ control char \l lowercase next char @@ -752,22 +752,22 @@ Options are: If "/" is the delimiter then the initial C<m> is optional. With the C<m> you can use any pair of non-alphanumeric, non-whitespace characters -as delimiters (if single quotes are used, no interpretation is done -on the replacement string. Unlike Perl 4, Perl 5 treats backticks as normal -delimiters; the replacement text is not evaluated as a command). -This is particularly useful for matching Unix path names -that contain "/", to avoid LTS (leaning toothpick syndrome). If "?" is +as delimiters. This is particularly useful for matching Unix path names +that contain "/", to avoid LTS (leaning toothpick syndrome). If "?" is the delimiter, then the match-only-once rule of C<?PATTERN?> applies. +If "'" is the delimiter, no variable interpolation is performed on the +PATTERN. PATTERN may contain variables, which will be interpolated (and the -pattern recompiled) every time the pattern search is evaluated. (Note -that C<$)> and C<$|> might not be interpolated because they look like -end-of-string tests.) If you want such a pattern to be compiled only -once, add a C</o> after the trailing delimiter. This avoids expensive -run-time recompilations, and is useful when the value you are -interpolating won't change over the life of the script. However, mentioning -C</o> constitutes a promise that you won't change the variables in the pattern. -If you change them, Perl won't even notice. +pattern recompiled) every time the pattern search is evaluated, except +for when the delimiter is a single quote. (Note that C<$)> and C<$|> +might not be interpolated because they look like end-of-string tests.) +If you want such a pattern to be compiled only once, add a C</o> after +the trailing delimiter. This avoids expensive run-time recompilations, +and is useful when the value you are interpolating won't change over +the life of the script. However, mentioning C</o> constitutes a promise +that you won't change the variables in the pattern. If you change them, +Perl won't even notice. If the PATTERN evaluates to the empty string, the last I<successfully> matched regular expression is used instead. @@ -829,10 +829,12 @@ Examples: ($one,$five,$fifteen) = (`uptime` =~ /(\d+\.\d+)/g); # scalar context - $/ = ""; $* = 1; # $* deprecated in modern perls - while (defined($paragraph = <>)) { - while ($paragraph =~ /[a-z]['")]*[.!?]+['")]*\s/g) { - $sentences++; + { + local $/ = ""; + while (defined($paragraph = <>)) { + while ($paragraph =~ /[a-z]['")]*[.!?]+['")]*\s/g) { + $sentences++; + } } } print "$sentences\n"; @@ -907,14 +909,50 @@ A double-quoted, interpolated string. if /(tcl|rexx|python)/; # :-) $baz = "\n"; # a one-character string -=item qr/STRING/imosx +=item qr/PATTERN/imosx + +Quote-as-a-regular-expression operator. I<STRING> is interpolated the +same way as I<PATTERN> in C<m/PATTERN/>. If "'" is used as the +delimiter, no variable interpolation is done. Returns a Perl value +which may be used instead of the corresponding C</STRING/imosx> expression. + +For example, + + $rex = qr/my.STRING/is; + s/$rex/foo/; -A string which is (possibly) interpolated and then compiled as a -regular expression. The result may be used as a pattern in a match +is equivalent to + + s/my.STRING/foo/is; + +The result may be used as a subpattern in a match: $re = qr/$pattern/; $string =~ /foo${re}bar/; # can be interpolated in other patterns $string =~ $re; # or used standalone + $string =~ /$re/; # or this way + +Since Perl may compile the pattern at the moment of execution of qr() +operator, using qr() may have speed advantages in I<some> situations, +notably if the result of qr() is used standalone: + + sub match { + my $patterns = shift; + my @compiled = map qr/$_/i, @$patterns; + grep { + my $success = 0; + foreach my $pat @compiled { + $success = 1, last if /$pat/; + } + $success; + } @_; + } + +Precompilation of the pattern into an internal representation at the +moment of qr() avoids a need to recompile the pattern every time a +match C</$pat/> is attempted. (Note that Perl has many other +internal optimizations, but none would be triggered in the above +example if we did not use qr() operator.) Options are: @@ -924,19 +962,6 @@ Options are: s Treat string as single line. x Use extended regular expressions. -The benefit from this is that the pattern is precompiled into an internal -representation, and does not need to be recompiled every time a match -is attempted. This makes it very efficient to do something like: - - foreach $pattern (@pattern_list) { - my $re = qr/$pattern/; - foreach $line (@lines) { - if($line =~ /$re/) { - do_something($line); - } - } - } - See L<perlre> for additional information on valid syntax for STRING, and for a detailed look at the semantics of regular expressions. @@ -1023,6 +1048,12 @@ whitespace as the word delimiters. It is exactly equivalent to This equivalency means that if used in scalar context, you'll get split's (unfortunate) scalar context behavior, complete with mysterious warnings. +However do not rely on this as in a future release it could be changed to +be exactly equivalent to the list + + ('foo', 'bar', 'baz') + +Which in a scalar context would result in C<'baz'>. Some frequently seen examples: @@ -1045,7 +1076,7 @@ variable is searched and modified. (The string specified with C<=~> must be scalar variable, an array element, a hash element, or an assignment to one of those, i.e., an lvalue.) -If the delimiter chosen is single quote, no variable interpolation is +If the delimiter chosen is a single quote, no variable interpolation is done on either the PATTERN or the REPLACEMENT. Otherwise, if the PATTERN contains a $ that looks like a variable rather than an end-of-string test, the variable will be interpolated into the pattern @@ -1148,6 +1179,7 @@ the number of characters replaced or deleted. If no string is specified via the =~ or !~ operator, the $_ string is transliterated. (The string specified with =~ must be a scalar variable, an array element, a hash element, or an assignment to one of those, i.e., an lvalue.) + A character range may be specified with a hyphen, so C<tr/A-J/0-9/> does the same replacement as C<tr/ACEGIBDFHJ/0246813579/>. For B<sed> devotees, C<y> is provided as a synonym for C<tr>. If the @@ -1155,6 +1187,13 @@ SEARCHLIST is delimited by bracketing quotes, the REPLACEMENTLIST has its own pair of quotes, which may or may not be bracketing quotes, e.g., C<tr[A-Z][a-z]> or C<tr(+\-*/)/ABCD/>. +Note also that the whole range idea is rather unportable between +character sets--and even within character sets they may cause results +you probably didn't expect. A sound principle is to use only ranges +that begin from and end at either alphabets of equal case (a-e, A-E), +or digits (0-4). Anything else is unsafe. If in doubt, spell out the +character sets in full. + Options: c Complement the SEARCHLIST. @@ -1229,6 +1268,13 @@ details discussed in this section is hairy regular expressions. However, the first steps of parsing are the same for all Perl quoting operators, so here they are discussed together. +The most important detail of Perl parsing rules is the first one +discussed below; when processing a quoted construct, Perl I<first> +finds the end of the construct, then it interprets the contents of the +construct. If you understand this rule, you may skip the rest of this +section on the first reading. The other rules would +contradict user's expectations much less frequently than the first one. + Some of the passes discussed below are performed concurrently, but as far as results are the same, we consider them one-by-one. For different quoting constructs Perl performs different number of passes, from @@ -1238,32 +1284,37 @@ one to five, but they are always performed in the same order. =item Finding the end -First pass is finding the end of the quoted construct, be it multichar ender +First pass is finding the end of the quoted construct, be it +a multichar delimiter C<"\nEOF\n"> of C<<<EOF> construct, C</> which terminates C<qq/> construct, C<]> which terminates C<qq[> construct, or C<E<gt>> which terminates a fileglob started with C<<>. -When searching for multichar construct no skipping is performed. When -searching for one-char non-matching delimiter, such as C</>, combinations +When searching for one-char non-matching delimiter, such as C</>, combinations C<\\> and C<\/> are skipped. When searching for one-char matching delimiter, such as C<]>, combinations C<\\>, C<\]> and C<\[> are skipped, and -nested C<[>, C<]> are skipped as well. +nested C<[>, C<]> are skipped as well. When searching for multichar delimiter +no skipping is performed. -For 3-parts constructs, C<s///> etc. the search is repeated once more. +For constructs with 3-part delimiters (C<s///> etc.) the search is +repeated once more. -During this search no attention is paid to the semantic of the construct, thus +During this search no attention is paid to the semantic of the construct, +thus: "$hash{"$foo/$bar"}" -or +or: m/ - bar # This is not a comment, this slash / terminated m//! + bar # NOT a comment, this slash / terminated m//! /x -do not form legal quoted expressions. Note that since the slash which -terminated C<m//> was followed by a C<SPACE>, this is not C<m//x>, -thus C<#> was interpreted as a literal C<#>. +do not form legal quoted expressions, the quoted part ends on the first C<"> +and C</>, and the rest happens to be a syntax error. Note that since the slash +which terminated C<m//> was followed by a C<SPACE>, the above is not C<m//x>, +but rather C<m//> with no 'x' switch. So the embedded C<#> is interpreted +as a literal C<#>. =item Removal of backslashes before delimiters @@ -1297,42 +1348,64 @@ The only interpolation is removal of C<\> from pairs C<\\>. =item C<"">, C<``>, C<qq//>, C<qx//>, C<<file*globE<gt>> C<\Q>, C<\U>, C<\u>, C<\L>, C<\l> (possibly paired with C<\E>) are converted -to corresponding Perl constructs, thus C<"$foo\Qbaz$bar"> is converted to +to corresponding Perl constructs, thus C<"$foo\Qbaz$bar"> is converted to : $foo . (quotemeta("baz" . $bar)); Other combinations of C<\> with following chars are substituted with -appropriate expansions. +appropriate expansions. + +Let it be stressed that I<whatever is between C<\Q> and C<\E>> is interpolated +in the usual way. Say, C<"\Q\\E"> has no C<\E> inside: it has C<\Q>, C<\\>, +and C<E>, thus the result is the same as for C<"\\\\E">. Generally speaking, +having backslashes between C<\Q> and C<\E> may lead to counterintuitive +results. So, C<"\Q\t\E"> is converted to: + + quotemeta("\t") + +which is the same as C<"\\\t"> (since TAB is not alphanumerical). Note also +that: -Interpolated scalars and arrays are converted to C<join> and C<.> Perl -constructs, thus C<"'@arr'"> becomes + $str = '\t'; + return "\Q$str"; - "'" . (join $", @arr) . "'"; +may be closer to the conjectural I<intention> of the writer of C<"\Q\t\E">. -Since all three above steps are performed simultaneously left-to-right, -the is no way to insert a literal C<$> or C<@> inside C<\Q\E> pair: it -cannot be protected by C<\>, since any C<\> (except in C<\E>) is -interpreted as a literal inside C<\Q\E>, and any C<$> is +Interpolated scalars and arrays are internally converted to the C<join> and +C<.> Perl operations, thus C<"$foo >>> '@arr'"> becomes: + + $foo . " >>> '" . (join $", @arr) . "'"; + +All the operations in the above are performed simultaneously left-to-right. + +Since the result of "\Q STRING \E" has all the metacharacters quoted +there is no way to insert a literal C<$> or C<@> inside a C<\Q\E> pair: if +protected by C<\> C<$> will be quoted to became "\\\$", if not, it is interpreted as starting an interpolated scalar. -Note also that the interpolating code needs to make decision where the -interpolated scalar ends, say, whether C<"a $b -E<gt> {c}"> means +Note also that the interpolating code needs to make a decision on where the +interpolated scalar ends. For instance, whether C<"a $b -E<gt> {c}"> means: "a " . $b . " -> {c}"; -or +or: "a " . $b -> {c}; -Most the time the decision is to take the longest possible text which does -not include spaces between components and contains matching braces/brackets. +I<Most of the time> the decision is to take the longest possible text which +does not include spaces between components and contains matching +braces/brackets. Since the outcome may be determined by I<voting> based +on heuristic estimators, the result I<is not strictly predictable>, but +is usually correct for the ambiguous cases. =item C<?RE?>, C</RE/>, C<m/RE/>, C<s/RE/foo/>, Processing of C<\Q>, C<\U>, C<\u>, C<\L>, C<\l> and interpolation happens (almost) as with C<qq//> constructs, but I<the substitution of C<\> followed by -other chars is not performed>! Moreover, inside C<(?{BLOCK})> no processing -is performed at all. +RE-special chars (including C<\>) is not performed>! Moreover, +inside C<(?{BLOCK})>, C<(?# comment )>, and C<#>-comment of +C<//x>-regular expressions no processing is performed at all. +This is the first step where presence of the C<//x> switch is relevant. Interpolation has several quirks: C<$|>, C<$(> and C<$)> are not interpolated, and constructs C<$var[SOMETHING]> are I<voted> (by several different estimators) @@ -1340,15 +1413,25 @@ to be an array element or C<$var> followed by a RE alternative. This is the place where the notation C<${arr[$bar]}> comes handy: C</${arr[0-9]}/> is interpreted as an array element C<-9>, not as a regular expression from variable C<$arr> followed by a digit, which is the interpretation of -C</$arr[0-9]/>. +C</$arr[0-9]/>. Since voting among different estimators may be performed, +the result I<is not predictable>. + +It is on this step that C<\1> is converted to C<$1> in the replacement +text of C<s///>. Note that absence of processing of C<\\> creates specific restrictions on the post-processed text: if the delimiter is C</>, one cannot get the combination C<\/> into the result of this step: C</> will finish the regular expression, C<\/> will be stripped to C</> on the previous step, and C<\\/> will be left as is. Since C</> is equivalent to C<\/> inside a regular expression, this -does not matter unless the delimiter is special character for the RE engine, as -in C<s*foo*bar*>, C<m[foo]>, or C<?foo?>. +does not matter unless the delimiter is a special character for the RE engine, +as in C<s*foo*bar*>, C<m[foo]>, or C<?foo?>, or an alphanumeric char, as in: + + m m ^ a \s* b mmx; + +In the above RE, which is intentionally obfuscated for illustration, the +delimiter is C<m>, the modifier is C<mx>, and after backslash-removal the +RE is the same as for C<m/ ^ a s* b /mx>). =back @@ -1367,32 +1450,48 @@ engine for compilation. Whatever happens in the RE engine is better be discussed in L<perlre>, but for the sake of continuity let us do it here. -This is the first step where presence of the C<//x> switch is relevant. +This is another step where presence of the C<//x> switch is relevant. The RE engine scans the string left-to-right, and converts it to a finite automaton. Backslashed chars are either substituted by corresponding literal -strings, or generate special nodes of the finite automaton. Characters -which are special to the RE engine generate corresponding nodes. C<(?#...)> +strings (as with C<\{>), or generate special nodes of the finite automaton +(as with C<\b>). Characters which are special to the RE engine (such as +C<|>) generate corresponding nodes or groups of nodes. C<(?#...)> comments are ignored. All the rest is either converted to literal strings to match, or is ignored (as is whitespace and C<#>-style comments if C<//x> is present). Note that the parsing of the construct C<[...]> is performed using -absolutely different rules than the rest of the regular expression. -Similarly, the C<(?{...})> is only checked for matching braces. +rather different rules than for the rest of the regular expression. +The terminator of this construct is found using the same rules as for +finding a terminator of a C<{}>-delimited construct, the only exception +being that C<]> immediately following C<[> is considered as if preceded +by a backslash. Similarly, the terminator of C<(?{...})> is found using +the same rules as for finding a terminator of a C<{}>-delimited construct. + +It is possible to inspect both the string given to RE engine, and the +resulting finite automaton. See arguments C<debug>/C<debugcolor> +of C<use L<re>> directive, and/or B<-Dr> option of Perl in +L<perlrun/Switches>. =item Optimization of regular expressions This step is listed for completeness only. Since it does not change semantics, details of this step are not documented and are subject -to change. +to change. This step is performed over the finite automaton generated +during the previous pass. + +However, in older versions of Perl C<L<split>> used to silently +optimize C</^/> to mean C</^/m>. This behaviour, though present +in current versions of Perl, may be deprecated in future. =back =head2 I/O Operators There are several I/O operators you should know about. + A string enclosed by backticks (grave accents) first undergoes variable substitution just like a double quoted string. It is then interpreted as a command, and the output of that command is the value @@ -1410,9 +1509,13 @@ The generalized form of backticks is C<qx//>. (Because backticks always undergo shell expansion as well, see L<perlsec> for security concerns.) -Evaluating a filehandle in angle brackets yields the next line from -that file (newline, if any, included), or C<undef> at end of file. -Ordinarily you must assign that value to a variable, but there is one +In a scalar context, evaluating a filehandle in angle brackets yields the +next line from that file (newline, if any, included), or C<undef> at +end-of-file. When C<$/> is set to C<undef> (i.e. file slurp mode), +and the file is empty, it returns C<''> the first time, followed by +C<undef> subsequently. + +Ordinarily you must assign the returned value to a variable, but there is one situation where an automatic assignment happens. I<If and ONLY if> the input symbol is the only thing inside the conditional of a C<while> or C<for(;;)> loop, the value is automatically assigned to the variable @@ -1449,13 +1552,16 @@ The filehandles STDIN, STDOUT, and STDERR are predefined. (The filehandles C<stdin>, C<stdout>, and C<stderr> will also work except in packages, where they would be interpreted as local identifiers rather than global.) Additional filehandles may be created with the open() -function. See L<perlfunc/open()> for details on this. +function. See L<perlfunc/open> for details on this. If a E<lt>FILEHANDLEE<gt> is used in a context that is looking for a list, a list consisting of all the input lines is returned, one line per list element. It's easy to make a I<LARGE> data space this way, so use with care. +E<lt>FILEHANDLEE<gt> may also be spelt readline(FILEHANDLE). See +L<perlfunc/readline>. + The null filehandle E<lt>E<gt> is special and can be used to emulate the behavior of B<sed> and B<awk>. Input from E<lt>E<gt> comes either from standard input, or from each file listed on the command line. Here's @@ -1622,9 +1728,10 @@ Bitstrings of any size may be manipulated by the bitwise operators (C<~ | & ^>). If the operands to a binary bitwise op are strings of different sizes, -B<or> and B<xor> ops will act as if the shorter operand had additional -zero bits on the right, while the B<and> op will act as if the longer -operand were truncated to the length of the shorter. +B<|> and B<^> ops will act as if the shorter operand had additional +zero bits on the right, while the B<&> op will act as if the longer +operand were truncated to the length of the shorter. Note that the +granularity for such extension or truncation is one or more I<bytes>. # ASCII-based examples print "j p \n" ^ " a h"; # prints "JAPH\n" @@ -1645,6 +1752,9 @@ operation you intend by using C<""> or C<0+>, as in the examples below. $baz = 0+$foo & 0+$bar; # both ops explicitly numeric $biz = "$foo" ^ "$bar"; # both ops explicitly stringy +See L<perlfunc/vec> for information on how to manipulate individual bits +in a bit vector. + =head2 Integer Arithmetic By default Perl assumes that it must do most of its arithmetic in diff --git a/contrib/perl5/pod/perlopentut.pod b/contrib/perl5/pod/perlopentut.pod new file mode 100644 index 0000000..6e6091a --- /dev/null +++ b/contrib/perl5/pod/perlopentut.pod @@ -0,0 +1,862 @@ +=head1 NAME + +perlopentut - tutorial on opening things in Perl + +=head1 DESCRIPTION + +Perl has two simple, built-in ways to open files: the shell way for +convenience, and the C way for precision. The choice is yours. + +=head1 Open E<agrave> la shell + +Perl's C<open> function was designed to mimic the way command-line +redirection in the shell works. Here are some basic examples +from the shell: + + $ myprogram file1 file2 file3 + $ myprogram < inputfile + $ myprogram > outputfile + $ myprogram >> outputfile + $ myprogram | otherprogram + $ otherprogram | myprogram + +And here are some more advanced examples: + + $ otherprogram | myprogram f1 - f2 + $ otherprogram 2>&1 | myprogram - + $ myprogram <&3 + $ myprogram >&4 + +Programmers accustomed to constructs like those above can take comfort +in learning that Perl directly supports these familiar constructs using +virtually the same syntax as the shell. + +=head2 Simple Opens + +The C<open> function takes two arguments: the first is a filehandle, +and the second is a single string comprising both what to open and how +to open it. C<open> returns true when it works, and when it fails, +returns a false value and sets the special variable $! to reflect +the system error. If the filehandle was previously opened, it will +be implicitly closed first. + +For example: + + open(INFO, "datafile") || die("can't open datafile: $!"); + open(INFO, "< datafile") || die("can't open datafile: $!"); + open(RESULTS,"> runstats") || die("can't open runstats: $!"); + open(LOG, ">> logfile ") || die("can't open logfile: $!"); + +If you prefer the low-punctuation version, you could write that this way: + + open INFO, "< datafile" or die "can't open datafile: $!"; + open RESULTS,"> runstats" or die "can't open runstats: $!"; + open LOG, ">> logfile " or die "can't open logfile: $!"; + +A few things to notice. First, the leading less-than is optional. +If omitted, Perl assumes that you want to open the file for reading. + +The other important thing to notice is that, just as in the shell, +any white space before or after the filename is ignored. This is good, +because you wouldn't want these to do different things: + + open INFO, "<datafile" + open INFO, "< datafile" + open INFO, "< datafile" + +Ignoring surround whitespace also helps for when you read a filename in +from a different file, and forget to trim it before opening: + + $filename = <INFO>; # oops, \n still there + open(EXTRA, "< $filename") || die "can't open $filename: $!"; + +This is not a bug, but a feature. Because C<open> mimics the shell in +its style of using redirection arrows to specify how to open the file, it +also does so with respect to extra white space around the filename itself +as well. For accessing files with naughty names, see L</"Dispelling +the Dweomer">. + +=head2 Pipe Opens + +In C, when you want to open a file using the standard I/O library, +you use the C<fopen> function, but when opening a pipe, you use the +C<popen> function. But in the shell, you just use a different redirection +character. That's also the case for Perl. The C<open> call +remains the same--just its argument differs. + +If the leading character is a pipe symbol, C<open) starts up a new +command and open a write-only filehandle leading into that command. +This lets you write into that handle and have what you write show up on +that command's standard input. For example: + + open(PRINTER, "| lpr -Plp1") || die "cannot fork: $!"; + print PRINTER "stuff\n"; + close(PRINTER) || die "can't close lpr: $!"; + +If the trailing character is a pipe, you start up a new command and open a +read-only filehandle leading out of that command. This lets whatever that +command writes to its standard output show up on your handle for reading. +For example: + + open(NET, "netstat -i -n |") || die "cannot fork: $!"; + while (<NET>) { } # do something with input + close(NET) || die "can't close netstat: $!"; + +What happens if you try to open a pipe to or from a non-existent command? +In most systems, such an C<open> will not return an error. That's +because in the traditional C<fork>/C<exec> model, running the other +program happens only in the forked child process, which means that +the failed C<exec> can't be reflected in the return value of C<open>. +Only a failed C<fork> shows up there. See L<perlfaq8/"Why doesn't open() +return an error when a pipe open fails?"> to see how to cope with this. +There's also an explanation in L<perlipc>. + +If you would like to open a bidirectional pipe, the IPC::Open2 +library will handle this for you. Check out L<perlipc/"Bidirectional +Communication with Another Process"> + +=head2 The Minus File + +Again following the lead of the standard shell utilities, Perl's +C<open> function treats a file whose name is a single minus, "-", in a +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 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 +a stealth C<fork> hidden inside an C<open> call. See L<perlipc/"Safe Pipe +Opens"> for details. + +=head2 Mixing Reads and Writes + +It is possible to specify both read and write access. All you do is +add a "+" symbol in front of the redirection. But as in the shell, +using a less-than on a file never creates a new file; it only opens an +existing one. On the other hand, using a greater-than always clobbers +(truncates to zero length) an existing file, or creates a brand-new one +if there isn't an old one. Adding a "+" for read-write doesn't affect +whether it only works on existing files or always clobbers existing ones. + + open(WTMP, "+< /usr/adm/wtmp") + || die "can't open /usr/adm/wtmp: $!"; + + open(SCREEN, "+> /tmp/lkscreen") + || die "can't open /tmp/lkscreen: $!"; + + open(LOGFILE, "+>> /tmp/applog" + || die "can't open /tmp/applog: $!"; + +The first one won't create a new file, and the second one will always +clobber an old one. The third one will create a new file if necessary +and not clobber an old one, and it will allow you to read at any point +in the file, but all writes will always go to the end. In short, +the first case is substantially more common than the second and third +cases, which are almost always wrong. (If you know C, the plus in +Perl's C<open> is historically derived from the one in C's fopen(3S), +which it ultimately calls.) + +In fact, when it comes to updating a file, unless you're working on +a binary file as in the WTMP case above, you probably don't want to +use this approach for updating. Instead, Perl's B<-i> flag comes to +the rescue. The following command takes all the C, C++, or yacc source +or header files and changes all their foo's to bar's, leaving +the old version in the original file name with a ".orig" tacked +on the end: + + $ perl -i.orig -pe 's/\bfoo\b/bar/g' *.[Cchy] + +This is a short cut for some renaming games that are really +the best way to update textfiles. See the second question in +L<perlfaq5> for more details. + +=head2 Filters + +One of the most common uses for C<open> is one you never +even notice. When you process the ARGV filehandle using +C<E<lt>ARGVE<gt>>, Perl actually does an implicit open +on each file in @ARGV. Thus a program called like this: + + $ myprogram file1 file2 file3 + +Can have all its files opened and processed one at a time +using a construct no more complex than: + + while (<>) { + # do something with $_ + } + +If @ARGV is empty when the loop first begins, Perl pretends you've opened +up minus, that is, the standard input. In fact, $ARGV, the currently +open file during C<E<lt>ARGVE<gt>> processing, is even set to "-" +in these circumstances. + +You are welcome to pre-process your @ARGV before starting the loop to +make sure it's to your liking. One reason to do this might be to remove +command options beginning with a minus. While you can always roll the +simple ones by hand, the Getopts modules are good for this. + + use Getopt::Std; + + # -v, -D, -o ARG, sets $opt_v, $opt_D, $opt_o + getopts("vDo:"); + + # -v, -D, -o ARG, sets $args{v}, $args{D}, $args{o} + getopts("vDo:", \%args); + +Or the standard Getopt::Long module to permit named arguments: + + use Getopt::Long; + GetOptions( "verbose" => \$verbose, # --verbose + "Debug" => \$debug, # --Debug + "output=s" => \$output ); + # --output=somestring or --output somestring + +Another reason for preprocessing arguments is to make an empty +argument list default to all files: + + @ARGV = glob("*") unless @ARGV; + +You could even filter out all but plain, text files. This is a bit +silent, of course, and you might prefer to mention them on the way. + + @ARGV = grep { -f && -T } @ARGV; + +If you're using the B<-n> or B<-p> command-line options, you +should put changes to @ARGV in a C<BEGIN{}> block. + +Remember that a normal C<open> has special properties, in that it might +call fopen(3S) or it might called popen(3S), depending on what its +argument looks like; that's why it's sometimes called "magic open". +Here's an example: + + $pwdinfo = `domainname` =~ /^(\(none\))?$/ + ? '< /etc/passwd' + : 'ypcat passwd |'; + + open(PWD, $pwdinfo) + or die "can't open $pwdinfo: $!"; + +This sort of thing also comes into play in filter processing. Because +C<E<lt>ARGVE<gt>> processing employs the normal, shell-style Perl C<open>, +it respects all the special things we've already seen: + + $ myprogram f1 "cmd1|" - f2 "cmd2|" f3 < tmpfile + +That program will read from the file F<f1>, the process F<cmd1>, standard +input (F<tmpfile> in this case), the F<f2> file, the F<cmd2> command, +and finally the F<f3> file. + +Yes, this also means that if you have a file named "-" (and so on) in +your directory, that they won't be processed as literal files by C<open>. +You'll need to pass them as "./-" much as you would for the I<rm> program. +Or you could use C<sysopen> as described below. + +One of the more interesting applications is to change files of a certain +name into pipes. For example, to autoprocess gzipped or compressed +files by decompressing them with I<gzip>: + + @ARGV = map { /^\.(gz|Z)$/ ? "gzip -dc $_ |" : $_ } @ARGV; + +Or, if you have the I<GET> program installed from LWP, +you can fetch URLs before processing them: + + @ARGV = map { m#^\w+://# ? "GET $_ |" : $_ } @ARGV; + +It's not for nothing that this is called magic C<E<lt>ARGVE<gt>>. +Pretty nifty, eh? + +=head1 Open E<agrave> la C + +If you want the convenience of the shell, then Perl's C<open> is +definitely the way to go. On the other hand, if you want finer precision +than C's simplistic fopen(3S) provides, then you should look to Perl's +C<sysopen>, which is a direct hook into the open(2) system call. +That does mean it's a bit more involved, but that's the price of +precision. + +C<sysopen> takes 3 (or 4) arguments. + + sysopen HANDLE, PATH, FLAGS, [MASK] + +The HANDLE argument is a filehandle just as with C<open>. The PATH is +a literal path, one that doesn't pay attention to any greater-thans or +less-thans or pipes or minuses, nor ignore white space. If it's there, +it's part of the path. The FLAGS argument contains one or more values +derived from the Fcntl module that have been or'd together using the +bitwise "|" operator. The final argument, the MASK, is optional; if +present, it is combined with the user's current umask for the creation +mode of the file. You should usually omit this. + +Although the traditional values of read-only, write-only, and read-write +are 0, 1, and 2 respectively, this is known not to hold true on some +systems. Instead, it's best to load in the appropriate constants first +from the Fcntl module, which supplies the following standard flags: + + O_RDONLY Read only + O_WRONLY Write only + O_RDWR Read and write + O_CREAT Create the file if it doesn't exist + O_EXCL Fail if the file already exists + O_APPEND Append to the file + O_TRUNC Truncate the file + O_NONBLOCK Non-blocking access + +Less common flags that are sometimes available on some operating systems +include C<O_BINARY>, C<O_TEXT>, C<O_SHLOCK>, C<O_EXLOCK>, C<O_DEFER>, +C<O_SYNC>, C<O_ASYNC>, C<O_DSYNC>, C<O_RSYNC>, C<O_NOCTTY>, C<O_NDELAY> +and C<O_LARGEFILE>. Consult your open(2) manpage or its local equivalent +for details. + +Here's how to use C<sysopen> to emulate the simple C<open> calls we had +before. We'll omit the C<|| die $!> checks for clarity, but make sure +you always check the return values in real code. These aren't quite +the same, since C<open> will trim leading and trailing white space, +but you'll get the idea: + +To open a file for reading: + + open(FH, "< $path"); + sysopen(FH, $path, O_RDONLY); + +To open a file for writing, creating a new file if needed or else truncating +an old file: + + open(FH, "> $path"); + sysopen(FH, $path, O_WRONLY | O_TRUNC | O_CREAT); + +To open a file for appending, creating one if necessary: + + open(FH, ">> $path"); + sysopen(FH, $path, O_WRONLY | O_APPEND | O_CREAT); + +To open a file for update, where the file must already exist: + + open(FH, "+< $path"); + sysopen(FH, $path, O_RDWR); + +And here are things you can do with C<sysopen> that you cannot do with +a regular C<open>. As you see, it's just a matter of controlling the +flags in the third argument. + +To open a file for writing, creating a new file which must not previously +exist: + + sysopen(FH, $path, O_WRONLY | O_EXCL | O_CREAT); + +To open a file for appending, where that file must already exist: + + sysopen(FH, $path, O_WRONLY | O_APPEND); + +To open a file for update, creating a new file if necessary: + + sysopen(FH, $path, O_RDWR | O_CREAT); + +To open a file for update, where that file must not already exist: + + sysopen(FH, $path, O_RDWR | O_EXCL | O_CREAT); + +To open a file without blocking, creating one if necessary: + + sysopen(FH, $path, O_WRONLY | O_NONBLOCK | O_CREAT); + +=head2 Permissions E<agrave> la mode + +If you omit the MASK argument to C<sysopen>, Perl uses the octal value +0666. The normal MASK to use for executables and directories should +be 0777, and for anything else, 0666. + +Why so permissive? Well, it isn't really. The MASK will be modified +by your process's current C<umask>. A umask is a number representing +I<disabled> permissions bits; that is, bits that will not be turned on +in the created files' permissions field. + +For example, if your C<umask> were 027, then the 020 part would +disable the group from writing, and the 007 part would disable others +from reading, writing, or executing. Under these conditions, passing +C<sysopen> 0666 would create a file with mode 0640, since C<0666 &~ 027> +is 0640. + +You should seldom use the MASK argument to C<sysopen()>. That takes +away the user's freedom to choose what permission new files will have. +Denying choice is almost always a bad thing. One exception would be for +cases where sensitive or private data is being stored, such as with mail +folders, cookie files, and internal temporary files. + +=head1 Obscure Open Tricks + +=head2 Re-Opening Files (dups) + +Sometimes you already have a filehandle open, and want to make another +handle that's a duplicate of the first one. In the shell, we place an +ampersand in front of a file descriptor number when doing redirections. +For example, C<2E<gt>&1> makes descriptor 2 (that's STDERR in Perl) +be redirected into descriptor 1 (which is usually Perl's STDOUT). +The same is essentially true in Perl: a filename that begins with an +ampersand is treated instead as a file descriptor if a number, or as a +filehandle if a string. + + open(SAVEOUT, ">&SAVEERR") || die "couldn't dup SAVEERR: $!"; + open(MHCONTEXT, "<&4") || die "couldn't dup fd4: $!"; + +That means that if a function is expecting a filename, but you don't +want to give it a filename because you already have the file open, you +can just pass the filehandle with a leading ampersand. It's best to +use a fully qualified handle though, just in case the function happens +to be in a different package: + + somefunction("&main::LOGFILE"); + +This way if somefunction() is planning on opening its argument, it can +just use the already opened handle. This differs from passing a handle, +because with a handle, you don't open the file. Here you have something +you can pass to open. + +If you have one of those tricky, newfangled I/O objects that the C++ +folks are raving about, then this doesn't work because those aren't a +proper filehandle in the native Perl sense. You'll have to use fileno() +to pull out the proper descriptor number, assuming you can: + + use IO::Socket; + $handle = IO::Socket::INET->new("www.perl.com:80"); + $fd = $handle->fileno; + somefunction("&$fd"); # not an indirect function call + +It can be easier (and certainly will be faster) just to use real +filehandles though: + + use IO::Socket; + local *REMOTE = IO::Socket::INET->new("www.perl.com:80"); + die "can't connect" unless defined(fileno(REMOTE)); + somefunction("&main::REMOTE"); + +If the filehandle or descriptor number is preceded not just with a simple +"&" but rather with a "&=" combination, then Perl will not create a +completely new descriptor opened to the same place using the dup(2) +system call. Instead, it will just make something of an alias to the +existing one using the fdopen(3S) library call This is slightly more +parsimonious of systems resources, although this is less a concern +these days. Here's an example of that: + + $fd = $ENV{"MHCONTEXTFD"}; + open(MHCONTEXT, "<&=$fd") or die "couldn't fdopen $fd: $!"; + +If you're using magic C<E<lt>ARGVE<gt>>, you could even pass in as a +command line argument in @ARGV something like C<"E<lt>&=$MHCONTEXTFD">, +but we've never seen anyone actually do this. + +=head2 Dispelling the Dweomer + +Perl is more of a DWIMmer language than something like Java--where DWIM +is an acronym for "do what I mean". But this principle sometimes leads +to more hidden magic than one knows what to do with. In this way, Perl +is also filled with I<dweomer>, an obscure word meaning an enchantment. +Sometimes, Perl's DWIMmer is just too much like dweomer for comfort. + +If magic C<open> is a bit too magical for you, you don't have to turn +to C<sysopen>. To open a file with arbitrary weird characters in +it, it's necessary to protect any leading and trailing whitespace. +Leading whitespace is protected by inserting a C<"./"> in front of a +filename that starts with whitespace. Trailing whitespace is protected +by appending an ASCII NUL byte (C<"\0">) at the end off the string. + + $file =~ s#^(\s)#./$1#; + open(FH, "< $file\0") || die "can't open $file: $!"; + +This assumes, of course, that your system considers dot the current +working directory, slash the directory separator, and disallows ASCII +NULs within a valid filename. Most systems follow these conventions, +including all POSIX systems as well as proprietary Microsoft systems. +The only vaguely popular system that doesn't work this way is the +proprietary Macintosh system, which uses a colon where the rest of us +use a slash. Maybe C<sysopen> isn't such a bad idea after all. + +If you want to use C<E<lt>ARGVE<gt>> processing in a totally boring +and non-magical way, you could do this first: + + # "Sam sat on the ground and put his head in his hands. + # 'I wish I had never come here, and I don't want to see + # no more magic,' he said, and fell silent." + for (@ARGV) { + s#^([^./])#./$1#; + $_ .= "\0"; + } + while (<>) { + # now process $_ + } + +But be warned that users will not appreciate being unable to use "-" +to mean standard input, per the standard convention. + +=head2 Paths as Opens + +You've probably noticed how Perl's C<warn> and C<die> functions can +produce messages like: + + Some warning at scriptname line 29, <FH> chunk 7. + +That's because you opened a filehandle FH, and had read in seven records +from it. But what was the name of the file, not the handle? + +If you aren't running with C<strict refs>, or if you've turn them off +temporarily, then all you have to do is this: + + open($path, "< $path") || die "can't open $path: $!"; + while (<$path>) { + # whatever + } + +Since you're using the pathname of the file as its handle, +you'll get warnings more like + + Some warning at scriptname line 29, </etc/motd> chunk 7. + +=head2 Single Argument Open + +Remember how we said that Perl's open took two arguments? That was a +passive prevarication. You see, it can also take just one argument. +If and only if the variable is a global variable, not a lexical, you +can pass C<open> just one argument, the filehandle, and it will +get the path from the global scalar variable of the same name. + + $FILE = "/etc/motd"; + open FILE or die "can't open $FILE: $!"; + while (<FILE>) { + # whatever + } + +Why is this here? Someone has to cater to the hysterical porpoises. +It's something that's been in Perl since the very beginning, if not +before. + +=head2 Playing with STDIN and STDOUT + +One clever move with STDOUT is to explicitly close it when you're done +with the program. + + END { close(STDOUT) || die "can't close stdout: $!" } + +If you don't do this, and your program fills up the disk partition due +to a command line redirection, it won't report the error exit with a +failure status. + +You don't have to accept the STDIN and STDOUT you were given. You are +welcome to reopen them if you'd like. + + open(STDIN, "< datafile") + || die "can't open datafile: $!"; + + open(STDOUT, "> output") + || die "can't open output: $!"; + +And then these can be read directly or passed on to subprocesses. +This makes it look as though the program were initially invoked +with those redirections from the command line. + +It's probably more interesting to connect these to pipes. For example: + + $pager = $ENV{PAGER} || "(less || more)"; + open(STDOUT, "| $pager") + || die "can't fork a pager: $!"; + +This makes it appear as though your program were called with its stdout +already piped into your pager. You can also use this kind of thing +in conjunction with an implicit fork to yourself. You might do this +if you would rather handle the post processing in your own program, +just in a different process: + + head(100); + while (<>) { + print; + } + + sub head { + my $lines = shift || 20; + return unless $pid = open(STDOUT, "|-"); + die "cannot fork: $!" unless defined $pid; + while (<STDIN>) { + print; + last if --$lines < 0; + } + exit; + } + +This technique can be applied to repeatedly push as many filters on your +output stream as you wish. + +=head1 Other I/O Issues + +These topics aren't really arguments related to C<open> or C<sysopen>, +but they do affect what you do with your open files. + +=head2 Opening Non-File Files + +When is a file not a file? Well, you could say when it exists but +isn't a plain file. We'll check whether it's a symbolic link first, +just in case. + + if (-l $file || ! -f _) { + print "$file is not a plain file\n"; + } + +What other kinds of files are there than, well, files? Directories, +symbolic links, named pipes, Unix-domain sockets, and block and character +devices. Those are all files, too--just not I<plain> files. This isn't +the same issue as being a text file. Not all text files are plain files. +Not all plain files are textfiles. That's why there are separate C<-f> +and C<-T> file tests. + +To open a directory, you should use the C<opendir> function, then +process it with C<readdir>, carefully restoring the directory +name if necessary: + + opendir(DIR, $dirname) or die "can't opendir $dirname: $!"; + while (defined($file = readdir(DIR))) { + # do something with "$dirname/$file" + } + closedir(DIR); + +If you want to process directories recursively, it's better to use the +File::Find module. For example, this prints out all files recursively, +add adds a slash to their names if the file is a directory. + + @ARGV = qw(.) unless @ARGV; + use File::Find; + find sub { print $File::Find::name, -d && '/', "\n" }, @ARGV; + +This finds all bogus symbolic links beneath a particular directory: + + find sub { print "$File::Find::name\n" if -l && !-e }, $dir; + +As you see, with symbolic links, you can just pretend that it is +what it points to. Or, if you want to know I<what> it points to, then +C<readlink> is called for: + + if (-l $file) { + if (defined($whither = readlink($file))) { + print "$file points to $whither\n"; + } else { + print "$file points nowhere: $!\n"; + } + } + +Named pipes are a different matter. You pretend they're regular files, +but their opens will normally block until there is both a reader and +a writer. You can read more about them in L<perlipc/"Named Pipes">. +Unix-domain sockets are rather different beasts as well; they're +described in L<perlipc/"Unix-Domain TCP Clients and Servers">. + +When it comes to opening devices, it can be easy and it can tricky. +We'll assume that if you're opening up a block device, you know what +you're doing. The character devices are more interesting. These are +typically used for modems, mice, and some kinds of printers. This is +described in L<perlfaq8/"How do I read and write the serial port?"> +It's often enough to open them carefully: + + sysopen(TTYIN, "/dev/ttyS1", O_RDWR | O_NDELAY | O_NOCTTY) + # (O_NOCTTY no longer needed on POSIX systems) + or die "can't open /dev/ttyS1: $!"; + open(TTYOUT, "+>&TTYIN") + or die "can't dup TTYIN: $!"; + + $ofh = select(TTYOUT); $| = 1; select($ofh); + + print TTYOUT "+++at\015"; + $answer = <TTYIN>; + +With descriptors that you haven't opened using C<sysopen>, such as a +socket, you can set them to be non-blocking using C<fcntl>: + + use Fcntl; + fcntl(Connection, F_SETFL, O_NONBLOCK) + or die "can't set non blocking: $!"; + +Rather than losing yourself in a morass of twisting, turning C<ioctl>s, +all dissimilar, if you're going to manipulate ttys, it's best to +make calls out to the stty(1) program if you have it, or else use the +portable POSIX interface. To figure this all out, you'll need to read the +termios(3) manpage, which describes the POSIX interface to tty devices, +and then L<POSIX>, which describes Perl's interface to POSIX. There are +also some high-level modules on CPAN that can help you with these games. +Check out Term::ReadKey and Term::ReadLine. + +What else can you open? To open a connection using sockets, you won't use +one of Perl's two open functions. See L<perlipc/"Sockets: Client/Server +Communication"> for that. Here's an example. Once you have it, +you can use FH as a bidirectional filehandle. + + use IO::Socket; + local *FH = IO::Socket::INET->new("www.perl.com:80"); + +For opening up a URL, the LWP modules from CPAN are just what +the doctor ordered. There's no filehandle interface, but +it's still easy to get the contents of a document: + + use LWP::Simple; + $doc = get('http://www.sn.no/libwww-perl/'); + +=head2 Binary Files + +On certain legacy systems with what could charitably be called terminally +convoluted (some would say broken) I/O models, a file isn't a file--at +least, not with respect to the C standard I/O library. On these old +systems whose libraries (but not kernels) distinguish between text and +binary streams, to get files to behave properly you'll have to bend over +backwards to avoid nasty problems. On such infelicitous systems, sockets +and pipes are already opened in binary mode, and there is currently no +way to turn that off. With files, you have more options. + +Another option is to use the C<binmode> function on the appropriate +handles before doing regular I/O on them: + + binmode(STDIN); + binmode(STDOUT); + while (<STDIN>) { print } + +Passing C<sysopen> a non-standard flag option will also open the file in +binary mode on those systems that support it. This is the equivalent of +opening the file normally, then calling C<binmode>ing on the handle. + + sysopen(BINDAT, "records.data", O_RDWR | O_BINARY) + || die "can't open records.data: $!"; + +Now you can use C<read> and C<print> on that handle without worrying +about the system non-standard I/O library breaking your data. It's not +a pretty picture, but then, legacy systems seldom are. CP/M will be +with us until the end of days, and after. + +On systems with exotic I/O systems, it turns out that, astonishingly +enough, even unbuffered I/O using C<sysread> and C<syswrite> might do +sneaky data mutilation behind your back. + + while (sysread(WHENCE, $buf, 1024)) { + syswrite(WHITHER, $buf, length($buf)); + } + +Depending on the vicissitudes of your runtime system, even these calls +may need C<binmode> or C<O_BINARY> first. Systems known to be free of +such difficulties include Unix, the Mac OS, Plan9, and Inferno. + +=head2 File Locking + +In a multitasking environment, you may need to be careful not to collide +with other processes who want to do I/O on the same files as others +are working on. You'll often need shared or exclusive locks +on files for reading and writing respectively. You might just +pretend that only exclusive locks exist. + +Never use the existence of a file C<-e $file> as a locking indication, +because there is a race condition between the test for the existence of +the file and its creation. Atomicity is critical. + +Perl's most portable locking interface is via the C<flock> function, +whose simplicity is emulated on systems that don't directly support it, +such as SysV or WindowsNT. The underlying semantics may affect how +it all works, so you should learn how C<flock> is implemented on your +system's port of Perl. + +File locking I<does not> lock out another process that would like to +do I/O. A file lock only locks out others trying to get a lock, not +processes trying to do I/O. Because locks are advisory, if one process +uses locking and another doesn't, all bets are off. + +By default, the C<flock> call will block until a lock is granted. +A request for a shared lock will be granted as soon as there is no +exclusive locker. A request for a exclusive lock will be granted as +soon as there is no locker of any kind. Locks are on file descriptors, +not file names. You can't lock a file until you open it, and you can't +hold on to a lock once the file has been closed. + +Here's how to get a blocking shared lock on a file, typically used +for reading: + + use 5.004; + use Fcntl qw(:DEFAULT :flock); + open(FH, "< filename") or die "can't open filename: $!"; + flock(FH, LOCK_SH) or die "can't lock filename: $!"; + # now read from FH + +You can get a non-blocking lock by using C<LOCK_NB>. + + flock(FH, LOCK_SH | LOCK_NB) + or die "can't lock filename: $!"; + +This can be useful for producing more user-friendly behaviour by warning +if you're going to be blocking: + + use 5.004; + use Fcntl qw(:DEFAULT :flock); + open(FH, "< filename") or die "can't open filename: $!"; + unless (flock(FH, LOCK_SH | LOCK_NB)) { + $| = 1; + print "Waiting for lock..."; + flock(FH, LOCK_SH) or die "can't lock filename: $!"; + print "got it.\n" + } + # now read from FH + +To get an exclusive lock, typically used for writing, you have to be +careful. We C<sysopen> the file so it can be locked before it gets +emptied. You can get a nonblocking version using C<LOCK_EX | LOCK_NB>. + + use 5.004; + use Fcntl qw(:DEFAULT :flock); + sysopen(FH, "filename", O_WRONLY | O_CREAT) + or die "can't open filename: $!"; + flock(FH, LOCK_EX) + or die "can't lock filename: $!"; + truncate(FH, 0) + or die "can't truncate filename: $!"; + # now write to FH + +Finally, due to the uncounted millions who cannot be dissuaded from +wasting cycles on useless vanity devices called hit counters, here's +how to increment a number in a file safely: + + use Fcntl qw(:DEFAULT :flock); + + sysopen(FH, "numfile", O_RDWR | O_CREAT) + or die "can't open numfile: $!"; + # autoflush FH + $ofh = select(FH); $| = 1; select ($ofh); + flock(FH, LOCK_EX) + or die "can't write-lock numfile: $!"; + + $num = <FH> || 0; + seek(FH, 0, 0) + or die "can't rewind numfile : $!"; + print FH $num+1, "\n" + or die "can't write numfile: $!"; + + truncate(FH, tell(FH)) + or die "can't truncate numfile: $!"; + close(FH) + or die "can't close numfile: $!"; + +=head1 SEE ALSO + +The C<open> and C<sysopen> function in perlfunc(1); +the standard open(2), dup(2), fopen(3), and fdopen(3) manpages; +the POSIX documentation. + +=head1 AUTHOR and COPYRIGHT + +Copyright 1998 Tom Christiansen. + +When included as part of the Standard Version of Perl, or as part of +its complete documentation whether printed or otherwise, this work may +be distributed only under the terms of Perl's Artistic License. Any +distribution of this file or derivatives thereof outside of that +package require that special arrangements be made with copyright +holder. + +Irrespective of its distribution, all code examples in these files are +hereby placed into the public domain. You are permitted and +encouraged to use this code in your own programs for fun or for profit +as you see fit. A simple comment in the code giving credit would be +courteous but is not required. + +=head1 HISTORY + +First release: Sat Jan 9 08:09:11 MST 1999 diff --git a/contrib/perl5/pod/perlpod.pod b/contrib/perl5/pod/perlpod.pod index d20d62d..7fa8290 100644 --- a/contrib/perl5/pod/perlpod.pod +++ b/contrib/perl5/pod/perlpod.pod @@ -171,7 +171,8 @@ here and in commands: (the quotes are optional) L</"sec"> ditto same as above but only 'text' is used for output. - (Text can not contain the characters '|' or '>') + (Text can not contain the characters '/' and '|', + and should contain matched '<' or '>') L<text|name> L<text|name/ident> L<text|name/"sec"> @@ -184,6 +185,8 @@ here and in commands: E<escape> A named character (very similar to HTML escapes) E<lt> A literal < E<gt> A literal > + E<sol> A literal / + E<verbar> A literal | (these are optional except in other interior sequences and when preceded by a capital letter) E<n> Character number n (probably in ASCII) diff --git a/contrib/perl5/pod/perlport.pod b/contrib/perl5/pod/perlport.pod index 79ca767..c1a5483 100644 --- a/contrib/perl5/pod/perlport.pod +++ b/contrib/perl5/pod/perlport.pod @@ -84,7 +84,7 @@ should be considered a perpetual work in progress =head2 Newlines -In most operating systems, lines in files are separated with newlines. +In most operating systems, lines in files are terminated by newlines. Just what is used as a newline may vary from OS to OS. Unix traditionally uses C<\012>, one kind of Windows I/O uses C<\015\012>, and S<Mac OS> uses C<\015>. @@ -148,6 +148,13 @@ And this example is actually better than the previous one even for Unix platforms, because now any C<\015>'s (C<\cM>'s) are stripped out (and there was much rejoicing). +An important thing to remember is that functions that return data +should translate newlines when appropriate. Often one line of code +will suffice: + + $data =~ s/\015?\012/\n/g; + return $data; + =head2 Numbers endianness and Width @@ -175,7 +182,7 @@ transfer and store numbers always in text format, instead of raw binary, or consider using modules like C<Data::Dumper> (included in the standard distribution as of Perl 5.005) and C<Storable>. -=head2 Files +=head2 Files and Filesystems Most platforms these days structure files in a hierarchical fashion. So, it is reasonably safe to assume that any platform supports the @@ -183,9 +190,9 @@ notion of a "path" to uniquely identify a file on the system. Just how that path is actually written, differs. While they are similar, file path specifications differ between Unix, -Windows, S<Mac OS>, OS/2, VMS, S<RISC OS> and probably others. Unix, -for example, is one of the few OSes that has the idea of a single root -directory. +Windows, S<Mac OS>, OS/2, VMS, VOS, S<RISC OS> and probably others. +Unix, for example, is one of the few OSes that has the idea of a single +root directory. VMS, Windows, and OS/2 can work similarly to Unix with C</> as path separator, or in their own idiosyncratic ways (such as having several @@ -194,6 +201,18 @@ LPT:). S<Mac OS> uses C<:> as a path separator instead of C</>. +The filesystem may support neither hard links (C<link()>) nor +symbolic links (C<symlink()>, C<readlink()>, C<lstat()>). + +The filesystem may not support neither access timestamp nor change +timestamp (meaning that about the only portable timestamp is the +modification timestamp), or one second granularity of any timestamps +(e.g. the FAT filesystem limits the time granularity to two seconds). + +VOS perl can emulate Unix filenames with C</> as path separator. The +native pathname characters greater-than, less-than, number-sign, and +percent-sign are always accepted. + C<RISC OS> perl can emulate Unix filenames with C</> as path separator, or go native and use C<.> for path separator and C<:> to signal filing systems and disc names. @@ -224,19 +243,21 @@ Also of use is C<File::Basename>, from the standard distribution, which splits a pathname into pieces (base filename, full path to directory, and file suffix). -Even when on a single platform (if you can call UNIX a single -platform), remember not to count on the existence or the contents of -system-specific files, like F</etc/passwd>, F</etc/sendmail.conf>, or -F</etc/resolv.conf>. For example the F</etc/passwd> may exist but it -may not contain the encrypted passwords because the system is using -some form of enhanced security-- or it may not contain all the -accounts because the system is using NIS. If code does need to rely -on such a file, include a description of the file and its format in -the code's documentation, and make it easy for the user to override -the default location of the file. +Even when on a single platform (if you can call UNIX a single platform), +remember not to count on the existence or the contents of +system-specific files or directories, like F</etc/passwd>, +F</etc/sendmail.conf>, F</etc/resolv.conf>, or even F</tmp/>. For +example, F</etc/passwd> may exist but it may not contain the encrypted +passwords because the system is using some form of enhanced security -- +or it may not contain all the accounts because the system is using NIS. +If code does need to rely on such a file, include a description of the +file and its format in the code's documentation, and make it easy for +the user to override the default location of the file. + +Don't assume a text file will end with a newline. Do not have two files of the same name with different case, like -F<test.pl> and <Test.pl>, as many platforms have case-insensitive +F<test.pl> and F<Test.pl>, as many platforms have case-insensitive filenames. Also, try not to have non-word characters (except for C<.>) in the names, and keep them to the 8.3 convention, for maximum portability. @@ -246,11 +267,17 @@ Likewise, if using C<AutoSplit>, try to keep the split functions to make it so the resulting files have a unique (case-insensitively) first 8 characters. -Don't assume C<E<lt>> won't be the first character of a filename. Always -use C<E<gt>> explicitly to open a file for reading: +There certainly can be whitespace in filenames. Many systems (DOS, +VMS) cannot have more than one C<"."> in their filenames. + +Don't assume C<E<gt>> won't be the first character of a filename. +Always use C<E<lt>> explicitly to open a file for reading. open(FILE, "<$existing_file") or die $!; +Actually, though, if filenames might use strange characters, it is +safest to open it with C<sysopen> instead of C<open>, which is magic. + =head2 System Interaction @@ -280,6 +307,8 @@ C<closedir> instead. Don't count on per-program environment variables, or per-program current directories. +Don't count on specific values of C<$!>. + =head2 Interprocess Communication (IPC) @@ -316,6 +345,7 @@ code, but expose a common interface). The UNIX System V IPC (C<msg*(), sem*(), shm*()>) is not available even in all UNIX platforms. + =head2 External Subroutines (XS) XS code, in general, can be made to work with any platform; but dependent @@ -371,7 +401,7 @@ C<Time::Local>. Assume very little about character sets. Do not assume anything about the numerical values (C<ord()>, C<chr()>) of characters. Do not assume that the alphabetic characters are encoded contiguously (in -numerical sense). Do no assume anything about the ordering of the +numerical sense). Do not assume anything about the ordering of the characters. The lowercase letters may come before or after the uppercase letters, the lowercase and uppercase may be interlaced so that both 'a' and 'A' come before the 'b', the accented and other @@ -381,10 +411,10 @@ before the 'b'. =head2 Internationalisation -If you may assume POSIX (a rather large assumption, that: in practise -that means UNIX) you may read more about the POSIX locale system from +If you may assume POSIX (a rather large assumption, that in practice +means UNIX), you may read more about the POSIX locale system from L<perllocale>. The locale system at least attempts to make things a -little bit more portable or at least more convenient and +little bit more portable, or at least more convenient and native-friendly for non-English users. The system affects character sets and encoding, and date and time formatting, among other things. @@ -476,7 +506,7 @@ Unix flavors: FreeBSD freebsd freebsd-i386 Linux linux i386-linux HP-UX hpux PA-RISC1.1 - IRIX irix irix + IRIX irix irix OSF1 dec_osf alpha-dec_osf SunOS solaris sun4-solaris SunOS solaris i86pc-solaris @@ -547,7 +577,8 @@ Also see: =item The djgpp environment for DOS, C<http://www.delorie.com/djgpp/> =item The EMX environment for DOS, OS/2, etc. C<emx@iaehv.nl>, -C<http://www.juge.com/bbs/Hobb.19.html> +C<http://www.leo.org/pub/comp/os/os2/leo/gnu/emx+gcc/index.html> or +C<ftp://hobbes.nmsu.edu/pub/os2/dev/emx> =item Build instructions for Win32, L<perlwin32>. @@ -578,7 +609,7 @@ limited to 31 characters, and may include any character except C<:>, which is reserved as a path separator. Instead of C<flock>, see C<FSpSetFLock> and C<FSpRstFLock> in the -C<Mac::Files> module. +C<Mac::Files> module, or C<chmod(0444, ...)> and C<chmod(0666, ...)>. In the MacPerl application, you can't run a program from the command line; programs that expect C<@ARGV> to be populated can be edited with something @@ -613,10 +644,9 @@ the application or MPW tool version is running, check: $is_ppc = $MacPerl::Architecture eq 'MacPPC'; $is_68k = $MacPerl::Architecture eq 'Mac68K'; -S<Mac OS X>, to be based on NeXT's OpenStep OS, will be able to run -MacPerl natively (in the Blue Box, and even in the Yellow Box, once some -changes to the toolbox calls are made), but Unix perl will also run -natively. +S<Mac OS X>, to be based on NeXT's OpenStep OS, will (in theory) be able +to run MacPerl natively, but Unix perl will also run natively under the +built-in Unix environment. Also see: @@ -727,18 +757,84 @@ Put words C<SUBSCRIBE VMSPERL> in message body. =back +=head2 VOS + +Perl on VOS is discussed in F<README.vos> in the perl distribution. +Note that perl on VOS can accept either VOS- or Unix-style file +specifications as in either of the following: + + $ perl -ne "print if /perl_setup/i" >system>notices + $ perl -ne "print if /perl_setup/i" /system/notices + +or even a mixture of both as in: + + $ perl -ne "print if /perl_setup/i" >system/notices + +Note that even though VOS allows the slash character to appear in object +names, because the VOS port of Perl interprets it as a pathname +delimiting character, VOS files, directories, or links whose names +contain a slash character cannot be processed. Such files must be +renamed before they can be processed by Perl. + +The following C functions are unimplemented on VOS, and any attempt by +Perl to use them will result in a fatal error message and an immediate +exit from Perl: dup, do_aspawn, do_spawn, fork, waitpid. Once these +functions become available in the VOS POSIX.1 implementation, you can +either recompile and rebind Perl, or you can download a newer port from +ftp.stratus.com. + +The value of C<$^O> on VOS is "VOS". To determine the architecture that +you are running on without resorting to loading all of C<%Config> you +can examine the content of the C<@INC> array like so: + + if (grep(/VOS/, @INC)) { + print "I'm on a Stratus box!\n"; + } else { + print "I'm not on a Stratus box!\n"; + die; + } + + if (grep(/860/, @INC)) { + print "This box is a Stratus XA/R!\n"; + } elsif (grep(/7100/, @INC)) { + print "This box is a Stratus HP 7100 or 8000!\n"; + } elsif (grep(/8000/, @INC)) { + print "This box is a Stratus HP 8000!\n"; + } else { + print "This box is a Stratus 68K...\n"; + } + +Also see: + +=over 4 + +=item L<README.vos> + +=item VOS mailing list + +There is no specific mailing list for Perl on VOS. You can post +comments to the comp.sys.stratus newsgroup, or subscribe to the general +Stratus mailing list. Send a letter with "Subscribe Info-Stratus" in +the message body to majordomo@list.stratagy.com. + +=item VOS Perl on the web at C<http://ftp.stratus.com/pub/vos/vos.html> + +=back + + =head2 EBCDIC Platforms Recent versions of Perl have been ported to platforms such as OS/400 on -AS/400 minicomputers as well as OS/390 for IBM Mainframes. Such computers -use EBCDIC character sets internally (usually Character Code Set ID 00819 -for OS/400 and IBM-1047 for OS/390). Note that on the mainframe perl -currently works under the "Unix system services for OS/390" (formerly -known as OpenEdition). +AS/400 minicomputers as well as OS/390 & VM/ESA for IBM Mainframes. Such +computers use EBCDIC character sets internally (usually Character Code +Set ID 00819 for OS/400 and IBM-1047 for OS/390 & VM/ESA). Note that on +the mainframe perl currently works under the "Unix system services +for OS/390" (formerly known as OpenEdition) and VM/ESA OpenEdition. -As of R2.5 of USS for OS/390 that Unix sub-system did not support the -C<#!> shebang trick for script invocation. Hence, on OS/390 perl scripts -can executed with a header similar to the following simple script: +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. +Hence, on OS/390 and VM/ESA perl scripts can be executed with a header +similar to the following simple script: : # use perl eval 'exec /usr/local/bin/perl -S $0 ${1+"$@"}' @@ -752,16 +848,18 @@ an effect on what happens with some perl functions (such as C<chr>, C<pack>, C<print>, C<printf>, C<ord>, C<sort>, C<sprintf>, C<unpack>), as well as bit-fiddling with ASCII constants using operators like C<^>, C<&> and C<|>, not to mention dealing with socket interfaces to ASCII computers -(see L<"NEWLINES">). +(see L<Newlines>). Fortunately, most web servers for the mainframe will correctly translate the C<\n> in the following statement to its ASCII equivalent (note that -C<\r> is the same under both Unix and OS/390): +C<\r> is the same under both Unix and OS/390 & VM/ESA): print "Content-type: text/html\r\n\r\n"; The value of C<$^O> on OS/390 is "os390". +The value of C<$^O> on VM/ESA is "vmesa". + Some simple tricks for determining if you are running on an EBCDIC platform could include any of the following (perhaps all): @@ -834,7 +932,7 @@ C<System$Path> contains a single item list. The filesystem will also expand system variables in filenames if enclosed in angle brackets, so C<E<lt>System$DirE<gt>.Modules> would look for the file S<C<$ENV{'System$Dir'} . 'Modules'>>. The obvious implication of this is -that B<fully qualified filenames can start with C<E<lt>E<gt>> and should +that B<fully qualified filenames can start with C<E<lt>E<gt>>> and should be protected when C<open> is used for input. Because C<.> was in use as a directory separator and filenames could not @@ -1013,9 +1111,11 @@ bits are meaningless. (Win32) Only good for changing "owner" and "other" read-write access. (S<RISC OS>) +Access permissions are mapped onto VOS access-control list changes. (VOS) + =item chown LIST -Not implemented. (S<Mac OS>, Win32, Plan9, S<RISC OS>) +Not implemented. (S<Mac OS>, Win32, Plan9, S<RISC OS>, VOS) Does nothing, but won't fail. (Win32) @@ -1023,20 +1123,22 @@ Does nothing, but won't fail. (Win32) =item chroot -Not implemented. (S<Mac OS>, Win32, VMS, Plan9, S<RISC OS>) +Not implemented. (S<Mac OS>, Win32, VMS, Plan9, S<RISC OS>, VOS, VM/ESA) =item crypt PLAINTEXT,SALT May not be available if library or source was not provided when building perl. (Win32) +Not implemented. (VOS) + =item dbmclose HASH -Not implemented. (VMS, Plan9) +Not implemented. (VMS, Plan9, VOS) =item dbmopen HASH,DBNAME,MODE -Not implemented. (VMS, Plan9) +Not implemented. (VMS, Plan9, VOS) =item dump LABEL @@ -1050,19 +1152,21 @@ Invokes VMS debugger. (VMS) Not implemented. (S<Mac OS>) +Implemented via Spawn. (VM/ESA) + =item fcntl FILEHANDLE,FUNCTION,SCALAR Not implemented. (Win32, VMS) =item flock FILEHANDLE,OPERATION -Not implemented (S<Mac OS>, VMS, S<RISC OS>). +Not implemented (S<Mac OS>, VMS, S<RISC OS>, VOS). Available only on Windows NT (not on Windows 95). (Win32) =item fork -Not implemented. (S<Mac OS>, Win32, AmigaOS, S<RISC OS>) +Not implemented. (S<Mac OS>, Win32, AmigaOS, S<RISC OS>, VOS, VM/ESA) =item getlogin @@ -1070,7 +1174,7 @@ Not implemented. (S<Mac OS>, S<RISC OS>) =item getpgrp PID -Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>, VOS) =item getppid @@ -1078,7 +1182,7 @@ Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) =item getpriority WHICH,WHO -Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>, VOS, VM/ESA) =item getpwnam NAME @@ -1118,11 +1222,11 @@ Not implemented. (S<Mac OS>) =item getpwent -Not implemented. (S<Mac OS>, Win32) +Not implemented. (S<Mac OS>, Win32, VM/ESA) =item getgrent -Not implemented. (S<Mac OS>, Win32, VMS) +Not implemented. (S<Mac OS>, Win32, VMS, VM/ESA) =item gethostent @@ -1166,11 +1270,11 @@ Not implemented. (Plan9, Win32, S<RISC OS>) =item endpwent -Not implemented. (S<Mac OS>, Win32) +Not implemented. (S<Mac OS>, Win32, VM/ESA) =item endgrent -Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>, VM/ESA) =item endhostent @@ -1229,6 +1333,9 @@ method of spawning a process. (Win32) Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) +Link count not updated because hard links are not quite that hard +(They are sort of half-way between hard and soft links). (AmigaOS) + =item lstat FILEHANDLE =item lstat EXPR @@ -1247,7 +1354,7 @@ Return values may be bogus. (Win32) =item msgrcv ID,VAR,SIZE,TYPE,FLAGS -Not implemented. (S<Mac OS>, Win32, VMS, Plan9, S<RISC OS>) +Not implemented. (S<Mac OS>, Win32, VMS, Plan9, S<RISC OS>, VOS) =item open FILEHANDLE,EXPR @@ -1262,6 +1369,8 @@ open to C<|-> and C<-|> are unsupported. (S<Mac OS>, Win32, S<RISC OS>) Not implemented. (S<Mac OS>) +Very limited functionality. (MiNT) + =item readlink EXPR =item readlink @@ -1280,15 +1389,15 @@ Only reliable on sockets. (S<RISC OS>) =item semop KEY,OPSTRING -Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>, VOS) =item setpgrp PID,PGRP -Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>, VOS) =item setpriority WHICH,WHO,PRIORITY -Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>, VOS) =item setsockopt SOCKET,LEVEL,OPTNAME,OPTVAL @@ -1302,11 +1411,11 @@ Not implemented. (S<Mac OS>, Plan9) =item shmwrite ID,STRING,POS,SIZE -Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>, VOS) =item socketpair SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL -Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>, VOS, VM/ESA) =item stat FILEHANDLE @@ -1330,14 +1439,14 @@ Not implemented. (Win32, VMS, S<RISC OS>) =item syscall LIST -Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>) +Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>, VOS, VM/ESA) =item sysopen FILEHANDLE,FILENAME,MODE,PERMS The traditional "0", "1", and "2" MODEs are implemented with different numeric values on some systems. The flags exported by C<Fcntl> (O_RDONLY, O_WRONLY, O_RDWR) should work everywhere though. (S<Mac -OS>, OS/390) +OS>, OS/390, VM/ESA) =item system LIST @@ -1359,6 +1468,11 @@ the child program uses a compatible version of the emulation library. I<scalar> will call the native command line direct and no such emulation of a child Unix program will exists. Mileage B<will> vary. (S<RISC OS>) +Far from being POSIX compliant. Because there may be no underlying +/bin/sh tries to work around the problem by forking and execing the +first token in its argument string. Handles basic redirection +("E<lt>" or "E<gt>") on its own behalf. (MiNT) + =item times Only the first entry returned is nonzero. (S<Mac OS>) @@ -1375,12 +1489,22 @@ Not useful. (S<RISC OS>) Not implemented. (VMS) +Truncation to zero-length only. (VOS) + +If a FILEHANDLE is supplied, it must be writable and opened in append +mode (i.e., use C<open(FH, '>>filename')> +or C<sysopen(FH,...,O_APPEND|O_RDWR)>. If a filename is supplied, it +should not be held open elsewhere. (Win32) + =item umask EXPR =item umask Returns undef where unavailable, as of version 5.005. +C<umask()> works but the correct permissions are only set when the file +is finally close()d. (AmigaOS) + =item utime LIST Only the modification time is updated. (S<Mac OS>, VMS, S<RISC OS>) @@ -1395,7 +1519,7 @@ two seconds. (Win32) =item waitpid PID,FLAGS -Not implemented. (S<Mac OS>) +Not implemented. (S<Mac OS>, VOS) Can only be applied to process handles returned for processes spawned using C<system(1, ...)>. (Win32) @@ -1408,19 +1532,43 @@ Not useful. (S<RISC OS>) =over 4 -=item 1.33, 06 August 1998 +=item v1.39, 11 February, 1999 + +Changes from Jarkko and EMX URL fixes Michael Schwern. Additional +note about newlines added. + +=item v1.38, 31 December 1998 + +More changes from Jarkko. + +=item v1.37, 19 December 1998 + +More minor changes. Merge two separate version 1.35 documents. + +=item v1.36, 9 September 1998 + +Updated for Stratus VOS. Also known as version 1.35. + +=item v1.35, 13 August 1998 + +Integrate more minor changes, plus addition of new sections under +L<"ISSUES">: L<"Numbers endianness and Width">, +L<"Character sets and character encoding">, +L<"Internationalisation">. + +=item v1.33, 06 August 1998 Integrate more minor changes. -=item 1.32, 05 August 1998 +=item v1.32, 05 August 1998 Integrate more minor changes. -=item 1.30, 03 August 1998 +=item v1.30, 03 August 1998 Major update for RISC OS, other minor changes. -=item 1.23, 10 July 1998 +=item v1.23, 10 July 1998 First public release with perl5.005. @@ -1429,16 +1577,20 @@ First public release with perl5.005. =head1 AUTHORS / CONTRIBUTORS Abigail E<lt>abigail@fnx.comE<gt>, -Charles Bailey E<lt>bailey@genetics.upenn.eduE<gt>, +Charles Bailey E<lt>bailey@newman.upenn.eduE<gt>, Graham Barr E<lt>gbarr@pobox.comE<gt>, Tom Christiansen E<lt>tchrist@perl.comE<gt>, Nicholas Clark E<lt>Nicholas.Clark@liverpool.ac.ukE<gt>, Andy Dougherty E<lt>doughera@lafcol.lafayette.eduE<gt>, Dominic Dunlop E<lt>domo@vo.luE<gt>, +Neale Ferguson E<lt>neale@mailbox.tabnsw.com.auE<gt> +Paul Green E<lt>Paul_Green@stratus.comE<gt>, M.J.T. Guy E<lt>mjtg@cus.cam.ac.ukE<gt>, +Jarkko Hietaniemi E<lt>jhi@iki.fi<gt>, Luther Huffman E<lt>lutherh@stratcom.comE<gt>, Nick Ing-Simmons E<lt>nick@ni-s.u-net.comE<gt>, Andreas J. KE<ouml>nig E<lt>koenig@kulturbox.deE<gt>, +Markus Laker E<lt>mlaker@contax.co.ukE<gt>, Andrew M. Langmead E<lt>aml@world.std.comE<gt>, Paul Moore E<lt>Paul.Moore@uk.origin-it.comE<gt>, Chris Nandor E<lt>pudge@pobox.comE<gt>, @@ -1449,13 +1601,13 @@ Peter Prymmer E<lt>pvhp@forte.comE<gt>, Hugo van der Sanden E<lt>hv@crypt0.demon.co.ukE<gt>, Gurusamy Sarathy E<lt>gsar@umich.eduE<gt>, Paul J. Schinder E<lt>schinder@pobox.comE<gt>, +Michael G Schwern E<lt>schwern@pobox.comE<gt>, Dan Sugalski E<lt>sugalskd@ous.eduE<gt>, Nathan Torkington E<lt>gnat@frii.comE<gt>. -This document is maintained by Chris Nandor. +This document is maintained by Chris Nandor +E<lt>pudge@pobox.comE<gt>. =head1 VERSION -Version 1.34, last modified 07 August 1998. - - +Version 1.39, last modified 11 February 1999 diff --git a/contrib/perl5/pod/perlre.pod b/contrib/perl5/pod/perlre.pod index 382ba65..d4c1dee 100644 --- a/contrib/perl5/pod/perlre.pod +++ b/contrib/perl5/pod/perlre.pod @@ -116,7 +116,11 @@ The following standard quantifiers are recognized: (If a curly bracket occurs in any other context, it is treated as a regular character.) The "*" modifier is equivalent to C<{0,}>, the "+" modifier to C<{1,}>, and the "?" modifier to C<{0,1}>. n and m are limited -to integral values less than 65536. +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; By default, a quantified subpattern is "greedy", that is, it will match as many times as possible (given a particular starting location) while still @@ -458,7 +462,7 @@ the time when used on a similar string with 1000000 C<a>s. Be aware, however, that this pattern currently triggers a warning message under B<-w> saying it C<"matches the null string many times">): -On simple groups, such as the pattern C<(?> [^()]+ )>, a comparable +On simple groups, such as the pattern C<(?E<gt> [^()]+ )>, a comparable effect may be achieved by negative lookahead, as in C<[^()]+ (?! [^()] )>. This was only 4 times slower on a string with 1000000 C<a>s. @@ -730,6 +734,13 @@ 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.) +Note also that the whole range idea is rather unportable between +character sets--and even within character sets they may cause results +you probably didn't expect. A sound principle is to use only ranges +that begin from and end at either alphabets of equal case ([a-e], +[A-E]), or digits ([0-9]). Anything else is unsafe. If in doubt, +spell out the character sets in full. + Characters may be specified using a metacharacter syntax much like that used in C: "\n" matches a newline, "\t" a tab, "\r" a carriage return, "\f" a form feed, etc. More generally, \I<nnn>, where I<nnn> is a string @@ -752,7 +763,7 @@ start and end. Alternatives are tried from left to right, so the first alternative found for which the entire expression matches, is the one that is chosen. This means that alternatives are not necessarily greedy. For -example: when mathing C<foo|foot> against "barefoot", only the "foo" +example: when matching C<foo|foot> against "barefoot", only the "foo" part will match, as that is the first alternative tried, and it successfully matches the target string. (This might not seem important, but it is important when you are capturing matched text using parentheses.) @@ -805,7 +816,7 @@ with most other power tools, power comes together with the ability to wreak havoc. A common abuse of this power stems from the ability to make infinite -loops using regular expressions, with something as innocous as: +loops using regular expressions, with something as innocuous as: 'foo' =~ m{ ( o? )* }x; diff --git a/contrib/perl5/pod/perlref.pod b/contrib/perl5/pod/perlref.pod index 66b1a7d..596ff72 100644 --- a/contrib/perl5/pod/perlref.pod +++ b/contrib/perl5/pod/perlref.pod @@ -2,6 +2,12 @@ perlref - Perl references and nested data structures +=head1 NOTE + +This is complete documentation about all aspects of references. +For a shorter, tutorial introduction to just the essential features, +see L<perlreftut>. + =head1 DESCRIPTION Before release 5 of Perl it was difficult to represent complex data @@ -89,7 +95,9 @@ a list of references! @list = \($a, @b, %c); # same thing! As a special case, C<\(@foo)> returns a list of references to the contents -of C<@foo>, not a reference to C<@foo> itself. Likewise for C<%foo>. +of C<@foo>, not a reference to C<@foo> itself. Likewise for C<%foo>, +except that the key references are to copies (since the keys are just +strings rather than full-fledged scalars). =item 3. @@ -448,7 +456,7 @@ symbolic references. Lexical variables (declared with my()) aren't in a symbol table, and thus are invisible to this mechanism. For example: local $value = 10; - $ref = \$value; + $ref = "value"; { my $value = 20; print $$ref; @@ -551,7 +559,7 @@ access to those variables even though it doesn't get run until later, such as in a signal handler or a Tk callback. Using a closure as a function template allows us to generate many functions -that act similarly. Suppopose you wanted functions named after the colors +that act similarly. Suppose you wanted functions named after the colors that generated HTML font changes for the various colors: print "Be ", red("careful"), "with that ", green("light"); diff --git a/contrib/perl5/pod/perlreftut.pod b/contrib/perl5/pod/perlreftut.pod new file mode 100644 index 0000000..09bea59 --- /dev/null +++ b/contrib/perl5/pod/perlreftut.pod @@ -0,0 +1,416 @@ + +=head1 NAME + +perlreftut - Mark's very short tutorial about references + +=head1 DESCRIPTION + +One of the most important new features in Perl 5 was the capability to +manage complicated data structures like multidimensional arrays and +nested hashes. To enable these, Perl 5 introduced a feature called +`references', and using references is the key to managing complicated, +structured data in Perl. Unfortunately, there's a lot of funny syntax +to learn, and the main manual page can be hard to follow. The manual +is quite complete, and sometimes people find that a problem, because +it can be hard to tell what is important and what isn't. + +Fortunately, you only need to know 10% of what's in the main page to get +90% of the benefit. This page will show you that 10%. + +=head1 Who Needs Complicated Data Structures? + +One problem that came up all the time in Perl 4 was how to represent a +hash whose values were lists. Perl 4 had hashes, of course, but the +values had to be scalars; they couldn't be lists. + +Why would you want a hash of lists? Let's take a simple example: You +have a file of city and country names, like this: + + Chicago, USA + Frankfurt, Germany + Berlin, Germany + Washington, USA + Helsinki, Finland + New York, USA + +and you want to produce an output like this, with each country mentioned +once, and then an alphabetical list of the cities in that country: + + Finland: Helsinki. + Germany: Berlin, Frankfurt. + USA: Chicago, New York, Washington. + +The natural way to do this is to have a hash whose keys are country +names. Associated with each country name key is a list of the cities in +that country. Each time you read a line of input, split it into a country +and a city, look up the list of cities already known to be in that +country, and append the new city to the list. When you're done reading +the input, iterate over the hash as usual, sorting each list of cities +before you print it out. + +If hash values can't be lists, you lose. In Perl 4, hash values can't +be lists; they can only be strings. You lose. You'd probably have to +combine all the cities into a single string somehow, and then when +time came to write the output, you'd have to break the string into a +list, sort the list, and turn it back into a string. This is messy +and error-prone. And it's frustrating, because Perl already has +perfectly good lists that would solve the problem if only you could +use them. + +=head1 The Solution + +By the time Perl 5 rolled around, we were already stuck with this +design: Hash values must be scalars. The solution to this is +references. + +A reference is a scalar value that I<refers to> an entire array or an +entire hash (or to just about anything else). Names are one kind of +reference that you're already familiar with. Think of the President: +a messy, inconvenient bag of blood and bones. But to talk about him, +or to represent him in a computer program, all you need is the easy, +convenient scalar string "Bill Clinton". + +References in Perl are like names for arrays and hashes. They're +Perl's private, internal names, so you can be sure they're +unambiguous. Unlike "Bill Clinton", a reference only refers to one +thing, and you always know what it refers to. If you have a reference +to an array, you can recover the entire array from it. If you have a +reference to a hash, you can recover the entire hash. But the +reference is still an easy, compact scalar value. + +You can't have a hash whose values are arrays; hash values can only be +scalars. We're stuck with that. But a single reference can refer to +an entire array, and references are scalars, so you can have a hash of +references to arrays, and it'll act a lot like a hash of arrays, and +it'll be just as useful as a hash of arrays. + +We'll come back to this city-country problem later, after we've seen +some syntax for managing references. + + +=head1 Syntax + +There are just two ways to make a reference, and just two ways to use +it once you have it. + +=head2 Making References + +B<Make Rule 1> + +If you put a C<\> in front of a variable, you get a +reference to that variable. + + $aref = \@array; # $aref now holds a reference to @array + $href = \%hash; # $href now holds a reference to %hash + +Once the reference is stored in a variable like $aref or $href, you +can copy it or store it just the same as any other scalar value: + + $xy = $aref; # $xy now holds a reference to @array + $p[3] = $href; # $p[3] now holds a reference to %hash + $z = $p[3]; # $z now holds a reference to %hash + + +These examples show how to make references to variables with names. +Sometimes you want to make an array or a hash that doesn't have a +name. This is analogous to the way you like to be able to use the +string C<"\n"> or the number 80 without having to store it in a named +variable first. + +B<Make Rule 2> + +C<[ ITEMS ]> makes a new, anonymous array, and returns a reference to +that array. C<{ ITEMS }> makes a new, anonymous hash. and returns a +reference to that hash. + + $aref = [ 1, "foo", undef, 13 ]; + # $aref now holds a reference to an array + + $href = { APR => 4, AUG => 8 }; + # $href now holds a reference to a hash + + +The references you get from rule 2 are the same kind of +references that you get from rule 1: + + # This: + $aref = [ 1, 2, 3 ]; + + # Does the same as this: + @array = (1, 2, 3); + $aref = \@array; + + +The first line is an abbreviation for the following two lines, except +that it doesn't create the superfluous array variable C<@array>. + + +=head2 Using References + +What can you do with a reference once you have it? It's a scalar +value, and we've seen that you can store it as a scalar and get it back +again just like any scalar. There are just two more ways to use it: + +B<Use Rule 1> + +If C<$aref> contains a reference to an array, then you +can put C<{$aref}> anywhere you would normally put the name of an +array. For example, C<@{$aref}> instead of C<@array>. + +Here are some examples of that: + +Arrays: + + + @a @{$aref} An array + reverse @a reverse @{$aref} Reverse the array + $a[3] ${$aref}[3] An element of the array + $a[3] = 17; ${$aref}[3] = 17 Assigning an element + + +On each line are two expressions that do the same thing. The +left-hand versions operate on the array C<@a>, and the right-hand +versions operate on the array that is referred to by C<$aref>, but +once they find the array they're operating on, they do the same things +to the arrays. + +Using a hash reference is I<exactly> the same: + + %h %{$href} A hash + keys %h keys %{$href} Get the keys from the hash + $h{'red'} ${$href}{'red'} An element of the hash + $h{'red'} = 17 ${$href}{'red'} = 17 Assigning an element + + +B<Use Rule 2> + +C<${$aref}[3]> is too hard to read, so you can write C<$aref-E<gt>[3]> +instead. + +C<${$href}{red}> is too hard to read, so you can write +C<$href-E<gt>{red}> instead. + +Most often, when you have an array or a hash, you want to get or set a +single element from it. C<${$aref}[3]> and C<${$href}{'red'}> have +too much punctuation, and Perl lets you abbreviate. + +If C<$aref> holds a reference to an array, then C<$aref-E<gt>[3]> is +the fourth element of the array. Don't confuse this with C<$aref[3]>, +which is the fourth element of a totally different array, one +deceptively named C<@aref>. C<$aref> and C<@aref> are unrelated the +same way that C<$item> and C<@item> are. + +Similarly, C<$href-E<gt>{'red'}> is part of the hash referred to by +the scalar variable C<$href>, perhaps even one with no name. +C<$href{'red'}> is part of the deceptively named C<%href> hash. It's +easy to forget to leave out the C<-E<gt>>, and if you do, you'll get +bizarre results when your program gets array and hash elements out of +totally unexpected hashes and arrays that weren't the ones you wanted +to use. + + +=head1 An Example + +Let's see a quick example of how all this is useful. + +First, remember that C<[1, 2, 3]> makes an anonymous array containing +C<(1, 2, 3)>, and gives you a reference to that array. + +Now think about + + @a = ( [1, 2, 3], + [4, 5, 6], + [7, 8, 9] + ); + +@a is an array with three elements, and each one is a reference to +another array. + +C<$a[1]> is one of these references. It refers to an array, the array +containing C<(4, 5, 6)>, and because it is a reference to an array, +B<USE RULE 2> says that we can write C<$a[1]-E<gt>[2]> to get the +third element from that array. C<$a[1]-E<gt>[2]> is the 6. +Similarly, C<$a[0]-E<gt>[1]> is the 2. What we have here is like a +two-dimensional array; you can write C<$a[ROW]-E<gt>[COLUMN]> to get +or set the element in any row and any column of the array. + +The notation still looks a little cumbersome, so there's one more +abbreviation: + +=head1 Arrow Rule + +In between two B<subscripts>, the arrow is optional. + +Instead of C<$a[1]-E<gt>[2]>, we can write C<$a[1][2]>; it means the +same thing. Instead of C<$a[0]-E<gt>[1]>, we can write C<$a[0][1]>; +it means the same thing. + +Now it really looks like two-dimensional arrays! + +You can see why the arrows are important. Without them, we would have +had to write C<${$a[1]}[2]> instead of C<$a[1][2]>. For +three-dimensional arrays, they let us write C<$x[2][3][5]> instead of +the unreadable C<${${$x[2]}[3]}[5]>. + + +=head1 Solution + +Here's the answer to the problem I posed earlier, of reformatting a +file of city and country names. + + 1 while (<>) { + 2 chomp; + 3 my ($city, $country) = split /, /; + 4 push @{$table{$country}}, $city; + 5 } + 6 + 7 foreach $country (sort keys %table) { + 8 print "$country: "; + 9 my @cities = @{$table{$country}}; + 10 print join ', ', sort @cities; + 11 print ".\n"; + 12 } + + +The program has two pieces: Lines 1--5 read the input and build a +data structure, and lines 7--12 analyze the data and print out the +report. + +In the first part, line 4 is the important one. We're going to have a +hash, C<%table>, whose keys are country names, and whose values are +(references to) arrays of city names. After acquiring a city and +country name, the program looks up C<$table{$country}>, which holds (a +reference to) the list of cities seen in that country so far. Line 4 is +totally analogous to + + push @array, $city; + +except that the name C<array> has been replaced by the reference +C<{$table{$country}}>. The C<push> adds a city name to the end of the +referred-to array. + +In the second part, line 9 is the important one. Again, +C<$table{$country}> is (a reference to) the list of cities in the country, so +we can recover the original list, and copy it into the array C<@cities>, +by using C<@{$table{$country}}>. Line 9 is totally analogous to + + @cities = @array; + +except that the name C<array> has been replaced by the reference +C<{$table{$country}}>. The C<@> tells Perl to get the entire array. + +The rest of the program is just familiar uses of C<chomp>, C<split>, C<sort>, +C<print>, and doesn't involve references at all. + +There's one fine point I skipped. Suppose the program has just read +the first line in its input that happens to mention Greece. +Control is at line 4, C<$country> is C<'Greece'>, and C<$city> is +C<'Athens'>. Since this is the first city in Greece, +C<$table{$country}> is undefined---in fact there isn't an C<'Greece'> key +in C<%table> at all. What does line 4 do here? + + 4 push @{$table{$country}}, $city; + + +This is Perl, so it does the exact right thing. It sees that you want +to push C<Athens> onto an array that doesn't exist, so it helpfully +makes a new, empty, anonymous array for you, installs it in the table, +and then pushes C<Athens> onto it. This is called `autovivification'. + + +=head1 The Rest + +I promised to give you 90% of the benefit with 10% of the details, and +that means I left out 90% of the details. Now that you have an +overview of the important parts, it should be easier to read the +L<perlref> manual page, which discusses 100% of the details. + +Some of the highlights of L<perlref>: + +=over 4 + +=item * + +You can make references to anything, including scalars, functions, and +other references. + +=item * + +In B<USE RULE 1>, you can omit the curly brackets whenever the thing +inside them is an atomic scalar variable like C<$aref>. For example, +C<@$aref> is the same as C<@{$aref}>, and C<$$aref[1]> is the same as +C<${$aref}[1]>. If you're just starting out, you may want to adopt +the habit of always including the curly brackets. + +=item * + +To see if a variable contains a reference, use the `ref' function. +It returns true if its argument is a reference. Actually it's a +little better than that: It returns HASH for hash references and +ARRAY for array references. + +=item * + +If you try to use a reference like a string, you get strings like + + ARRAY(0x80f5dec) or HASH(0x826afc0) + +If you ever see a string that looks like this, you'll know you +printed out a reference by mistake. + +A side effect of this representation is that you can use C<eq> to see +if two references refer to the same thing. (But you should usually use +C<==> instead because it's much faster.) + +=item * + +You can use a string as if it were a reference. If you use the string +C<"foo"> as an array reference, it's taken to be a reference to the +array C<@foo>. This is called a I<soft reference> or I<symbolic reference>. + +=back + +You might prefer to go on to L<perllol> instead of L<perlref>; it +discusses lists of lists and multidimensional arrays in detail. After +that, you should move on to L<perldsc>; it's a Data Structure Cookbook +that shows recipes for using and printing out arrays of hashes, hashes +of arrays, and other kinds of data. + +=head1 Summary + +Everyone needs compound data structures, and in Perl the way you get +them is with references. There are four important rules for managing +references: Two for making references and two for using them. Once +you know these rules you can do most of the important things you need +to do with references. + +=head1 Credits + +Author: Mark-Jason Dominus, Plover Systems (C<mjd-perl-ref@plover.com>) + +This article originally appeared in I<The Perl Journal> +(http://tpj.com) volume 3, #2. Reprinted with permission. + +The original title was I<Understand References Today>. + +=head2 Distribution Conditions + +Copyright 1998 The Perl Journal. + +When included as part of the Standard Version of Perl, or as part of +its complete documentation whether printed or otherwise, this work may +be distributed only under the terms of Perl's Artistic License. Any +distribution of this file or derivatives thereof outside of that +package require that special arrangements be made with copyright +holder. + +Irrespective of its distribution, all code examples in these files are +hereby placed into the public domain. You are permitted and +encouraged to use this code in your own programs for fun or for profit +as you see fit. A simple comment in the code giving credit would be +courteous but is not required. + + + + +=cut diff --git a/contrib/perl5/pod/perlrun.pod b/contrib/perl5/pod/perlrun.pod index a0c85b9..7cb9aed 100644 --- a/contrib/perl5/pod/perlrun.pod +++ b/contrib/perl5/pod/perlrun.pod @@ -129,6 +129,21 @@ and a Perl library file. Macintosh perl scripts will have the appropriate Creator and Type, so that double-clicking them will invoke the perl application. +=item VMS + +Put + + $ perl -mysw 'f$env("procedure")' 'p1' 'p2' 'p3' 'p4' 'p5' 'p6' 'p7' 'p8' ! + $ exit++ + ++$status != 0 and $exit = $status = undef; + +at the top of your script, where C<-mysw> are any command line switches you +want to pass to Perl. You can now invoke the script directly, by saying +C<perl script>, or as a DCL procedure, by saying C<@script> (or implicitly +via F<DCL$PATH> by just using the name of the script). + +This incantation is a bit much to remember, but Perl will display it for +you if you say C<perl "-V:startperl">. + =back Command-interpreters on non-Unix systems have rather different ideas @@ -492,7 +507,7 @@ makes it iterate over filename arguments somewhat like B<sed>: If a file named by an argument cannot be opened for some reason, Perl warns you about it, and moves on to the next file. Note that the -lines are printed automatically. An error occuring during printing is +lines are printed automatically. An error occurring during printing is treated as fatal. To suppress printing use the B<-n> switch. A B<-p> overrides a B<-n> switch. @@ -671,7 +686,8 @@ Command-line options (switches). Switches in this variable are taken as if they were on every Perl command line. Only the B<-[DIMUdmw]> switches are allowed. When running taint checks (because the script was running setuid or setgid, or the B<-T> switch was used), this -variable is ignored. +variable is ignored. If PERL5OPT begins with B<-T>, tainting will be +enabled, and any subsequent options ignored. =item PERLLIB diff --git a/contrib/perl5/pod/perlstyle.pod b/contrib/perl5/pod/perlstyle.pod index cf280ce..04aab98 100644 --- a/contrib/perl5/pod/perlstyle.pod +++ b/contrib/perl5/pod/perlstyle.pod @@ -16,7 +16,7 @@ The C<use sigtrap> and even C<use diagnostics> pragmas may also prove useful. Regarding aesthetics of code lay out, about the only thing Larry -cares strongly about is that the closing curly brace of +cares strongly about is that the closing curly bracket of a multi-line BLOCK should line up with the keyword that started the construct. Beyond that, he has other preferences that aren't so strong: diff --git a/contrib/perl5/pod/perlsub.pod b/contrib/perl5/pod/perlsub.pod index 957b3d8..bfab0fe 100644 --- a/contrib/perl5/pod/perlsub.pod +++ b/contrib/perl5/pod/perlsub.pod @@ -199,7 +199,7 @@ pre-defined things are C<BEGIN>, C<END>, C<AUTOLOAD>, and C<DESTROY>--plus all t functions mentioned in L<perltie>. The 5.005 release adds C<INIT> to this list. -=head2 Private Variables via C<my()> +=head2 Private Variables via my() Synopsis: @@ -381,7 +381,7 @@ unqualified and unqualifiable. This does not work with object methods, however; all object methods have to be in the symbol table of some package to be found. -=head2 Peristent Private Variables +=head2 Persistent Private Variables Just because a lexical variable is lexically (also called statically) scoped to its enclosing block, C<eval>, or C<do> FILE, this doesn't mean that @@ -581,6 +581,28 @@ Perl will print This is a test only a test. The array has 6 elements: 0, 1, 2, undef, undef, 5 +Note also that when you C<local>ize a member of a composite type that +B<does not exist previously>, the value is treated as though it were +in an lvalue context, i.e., it is first created and then C<local>ized. +The consequence of this is that the hash or array is in fact permanently +modified. For instance, if you say + + %hash = ( 'This' => 'is', 'a' => 'test' ); + @ary = ( 0..5 ); + { + local($ary[8]) = 0; + local($hash{'b'}) = 'whatever'; + } + printf "%%hash has now %d keys, \@ary %d elements.\n", + scalar(keys(%hash)), scalar(@ary); + +Perl will print + + %hash has now 3 keys, @ary 9 elements. + +The above behavior of local() on non-existent members of composite +types is subject to change in future. + =head2 Passing Symbol Table Entries (typeglobs) [Note: The mechanism described in this section was originally the only @@ -825,7 +847,8 @@ if you call it like a builtin function, then it behaves like a builtin function. If you call it like an old-fashioned subroutine, then it behaves like an old-fashioned subroutine. It naturally falls out from this rule that prototypes have no influence on subroutine references -like C<\&foo> or on indirect subroutine calls like C<&{$subref}>. +like C<\&foo> or on indirect subroutine calls like C<&{$subref}> or +C<$subref-E<gt>()>. Method calls are not influenced by prototypes either, because the function to be called is indeterminate at compile time, because it depends @@ -863,8 +886,10 @@ unbackslashed C<@> or C<%> eats all the rest of the arguments, and forces list context. An argument represented by C<$> forces scalar context. An C<&> requires an anonymous subroutine, which, if passed as the first argument, does not require the "C<sub>" keyword or a subsequent comma. A -C<*> does whatever it has to do to turn the argument into a reference to a -symbol table entry. +C<*> allows the subroutine to accept a bareword, constant, scalar expression, +typeglob, or a reference to a typeglob in that slot. The value will be +available to the subroutine either as a simple scalar, or (in the latter +two cases) as a reference to the typeglob. A semicolon separates mandatory arguments from optional arguments. (It is redundant before C<@> or C<%>.) diff --git a/contrib/perl5/pod/perlsyn.pod b/contrib/perl5/pod/perlsyn.pod index 8321235..a3bc5ab 100644 --- a/contrib/perl5/pod/perlsyn.pod +++ b/contrib/perl5/pod/perlsyn.pod @@ -21,13 +21,13 @@ mandatory default like it is in B<sed> and B<awk>.) =head2 Declarations -Perl is, for the most part, a free-form language. (The only -exception to this is format declarations, for obvious reasons.) Comments -are indicated by the C<"#"> character, and extend to the end of the line. If -you attempt to use C</* */> C-style comments, it will be interpreted -either as division or pattern matching, depending on the context, and C++ -C<//> comments just look like a null regular expression, so don't do -that. +Perl is, for the most part, a free-form language. (The only exception +to this is format declarations, for obvious reasons.) Text from a +C<"#"> character until the end of the line is a comment, and is +ignored. If you attempt to use C</* */> C-style comments, it will be +interpreted either as division or pattern matching, depending on the +context, and C++ C<//> comments just look like a null regular +expression, so don't do that. A declaration can be put anywhere a statement can, but has no effect on the execution of the primary sequence of statements--declarations all diff --git a/contrib/perl5/pod/perlthrtut.pod b/contrib/perl5/pod/perlthrtut.pod new file mode 100644 index 0000000..f2ca3bd --- /dev/null +++ b/contrib/perl5/pod/perlthrtut.pod @@ -0,0 +1,1063 @@ +=head1 NAME + +perlthrtut - tutorial on threads in Perl + +=head1 DESCRIPTION + +One of the most prominent new features of Perl 5.005 is the inclusion +of threads. Threads make a number of things a lot easier, and are a +very useful addition to your bag of programming tricks. + +=head1 What Is A Thread Anyway? + +A thread is a flow of control through a program with a single +execution point. + +Sounds an awful lot like a process, doesn't it? Well, it should. +Threads are one of the pieces of a process. Every process has at least +one thread and, up until now, every process running Perl had only one +thread. With 5.005, though, you can create extra threads. We're going +to show you how, when, and why. + +=head1 Threaded Program Models + +There are three basic ways that you can structure a threaded +program. Which model you choose depends on what you need your program +to do. For many non-trivial threaded programs you'll need to choose +different models for different pieces of your program. + +=head2 Boss/Worker + +The boss/worker model usually has one `boss' thread and one or more +`worker' threads. The boss thread gathers or generates tasks that need +to be done, then parcels those tasks out to the appropriate worker +thread. + +This model is common in GUI and server programs, where a main thread +waits for some event and then passes that event to the appropriate +worker threads for processing. Once the event has been passed on, the +boss thread goes back to waiting for another event. + +The boss thread does relatively little work. While tasks aren't +necessarily performed faster than with any other method, it tends to +have the best user-response times. + +=head2 Work Crew + +In the work crew model, several threads are created that do +essentially the same thing to different pieces of data. It closely +mirrors classical parallel processing and vector processors, where a +large array of processors do the exact same thing to many pieces of +data. + +This model is particularly useful if the system running the program +will distribute multiple threads across different processors. It can +also be useful in ray tracing or rendering engines, where the +individual threads can pass on interim results to give the user visual +feedback. + +=head2 Pipeline + +The pipeline model divides up a task into a series of steps, and +passes the results of one step on to the thread processing the +next. Each thread does one thing to each piece of data and passes the +results to the next thread in line. + +This model makes the most sense if you have multiple processors so two +or more threads will be executing in parallel, though it can often +make sense in other contexts as well. It tends to keep the individual +tasks small and simple, as well as allowing some parts of the pipeline +to block (on I/O or system calls, for example) while other parts keep +going. If you're running different parts of the pipeline on different +processors you may also take advantage of the caches on each +processor. + +This model is also handy for a form of recursive programming where, +rather than having a subroutine call itself, it instead creates +another thread. Prime and Fibonacci generators both map well to this +form of the pipeline model. (A version of a prime number generator is +presented later on.) + +=head1 Native threads + +There are several different ways to implement threads on a system. How +threads are implemented depends both on the vendor and, in some cases, +the version of the operating system. Often the first implementation +will be relatively simple, but later versions of the OS will be more +sophisticated. + +While the information in this section is useful, it's not necessary, +so you can skip it if you don't feel up to it. + +There are three basic categories of threads-user-mode threads, kernel +threads, and multiprocessor kernel threads. + +User-mode threads are threads that live entirely within a program and +its libraries. In this model, the OS knows nothing about threads. As +far as it's concerned, your process is just a process. + +This is the easiest way to implement threads, and the way most OSes +start. The big disadvantage is that, since the OS knows nothing about +threads, if one thread blocks they all do. Typical blocking activities +include most system calls, most I/O, and things like sleep(). + +Kernel threads are the next step in thread evolution. The OS knows +about kernel threads, and makes allowances for them. The main +difference between a kernel thread and a user-mode thread is +blocking. With kernel threads, things that block a single thread don't +block other threads. This is not the case with user-mode threads, +where the kernel blocks at the process level and not the thread level. + +This is a big step forward, and can give a threaded program quite a +performance boost over non-threaded programs. Threads that block +performing I/O, for example, won't block threads that are doing other +things. Each process still has only one thread running at once, +though, regardless of how many CPUs a system might have. + +Since kernel threading can interrupt a thread at any time, they will +uncover some of the implicit locking assumptions you may make in your +program. For example, something as simple as C<$a = $a + 2> can behave +unpredictably with kernel threads if C<$a> is visible to other +threads, as another thread may have changed C<$a> between the time it +was fetched on the right hand side and the time the new value is +stored. + +Multiprocessor Kernel Threads are the final step in thread +support. With multiprocessor kernel threads on a machine with multiple +CPUs, the OS may schedule two or more threads to run simultaneously on +different CPUs. + +This can give a serious performance boost to your threaded program, +since more than one thread will be executing at the same time. As a +tradeoff, though, any of those nagging synchronization issues that +might not have shown with basic kernel threads will appear with a +vengeance. + +In addition to the different levels of OS involvement in threads, +different OSes (and different thread implementations for a particular +OS) allocate CPU cycles to threads in different ways. + +Cooperative multitasking systems have running threads give up control +if one of two things happen. If a thread calls a yield function, it +gives up control. It also gives up control if the thread does +something that would cause it to block, such as perform I/O. In a +cooperative multitasking implementation, one thread can starve all the +others for CPU time if it so chooses. + +Preemptive multitasking systems interrupt threads at regular intervals +while the system decides which thread should run next. In a preemptive +multitasking system, one thread usually won't monopolize the CPU. + +On some systems, there can be cooperative and preemptive threads +running simultaneously. (Threads running with realtime priorities +often behave cooperatively, for example, while threads running at +normal priorities behave preemptively.) + +=head1 What kind of threads are perl threads? + +If you have experience with other thread implementations, you might +find that things aren't quite what you expect. It's very important to +remember when dealing with Perl threads that Perl Threads Are Not X +Threads, for all values of X. They aren't POSIX threads, or +DecThreads, or Java's Green threads, or Win32 threads. There are +similarities, and the broad concepts are the same, but if you start +looking for implementation details you're going to be either +disappointed or confused. Possibly both. + +This is not to say that Perl threads are completely different from +everything that's ever come before--they're not. Perl's threading +model owes a lot to other thread models, especially POSIX. Just as +Perl is not C, though, Perl threads are not POSIX threads. So if you +find yourself looking for mutexes, or thread priorities, it's time to +step back a bit and think about what you want to do and how Perl can +do it. + +=head1 Threadsafe Modules + +The addition of threads has changed Perl's internals +substantially. There are implications for people who write +modules--especially modules with XS code or external libraries. While +most modules won't encounter any problems, modules that aren't +explicitly tagged as thread-safe should be tested before being used in +production code. + +Not all modules that you might use are thread-safe, and you should +always assume a module is unsafe unless the documentation says +otherwise. This includes modules that are distributed as part of the +core. Threads are a beta feature, and even some of the standard +modules aren't thread-safe. + +If you're using a module that's not thread-safe for some reason, you +can protect yourself by using semaphores and lots of programming +discipline to control access to the module. Semaphores are covered +later in the article. Perl Threads Are Different + +=head1 Thread Basics + +The core Thread module provides the basic functions you need to write +threaded programs. In the following sections we'll cover the basics, +showing you what you need to do to create a threaded program. After +that, we'll go over some of the features of the Thread module that +make threaded programming easier. + +=head2 Basic Thread Support + +Thread support is a Perl compile-time option-it's something that's +turned on or off when Perl is built at your site, rather than when +your programs are compiled. If your Perl wasn't compiled with thread +support enabled, then any attempt to use threads will fail. + +Remember that the threading support in 5.005 is in beta release, and +should be treated as such. You should expect that it may not function +entirely properly, and the thread interface may well change some +before it is a fully supported, production release. The beta version +shouldn't be used for mission-critical projects. Having said that, +threaded Perl is pretty nifty, and worth a look. + +Your programs can use the Config module to check whether threads are +enabled. If your program can't run without them, you can say something +like: + + $Config{usethreads} or die "Recompile Perl with threads to run this program."; + +A possibly-threaded program using a possibly-threaded module might +have code like this: + + use Config; + use MyMod; + + if ($Config{usethreads}) { + # We have threads + require MyMod_threaded; + import MyMod_threaded; + } else { + require MyMod_unthreaded; + import MyMod_unthreaded; + } + +Since code that runs both with and without threads is usually pretty +messy, it's best to isolate the thread-specific code in its own +module. In our example above, that's what MyMod_threaded is, and it's +only imported if we're running on a threaded Perl. + +=head2 Creating Threads + +The Thread package provides the tools you need to create new +threads. Like any other module, you need to tell Perl you want to use +it; use Thread imports all the pieces you need to create basic +threads. + +The simplest, straightforward way to create a thread is with new(): + + use Thread; + + $thr = new Thread \&sub1; + + sub sub1 { + print "In the thread\n"; + } + +The new() method takes a reference to a subroutine and creates a new +thread, which starts executing in the referenced subroutine. Control +then passes both to the subroutine and the caller. + +If you need to, your program can pass parameters to the subroutine as +part of the thread startup. Just include the list of parameters as +part of the C<Thread::new> call, like this: + + use Thread; + $Param3 = "foo"; + $thr = new Thread \&sub1, "Param 1", "Param 2", $Param3; + $thr = new Thread \&sub1, @ParamList; + $thr = new Thread \&sub1, qw(Param1 Param2 $Param3); + + sub sub1 { + my @InboundParameters = @_; + print "In the thread\n"; + print "got parameters >", join("<>", @InboundParameters), "<\n"; + } + + +The subroutine runs like a normal Perl subroutine, and the call to new +Thread returns whatever the subroutine returns. + +The last example illustrates another feature of threads. You can spawn +off several threads using the same subroutine. Each thread executes +the same subroutine, but in a separate thread with a separate +environment and potentially separate arguments. + +The other way to spawn a new thread is with async(), which is a way to +spin off a chunk of code like eval(), but into its own thread: + + use Thread qw(async); + + $LineCount = 0; + + $thr = async { + while(<>) {$LineCount++} + print "Got $LineCount lines\n"; + }; + + print "Waiting for the linecount to end\n"; + $thr->join; + print "All done\n"; + +You'll notice we did a use Thread qw(async) in that example. async is +not exported by default, so if you want it, you'll either need to +import it before you use it or fully qualify it as +Thread::async. You'll also note that there's a semicolon after the +closing brace. That's because async() treats the following block as an +anonymous subroutine, so the semicolon is necessary. + +Like eval(), the code executes in the same context as it would if it +weren't spun off. Since both the code inside and after the async start +executing, you need to be careful with any shared resources. Locking +and other synchronization techniques are covered later. + +=head2 Giving up control + +There are times when you may find it useful to have a thread +explicitly give up the CPU to another thread. Your threading package +might not support preemptive multitasking for threads, for example, or +you may be doing something compute-intensive and want to make sure +that the user-interface thread gets called frequently. Regardless, +there are times that you might want a thread to give up the processor. + +Perl's threading package provides the yield() function that does +this. yield() is pretty straightforward, and works like this: + + use Thread qw(yield async); + async { + my $foo = 50; + while ($foo--) { print "first async\n" } + yield; + $foo = 50; + while ($foo--) { print "first async\n" } + }; + async { + my $foo = 50; + while ($foo--) { print "second async\n" } + yield; + $foo = 50; + while ($foo--) { print "second async\n" } + }; + +=head2 Waiting For A Thread To Exit + +Since threads are also subroutines, they can return values. To wait +for a thread to exit and extract any scalars it might return, you can +use the join() method. + + use Thread; + $thr = new Thread \&sub1; + + @ReturnData = $thr->join; + print "Thread returned @ReturnData"; + + sub sub1 { return "Fifty-six", "foo", 2; } + +In the example above, the join() method returns as soon as the thread +ends. In addition to waiting for a thread to finish and gathering up +any values that the thread might have returned, join() also performs +any OS cleanup necessary for the thread. That cleanup might be +important, especially for long-running programs that spawn lots of +threads. If you don't want the return values and don't want to wait +for the thread to finish, you should call the detach() method +instead. detach() is covered later in the article. + +=head2 Errors In Threads + +So what happens when an error occurs in a thread? Any errors that +could be caught with eval() are postponed until the thread is +joined. If your program never joins, the errors appear when your +program exits. + +Errors deferred until a join() can be caught with eval(): + + use Thread qw(async); + $thr = async {$b = 3/0}; # Divide by zero error + $foo = eval {$thr->join}; + if ($@) { + print "died with error $@\n"; + } else { + print "Hey, why aren't you dead?\n"; + } + +eval() passes any results from the joined thread back unmodified, so +if you want the return value of the thread, this is your only chance +to get them. + +=head2 Ignoring A Thread + +join() does three things:it waits for a thread to exit, cleans up +after it, and returns any data the thread may have produced. But what +if you're not interested in the thread's return values, and you don't +really care when the thread finishes? All you want is for the thread +to get cleaned up after when it's done. + +In this case, you use the detach() method. Once a thread is detached, +it'll run until it's finished, then Perl will clean up after it +automatically. + + use Thread; + $thr = new Thread \&sub1; # Spawn the thread + + $thr->detach; # Now we officially don't care any more + + sub sub1 { + $a = 0; + while (1) { + $a++; + print "\$a is $a\n"; + sleep 1; + } + } + + +Once a thread is detached, it may not be joined, and any output that +it might have produced (if it was done and waiting for a join) is +lost. + +=head1 Threads And Data + +Now that we've covered the basics of threads, it's time for our next +topic: data. Threading introduces a couple of complications to data +access that non-threaded programs never need to worry about. + +=head2 Shared And Unshared Data + +The single most important thing to remember when using threads is that +all threads potentially have access to all the data anywhere in your +program. While this is true with a nonthreaded Perl program as well, +it's especially important to remember with a threaded program, since +more than one thread can be accessing this data at once. + +Perl's scoping rules don't change because you're using threads. If a +subroutine (or block, in the case of async()) could see a variable if +you weren't running with threads, it can see it if you are. This is +especially important for the subroutines that create, and makes my +variables even more important. Remember--if your variables aren't +lexically scoped (declared with C<my>) you're probably sharing it between +threads. + +=head2 Thread Pitfall: Races + +While threads bring a new set of useful tools, they also bring a +number of pitfalls. One pitfall is the race condition: + + use Thread; + $a = 1; + $thr1 = Thread->new(\&sub1); + $thr2 = Thread->new(\&sub2); + + sleep 10; + print "$a\n"; + + sub sub1 { $foo = $a; $a = $foo + 1; } + sub sub2 { $bar = $a; $a = $bar + 1; } + +What do you think $a will be? The answer, unfortunately, is "it +depends." Both sub1() and sub2() access the global variable $a, once +to read and once to write. Depending on factors ranging from your +thread implementation's scheduling algorithm to the phase of the moon, +$a can be 2 or 3. + +Race conditions are caused by unsynchronized access to shared +data. Without explicit synchronization, there's no way to be sure that +nothing has happened to the shared data between the time you access it +and the time you update it. Even this simple code fragment has the +possibility of error: + + use Thread qw(async); + $a = 2; + async{ $b = $a; $a = $b + 1; }; + async{ $c = $a; $a = $c + 1; }; + +Two threads both access $a. Each thread can potentially be interrupted +at any point, or be executed in any order. At the end, $a could be 3 +or 4, and both $b and $c could be 2 or 3. + +Whenever your program accesses data or resources that can be accessed +by other threads, you must take steps to coordinate access or risk +data corruption and race conditions. + +=head2 Controlling access: lock() + +The lock() function takes a variable (or subroutine, but we'll get to +that later) and puts a lock on it. No other thread may lock the +variable until the locking thread exits the innermost block containing +the lock. Using lock() is straightforward: + + use Thread qw(async); + $a = 4; + $thr1 = async { + $foo = 12; + { + lock ($a); # Block until we get access to $a + $b = $a; + $a = $b * $foo; + } + print "\$foo was $foo\n"; + }; + $thr2 = async { + $bar = 7; + { + lock ($a); # Block until we can get access to $a + $c = $a; + $a = $c * $bar; + } + print "\$bar was $bar\n"; + }; + $thr1->join; + $thr2->join; + print "\$a is $a\n"; + +lock() blocks the thread until the variable being locked is +available. When lock() returns, your thread can be sure that no other +thread can lock that variable until the innermost block containing the +lock exits. + +It's important to note that locks don't prevent access to the variable +in question, only lock attempts. This is in keeping with Perl's +longstanding tradition of courteous programming, and the advisory file +locking that flock() gives you. Locked subroutines behave differently, +however. We'll cover that later in the article. + +You may lock arrays and hashes as well as scalars. Locking an array, +though, will not block subsequent locks on array elements, just lock +attempts on the array itself. + +Finally, locks are recursive, which means it's okay for a thread to +lock a variable more than once. The lock will last until the outermost +lock() on the variable goes out of scope. + +=head2 Thread Pitfall: Deadlocks + +Locks are a handy tool to synchronize access to data. Using them +properly is the key to safe shared data. Unfortunately, locks aren't +without their dangers. Consider the following code: + + use Thread qw(async yield); + $a = 4; + $b = "foo"; + async { + lock($a); + yield; + sleep 20; + lock ($b); + }; + async { + lock($b); + yield; + sleep 20; + lock ($a); + }; + +This program will probably hang until you kill it. The only way it +won't hang is if one of the two async() routines acquires both locks +first. A guaranteed-to-hang version is more complicated, but the +principle is the same. + +The first thread spawned by async() will grab a lock on $a then, a +second or two later, try to grab a lock on $b. Meanwhile, the second +thread grabs a lock on $b, then later tries to grab a lock on $a. The +second lock attempt for both threads will block, each waiting for the +other to release its lock. + +This condition is called a deadlock, and it occurs whenever two or +more threads are trying to get locks on resources that the others +own. Each thread will block, waiting for the other to release a lock +on a resource. That never happens, though, since the thread with the +resource is itself waiting for a lock to be released. + +There are a number of ways to handle this sort of problem. The best +way is to always have all threads acquire locks in the exact same +order. If, for example, you lock variables $a, $b, and $c, always lock +$a before $b, and $b before $c. It's also best to hold on to locks for +as short a period of time to minimize the risks of deadlock. + +=head2 Queues: Passing Data Around + +A queue is a special thread-safe object that lets you put data in one +end and take it out the other without having to worry about +synchronization issues. They're pretty straightforward, and look like +this: + + use Thread qw(async); + use Thread::Queue; + + my $DataQueue = new Thread::Queue; + $thr = async { + while ($DataElement = $DataQueue->dequeue) { + print "Popped $DataElement off the queue\n"; + } + }; + + $DataQueue->enqueue(12); + $DataQueue->enqueue("A", "B", "C"); + $DataQueue->enqueue(\$thr); + sleep 10; + $DataQueue->enqueue(undef); + +You create the queue with new Thread::Queue. Then you can add lists of +scalars onto the end with enqueue(), and pop scalars off the front of +it with dequeue(). A queue has no fixed size, and can grow as needed +to hold everything pushed on to it. + +If a queue is empty, dequeue() blocks until another thread enqueues +something. This makes queues ideal for event loops and other +communications between threads. + +=head1 Threads And Code + +In addition to providing thread-safe access to data via locks and +queues, threaded Perl also provides general-purpose semaphores for +coarser synchronization than locks provide and thread-safe access to +entire subroutines. + +=head2 Semaphores: Synchronizing Data Access + +Semaphores are a kind of generic locking mechanism. Unlike lock, which +gets a lock on a particular scalar, Perl doesn't associate any +particular thing with a semaphore so you can use them to control +access to anything you like. In addition, semaphores can allow more +than one thread to access a resource at once, though by default +semaphores only allow one thread access at a time. + +=over 4 + +=item Basic semaphores + +Semaphores have two methods, down and up. down decrements the resource +count, while up increments it. down calls will block if the +semaphore's current count would decrement below zero. This program +gives a quick demonstration: + + use Thread qw(yield); + use Thread::Semaphore; + my $semaphore = new Thread::Semaphore; + $GlobalVariable = 0; + + $thr1 = new Thread \&sample_sub, 1; + $thr2 = new Thread \&sample_sub, 2; + $thr3 = new Thread \&sample_sub, 3; + + sub sample_sub { + my $SubNumber = shift @_; + my $TryCount = 10; + my $LocalCopy; + sleep 1; + while ($TryCount--) { + $semaphore->down; + $LocalCopy = $GlobalVariable; + print "$TryCount tries left for sub $SubNumber (\$GlobalVariable is $GlobalVariable)\n"; + yield; + sleep 2; + $LocalCopy++; + $GlobalVariable = $LocalCopy; + $semaphore->up; + } + } + +The three invocations of the subroutine all operate in sync. The +semaphore, though, makes sure that only one thread is accessing the +global variable at once. + +=item Advanced Semaphores + +By default, semaphores behave like locks, letting only one thread +down() them at a time. However, there are other uses for semaphores. + +Each semaphore has a counter attached to it. down() decrements the +counter and up() increments the counter. By default, semaphores are +created with the counter set to one, down() decrements by one, and +up() increments by one. If down() attempts to decrement the counter +below zero, it blocks until the counter is large enough. Note that +while a semaphore can be created with a starting count of zero, any +up() or down() always changes the counter by at least +one. $semaphore->down(0) is the same as $semaphore->down(1). + +The question, of course, is why would you do something like this? Why +create a semaphore with a starting count that's not one, or why +decrement/increment it by more than one? The answer is resource +availability. Many resources that you want to manage access for can be +safely used by more than one thread at once. + +For example, let's take a GUI driven program. It has a semaphore that +it uses to synchronize access to the display, so only one thread is +ever drawing at once. Handy, but of course you don't want any thread +to start drawing until things are properly set up. In this case, you +can create a semaphore with a counter set to zero, and up it when +things are ready for drawing. + +Semaphores with counters greater than one are also useful for +establishing quotas. Say, for example, that you have a number of +threads that can do I/O at once. You don't want all the threads +reading or writing at once though, since that can potentially swamp +your I/O channels, or deplete your process' quota of filehandles. You +can use a semaphore initialized to the number of concurrent I/O +requests (or open files) that you want at any one time, and have your +threads quietly block and unblock themselves. + +Larger increments or decrements are handy in those cases where a +thread needs to check out or return a number of resources at once. + +=back + +=head2 Attributes: Restricting Access To Subroutines + +In addition to synchronizing access to data or resources, you might +find it useful to synchronize access to subroutines. You may be +accessing a singular machine resource (perhaps a vector processor), or +find it easier to serialize calls to a particular subroutine than to +have a set of locks and sempahores. + +One of the additions to Perl 5.005 is subroutine attributes. The +Thread package uses these to provide several flavors of +serialization. It's important to remember that these attributes are +used in the compilation phase of your program so you can't change a +subroutine's behavior while your program is actually running. + +=head2 Subroutine Locks + +The basic subroutine lock looks like this: + + sub test_sub { + use attrs qw(locked); + } + +This ensures that only one thread will be executing this subroutine at +any one time. Once a thread calls this subroutine, any other thread +that calls it will block until the thread in the subroutine exits +it. A more elaborate example looks like this: + + use Thread qw(yield); + + new Thread \&thread_sub, 1; + new Thread \&thread_sub, 2; + new Thread \&thread_sub, 3; + new Thread \&thread_sub, 4; + + sub sync_sub { + use attrs qw(locked); + my $CallingThread = shift @_; + print "In sync_sub for thread $CallingThread\n"; + yield; + sleep 3; + print "Leaving sync_sub for thread $CallingThread\n"; + } + + sub thread_sub { + my $ThreadID = shift @_; + print "Thread $ThreadID calling sync_sub\n"; + sync_sub($ThreadID); + print "$ThreadID is done with sync_sub\n"; + } + +The use attrs qw(locked) locks sync_sub(), and if you run this, you +can see that only one thread is in it at any one time. + +=head2 Methods + +Locking an entire subroutine can sometimes be overkill, especially +when dealing with Perl objects. When calling a method for an object, +for example, you want to serialize calls to a method, so that only one +thread will be in the subroutine for a particular object, but threads +calling that subroutine for a different object aren't blocked. The +method attribute indicates whether the subroutine is really a method. + + use Thread; + + sub tester { + my $thrnum = shift @_; + my $bar = new Foo; + foreach (1..10) { + print "$thrnum calling per_object\n"; + $bar->per_object($thrnum); + print "$thrnum out of per_object\n"; + yield; + print "$thrnum calling one_at_a_time\n"; + $bar->one_at_a_time($thrnum); + print "$thrnum out of one_at_a_time\n"; + yield; + } + } + + foreach my $thrnum (1..10) { + new Thread \&tester, $thrnum; + } + + package Foo; + sub new { + my $class = shift @_; + return bless [@_], $class; + } + + sub per_object { + use attrs qw(locked method); + my ($class, $thrnum) = @_; + print "In per_object for thread $thrnum\n"; + yield; + sleep 2; + print "Exiting per_object for thread $thrnum\n"; + } + + sub one_at_a_time { + use attrs qw(locked); + my ($class, $thrnum) = @_; + print "In one_at_a_time for thread $thrnum\n"; + yield; + sleep 2; + print "Exiting one_at_a_time for thread $thrnum\n"; + } + +As you can see from the output (omitted for brevity; it's 800 lines) +all the threads can be in per_object() simultaneously, but only one +thread is ever in one_at_a_time() at once. + +=head2 Locking A Subroutine + +You can lock a subroutine as you would lock a variable. Subroutine +locks work the same as a C<use attrs qw(locked)> in the subroutine, +and block all access to the subroutine for other threads until the +lock goes out of scope. When the subroutine isn't locked, any number +of threads can be in it at once, and getting a lock on a subroutine +doesn't affect threads already in the subroutine. Getting a lock on a +subroutine looks like this: + + lock(\&sub_to_lock); + +Simple enough. Unlike use attrs, which is a compile time option, +locking and unlocking a subroutine can be done at runtime at your +discretion. There is some runtime penalty to using lock(\&sub) instead +of use attrs qw(locked), so make sure you're choosing the proper +method to do the locking. + +You'd choose lock(\&sub) when writing modules and code to run on both +threaded and unthreaded Perl, especially for code that will run on +5.004 or earlier Perls. In that case, it's useful to have subroutines +that should be serialized lock themselves if they're running threaded, +like so: + + package Foo; + use Config; + $Running_Threaded = 0; + + BEGIN { $Running_Threaded = $Config{'usethreads'} } + + sub sub1 { lock(\&sub1) if $Running_Threaded } + + +This way you can ensure single-threadedness regardless of which +version of Perl you're running. + +=head1 General Thread Utility Routines + +We've covered the workhorse parts of Perl's threading package, and +with these tools you should be well on your way to writing threaded +code and packages. There are a few useful little pieces that didn't +really fit in anyplace else. + +=head2 What Thread Am I In? + +The Thread->self method provides your program with a way to get an +object representing the thread it's currently in. You can use this +object in the same way as the ones returned from the thread creation. + +=head2 Thread IDs + +tid() is a thread object method that returns the thread ID of the +thread the object represents. Thread IDs are integers, with the main +thread in a program being 0. Currently Perl assigns a unique tid to +every thread ever created in your program, assigning the first thread +to be created a tid of 1, and increasing the tid by 1 for each new +thread that's created. + +=head2 Are These Threads The Same? + +The equal() method takes two thread objects and returns true +if the objects represent the same thread, and false if they don't. + +=head2 What Threads Are Running? + +Thread->list returns a list of thread objects, one for each thread +that's currently running. Handy for a number of things, including +cleaning up at the end of your program: + + # Loop through all the threads + foreach $thr (Thread->list) { + # Don't join the main thread or ourselves + if ($thr->tid && !Thread::equal($thr, Thread->self)) { + $thr->join; + } + } + +The example above is just for illustration. It isn't strictly +necessary to join all the threads you create, since Perl detaches all +the threads before it exits. + +=head1 A Complete Example + +Confused yet? It's time for an example program to show some of the +things we've covered. This program finds prime numbers using threads. + + 1 #!/usr/bin/perl -w + 2 # prime-pthread, courtesy of Tom Christiansen + 3 + 4 use strict; + 5 + 6 use Thread; + 7 use Thread::Queue; + 8 + 9 my $stream = new Thread::Queue; + 10 my $kid = new Thread(\&check_num, $stream, 2); + 11 + 12 for my $i ( 3 .. 1000 ) { + 13 $stream->enqueue($i); + 14 } + 15 + 16 $stream->enqueue(undef); + 17 $kid->join(); + 18 + 19 sub check_num { + 20 my ($upstream, $cur_prime) = @_; + 21 my $kid; + 22 my $downstream = new Thread::Queue; + 23 while (my $num = $upstream->dequeue) { + 24 next unless $num % $cur_prime; + 25 if ($kid) { + 26 $downstream->enqueue($num); + 27 } else { + 28 print "Found prime $num\n"; + 29 $kid = new Thread(\&check_num, $downstream, $num); + 30 } + 31 } + 32 $downstream->enqueue(undef) if $kid; + 33 $kid->join() if $kid; + 34 } + +This program uses the pipeline model to generate prime numbers. Each +thread in the pipeline has an input queue that feeds numbers to be +checked, a prime number that it's responsible for, and an output queue +that it funnels numbers that have failed the check into. If the thread +has a number that's failed its check and there's no child thread, then +the thread must have found a new prime number. In that case, a new +child thread is created for that prime and stuck on the end of the +pipeline. + +This probably sounds a bit more confusing than it really is, so lets +go through this program piece by piece and see what it does. (For +those of you who might be trying to remember exactly what a prime +number is, it's a number that's only evenly divisible by itself and 1) + +The bulk of the work is done by the check_num() subroutine, which +takes a reference to its input queue and a prime number that it's +responsible for. After pulling in the input queue and the prime that +the subroutine's checking (line 20), we create a new queue (line 22) +and reserve a scalar for the thread that we're likely to create later +(line 21). + +The while loop from lines 23 to line 31 grabs a scalar off the input +queue and checks against the prime this thread is responsible +for. Line 24 checks to see if there's a remainder when we modulo the +number to be checked against our prime. If there is one, the number +must not be evenly divisible by our prime, so we need to either pass +it on to the next thread if we've created one (line 26) or create a +new thread if we haven't. + +The new thread creation is line 29. We pass on to it a reference to +the queue we've created, and the prime number we've found. + +Finally, once the loop terminates (because we got a 0 or undef in the +queue, which serves as a note to die), we pass on the notice to our +child and wait for it to exit if we've created a child (Lines 32 and +37). + +Meanwhile, back in the main thread, we create a queue (line 9) and the +initial child thread (line 10), and pre-seed it with the first prime: +2. Then we queue all the numbers from 3 to 1000 for checking (lines +12-14), then queue a die notice (line 16) and wait for the first child +thread to terminate (line 17). Because a child won't die until its +child has died, we know that we're done once we return from the join. + +That's how it works. It's pretty simple; as with many Perl programs, +the explanation is much longer than the program. + +=head1 Conclusion + +A complete thread tutorial could fill a book (and has, many times), +but this should get you well on your way. The final authority on how +Perl's threads behave is the documention bundled with the Perl +distribution, but with what we've covered in this article, you should +be well on your way to becoming a threaded Perl expert. + +=head1 Bibliography + +Here's a short bibliography courtesy of Jürgen Christoffel: + +=head2 Introductory Texts + +Birrell, Andrew D. An Introduction to Programming with +Threads. Digital Equipment Corporation, 1989, DEC-SRC Research Report +#35 online as +http://www.research.digital.com/SRC/staff/birrell/bib.html (highly +recommended) + +Robbins, Kay. A., and Steven Robbins. Practical Unix Programming: A +Guide to Concurrency, Communication, and +Multithreading. Prentice-Hall, 1996. + +Lewis, Bill, and Daniel J. Berg. Multithreaded Programming with +Pthreads. Prentice Hall, 1997, ISBN 0-13-443698-9 (a well-written +introduction to threads). + +Nelson, Greg (editor). Systems Programming with Modula-3. Prentice +Hall, 1991, ISBN 0-13-590464-1. + +Nichols, Bradford, Dick Buttlar, and Jacqueline Proulx Farrell. +Pthreads Programming. O'Reilly & Associates, 1996, ISBN 156592-115-1 +(covers POSIX threads). + +=head2 OS-Related References + +Boykin, Joseph, David Kirschen, Alan Langerman, and Susan +LoVerso. Programming under Mach. Addison-Wesley, 1994, ISBN +0-201-52739-1. + +Tanenbaum, Andrew S. Distributed Operating Systems. Prentice Hall, +1995, ISBN 0-13-143934-0 (great textbook). + +Silberschatz, Abraham, and Peter B. Galvin. Operating System Concepts, +4th ed. Addison-Wesley, 1995, ISBN 0-201-59292-4 + +=head2 Other References + +Arnold, Ken and James Gosling. The Java Programming Language, 2nd +ed. Addison-Wesley, 1998, ISBN 0-201-31006-6. + +Le Sergent, T. and B. Berthomieu. "Incremental MultiThreaded Garbage +Collection on Virtually Shared Memory Architectures" in Memory +Management: Proc. of the International Workshop IWMM 92, St. Malo, +France, September 1992, Yves Bekkers and Jacques Cohen, eds. Springer, +1992, ISBN 3540-55940-X (real-life thread applications). + +=head1 Acknowledgements + +Thanks (in no particular order) to Chaim Frenkel, Steve Fink, Gurusamy +Sarathy, Ilya Zakharevich, Benjamin Sugars, Jürgen Christoffel, Joshua +Pritikin, and Alan Burlison, for their help in reality-checking and +polishing this article. Big thanks to Tom Christiansen for his rewrite +of the prime number generator. + +=head1 AUTHOR + +Dan Sugalski E<lt>sugalskd@ous.eduE<gt> + +=head1 Copyrights + +This article originally appeared in The Perl Journal #10, and is +copyright 1998 The Perl Journal. It appears courtesy of Jon Orwant and +The Perl Journal. This document may be distributed under the same terms +as Perl itself. + + diff --git a/contrib/perl5/pod/perltie.pod b/contrib/perl5/pod/perltie.pod index cae0a15..6652658 100644 --- a/contrib/perl5/pod/perltie.pod +++ b/contrib/perl5/pod/perltie.pod @@ -680,9 +680,12 @@ This method will be called when the handle is read from via the C<read> or C<sysread> functions. sub READ { - $r = shift; - my($buf,$len,$offset) = @_; - print "READ called, \$buf=$buf, \$len=$len, \$offset=$offset"; + my $self = shift; + my $$bufref = \$_[0]; + my(undef,$len,$offset) = @_; + print "READ called, \$buf=$bufref, \$len=$len, \$offset=$offset"; + # add to $$bufref, set $len to number of characters read + $len; } =item READLINE this @@ -690,7 +693,7 @@ or C<sysread> functions. This method will be called when the handle is read from via <HANDLE>. The method should return undef when there is no more data. - sub READLINE { $r = shift; "PRINT called $$r times\n"; } + sub READLINE { $r = shift; "READLINE called $$r times\n"; } =item GETC this diff --git a/contrib/perl5/pod/perltoc.pod b/contrib/perl5/pod/perltoc.pod index 980ca8f..9dc0b36 100644 --- a/contrib/perl5/pod/perltoc.pod +++ b/contrib/perl5/pod/perltoc.pod @@ -1353,7 +1353,7 @@ $BASETIME, $^T, $WARNING, $^W, $EXECUTABLE_NAME, $^X, $ARGV, @ARGV, @INC, =item Private Variables via C<my()> -=item Peristent Private Variables +=item Persistent Private Variables =item Temporary Values via local() @@ -2263,7 +2263,8 @@ C<http://www.connect.net/gbarr/cpan-test/> The djgpp environment for DOS, C<http://www.delorie.com/djgpp/>, The EMX environment for DOS, OS/2, etc. -C<emx@iaehv.nl>,C<http://www.juge.com/bbs/Hobb.19.html>, Build instructions +C<emx@iaehv.nl>,C<http://www.leo.org/pub/comp/os/os2/leo/gnu/emx+gcc/index.html>, +C<ftp://hobbes.nmsu.edu/pub/os2/dev/emx>. Build instructions for Win32, L<perlwin32>, The ActiveState Pages, C<http://www.activestate.com/> diff --git a/contrib/perl5/pod/perlvar.pod b/contrib/perl5/pod/perlvar.pod index 2ed3e97..8d0ded6 100644 --- a/contrib/perl5/pod/perlvar.pod +++ b/contrib/perl5/pod/perlvar.pod @@ -17,6 +17,15 @@ at the top of your program. This will alias all the short names to the long names in the current package. Some even have medium names, generally borrowed from B<awk>. +Due to an unfortunate accident of Perl's implementation, "C<use English>" +imposes a considerable performance penalty on all regular expression +matches in a program, regardless of whether they occur in the scope of +"C<use English>". For that reason, saying "C<use English>" in +libraries is strongly discouraged. See the Devel::SawAmpersand module +documentation from CPAN +(http://www.perl.com/CPAN/modules/by-module/Devel/Devel-SawAmpersand-0.10.readme) +for more information. + To go a step further, those variables that depend on the currently selected filehandle may instead (and preferably) be set by calling an object method on the FileHandle object. (Summary lines below for this @@ -127,6 +136,10 @@ The string matched by the last successful pattern match (not counting any matches hidden within a BLOCK or eval() enclosed by the current BLOCK). (Mnemonic: like & in some editors.) This variable is read-only. +The use of this variable anywhere in a program imposes a considerable +performance penalty on all regular expression matches. See the +Devel::SawAmpersand module from CPAN for more information. + =item $PREMATCH =item $` @@ -136,6 +149,10 @@ pattern match (not counting any matches hidden within a BLOCK or eval enclosed by the current BLOCK). (Mnemonic: C<`> often precedes a quoted string.) This variable is read-only. +The use of this variable anywhere in a program imposes a considerable +performance penalty on all regular expression matches. See the +Devel::SawAmpersand module from CPAN for more information. + =item $POSTMATCH =item $' @@ -151,6 +168,10 @@ string.) Example: This variable is read-only. +The use of this variable anywhere in a program imposes a considerable +performance penalty on all regular expression matches. See the +Devel::SawAmpersand module from CPAN for more information. + =item $LAST_PAREN_MATCH =item $+ @@ -188,7 +209,10 @@ the C</s> and C</m> modifiers on pattern matching. =item $. The current input line number for the last file handle from -which you read (or performed a C<seek> or C<tell> on). An +which you read (or performed a C<seek> or C<tell> on). The value +may be different from the actual physical line number in the file, +depending on what notion of "line" is in effect--see L<$/> on how +to affect that. An explicit close on a filehandle resets the line number. Because "C<E<lt>E<gt>>" never does an explicit close, line numbers increase across ARGV files (but see examples under eof()). Localizing C<$.> has @@ -204,7 +228,8 @@ number.) =item $/ -The input record separator, newline by default. Works like B<awk>'s RS +The input record separator, newline by default. This is used to +influence Perl's idea of what a "line" is. Works like B<awk>'s RS variable, including treating empty lines as delimiters if set to the null string. (Note: An empty line cannot contain any spaces or tabs.) You may set it to a multi-character string to match a multi-character @@ -216,8 +241,8 @@ line. Setting it to C<"\n\n"> will blindly assume that the next input character belongs to the next paragraph, even if it's a newline. (Mnemonic: / is used to delimit line boundaries when quoting poetry.) - undef $/; - $_ = <FH>; # whole file now here + undef $/; # enable "slurp" mode + $_ = <FH>; # whole file now here s/\n[ \t]+/ /g; Remember: the value of $/ is a string, not a regexp. AWK has to be @@ -241,9 +266,11 @@ 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 likely not a problem, as any file you'd want to read in record mode is -proably usable in line mode) Non-VMS systems perform normal I/O, so +probably usable in line mode) Non-VMS systems perform normal I/O, so it's safe to mix record and non-record reads of a file. +Also see L<$.>. + =item autoflush HANDLE EXPR =item $OUTPUT_AUTOFLUSH @@ -626,6 +653,15 @@ of perl in the right bracket?) Example: See also the documentation of C<use VERSION> and C<require VERSION> for a convenient way to fail if the Perl interpreter is too old. +=item $COMPILING + +=item $^C + +The current value of the flag associated with the B<-c> switch. Mainly +of use with B<-MO=...> to allow code to alter its behaviour when being compiled. +(For example to automatically AUTOLOADing at compile time rather than normal +deferred loading.) Setting C<$^C = 1> is similar to calling C<B::minus_c>. + =item $DEBUGGING =item $^D @@ -643,7 +679,7 @@ descriptors are not. Also, during an open(), system file descriptors are preserved even if the open() fails. (Ordinary file descriptors are closed before the open() is attempted.) Note that the close-on-exec status of a file descriptor will be decided according to the value of -C<$^F> at the time of the open, not the time of the exec. +C<$^F> when the open() or pipe() was called, not the time of the exec(). =item $^H @@ -714,7 +750,7 @@ Start with single-step on. =back -Note that some bits may be relevent at compile-time only, some at +Note that some bits may be relevant at compile-time only, some at run-time only. This is a new mechanism and the details may change. =item $^R @@ -788,12 +824,16 @@ specified, and the value is the location of the file actually found. The C<require> command uses this array to determine whether a given file has already been included. -=item %ENV $ENV{expr} +=item %ENV + +=item $ENV{expr} The hash %ENV contains your current environment. Setting a value in C<ENV> changes the environment for child processes. -=item %SIG $SIG{expr} +=item %SIG + +=item $SIG{expr} The hash %SIG is used to set signal handlers for various signals. Example: @@ -811,6 +851,10 @@ signals. Example: $SIG{'INT'} = 'DEFAULT'; # restore default action $SIG{'QUIT'} = 'IGNORE'; # ignore SIGQUIT +Using a value of C<'IGNORE'> usually has the effect of ignoring the +signal, except for the C<CHLD> signal. See L<perlipc> for more about +this special case. + The %SIG array contains values for only the signals actually set within the Perl script. Here are some other examples: @@ -867,7 +911,7 @@ respect: they may be called to report (probable) errors found by the parser. In such a case the parser may be in inconsistent state, so any attempt to evaluate Perl code from such a handler will probably result in a segfault. This means that calls which result/may-result -in parsing Perl should be used with extreme causion, like this: +in parsing Perl should be used with extreme caution, like this: require Carp if defined $^S; Carp::confess("Something wrong") if defined &Carp::confess; @@ -934,3 +978,35 @@ pipe C<close>, overwriting the old value. For more details, see the individual descriptions at L<$@>, L<$!>, L<$^E>, and L<$?>. + + +=head2 Technical Note on the Syntax of Variable Names + +Variable names in Perl can have several formats. Usually, they must +begin with a letter or underscore, in which case they can be +arbitrarily long (up to an internal limit of 256 characters) and may +contain letters, digits, underscores, or the special sequence C<::>. +In this case the part before the last C<::> is taken to be a I<package +qualifier>; see L<perlmod>. + +Perl variable names may also be a sequence of digits or a single +punctuation or control character. These names are all reserved for +special uses by Perl; for example, the all-digits names are used to +hold backreferences after a regular expression match. Perl has a +special syntax for the single-control-character names: It understands +C<^X> (caret C<X>) to mean the control-C<X> character. For example, +the notation C<$^W> (dollar-sign caret C<W>) is the scalar variable +whose name is the single character control-C<W>. This is better than +typing a literal control-C<W> into your program. + +All Perl variables that begin with digits, control characters, or +punctuation characters are exempt from the effects of the C<package> +declaration and are always forced to be in package C<main>. A few +other names are also exempt: + + ENV STDIN + INC STDOUT + ARGV STDERR + ARGVOUT + SIG + diff --git a/contrib/perl5/pod/perlxs.pod b/contrib/perl5/pod/perlxs.pod index c578a2e..98a9834 100644 --- a/contrib/perl5/pod/perlxs.pod +++ b/contrib/perl5/pod/perlxs.pod @@ -181,10 +181,10 @@ directive is used which sets ST(0) explicitly. Older versions of this document recommended to use C<void> return value in such cases. It was discovered that this could lead to -segfaults in cases when XSUB was I<truely> C<void>. This practice is +segfaults in cases when XSUB was I<truly> C<void>. This practice is now deprecated, and may be not supported at some future version. Use the return value C<SV *> in such cases. (Currently C<xsubpp> contains -some heuristic code which tries to disambiguate between "truely-void" +some heuristic code which tries to disambiguate between "truly-void" and "old-practice-declared-as-void" functions. Hence your code is at mercy of this heuristics unless you use C<SV *> as return value.) @@ -387,9 +387,9 @@ 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 preceed +For the C<+> case, the initialization from the typemap will precede the initialization code included after the C<+>. A global -variable, C<%v>, is available for the truely rare case where +variable, C<%v>, is available for the truly rare case where information from one initialization is needed in another initialization. @@ -553,9 +553,10 @@ The XS code, with ellipsis, follows. time_t timep = NO_INIT PREINIT: char *host = "localhost"; + STRLEN n_a; CODE: if( items > 1 ) - host = (char *)SvPV(ST(1), PL_na); + host = (char *)SvPV(ST(1), n_a); RETVAL = rpcb_gettime( host, &timep ); OUTPUT: timep @@ -786,9 +787,10 @@ prototypes. PROTOTYPE: $;$ PREINIT: char *host = "localhost"; + STRLEN n_a; CODE: if( items > 1 ) - host = (char *)SvPV(ST(1), PL_na); + host = (char *)SvPV(ST(1), n_a); RETVAL = rpcb_gettime( host, &timep ); OUTPUT: timep @@ -1212,13 +1214,15 @@ 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>. The INPUT section tells the compiler how to translate Perl values +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 +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 understand. The TYPEMAP section tells the compiler which of the INPUT and OUTPUT code fragments should be used to map a given C type to a Perl value. -Each of the sections of the typemap must be preceded by one of the TYPEMAP, -INPUT, or OUTPUT keywords. +The section labels C<TYPEMAP>, C<INPUT>, or C<OUTPUT> must begin +in the first column on a line by themselves, and must be in uppercase. The default typemap in the C<ext> directory of the Perl source contains many useful types which can be used by Perl extensions. Some extensions define diff --git a/contrib/perl5/pod/perlxstut.pod b/contrib/perl5/pod/perlxstut.pod index 867d42a..69a1a25 100644 --- a/contrib/perl5/pod/perlxstut.pod +++ b/contrib/perl5/pod/perlxstut.pod @@ -465,7 +465,7 @@ include a C source file and a header file. We'll also create a Makefile.PL in this directory. Then we'll make sure that running make at the Mytest2 level will automatically run this Makefile.PL file and the resulting Makefile. -In the testlib directory, create a file mylib.h that looks like this: +In the mylib directory, create a file mylib.h that looks like this: #define TESTVAL 4 diff --git a/contrib/perl5/pod/pod2html.PL b/contrib/perl5/pod/pod2html.PL index 4eec29c..366dc16 100644 --- a/contrib/perl5/pod/pod2html.PL +++ b/contrib/perl5/pod/pod2html.PL @@ -164,7 +164,7 @@ See L<Pod::Html> for a list of known bugs in the translator. =head1 SEE ALSO -L<perlpod>, L<Pod::HTML> +L<perlpod>, L<Pod::Html> =head1 COPYRIGHT diff --git a/contrib/perl5/pod/pod2man.PL b/contrib/perl5/pod/pod2man.PL index 8040bf5..3c55d6e 100644 --- a/contrib/perl5/pod/pod2man.PL +++ b/contrib/perl5/pod/pod2man.PL @@ -318,8 +318,12 @@ $cutting = 1; # running an installed version of Perl to produce documentation from an # uninstalled newer version's pod files. if ($^O ne 'plan9' and $^O ne 'dos' and $^O ne 'os2' and $^O ne 'MSWin32') { - ($version,$patch) = - `\PATH=.:..:\$PATH; perl -v` =~ /version (\d\.\d{3})(?:_(\d{2}))?/; + my $perl = (-x './perl' && -f './perl' ) ? + './perl' : + ((-x '../perl' && -f '../perl') ? + '../perl' : + ''); + ($version,$patch) = `$perl -e 'print $]'` =~ /^(\d\.\d{3})(\d{2})?/ if $perl; } # No luck; we'll just go with the running Perl's version ($version,$patch) = $] =~ /^(.{5})(\d{2})?/ unless $version; @@ -331,6 +335,7 @@ sub makedate { my $secs = shift; my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($secs); my $mname = (qw{Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec})[$mon]; + $year += 1900; return "$mday/$mname/$year"; } diff --git a/contrib/perl5/pod/roffitall b/contrib/perl5/pod/roffitall index 918fe02..9ab7f29 100644 --- a/contrib/perl5/pod/roffitall +++ b/contrib/perl5/pod/roffitall @@ -36,6 +36,7 @@ toroff=` $mandir/perlre.1 \ $mandir/perlrun.1 \ $mandir/perlfunc.1 \ + $mandir/perlopentut.1 \ $mandir/perlvar.1 \ $mandir/perlsub.1 \ $mandir/perlmod.1 \ @@ -44,6 +45,7 @@ toroff=` $mandir/perlform.1 \ $mandir/perllocale.1 \ $mandir/perlref.1 \ + $mandir/perlreftut.1 \ $mandir/perldsc.1 \ $mandir/perllol.1 \ $mandir/perltoot.1 \ @@ -65,6 +67,7 @@ toroff=` $mandir/perlxstut.1 \ $mandir/perlguts.1 \ $mandir/perlcall.1 \ + $mandir/perlthrtut.1 \ $mandir/perlhist.1 \ $mandir/perldelta.1 \ $mandir/perl5004delta.1 \ @@ -149,6 +152,7 @@ toroff=` $libdir/Devel::SelfStubber.3 \ $libdir/DirHandle.3 \ $libdir/DynaLoader.3 \ + $libdir/Dumpvalue.3 \ $libdir/English.3 \ $libdir/Env.3 \ $libdir/Errno.3 \ diff --git a/contrib/perl5/pp.c b/contrib/perl5/pp.c index 35b1552..1f62886 100644 --- a/contrib/perl5/pp.c +++ b/contrib/perl5/pp.c @@ -1,6 +1,6 @@ /* pp.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -105,9 +105,9 @@ typedef unsigned UBW; static void doencodes _((SV* sv, char* s, I32 len)); static SV* refto _((SV* sv)); static U32 seed _((void)); +static bool srand_called = FALSE; #endif -static bool srand_called = FALSE; /* variations on pp_null */ @@ -224,6 +224,7 @@ PP(pp_rv2gv) else { if (SvTYPE(sv) != SVt_PVGV) { char *sym; + STRLEN n_a; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -238,7 +239,7 @@ PP(pp_rv2gv) warn(warn_uninit); RETSETUNDEF; } - sym = SvPV(sv, PL_na); + sym = SvPV(sv, n_a); if (PL_op->op_private & HINT_STRICT_REFS) DIE(no_symref, sym, "a symbol"); sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV); @@ -267,6 +268,7 @@ PP(pp_rv2sv) else { GV *gv = (GV*)sv; char *sym; + STRLEN n_a; if (SvTYPE(gv) != SVt_PVGV) { if (SvGMAGICAL(sv)) { @@ -282,7 +284,7 @@ PP(pp_rv2sv) warn(warn_uninit); RETSETUNDEF; } - sym = SvPV(sv, PL_na); + sym = SvPV(sv, n_a); if (PL_op->op_private & HINT_STRICT_REFS) DIE(no_symref, sym, "a SCALAR"); gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV); @@ -533,9 +535,10 @@ PP(pp_gelem) SV *tmpRef; char *elem; djSP; + STRLEN n_a; sv = POPs; - elem = SvPV(sv, PL_na); + elem = SvPV(sv, n_a); gv = (GV*)POPs; tmpRef = Nullsv; sv = Nullsv; @@ -716,11 +719,11 @@ PP(pp_defined) RETPUSHNO; switch (SvTYPE(sv)) { case SVt_PVAV: - if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)) + if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P'))) RETPUSHYES; break; case SVt_PVHV: - if (HvARRAY(sv) || SvGMAGICAL(sv)) + if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P'))) RETPUSHYES; break; case SVt_PVCV: @@ -751,8 +754,11 @@ PP(pp_undef) RETPUSHUNDEF; if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv)) - RETPUSHUNDEF; + if (SvREADONLY(sv)) { + dTHR; + if (PL_curcop != &PL_compiling) + croak(no_modify); + } if (SvROK(sv)) sv_unref(sv); } @@ -1634,21 +1640,50 @@ seed(void) #define SEED_C5 26107 dTHR; +#ifndef PERL_NO_DEV_RANDOM + int fd; +#endif U32 u; #ifdef VMS # include <starlet.h> /* when[] = (low 32 bits, high 32 bits) of time since epoch * in 100-ns units, typically incremented ever 10 ms. */ unsigned int when[2]; +#else +# ifdef HAS_GETTIMEOFDAY + struct timeval when; +# else + Time_t when; +# endif +#endif + +/* This test is an escape hatch, this symbol isn't set by Configure. */ +#ifndef PERL_NO_DEV_RANDOM +#ifndef PERL_RANDOM_DEVICE + /* /dev/random isn't used by default because reads from it will block + * if there isn't enough entropy available. You can compile with + * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there + * is enough real entropy to fill the seed. */ +# define PERL_RANDOM_DEVICE "/dev/urandom" +#endif + fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0); + if (fd != -1) { + if (PerlLIO_read(fd, &u, sizeof u) != sizeof u) + u = 0; + PerlLIO_close(fd); + if (u) + return u; + } +#endif + +#ifdef VMS _ckvmssts(sys$gettim(when)); u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1]; #else # ifdef HAS_GETTIMEOFDAY - struct timeval when; gettimeofday(&when,(struct timezone *) 0); u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec; # else - Time_t when; (void)time(&when); u = (U32)SEED_C1 * when; # endif @@ -1760,8 +1795,9 @@ PP(pp_hex) djSP; dTARGET; char *tmps; I32 argtype; + STRLEN n_a; - tmps = POPp; + tmps = POPpx; XPUSHu(scan_hex(tmps, 99, &argtype)); RETURN; } @@ -1772,8 +1808,9 @@ PP(pp_oct) UV value; I32 argtype; char *tmps; + STRLEN n_a; - tmps = POPp; + tmps = POPpx; while (*tmps && isSPACE(*tmps)) tmps++; if (*tmps == '0') @@ -1866,7 +1903,8 @@ PP(pp_substr) if (lvalue) { /* it's an lvalue! */ if (!SvGMAGICAL(sv)) { if (SvROK(sv)) { - SvPV_force(sv,PL_na); + STRLEN n_a; + SvPV_force(sv,n_a); if (PL_dowarn) warn("Attempt to use reference as lvalue in substr"); } @@ -2067,13 +2105,14 @@ PP(pp_ord) djSP; dTARGET; I32 value; char *tmps; + STRLEN n_a; #ifndef I286 - tmps = POPp; + tmps = POPpx; value = (I32) (*tmps & 255); #else I32 anum; - tmps = POPp; + tmps = POPpx; anum = (I32) *tmps; value = (I32) (anum & 255); #endif @@ -2100,12 +2139,13 @@ PP(pp_chr) PP(pp_crypt) { djSP; dTARGET; dPOPTOPssrl; + STRLEN n_a; #ifdef HAS_CRYPT - char *tmps = SvPV(left, PL_na); + char *tmps = SvPV(left, n_a); #ifdef FCRYPT - sv_setpv(TARG, fcrypt(tmps, SvPV(right, PL_na))); + sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a))); #else - sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, PL_na))); + sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a))); #endif #else DIE( @@ -2120,6 +2160,7 @@ PP(pp_ucfirst) djSP; SV *sv = TOPs; register char *s; + STRLEN n_a; if (!SvPADTMP(sv)) { dTARGET; @@ -2127,7 +2168,7 @@ PP(pp_ucfirst) sv = TARG; SETs(sv); } - s = SvPV_force(sv, PL_na); + s = SvPV_force(sv, n_a); if (*s) { if (PL_op->op_private & OPpLOCALE) { TAINT; @@ -2146,6 +2187,7 @@ PP(pp_lcfirst) djSP; SV *sv = TOPs; register char *s; + STRLEN n_a; if (!SvPADTMP(sv)) { dTARGET; @@ -2153,7 +2195,7 @@ PP(pp_lcfirst) sv = TARG; SETs(sv); } - s = SvPV_force(sv, PL_na); + s = SvPV_force(sv, n_a); if (*s) { if (PL_op->op_private & OPpLOCALE) { TAINT; @@ -2428,8 +2470,10 @@ PP(pp_hslice) svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0); } if (lval) { - if (!svp || *svp == &PL_sv_undef) - DIE(no_helem, SvPV(keysv, PL_na)); + if (!svp || *svp == &PL_sv_undef) { + STRLEN n_a; + DIE(no_helem, SvPV(keysv, n_a)); + } if (PL_op->op_private & OPpLVAL_INTRO) save_helem(hv, keysv, svp); } @@ -2561,8 +2605,8 @@ PP(pp_splice) SV **tmparyval = 0; MAGIC *mg; - if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) { - *MARK-- = mg->mg_obj; + if (mg = SvTIED_mg((SV*)ary, 'P')) { + *MARK-- = SvTIED_obj((SV*)ary, mg); PUSHMARK(MARK); PUTBACK; ENTER; @@ -2759,8 +2803,8 @@ PP(pp_push) register SV *sv = &PL_sv_undef; MAGIC *mg; - if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) { - *MARK-- = mg->mg_obj; + if (mg = SvTIED_mg((SV*)ary, 'P')) { + *MARK-- = SvTIED_obj((SV*)ary, mg); PUSHMARK(MARK); PUTBACK; ENTER; @@ -2815,8 +2859,8 @@ PP(pp_unshift) register I32 i = 0; MAGIC *mg; - if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) { - *MARK-- = mg->mg_obj; + if (mg = SvTIED_mg((SV*)ary, 'P')) { + *MARK-- = SvTIED_obj((SV*)ary, mg); PUSHMARK(MARK); PUTBACK; ENTER; @@ -2910,7 +2954,9 @@ mul128(SV *sv, U8 m) static const char uuemap[] = "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"; +#ifndef PERL_OBJECT static char uudmap[256]; /* Initialised on first use */ +#endif #if 'I' == 73 && 'J' == 74 /* On an ASCII/ISO kind of system */ #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a') @@ -2959,13 +3005,15 @@ PP(pp_unpack) I32 checksum = 0; register U32 culong; double cdouble; +#ifndef PERL_OBJECT static char* bitcount = 0; +#endif int commas = 0; if (gimme != G_ARRAY) { /* arrange to do first one only */ /*SUPPRESS 530*/ for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ; - if (strchr("aAbBhHP", *patend) || *pat == '%') { + if (strchr("aAZbBhHP", *patend) || *pat == '%') { patend++; while (isDIGIT(*patend) || *patend == '*') patend++; @@ -3023,6 +3071,7 @@ PP(pp_unpack) s += len; break; case 'A': + case 'Z': case 'a': if (len > strend - s) len = strend - s; @@ -3031,12 +3080,19 @@ PP(pp_unpack) sv = NEWSV(35, len); sv_setpvn(sv, s, len); s += len; - if (datumtype == 'A') { + if (datumtype == 'A' || datumtype == 'Z') { aptr = s; /* borrow register */ - s = SvPVX(sv) + len - 1; - while (s >= SvPVX(sv) && (!*s || isSPACE(*s))) - s--; - *++s = '\0'; + if (datumtype == 'Z') { /* 'Z' strips stuff after first null */ + s = SvPVX(sv); + while (*s) + s++; + } + else { /* 'A' strips both nulls and spaces */ + s = SvPVX(sv) + len - 1; + while (s >= SvPVX(sv) && (!*s || isSPACE(*s))) + s--; + *++s = '\0'; + } SvCUR_set(sv, s - SvPVX(sv)); s = aptr; /* unborrow register */ } @@ -3195,6 +3251,10 @@ PP(pp_unpack) if (checksum) { while (len-- > 0) { COPY16(s, &ashort); +#if SHORTSIZE > SIZE16 + if (ashort > 32767) + ashort -= 65536; +#endif s += SIZE16; culong += ashort; } @@ -3204,6 +3264,10 @@ PP(pp_unpack) EXTEND_MORTAL(len); while (len-- > 0) { COPY16(s, &ashort); +#if SHORTSIZE > SIZE16 + if (ashort > 32767) + ashort -= 65536; +#endif s += SIZE16; sv = NEWSV(38, 0); sv_setiv(sv, (IV)ashort); @@ -3306,6 +3370,17 @@ PP(pp_unpack) Copy(s, &auint, 1, unsigned int); s += sizeof(unsigned int); sv = NEWSV(41, 0); +#ifdef __osf__ + /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF)) + * returns 1.84467440737096e+19 instead of 0xFFFFFFFF for + * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (aka V4.0D) + * with optimization turned on. + * (DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (aka V4.0B) + * does not have this problem even with -O4) + */ + (auint) ? + sv_setuv(sv, (UV)auint) : +#endif sv_setuv(sv, (UV)auint); PUSHs(sv_2mortal(sv)); } @@ -3318,6 +3393,10 @@ PP(pp_unpack) if (checksum) { while (len-- > 0) { COPY32(s, &along); +#if LONGSIZE > SIZE32 + if (along > 2147483647) + along -= 4294967296; +#endif s += SIZE32; if (checksum > 32) cdouble += (double)along; @@ -3330,6 +3409,10 @@ PP(pp_unpack) EXTEND_MORTAL(len); while (len-- > 0) { COPY32(s, &along); +#if LONGSIZE > SIZE32 + if (along > 2147483647) + along -= 4294967296; +#endif s += SIZE32; sv = NEWSV(42, 0); sv_setiv(sv, (IV)along); @@ -3419,6 +3502,7 @@ PP(pp_unpack) } else if (++bytes >= sizeof(UV)) { /* promote to string */ char *t; + STRLEN n_a; sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv); while (s < strend) { @@ -3428,7 +3512,7 @@ PP(pp_unpack) break; } } - t = SvPV(sv, PL_na); + t = SvPV(sv, n_a); while (*t == '0') t++; sv_chop(sv, t); @@ -3574,7 +3658,7 @@ PP(pp_unpack) char hunk[4]; hunk[3] = '\0'; - len = (*s++ - ' ') & 077; + len = uudmap[*s++] & 077; while (len > 0) { if (s < strend && ISUUCHAR(*s)) a = uudmap[*s++] & 077; @@ -3676,8 +3760,9 @@ doencodes(register SV *sv, register char *s, register I32 len) STATIC SV * is_an_int(char *s, STRLEN l) { + STRLEN n_a; SV *result = newSVpv("", l); - char *result_c = SvPV(result, PL_na); /* convenience */ + char *result_c = SvPV(result, n_a); /* convenience */ char *out = result_c; bool skip = 1; bool ignore = 0; @@ -3833,6 +3918,7 @@ PP(pp_pack) sv_catpvn(cat, null10, len); break; case 'A': + case 'Z': case 'a': fromstr = NEXTFROM; aptr = SvPV(fromstr, fromlen); @@ -4172,6 +4258,7 @@ PP(pp_pack) if (fromstr == &PL_sv_undef) aptr = NULL; else { + STRLEN n_a; /* XXX better yet, could spirit away the string to * a safe spot and hang on to it until the result * of pack() (and all copies of the result) are @@ -4180,9 +4267,9 @@ PP(pp_pack) if (PL_dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr))) warn("Attempt to pack pointer to temporary value"); if (SvPOK(fromstr) || SvNIOK(fromstr)) - aptr = SvPV(fromstr,PL_na); + aptr = SvPV(fromstr,n_a); else - aptr = SvPV_force(fromstr,PL_na); + aptr = SvPV_force(fromstr,n_a); } sv_catpvn(cat, (char*)&aptr, sizeof(char*)); } @@ -4271,9 +4358,9 @@ PP(pp_split) av_extend(ary,0); av_clear(ary); SPAGAIN; - if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) { + if (mg = SvTIED_mg((SV*)ary, 'P')) { PUSHMARK(SP); - XPUSHs(mg->mg_obj); + XPUSHs(SvTIED_obj((SV*)ary, mg)); } else { if (!AvREAL(ary)) { @@ -4522,7 +4609,6 @@ PP(pp_lock) DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n", (unsigned long)thr, (unsigned long)sv);) MUTEX_UNLOCK(MgMUTEXP(mg)); - SvREFCNT_inc(sv); /* keep alive until magic_mutexfree */ save_destructor(unlock_condpair, sv); } #endif /* USE_THREADS */ diff --git a/contrib/perl5/pp.h b/contrib/perl5/pp.h index 6fe91f4..c0cebcc 100644 --- a/contrib/perl5/pp.h +++ b/contrib/perl5/pp.h @@ -1,6 +1,6 @@ /* pp.h * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -61,14 +61,16 @@ #define RETURNX(x) return x, PUTBACK, NORMAL #define POPs (*sp--) -#define POPp (SvPVx(POPs, PL_na)) +#define POPp (SvPVx(POPs, PL_na)) /* deprecated */ +#define POPpx (SvPVx(POPs, n_a)) #define POPn (SvNVx(POPs)) #define POPi ((IV)SvIVx(POPs)) #define POPu ((UV)SvUVx(POPs)) #define POPl ((long)SvIVx(POPs)) #define TOPs (*sp) -#define TOPp (SvPV(TOPs, PL_na)) +#define TOPp (SvPV(TOPs, PL_na)) /* deprecated */ +#define TOPpx (SvPV(TOPs, n_a)) #define TOPn (SvNV(TOPs)) #define TOPi ((IV)SvIV(TOPs)) #define TOPu ((UV)SvUV(TOPs)) diff --git a/contrib/perl5/pp_ctl.c b/contrib/perl5/pp_ctl.c index 7a1ad79..653a345 100644 --- a/contrib/perl5/pp_ctl.c +++ b/contrib/perl5/pp_ctl.c @@ -1,6 +1,6 @@ /* pp_ctl.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -529,7 +529,13 @@ PP(pp_formline) break; case FF_MORE: - if (itemsize) { + s = chophere; + send = item + len; + if (chopspace) { + while (*s && isSPACE(*s) && s < send) + s++; + } + if (s < send) { arg = fieldsize - itemsize; if (arg) { fieldsize -= arg; @@ -661,6 +667,61 @@ PP(pp_mapwhile) } } +#define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \ + *svp = Nullsv; \ + if (PL_amagic_generation) { \ + if (SvAMAGIC(left)||SvAMAGIC(right))\ + *svp = amagic_call(left, \ + right, \ + CAT2(meth,_amg), \ + 0); \ + } \ + } STMT_END + +STATIC I32 +amagic_cmp(register SV *str1, register SV *str2) +{ + SV *tmpsv; + tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv); + if (tmpsv) { + double d; + + if (SvIOK(tmpsv)) { + I32 i = SvIVX(tmpsv); + if (i > 0) + return 1; + return i? -1 : 0; + } + d = SvNV(tmpsv); + if (d > 0) + return 1; + return d? -1 : 0; + } + return sv_cmp(str1, str2); +} + +STATIC I32 +amagic_cmp_locale(register SV *str1, register SV *str2) +{ + SV *tmpsv; + tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv); + if (tmpsv) { + double d; + + if (SvIOK(tmpsv)) { + I32 i = SvIVX(tmpsv); + if (i > 0) + return 1; + return i? -1 : 0; + } + d = SvNV(tmpsv); + if (d > 0) + return 1; + return d? -1 : 0; + } + return sv_cmp_locale(str1, str2); +} + PP(pp_sort) { djSP; dMARK; dORIGMARK; @@ -672,6 +733,7 @@ PP(pp_sort) CV *cv; I32 gimme = GIMME; OP* nextop = PL_op->op_next; + I32 overloading = 0; if (gimme != G_ARRAY) { SP = MARK; @@ -724,8 +786,14 @@ PP(pp_sort) /*SUPPRESS 560*/ if (*up = *++MARK) { /* Weed out nulls. */ SvTEMP_off(*up); - if (!PL_sortcop && !SvPOK(*up)) - (void)sv_2pv(*up, &PL_na); + if (!PL_sortcop && !SvPOK(*up)) { + if (SvAMAGIC(*up)) + overloading = 1; + else { + STRLEN n_a; + (void)sv_2pv(*up, &n_a); + } + } up++; } } @@ -772,8 +840,12 @@ PP(pp_sort) MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */ qsortsv(ORIGMARK+1, max, (PL_op->op_private & OPpLOCALE) - ? FUNC_NAME_TO_PTR(sv_cmp_locale) - : FUNC_NAME_TO_PTR(sv_cmp)); + ? ( overloading + ? FUNC_NAME_TO_PTR(amagic_cmp_locale) + : FUNC_NAME_TO_PTR(sv_cmp_locale)) + : ( overloading + ? FUNC_NAME_TO_PTR(amagic_cmp) + : FUNC_NAME_TO_PTR(sv_cmp) )); } } LEAVE; @@ -828,22 +900,25 @@ PP(pp_flop) if (GIMME == G_ARRAY) { dPOPPOPssrl; - register I32 i; + register I32 i, j; register SV *sv; I32 max; if (SvNIOKp(left) || !SvPOKp(left) || (looks_like_number(left) && *SvPVX(left) != '0') ) { - if (SvNV(left) < IV_MIN || SvNV(right) >= IV_MAX) + if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX) croak("Range iterator outside integer range"); i = SvIV(left); max = SvIV(right); if (max >= i) { - EXTEND_MORTAL(max - i + 1); - EXTEND(SP, max - i + 1); + j = max - i + 1; + EXTEND_MORTAL(j); + EXTEND(SP, j); } - while (i <= max) { + else + j = 0; + while (j--) { sv = sv_2mortal(newSViv(i++)); PUSHs(sv); } @@ -851,10 +926,11 @@ PP(pp_flop) else { SV *final = sv_mortalcopy(right); STRLEN len; + STRLEN n_a; char *tmps = SvPV(final, len); sv = sv_mortalcopy(left); - SvPV_force(sv,PL_na); + SvPV_force(sv,n_a); while (!SvNIOKp(sv) && SvCUR(sv) <= len) { XPUSHs(sv); if (strEQ(SvPVX(sv),tmps)) @@ -891,7 +967,7 @@ dopoptolabel(char *label) for (i = cxstack_ix; i >= 0; i--) { cx = &cxstack[i]; - switch (cx->cx_type) { + switch (CxTYPE(cx)) { case CXt_SUBST: if (PL_dowarn) warn("Exiting substitution via %s", op_name[PL_op->op_type]); @@ -968,7 +1044,7 @@ dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock) register PERL_CONTEXT *cx; for (i = startingblock; i >= 0; i--) { cx = &cxstk[i]; - switch (cx->cx_type) { + switch (CxTYPE(cx)) { default: continue; case CXt_EVAL: @@ -988,7 +1064,7 @@ dopoptoeval(I32 startingblock) register PERL_CONTEXT *cx; for (i = startingblock; i >= 0; i--) { cx = &cxstack[i]; - switch (cx->cx_type) { + switch (CxTYPE(cx)) { default: continue; case CXt_EVAL: @@ -1007,7 +1083,7 @@ dopoptoloop(I32 startingblock) register PERL_CONTEXT *cx; for (i = startingblock; i >= 0; i--) { cx = &cxstack[i]; - switch (cx->cx_type) { + switch (CxTYPE(cx)) { case CXt_SUBST: if (PL_dowarn) warn("Exiting substitution via %s", op_name[PL_op->op_type]); @@ -1043,9 +1119,9 @@ dounwind(I32 cxix) while (cxstack_ix > cxix) { cx = &cxstack[cxstack_ix]; DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", - (long) cxstack_ix, block_type[cx->cx_type])); + (long) cxstack_ix, block_type[CxTYPE(cx)])); /* Note: we don't need to restore the base context info till the end. */ - switch (cx->cx_type) { + switch (CxTYPE(cx)) { case CXt_SUBST: POPSUBST(cx); continue; /* not break */ @@ -1069,6 +1145,7 @@ OP * die_where(char *message) { dSP; + STRLEN n_a; if (PL_in_eval) { I32 cxix; register PERL_CONTEXT *cx; @@ -1100,7 +1177,7 @@ die_where(char *message) sv_setpv(ERRSV, message); } else - message = SvPVx(ERRSV, PL_na); + message = SvPVx(ERRSV, n_a); while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) { dounwind(-1); @@ -1114,7 +1191,7 @@ die_where(char *message) dounwind(cxix); POPBLOCK(cx,PL_curpm); - if (cx->cx_type != CXt_EVAL) { + if (CxTYPE(cx) != CXt_EVAL) { PerlIO_printf(PerlIO_stderr(), "panic: die %s", message); my_exit(1); } @@ -1127,12 +1204,14 @@ die_where(char *message) LEAVE; if (optype == OP_REQUIRE) { - char* msg = SvPVx(ERRSV, PL_na); + char* msg = SvPVx(ERRSV, n_a); DIE("%s", *msg ? msg : "Compilation failed in require"); } return pop_return(); } } + if(!message) + message = SvPVx(ERRSV, n_a); PerlIO_printf(PerlIO_stderr(), "%s",message); PerlIO_flush(PerlIO_stderr()); my_failure_exit(); @@ -1204,7 +1283,7 @@ PP(pp_caller) } cx = &ccstack[cxix]; - if (ccstack[cxix].cx_type == CXt_SUB) { + if (CxTYPE(cx) == CXt_SUB) { dbcxix = dopoptosub_at(ccstack, cxix - 1); /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the field below is defined for any cx. */ @@ -1233,7 +1312,7 @@ PP(pp_caller) PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line))); if (!MAXARG) RETURN; - if (cx->cx_type == CXt_SUB) { /* So is ccstack[dbcxix]. */ + if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */ sv = NEWSV(49, 0); gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch); PUSHs(sv_2mortal(sv)); @@ -1248,7 +1327,7 @@ PP(pp_caller) PUSHs(&PL_sv_undef); else PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY))); - if (cx->cx_type == CXt_EVAL) { + if (CxTYPE(cx) == CXt_EVAL) { if (cx->blk_eval.old_op_type == OP_ENTEREVAL) { PUSHs(cx->blk_eval.cur_text); PUSHs(&PL_sv_no); @@ -1259,7 +1338,7 @@ PP(pp_caller) PUSHs(&PL_sv_yes); } } - else if (cx->cx_type == CXt_SUB && + else if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs && PL_curcop->cop_stash == PL_debstash) { @@ -1310,11 +1389,12 @@ PP(pp_reset) { djSP; char *tmps; + STRLEN n_a; if (MAXARG < 1) tmps = ""; else - tmps = POPp; + tmps = POPpx; sv_reset(tmps, PL_curcop->cop_stash); PUSHs(&PL_sv_yes); RETURN; @@ -1387,8 +1467,12 @@ PP(pp_enteriter) SAVETMPS; #ifdef USE_THREADS - if (PL_op->op_flags & OPf_SPECIAL) - svp = save_threadsv(PL_op->op_targ); /* per-thread variable */ + if (PL_op->op_flags & OPf_SPECIAL) { + dTHR; + svp = &THREADSV(PL_op->op_targ); /* per-thread variable */ + SAVEGENERICSV(*svp); + *svp = NEWSV(0,0); + } else #endif /* USE_THREADS */ if (PL_op->op_targ) { @@ -1396,9 +1480,9 @@ PP(pp_enteriter) SAVESPTR(*svp); } else { - GV *gv = (GV*)POPs; - (void)save_scalar(gv); - svp = &GvSV(gv); /* symbol table variable */ + svp = &GvSV((GV*)POPs); /* symbol table variable */ + SAVEGENERICSV(*svp); + *svp = NEWSV(0,0); } ENTER; @@ -1516,7 +1600,7 @@ PP(pp_return) dounwind(cxix); POPBLOCK(cx,newpm); - switch (cx->cx_type) { + switch (CxTYPE(cx)) { case CXt_SUB: POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */ popsub2 = TRUE; @@ -1604,7 +1688,7 @@ PP(pp_last) dounwind(cxix); POPBLOCK(cx,newpm); - switch (cx->cx_type) { + switch (CxTYPE(cx)) { case CXt_LOOP: POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */ pop2 = CXt_LOOP; @@ -1770,6 +1854,7 @@ PP(pp_goto) label = 0; if (PL_op->op_flags & OPf_STACKED) { SV *sv = POPs; + STRLEN n_a; /* This egregious kludge implements goto &subroutine */ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { @@ -1779,11 +1864,23 @@ PP(pp_goto) SV** mark; I32 items = 0; I32 oldsave; + int arg_was_real = 0; + retry: if (!CvROOT(cv) && !CvXSUB(cv)) { - if (CvGV(cv)) { - SV *tmpstr = sv_newmortal(); - gv_efullname3(tmpstr, CvGV(cv), Nullch); + GV *gv = CvGV(cv); + GV *autogv; + if (gv) { + SV *tmpstr; + /* autoloaded stub? */ + if (cv != GvCV(gv) && (cv = GvCV(gv))) + goto retry; + autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), + GvNAMELEN(gv), FALSE); + if (autogv && (cv = GvCV(autogv))) + goto retry; + tmpstr = sv_newmortal(); + gv_efullname3(tmpstr, gv, Nullch); DIE("Goto undefined subroutine &%s",SvPVX(tmpstr)); } DIE("Goto undefined subroutine"); @@ -1796,10 +1893,10 @@ PP(pp_goto) if (cxix < cxstack_ix) dounwind(cxix); TOPBLOCK(cx); - if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) + if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) DIE("Can't goto subroutine from an eval-string"); mark = PL_stack_sp; - if (cx->cx_type == CXt_SUB && + if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) { /* put @_ back onto stack */ AV* av = cx->blk_sub.argarray; @@ -1812,7 +1909,10 @@ PP(pp_goto) SvREFCNT_dec(GvAV(PL_defgv)); GvAV(PL_defgv) = cx->blk_sub.savearray; #endif /* USE_THREADS */ - AvREAL_off(av); + if (AvREAL(av)) { + arg_was_real = 1; + AvREAL_off(av); /* so av_clear() won't clobber elts */ + } av_clear(av); } else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */ @@ -1829,7 +1929,7 @@ PP(pp_goto) Copy(AvARRAY(av), PL_stack_sp, items, SV*); PL_stack_sp += items; } - if (cx->cx_type == CXt_SUB && + if (CxTYPE(cx) == CXt_SUB && !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) SvREFCNT_dec(cx->blk_sub.cv); oldsave = PL_scopestack[PL_scopestack_ix - 1]; @@ -1868,7 +1968,7 @@ PP(pp_goto) else { AV* padlist = CvPADLIST(cv); SV** svp = AvARRAY(padlist); - if (cx->cx_type == CXt_EVAL) { + if (CxTYPE(cx) == CXt_EVAL) { PL_in_eval = cx->blk_eval.old_in_eval; PL_eval_root = cx->blk_eval.old_eval_root; cx->cx_type = CXt_SUB; @@ -1968,7 +2068,11 @@ PP(pp_goto) } Copy(mark,AvARRAY(av),items,SV*); AvFILLp(av) = items - 1; - + /* preserve @_ nature */ + if (arg_was_real) { + AvREIFY_off(av); + AvREAL_on(av); + } while (items--) { if (*mark) SvTEMP_off(*mark); @@ -2000,7 +2104,7 @@ PP(pp_goto) } } else - label = SvPV(sv,PL_na); + label = SvPV(sv,n_a); } else if (PL_op->op_flags & OPf_SPECIAL) { if (! do_dump) @@ -2018,7 +2122,7 @@ PP(pp_goto) *enterops = 0; for (ix = cxstack_ix; ix >= 0; ix--) { cx = &cxstack[ix]; - switch (cx->cx_type) { + switch (CxTYPE(cx)) { case CXt_EVAL: gotoprobe = PL_eval_root; /* XXX not good for nested eval */ break; @@ -2099,11 +2203,6 @@ PP(pp_goto) PL_do_undump = FALSE; } - if (PL_top_env->je_prev) { - PL_restartop = retop; - JMPENV_JUMP(3); - } - RETURNOP(retop); } @@ -2154,7 +2253,8 @@ PP(pp_cswitch) if (PL_multiline) PL_op = PL_op->op_next; /* can't assume anything */ else { - match = *(SvPVx(GvSV(cCOP->cop_gv), PL_na)) & 255; + STRLEN n_a; + match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255; match -= cCOP->uop.scop.scop_offset; if (match < 0) match = 0; @@ -2208,15 +2308,14 @@ docatch(OP *o) JMPENV_PUSH(ret); switch (ret) { default: /* topmost level handles it */ +pass_the_buck: JMPENV_POP; PL_op = oldop; JMPENV_JUMP(ret); /* NOTREACHED */ case 3: - if (!PL_restartop) { - PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); - break; - } + if (!PL_restartop) + goto pass_the_buck; PL_op = PL_restartop; PL_restartop = 0; /* FALL THROUGH */ @@ -2320,11 +2419,11 @@ doeval(int gimme, OP** startop) SAVEI32(PL_max_intro_pending); caller = PL_compcv; - for (i = cxstack_ix; i >= 0; i--) { + for (i = cxstack_ix - 1; i >= 0; i--) { PERL_CONTEXT *cx = &cxstack[i]; - if (cx->cx_type == CXt_EVAL) + if (CxTYPE(cx) == CXt_EVAL) break; - else if (cx->cx_type == CXt_SUB) { + else if (CxTYPE(cx) == CXt_SUB) { caller = cx->blk_sub.cv; break; } @@ -2333,7 +2432,7 @@ doeval(int gimme, OP** startop) SAVESPTR(PL_compcv); PL_compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)PL_compcv, SVt_PVCV); - CvUNIQUE_on(PL_compcv); + CvEVAL_on(PL_compcv); #ifdef USE_THREADS CvOWNER(PL_compcv) = 0; New(666, CvMUTEXP(PL_compcv), 1, perl_mutex); @@ -2392,6 +2491,7 @@ doeval(int gimme, OP** startop) I32 gimme; PERL_CONTEXT *cx; I32 optype = 0; /* Might be reset by POPEVAL. */ + STRLEN n_a; PL_op = saveop; if (PL_eval_root) { @@ -2407,10 +2507,10 @@ doeval(int gimme, OP** startop) lex_end(); LEAVE; if (optype == OP_REQUIRE) { - char* msg = SvPVx(ERRSV, PL_na); + char* msg = SvPVx(ERRSV, n_a); DIE("%s", *msg ? msg : "Compilation failed in require"); } else if (startop) { - char* msg = SvPVx(ERRSV, PL_na); + char* msg = SvPVx(ERRSV, n_a); POPBLOCK(cx,PL_curpm); POPEVAL(cx); @@ -2483,13 +2583,14 @@ PP(pp_require) SV** svp; I32 gimme = G_SCALAR; PerlIO *tryrsfp = 0; + STRLEN n_a; sv = POPs; if (SvNIOKp(sv) && !SvPOKp(sv)) { SET_NUMERIC_STANDARD(); if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv)) DIE("Perl %s required--this is only version %s, stopped", - SvPV(sv,PL_na),PL_patchlevel); + SvPV(sv,n_a),PL_patchlevel); RETPUSHYES; } name = SvPV(sv, len); @@ -2532,7 +2633,7 @@ PP(pp_require) { namesv = NEWSV(806, 0); for (i = 0; i <= AvFILL(ar); i++) { - char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na); + char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a); #ifdef VMS char *unixdir; if ((unixdir = tounixpath(dir, Nullch)) == Nullch) @@ -2542,6 +2643,7 @@ PP(pp_require) #else sv_setpvf(namesv, "%s/%s", dir, name); #endif + TAINT_PROPER("require"); tryname = SvPVX(namesv); tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE); if (tryrsfp) { @@ -2567,7 +2669,7 @@ PP(pp_require) sv_catpv(msg, " (did you run h2ph?)"); sv_catpv(msg, " (@INC contains:"); for (i = 0; i <= AvFILL(ar); i++) { - char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na); + char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a); sv_setpvf(dirmsgsv, " %s", dir); sv_catsv(msg, dirmsgsv); } @@ -2578,6 +2680,8 @@ PP(pp_require) RETPUSHUNDEF; } + else + SETERRNO(0, SS$_NORMAL); /* Assume success here to prevent recursive requirement. */ (void)hv_store(GvHVn(PL_incgv), name, strlen(name), @@ -2586,10 +2690,8 @@ PP(pp_require) ENTER; SAVETMPS; lex_start(sv_2mortal(newSVpv("",0))); - if (PL_rsfp_filters){ - save_aptr(&PL_rsfp_filters); - PL_rsfp_filters = NULL; - } + SAVEGENERICSV(PL_rsfp_filters); + PL_rsfp_filters = Nullav; PL_rsfp = tryrsfp; name = savepv(name); @@ -2603,6 +2705,7 @@ PP(pp_require) PUSHBLOCK(cx, CXt_EVAL, SP); PUSHEVAL(cx, name, PL_compiling.cop_filegv); + SAVEI16(PL_compiling.cop_line); PL_compiling.cop_line = 0; PUTBACK; @@ -2658,7 +2761,7 @@ PP(pp_entereval) PL_hints = PL_op->op_targ; push_return(PL_op->op_next); - PUSHBLOCK(cx, CXt_EVAL, SP); + PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); PUSHEVAL(cx, 0, PL_compiling.cop_filegv); /* prepare to compile string */ diff --git a/contrib/perl5/pp_hot.c b/contrib/perl5/pp_hot.c index e82c095..e4d398d 100644 --- a/contrib/perl5/pp_hot.c +++ b/contrib/perl5/pp_hot.c @@ -1,6 +1,6 @@ /* pp_hot.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -304,12 +304,13 @@ PP(pp_print) IO *io; register PerlIO *fp; MAGIC *mg; + STRLEN n_a; if (PL_op->op_flags & OPf_STACKED) gv = (GV*)*++MARK; else gv = PL_defoutgv; - if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) { + if (mg = SvTIED_mg((SV*)gv, 'q')) { if (MARK == ORIGMARK) { /* If using default handle then we need to make space to * pass object as 1st arg, so move other args up ... @@ -320,7 +321,7 @@ PP(pp_print) ++SP; } PUSHMARK(MARK - 1); - *MARK = mg->mg_obj; + *MARK = SvTIED_obj((SV*)gv, mg); PUTBACK; ENTER; perl_call_method("PRINT", G_SCALAR); @@ -335,7 +336,7 @@ PP(pp_print) if (PL_dowarn) { SV* sv = sv_newmortal(); gv_fullname3(sv, gv, Nullch); - warn("Filehandle %s never opened", SvPV(sv,PL_na)); + warn("Filehandle %s never opened", SvPV(sv,n_a)); } SETERRNO(EBADF,RMS$_IFI); @@ -346,9 +347,9 @@ PP(pp_print) SV* sv = sv_newmortal(); gv_fullname3(sv, gv, Nullch); if (IoIFP(io)) - warn("Filehandle %s opened only for input", SvPV(sv,PL_na)); + warn("Filehandle %s opened only for input", SvPV(sv,n_a)); else - warn("print on closed filehandle %s", SvPV(sv,PL_na)); + warn("print on closed filehandle %s", SvPV(sv,n_a)); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; @@ -425,6 +426,7 @@ PP(pp_rv2av) if (SvTYPE(sv) != SVt_PVGV) { char *sym; + STRLEN n_a; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -441,7 +443,7 @@ PP(pp_rv2av) RETURN; RETPUSHUNDEF; } - sym = SvPV(sv,PL_na); + sym = SvPV(sv,n_a); if (PL_op->op_private & HINT_STRICT_REFS) DIE(no_symref, sym, "an ARRAY"); gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV); @@ -509,6 +511,7 @@ PP(pp_rv2hv) if (SvTYPE(sv) != SVt_PVGV) { char *sym; + STRLEN n_a; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -527,7 +530,7 @@ PP(pp_rv2hv) } RETSETUNDEF; } - sym = SvPV(sv,PL_na); + sym = SvPV(sv,n_a); if (PL_op->op_private & HINT_STRICT_REFS) DIE(no_symref, sym, "a HASH"); gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV); @@ -859,9 +862,9 @@ PP(pp_match) } } } - safebase = (((gimme == G_ARRAY) || global || !rx->nparens) - && !PL_sawampersand); - safebase = safebase ? 0 : REXEC_COPY_STR ; + safebase = ((gimme != G_ARRAY && !global && rx->nparens) + || SvTEMP(TARG) || PL_sawampersand) + ? REXEC_COPY_STR : 0; if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { SAVEINT(PL_multiline); PL_multiline = pm->op_pmflags & PMf_MULTILINE; @@ -1048,9 +1051,9 @@ do_readline(void) I32 gimme = GIMME_V; MAGIC *mg; - if (SvRMAGICAL(PL_last_in_gv) && (mg = mg_find((SV*)PL_last_in_gv, 'q'))) { + if (mg = SvTIED_mg((SV*)PL_last_in_gv, 'q')) { PUSHMARK(SP); - XPUSHs(mg->mg_obj); + XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg)); PUTBACK; ENTER; perl_call_method("READLINE", gimme); @@ -1239,8 +1242,18 @@ do_readline(void) sv = sv_2mortal(NEWSV(57, 80)); offset = 0; } + +/* flip-flop 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)) + for (;;) { - if (!sv_gets(sv, fp, offset)) { + if (!sv_gets(sv, fp, offset) + && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv))) + { PerlIO_clearerr(fp); if (IoFLAGS(io) & IOf_ARGV) { fp = nextargv(PL_last_in_gv); @@ -1250,8 +1263,11 @@ do_readline(void) IoFLAGS(io) |= IOf_START; } else if (type == OP_GLOB) { - if (!do_close(PL_last_in_gv, FALSE)) - warn("internal error: glob failed"); + if (!do_close(PL_last_in_gv, FALSE)) { + warn("glob failed (child exited with status %d%s)", + STATUS_CURRENT >> 8, + (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); + } } if (gimme == G_SCALAR) { (void)SvOK_off(TARG); @@ -1354,8 +1370,10 @@ PP(pp_helem) if (!svp || *svp == &PL_sv_undef) { SV* lv; SV* key2; - if (!defer) - DIE(no_helem, SvPV(keysv, PL_na)); + if (!defer) { + STRLEN n_a; + DIE(no_helem, SvPV(keysv, n_a)); + } lv = sv_newmortal(); sv_upgrade(lv, SVt_PVLV); LvTYPE(lv) = 'y'; @@ -1453,7 +1471,7 @@ PP(pp_iter) EXTEND(SP, 1); cx = &cxstack[cxstack_ix]; - if (cx->cx_type != CXt_LOOP) + if (CxTYPE(cx) != CXt_LOOP) DIE("panic: pp_iter"); av = cx->blk_loop.iterary; @@ -1614,7 +1632,8 @@ PP(pp_subst) && SvTYPE(rx->check_substr) == SVt_PVBM && SvVALID(rx->check_substr)) ? TARG : Nullsv); - safebase = (!rx->nparens && !PL_sawampersand) ? 0 : REXEC_COPY_STR; + safebase = (rx->nparens || SvTEMP(TARG) || PL_sawampersand) + ? REXEC_COPY_STR : 0; if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { SAVEINT(PL_multiline); PL_multiline = pm->op_pmflags & PMf_MULTILINE; @@ -1980,6 +1999,7 @@ PP(pp_entersub) default: if (!SvROK(sv)) { char *sym; + STRLEN n_a; if (sv == &PL_sv_yes) { /* unfound import, ignore */ if (hasargs) @@ -1991,7 +2011,7 @@ PP(pp_entersub) sym = SvPOKp(sv) ? SvPVX(sv) : Nullch; } else - sym = SvPV(sv, PL_na); + sym = SvPV(sv, n_a); if (!sym) DIE(no_usym, "a subroutine"); if (PL_op->op_private & HINT_STRICT_REFS) @@ -2094,7 +2114,6 @@ PP(pp_entersub) DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n", thr, sv);) MUTEX_UNLOCK(MgMUTEXP(mg)); - SvREFCNT_inc(sv); /* Keep alive until magic_mutexfree */ save_destructor(unlock_condpair, sv); } MUTEX_LOCK(CvMUTEXP(cv)); @@ -2129,8 +2148,7 @@ PP(pp_entersub) * (3) instead of (2) so we'd have to clone. Would the fact * that we released the mutex more quickly make up for this? */ - if (PL_threadnum && - (svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE))) + if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE))) { /* We already have a clone to use */ MUTEX_UNLOCK(CvMUTEXP(cv)); @@ -2257,12 +2275,14 @@ PP(pp_entersub) PUSHBLOCK(cx, CXt_SUB, MARK); PUSHSUB(cx); CvDEPTH(cv)++; + /* XXX This would be a natural place to set C<PL_compcv = cv> so + * that eval'' ops within this sub know the correct lexical space. + * Owing the speed considerations, we choose to search for the cv + * in doeval() instead. + */ if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ - if (CvDEPTH(cv) == 100 && PL_dowarn - && !(PERLDB_SUB && cv == GvCV(PL_DBsub))) - sub_crush_depth(cv); if (CvDEPTH(cv) > AvFILLp(padlist)) { AV *av; AV *newpad = newAV(); @@ -2362,6 +2382,13 @@ PP(pp_entersub) MARK++; } } + /* warning must come *after* we fully set up the context + * stuff so that __WARN__ handlers can safely dounwind() + * if they want to + */ + if (CvDEPTH(cv) == 100 && PL_dowarn + && !(PERLDB_SUB && cv == GvCV(PL_DBsub))) + sub_crush_depth(cv); #if 0 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p entersub returning %p\n", thr, CvSTART(cv))); @@ -2474,7 +2501,7 @@ PP(pp_method) } } - name = SvPV(TOPs, PL_na); + name = SvPV(TOPs, packlen); sv = *(PL_stack_base + TOPMARK + 1); if (SvGMAGICAL(sv)) diff --git a/contrib/perl5/pp_sys.c b/contrib/perl5/pp_sys.c index 2630e05..1f3b119 100644 --- a/contrib/perl5/pp_sys.c +++ b/contrib/perl5/pp_sys.c @@ -1,6 +1,6 @@ /* pp_sys.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -56,7 +56,10 @@ extern "C" int syscall(unsigned long,...); /* XXX Configure test needed. h_errno might not be a simple 'int', especially for multi-threaded - applications. HOST_NOT_FOUND is typically defined in <netdb.h>. + applications, see "extern int errno in perl.h". Creating such + a test requires taking into account the differences between + compiling multithreaded and singlethreaded ($ccflags et al). + HOST_NOT_FOUND is typically defined in <netdb.h>. */ #if defined(HOST_NOT_FOUND) && !defined(h_errno) extern int h_errno; @@ -187,7 +190,8 @@ PP(pp_backtick) { djSP; dTARGET; PerlIO *fp; - char *tmps = POPp; + STRLEN n_a; + char *tmps = POPpx; I32 gimme = GIMME_V; TAINT_PROPER("``"); @@ -271,7 +275,8 @@ PP(pp_glob) #if 0 /* XXX never used! */ PP(pp_indread) { - PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), PL_na), TRUE,SVt_PVIO); + STRLEN n_a; + PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), n_a), TRUE,SVt_PVIO); return do_readline(); } #endif @@ -286,21 +291,22 @@ PP(pp_warn) { djSP; dMARK; char *tmps; + STRLEN n_a; if (SP - MARK != 1) { dTARGET; do_join(TARG, &PL_sv_no, MARK, SP); - tmps = SvPV(TARG, PL_na); + tmps = SvPV(TARG, n_a); SP = MARK + 1; } else { - tmps = SvPV(TOPs, PL_na); + tmps = SvPV(TOPs, n_a); } if (!tmps || !*tmps) { SV *error = ERRSV; (void)SvUPGRADE(error, SVt_PV); if (SvPOK(error) && SvCUR(error)) sv_catpv(error, "\t...caught"); - tmps = SvPV(error, PL_na); + tmps = SvPV(error, n_a); } if (!tmps || !*tmps) tmps = "Warning: something's wrong"; @@ -314,15 +320,16 @@ PP(pp_die) char *tmps; SV *tmpsv = Nullsv; char *pat = "%s"; + STRLEN n_a; if (SP - MARK != 1) { dTARGET; do_join(TARG, &PL_sv_no, MARK, SP); - tmps = SvPV(TARG, PL_na); + tmps = SvPV(TARG, n_a); SP = MARK + 1; } else { tmpsv = TOPs; - tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, PL_na); + tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, n_a); } if (!tmps || !*tmps) { SV *error = ERRSV; @@ -352,7 +359,7 @@ PP(pp_die) else { if (SvPOK(error) && SvCUR(error)) sv_catpv(error, "\t...propagated"); - tmps = SvPV(error, PL_na); + tmps = SvPV(error, n_a); } } if (!tmps || !*tmps) @@ -402,9 +409,9 @@ PP(pp_close) else gv = (GV*)POPs; - if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) { + if (mg = SvTIED_mg((SV*)gv, 'q')) { PUSHMARK(SP); - XPUSHs(mg->mg_obj); + XPUSHs(SvTIED_obj((SV*)gv, mg)); PUTBACK; ENTER; perl_call_method("CLOSE", G_SCALAR); @@ -459,7 +466,10 @@ PP(pp_pipe_op) else PerlLIO_close(fd[1]); goto badexit; } - +#if defined(HAS_FCNTL) && defined(F_SETFD) + fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */ + fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */ +#endif RETPUSHYES; badexit: @@ -579,8 +589,9 @@ PP(pp_tie) */ stash = gv_stashsv(*MARK, FALSE); if (!stash || !(gv = gv_fetchmethod(stash, methname))) { + STRLEN n_a; DIE("Can't locate object method \"%s\" via package \"%s\"", - methname, SvPV(*MARK,PL_na)); + methname, SvPV(*MARK,n_a)); } ENTER; PUSHSTACKi(PERLSI_MAGIC); @@ -596,8 +607,8 @@ PP(pp_tie) sv = TOPs; POPSTACK; if (sv_isobject(sv)) { - sv_unmagic(varsv, how); - sv_magic(varsv, sv, how, Nullch, 0); + sv_unmagic(varsv, how); + sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0); } LEAVE; SP = PL_stack_base + markoff; @@ -608,48 +619,35 @@ PP(pp_tie) PP(pp_untie) { djSP; - SV * sv ; - - sv = POPs; + SV *sv = POPs; + char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q'; if (PL_dowarn) { - MAGIC * mg ; - if (SvMAGICAL(sv)) { - if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) - mg = mg_find(sv, 'P') ; - else - mg = mg_find(sv, 'q') ; - - if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1) + MAGIC *mg; + if (mg = SvTIED_mg(sv, how)) { + if (mg->mg_obj && SvREFCNT(SvRV(mg->mg_obj)) > 1) warn("untie attempted while %lu inner references still exist", (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ; } } - if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) - sv_unmagic(sv, 'P'); - else - sv_unmagic(sv, 'q'); + sv_unmagic(sv, how); RETPUSHYES; } PP(pp_tied) { djSP; - SV * sv ; - MAGIC * mg ; + SV *sv = POPs; + char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q'; + MAGIC *mg; - sv = POPs; - if (SvMAGICAL(sv)) { - if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) - mg = mg_find(sv, 'P') ; - else - mg = mg_find(sv, 'q') ; - - if (mg) { - PUSHs(sv_2mortal(newSVsv(mg->mg_obj))) ; - RETURN ; - } + if (mg = SvTIED_mg(sv, how)) { + SV *osv = SvTIED_obj(sv, mg); + if (osv == mg->mg_obj) + osv = sv_mortalcopy(osv); + PUSHs(osv); + RETURN; } RETPUSHUNDEF; } @@ -731,6 +729,7 @@ PP(pp_sselect) struct timeval *tbuf = &timebuf; I32 growsize; char *fd_sets[4]; + STRLEN n_a; #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 I32 masksize; I32 offset; @@ -753,12 +752,17 @@ PP(pp_sselect) maxlen = j; } +/* little endians can use vecs directly */ #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 -/* XXX Configure test needed. */ -#if defined(__linux__) || defined(OS2) || defined(NeXT) || defined(__osf__) || defined(sun) - growsize = sizeof(fd_set); +# if SELECT_MIN_BITS > 1 + /* If SELECT_MIN_BITS is greater than one we most probably will want + * to align the sizes with SELECT_MIN_BITS/8 because for example + * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital + * UNIX, Solaris, NeXT) the smallest quantum select() operates on + * (sets bit) is 32 bits. */ + growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8))); #else - growsize = maxlen; /* little endians can use vecs directly */ + growsize = sizeof(fd_set); #endif #else #ifdef NFDBITS @@ -794,7 +798,7 @@ PP(pp_sselect) continue; } else if (!SvPOK(sv)) - SvPV_force(sv,PL_na); /* force string conversion */ + SvPV_force(sv,n_a); /* force string conversion */ j = SvLEN(sv); if (j < growsize) { Sv_Grow(sv, growsize); @@ -909,10 +913,10 @@ PP(pp_getc) if (!gv) gv = PL_argvgv; - if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) { + if (mg = SvTIED_mg((SV*)gv, 'q')) { I32 gimme = GIMME_V; PUSHMARK(SP); - XPUSHs(mg->mg_obj); + XPUSHs(SvTIED_obj((SV*)gv, mg)); PUTBACK; ENTER; perl_call_method("GETC", gimme); @@ -1121,13 +1125,14 @@ PP(pp_prtf) PerlIO *fp; SV *sv; MAGIC *mg; + STRLEN n_a; if (PL_op->op_flags & OPf_STACKED) gv = (GV*)*++MARK; else gv = PL_defoutgv; - if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) { + if (mg = SvTIED_mg((SV*)gv, 'q')) { if (MARK == ORIGMARK) { MEXTEND(SP, 1); ++MARK; @@ -1135,7 +1140,7 @@ PP(pp_prtf) ++SP; } PUSHMARK(MARK - 1); - *MARK = mg->mg_obj; + *MARK = SvTIED_obj((SV*)gv, mg); PUTBACK; ENTER; perl_call_method("PRINTF", G_SCALAR); @@ -1151,7 +1156,7 @@ PP(pp_prtf) if (!(io = GvIO(gv))) { if (PL_dowarn) { gv_fullname3(sv, gv, Nullch); - warn("Filehandle %s never opened", SvPV(sv,PL_na)); + warn("Filehandle %s never opened", SvPV(sv,n_a)); } SETERRNO(EBADF,RMS$_IFI); goto just_say_no; @@ -1160,9 +1165,9 @@ PP(pp_prtf) if (PL_dowarn) { gv_fullname3(sv, gv, Nullch); if (IoIFP(io)) - warn("Filehandle %s opened only for input", SvPV(sv,PL_na)); + warn("Filehandle %s opened only for input", SvPV(sv,n_a)); else - warn("printf on closed filehandle %s", SvPV(sv,PL_na)); + warn("printf on closed filehandle %s", SvPV(sv,n_a)); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; @@ -1237,12 +1242,12 @@ PP(pp_sysread) gv = (GV*)*++MARK; if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) && - SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) + (mg = SvTIED_mg((SV*)gv, 'q'))) { SV *sv; PUSHMARK(MARK-1); - *MARK = mg->mg_obj; + *MARK = SvTIED_obj((SV*)gv, mg); ENTER; perl_call_method("READ", G_SCALAR); LEAVE; @@ -1311,7 +1316,17 @@ PP(pp_sysread) Zero(buffer+bufsize, offset-bufsize, char); } if (PL_op->op_type == OP_SYSREAD) { - length = PerlLIO_read(PerlIO_fileno(IoIFP(io)), buffer+offset, length); +#ifdef PERL_SOCK_SYSREAD_IS_RECV + if (IoTYPE(io) == 's') { + length = PerlSock_recv(PerlIO_fileno(IoIFP(io)), + buffer+offset, length, 0); + } + else +#endif + { + length = PerlLIO_read(PerlIO_fileno(IoIFP(io)), + buffer+offset, length); + } } else #ifdef HAS_SOCKET__bad_code_maybe @@ -1353,6 +1368,15 @@ PP(pp_sysread) PP(pp_syswrite) { + djSP; + int items = (SP - PL_stack_base) - TOPMARK; + if (items == 2) { + SV *sv; + EXTEND(SP, 1); + sv = sv_2mortal(newSViv(sv_len(*SP))); + PUSHs(sv); + PUTBACK; + } return pp_send(ARGS); } @@ -1369,13 +1393,11 @@ PP(pp_send) MAGIC *mg; gv = (GV*)*++MARK; - if (PL_op->op_type == OP_SYSWRITE && - SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) - { + if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) { SV *sv; PUSHMARK(MARK-1); - *MARK = mg->mg_obj; + *MARK = SvTIED_obj((SV*)gv, mg); ENTER; perl_call_method("WRITE", G_SCALAR); LEAVE; @@ -1416,7 +1438,17 @@ PP(pp_send) offset = 0; if (length > blen - offset) length = blen - offset; - length = PerlLIO_write(PerlIO_fileno(IoIFP(io)), buffer+offset, length); +#ifdef PERL_SOCK_SYSWRITE_IS_SEND + if (IoTYPE(io) == 's') { + length = PerlSock_send(PerlIO_fileno(IoIFP(io)), + buffer+offset, length, 0); + } + else +#endif + { + length = PerlLIO_write(PerlIO_fileno(IoIFP(io)), + buffer+offset, length); + } } #ifdef HAS_SOCKET else if (SP > MARK) { @@ -1505,11 +1537,12 @@ PP(pp_truncate) Off_t len = (Off_t)POPn; int result = 1; GV *tmpgv; + STRLEN n_a; SETERRNO(0,0); #if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP) if (PL_op->op_flags & OPf_SPECIAL) { - tmpgv = gv_fetchpv(POPp, FALSE, SVt_PVIO); + tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO); do_ftruncate: TAINT_PROPER("truncate"); if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) || @@ -1533,7 +1566,7 @@ PP(pp_truncate) goto do_ftruncate; } - name = SvPV(sv, PL_na); + name = SvPV(sv, n_a); TAINT_PROPER("truncate"); #ifdef HAS_TRUNCATE if (truncate(name, len) < 0) @@ -2011,8 +2044,9 @@ PP(pp_ssockopt) char *buf; int aint; if (SvPOKp(sv)) { - buf = SvPV(sv, PL_na); - len = PL_na; + STRLEN l; + buf = SvPV(sv, l); + len = l; } else { aint = (int)SvIV(sv); @@ -2125,6 +2159,7 @@ PP(pp_stat) GV *tmpgv; I32 gimme; I32 max = 13; + STRLEN n_a; if (PL_op->op_flags & OPf_REF) { tmpgv = cGVOP->op_gv; @@ -2149,17 +2184,17 @@ PP(pp_stat) tmpgv = (GV*)SvRV(sv); goto do_fstat; } - sv_setpv(PL_statname, SvPV(sv,PL_na)); + sv_setpv(PL_statname, SvPV(sv,n_a)); PL_statgv = Nullgv; #ifdef HAS_LSTAT PL_laststype = PL_op->op_type; if (PL_op->op_type == OP_LSTAT) - PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, PL_na), &PL_statcache); + PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache); else #endif - PL_laststatval = PerlLIO_stat(SvPV(PL_statname, PL_na), &PL_statcache); + PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache); if (PL_laststatval < 0) { - if (PL_dowarn && strchr(SvPV(PL_statname, PL_na), '\n')) + if (PL_dowarn && strchr(SvPV(PL_statname, n_a), '\n')) warn(warn_nl, "stat"); max = 0; } @@ -2473,6 +2508,7 @@ PP(pp_fttty) int fd; GV *gv; char *tmps = Nullch; + STRLEN n_a; if (PL_op->op_flags & OPf_REF) gv = cGVOP->op_gv; @@ -2481,7 +2517,7 @@ PP(pp_fttty) else if (SvROK(TOPs) && isGV(SvRV(TOPs))) gv = (GV*)SvRV(POPs); else - gv = gv_fetchpv(tmps = POPp, FALSE, SVt_PVIO); + gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO); if (GvIO(gv) && IoIFP(GvIOp(gv))) fd = PerlIO_fileno(IoIFP(GvIOp(gv))); @@ -2513,6 +2549,7 @@ PP(pp_fttext) register IO *io; register SV *sv; GV *gv; + STRLEN n_a; if (PL_op->op_flags & OPf_REF) gv = cGVOP->op_gv; @@ -2576,14 +2613,14 @@ PP(pp_fttext) really_filename: PL_statgv = Nullgv; PL_laststatval = -1; - sv_setpv(PL_statname, SvPV(sv, PL_na)); + sv_setpv(PL_statname, SvPV(sv, n_a)); #ifdef HAS_OPEN3 - i = PerlLIO_open3(SvPV(sv, PL_na), O_RDONLY, 0); + i = PerlLIO_open3(SvPV(sv, n_a), O_RDONLY, 0); #else - i = PerlLIO_open(SvPV(sv, PL_na), 0); + i = PerlLIO_open(SvPV(sv, n_a), 0); #endif if (i < 0) { - if (PL_dowarn && strchr(SvPV(sv, PL_na), '\n')) + if (PL_dowarn && strchr(SvPV(sv, n_a), '\n')) warn(warn_nl, "open"); RETPUSHUNDEF; } @@ -2639,26 +2676,27 @@ PP(pp_chdir) djSP; dTARGET; char *tmps; SV **svp; + STRLEN n_a; if (MAXARG < 1) tmps = Nullch; else - tmps = POPp; + tmps = POPpx; if (!tmps || !*tmps) { svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE); if (svp) - tmps = SvPV(*svp, PL_na); + tmps = SvPV(*svp, n_a); } if (!tmps || !*tmps) { svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE); if (svp) - tmps = SvPV(*svp, PL_na); + tmps = SvPV(*svp, n_a); } #ifdef VMS if (!tmps || !*tmps) { svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE); if (svp) - tmps = SvPV(*svp, PL_na); + tmps = SvPV(*svp, n_a); } #endif TAINT_PROPER("chdir"); @@ -2689,8 +2727,9 @@ PP(pp_chroot) { djSP; dTARGET; char *tmps; + STRLEN n_a; #ifdef HAS_CHROOT - tmps = POPp; + tmps = POPpx; TAINT_PROPER("chroot"); PUSHi( chroot(tmps) >= 0 ); RETURN; @@ -2733,9 +2772,10 @@ PP(pp_rename) { djSP; dTARGET; int anum; + STRLEN n_a; - char *tmps2 = POPp; - char *tmps = SvPV(TOPs, PL_na); + char *tmps2 = POPpx; + char *tmps = SvPV(TOPs, n_a); TAINT_PROPER("rename"); #ifdef HAS_RENAME anum = PerlLIO_rename(tmps, tmps2); @@ -2759,8 +2799,9 @@ PP(pp_link) { djSP; dTARGET; #ifdef HAS_LINK - char *tmps2 = POPp; - char *tmps = SvPV(TOPs, PL_na); + STRLEN n_a; + char *tmps2 = POPpx; + char *tmps = SvPV(TOPs, n_a); TAINT_PROPER("link"); SETi( link(tmps, tmps2) >= 0 ); #else @@ -2773,8 +2814,9 @@ PP(pp_symlink) { djSP; dTARGET; #ifdef HAS_SYMLINK - char *tmps2 = POPp; - char *tmps = SvPV(TOPs, PL_na); + STRLEN n_a; + char *tmps2 = POPpx; + char *tmps = SvPV(TOPs, n_a); TAINT_PROPER("symlink"); SETi( symlink(tmps, tmps2) >= 0 ); RETURN; @@ -2790,11 +2832,12 @@ PP(pp_readlink) char *tmps; char buf[MAXPATHLEN]; int len; + STRLEN n_a; #ifndef INCOMPLETE_TAINTS TAINT; #endif - tmps = POPp; + tmps = POPpx; len = readlink(tmps, buf, sizeof buf); EXTEND(SP, 1); if (len < 0) @@ -2903,7 +2946,8 @@ PP(pp_mkdir) #ifndef HAS_MKDIR int oldumask; #endif - char *tmps = SvPV(TOPs, PL_na); + STRLEN n_a; + char *tmps = SvPV(TOPs, n_a); TAINT_PROPER("mkdir"); #ifdef HAS_MKDIR @@ -2921,8 +2965,9 @@ PP(pp_rmdir) { djSP; dTARGET; char *tmps; + STRLEN n_a; - tmps = POPp; + tmps = POPpx; TAINT_PROPER("rmdir"); #ifdef HAS_RMDIR XPUSHi( PerlDir_rmdir(tmps) >= 0 ); @@ -2938,7 +2983,8 @@ PP(pp_open_dir) { djSP; #if defined(Direntry_t) && defined(HAS_READDIR) - char *dirname = POPp; + STRLEN n_a; + char *dirname = POPpx; GV *gv = (GV*)POPs; register IO *io = GvIOn(gv); @@ -3183,10 +3229,11 @@ PP(pp_system) int result; int status; Sigsave_t ihand,qhand; /* place to save signals during system() */ + STRLEN n_a; if (SP - MARK == 1) { if (PL_tainting) { - char *junk = SvPV(TOPs, PL_na); + char *junk = SvPV(TOPs, n_a); TAINT_ENV(); TAINT_PROPER("system"); } @@ -3222,7 +3269,7 @@ PP(pp_system) else if (SP - MARK != 1) value = (I32)do_aexec(Nullsv, MARK, SP); else { - value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), PL_na)); + value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a)); } PerlProc__exit(-1); #else /* ! FORK or VMS or OS/2 */ @@ -3233,7 +3280,7 @@ PP(pp_system) else if (SP - MARK != 1) value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP); else { - value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), PL_na)); + value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a)); } STATUS_NATIVE_SET(value); do_execfree(); @@ -3247,6 +3294,7 @@ PP(pp_exec) { djSP; dMARK; dORIGMARK; dTARGET; I32 value; + STRLEN n_a; if (PL_op->op_flags & OPf_STACKED) { SV *really = *++MARK; @@ -3260,14 +3308,14 @@ PP(pp_exec) #endif else { if (PL_tainting) { - char *junk = SvPV(*SP, PL_na); + char *junk = SvPV(*SP, n_a); TAINT_ENV(); TAINT_PROPER("exec"); } #ifdef VMS - value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), PL_na)); + value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a)); #else - value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), PL_na)); + value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a)); #endif } SP = ORIGMARK; @@ -3692,12 +3740,14 @@ PP(pp_ghostent) unsigned long len; EXTEND(SP, 10); - if (which == OP_GHBYNAME) + if (which == OP_GHBYNAME) { #ifdef HAS_GETHOSTBYNAME - hent = PerlSock_gethostbyname(POPp); + STRLEN n_a; + hent = PerlSock_gethostbyname(POPpx); #else DIE(no_sock_func, "gethostbyname"); #endif + } else if (which == OP_GHBYADDR) { #ifdef HAS_GETHOSTBYADDR int addrtype = POPi; @@ -3798,12 +3848,14 @@ PP(pp_gnetent) #endif struct netent *nent; - if (which == OP_GNBYNAME) + if (which == OP_GNBYNAME) { #ifdef HAS_GETNETBYNAME - nent = PerlSock_getnetbyname(POPp); + STRLEN n_a; + nent = PerlSock_getnetbyname(POPpx); #else DIE(no_sock_func, "getnetbyname"); #endif + } else if (which == OP_GNBYADDR) { #ifdef HAS_GETNETBYADDR int addrtype = POPi; @@ -3885,12 +3937,14 @@ PP(pp_gprotoent) #endif struct protoent *pent; - if (which == OP_GPBYNAME) + if (which == OP_GPBYNAME) { #ifdef HAS_GETPROTOBYNAME - pent = PerlSock_getprotobyname(POPp); + STRLEN n_a; + pent = PerlSock_getprotobyname(POPpx); #else DIE(no_sock_func, "getprotobyname"); #endif + } else if (which == OP_GPBYNUMBER) #ifdef HAS_GETPROTOBYNUMBER pent = PerlSock_getprotobynumber(POPi); @@ -3969,8 +4023,9 @@ PP(pp_gservent) if (which == OP_GSBYNAME) { #ifdef HAS_GETSERVBYNAME - char *proto = POPp; - char *name = POPp; + STRLEN n_a; + char *proto = POPpx; + char *name = POPpx; if (proto && !*proto) proto = Nullch; @@ -3982,7 +4037,8 @@ PP(pp_gservent) } else if (which == OP_GSBYPORT) { #ifdef HAS_GETSERVBYPORT - char *proto = POPp; + STRLEN n_a; + char *proto = POPpx; unsigned short port = POPu; #ifdef HAS_HTONS @@ -4159,9 +4215,10 @@ PP(pp_gpwent) I32 which = PL_op->op_type; register SV *sv; struct passwd *pwent; + STRLEN n_a; if (which == OP_GPWNAM) - pwent = getpwnam(POPp); + pwent = getpwnam(POPpx); else if (which == OP_GPWUID) pwent = getpwuid(POPi); else @@ -4292,9 +4349,10 @@ PP(pp_ggrent) register char **elem; register SV *sv; struct group *grent; + STRLEN n_a; if (which == OP_GGRNAM) - grent = (struct group *)getgrnam(POPp); + grent = (struct group *)getgrnam(POPpx); else if (which == OP_GGRGID) grent = (struct group *)getgrgid(POPi); else @@ -4407,8 +4465,10 @@ PP(pp_syscall) a[i++] = SvIV(*MARK); else if (*MARK == &PL_sv_undef) a[i++] = 0; - else - a[i++] = (unsigned long)SvPV_force(*MARK, PL_na); + else { + STRLEN n_a; + a[i++] = (unsigned long)SvPV_force(*MARK, n_a); + } if (i > 15) break; } diff --git a/contrib/perl5/proto.h b/contrib/perl5/proto.h index 1b98675..62fb9f6 100644 --- a/contrib/perl5/proto.h +++ b/contrib/perl5/proto.h @@ -645,7 +645,7 @@ VIRTUAL struct perl_vars *Perl_GetVars _((void)); protected: void hsplit _((HV *hv)); void hfreeentries _((HV *hv)); -HE* more_he _((void)); +void more_he _((void)); HE* new_he _((void)); void del_he _((HE *p)); HEK *save_hek _((char *str, I32 len, U32 hash)); @@ -655,10 +655,10 @@ SV *save_scalar_at _((SV **sptr)); IV asIV _((SV* sv)); UV asUV _((SV* sv)); SV *more_sv _((void)); -XPVIV *more_xiv _((void)); -XPVNV *more_xnv _((void)); -XPV *more_xpv _((void)); -XRV *more_xrv _((void)); +void more_xiv _((void)); +void more_xnv _((void)); +void more_xpv _((void)); +void more_xrv _((void)); XPVIV *new_xiv _((void)); XPVNV *new_xnv _((void)); XPV *new_xpv _((void)); @@ -687,7 +687,7 @@ void qsortsv _((SV ** array, size_t num_elts, SVCOMPARE f)); I32 sortcv _((SV *a, SV *b)); void save_magic _((MGS *mgs, SV *sv)); int magic_methpack _((SV *sv, MAGIC *mg, char *meth)); -int magic_methcall _((MAGIC *mg, char *meth, I32 flags, int n, SV *val)); +int magic_methcall _((SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val)); OP * doform _((CV *cv, GV *gv, OP *retop)); void doencodes _((SV* sv, char* s, I32 len)); SV* refto _((SV* sv)); @@ -758,7 +758,7 @@ OP *scalarboolean _((OP *o)); OP *too_few_arguments _((OP *o, char* name)); OP *too_many_arguments _((OP *o, char* name)); void null _((OP* o)); -PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)); +PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval, U32 flags)); OP *newDEFSVOP _((void)); char* gv_ename _((GV *gv)); CV *cv_clone2 _((CV *proto, CV *outside)); @@ -822,6 +822,8 @@ void debprof _((OP *o)); void *bset_obj_store _((void *obj, I32 ix)); OP *new_logop _((I32 type, I32 flags, OP **firstp, OP **otherp)); +I32 amagic_cmp _((register SV *str1, register SV *str2)); +I32 amagic_cmp_locale _((register SV *str1, register SV *str2)); #define PPDEF(s) OP* CPerlObj::s _((ARGSproto)); public: @@ -866,6 +868,7 @@ void restore_rsfp _((void *f)); void restore_expect _((void *e)); void restore_lex_expect _((void *e)); void yydestruct _((void *ptr)); + VIRTUAL int fprintf _((PerlIO *pf, const char *pat, ...)); VIRTUAL SV** get_specialsv_list _((void)); @@ -896,6 +899,10 @@ VIRTUAL void sv_setpvn_mg _((SV *sv, const char *ptr, STRLEN len)); VIRTUAL void sv_setsv_mg _((SV *dstr, SV *sstr)); VIRTUAL void sv_usepvn_mg _((SV *sv, char *ptr, STRLEN len)); +VIRTUAL MGVTBL* get_vtbl _((int vtbl_id)); +VIRTUAL OP* dofile _((OP* term)); +VIRTUAL void save_generic_svref _((SV** sptr)); + /* New virtual functions must be added here to maintain binary * compatablity with PERL_OBJECT */ diff --git a/contrib/perl5/regcomp.c b/contrib/perl5/regcomp.c index f2f51a4..6ddecf9 100644 --- a/contrib/perl5/regcomp.c +++ b/contrib/perl5/regcomp.c @@ -64,7 +64,7 @@ * **** Alterations to Henry's code are... **** - **** Copyright (c) 1991-1997, Larry Wall + **** Copyright (c) 1991-1999, Larry Wall **** **** You may distribute under the terms of either the GNU General Public **** License or the Artistic License, as specified in the README file. @@ -239,6 +239,7 @@ study_chunk(regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 regnode *scan = *scanp, *next; I32 delta = 0; int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF); + int is_inf_internal = 0; /* The studied chunk is infinite */ I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0; scan_data_t data_fake; @@ -352,7 +353,7 @@ study_chunk(regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 if (max1 < minnext + deltanext) max1 = minnext + deltanext; if (deltanext == I32_MAX) - is_inf = 1; + is_inf = is_inf_internal = 1; scan = next; if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR)) pars++; @@ -423,7 +424,7 @@ study_chunk(regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 min++; /* Fall through. */ case STAR: - is_inf = 1; + is_inf = is_inf_internal = 1; scan = regnext(scan); if (flags & SCF_DO_SUBSTR) { scan_commit(data); @@ -457,8 +458,10 @@ study_chunk(regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 && maxcount <= 10000) /* Complement check for big count */ warn("Strange *+?{} on zero-length expression"); min += minnext * mincount; - is_inf |= (maxcount == REG_INFTY && (minnext + deltanext) > 0 - || deltanext == I32_MAX); + is_inf_internal |= (maxcount == REG_INFTY + && (minnext + deltanext) > 0 + || deltanext == I32_MAX); + is_inf |= is_inf_internal; delta += (minnext + deltanext) * maxcount - minnext * mincount; /* Try powerful optimization CURLYX => CURLYN. */ @@ -594,6 +597,7 @@ study_chunk(regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 } data->longest = &(data->longest_float); } + SvREFCNT_dec(last_str); } if (data && (fl & SF_HAS_EVAL)) data->flags |= SF_HAS_EVAL; @@ -609,7 +613,7 @@ study_chunk(regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 scan_commit(data); data->longest = &(data->longest_float); } - is_inf = 1; + is_inf = is_inf_internal = 1; break; } } else if (strchr(simple,OP(scan))) { @@ -661,7 +665,7 @@ study_chunk(regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 finish: *scanp = scan; - *deltap = is_inf ? I32_MAX : delta; + *deltap = is_inf_internal ? I32_MAX : delta; if (flags & SCF_DO_SUBSTR && is_inf) data->pos_delta = I32_MAX - data->pos_min; if (is_par > U8_MAX) @@ -911,8 +915,9 @@ pregcomp(char *exp, char *xend, PMOP *pm) && (!(data.flags & SF_FL_BEFORE_MEOL) || (PL_regflags & PMf_MULTILINE)))) { if (SvCUR(data.longest_fixed) - && data.offset_fixed == data.offset_float_min) - goto remove; /* Like in (a)+. */ + && data.offset_fixed == data.offset_float_min + && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)) + goto remove_float; /* Like in (a)+. */ r->float_substr = data.longest_float; r->float_min_offset = data.offset_float_min; @@ -924,7 +929,7 @@ pregcomp(char *exp, char *xend, PMOP *pm) || (PL_regflags & PMf_MULTILINE))) SvTAIL_on(r->float_substr); } else { - remove: + remove_float: r->float_substr = Nullsv; SvREFCNT_dec(data.longest_float); longest_float_length = 0; @@ -1119,10 +1124,14 @@ reg(I32 paren, I32 *flagp) else regtail(br, reganode(LONGJMP, 0)); c = *nextchar(); + if (flags&HASWIDTH) + *flagp |= HASWIDTH; if (c == '|') { lastbr = reganode(IFTHEN, 0); /* Fake one for optimizer. */ regbranch(&flags, 1); regtail(ret, lastbr); + if (flags&HASWIDTH) + *flagp |= HASWIDTH; c = *nextchar(); } else lastbr = NULL; @@ -2035,8 +2044,24 @@ regclass(void) } } if (!SIZE_ONLY) { - for ( ; lastclass <= Class; lastclass++) - ANYOF_SET(opnd, lastclass); +#ifndef ASCIIish + register I32 i; + if ((isLOWER(lastclass) && isLOWER(Class)) || + (isUPPER(lastclass) && isUPPER(Class))) { + if (isLOWER(lastclass)) { + for (i = lastclass; i <= Class; i++) + if (isLOWER(i)) + ANYOF_SET(opnd, i); + } else { + for (i = lastclass; i <= Class; i++) + if (isUPPER(i)) + ANYOF_SET(opnd, i); + } + } + else +#endif + for ( ; lastclass <= Class; lastclass++) + ANYOF_SET(opnd, lastclass); } lastclass = Class; } diff --git a/contrib/perl5/regexec.c b/contrib/perl5/regexec.c index f8c5e7e..98f7ef5 100644 --- a/contrib/perl5/regexec.c +++ b/contrib/perl5/regexec.c @@ -62,7 +62,7 @@ * **** Alterations to Henry's code are... **** - **** Copyright (c) 1991-1997, Larry Wall + **** Copyright (c) 1991-1999, Larry Wall **** **** You may distribute under the terms of either the GNU General Public **** License or the Artistic License, as specified in the README file. @@ -1573,6 +1573,7 @@ regmatch(regnode *prog) sayYES; /* Success! */ case SUSPEND: n = 1; + PL_reginput = locinput; goto do_ifmatch; case UNLESSM: n = 0; @@ -1768,25 +1769,26 @@ regrepeat_hard(regnode *p, I32 max, I32 *lp) register char *scan; register char *start; register char *loceol = PL_regeol; - I32 l = -1; + I32 l = 0; + I32 count = 0, res = 1; + + if (!max) + return 0; start = PL_reginput; - while (PL_reginput < loceol && (scan = PL_reginput, regmatch(p))) { - if (l == -1) { + while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) { + if (!count++) { *lp = l = PL_reginput - start; if (max != REG_INFTY && l*max < loceol - scan) loceol = scan + l*max; - if (l == 0) { + if (l == 0) return max; - } } } - if (PL_reginput < loceol) + if (!res) PL_reginput = scan; - else - scan = PL_reginput; - return (scan - start)/l; + return count; } /* diff --git a/contrib/perl5/run.c b/contrib/perl5/run.c index 97444ec..ed50fb0 100644 --- a/contrib/perl5/run.c +++ b/contrib/perl5/run.c @@ -1,6 +1,6 @@ /* run.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -77,6 +77,7 @@ debop(OP *o) { #ifdef DEBUGGING SV *sv; + STRLEN n_a; deb("%s", op_name[o->op_type]); switch (o->op_type) { case OP_CONST: @@ -87,7 +88,7 @@ debop(OP *o) if (cGVOPo->op_gv) { sv = NEWSV(0,0); gv_fullname3(sv, cGVOPo->op_gv, Nullch); - PerlIO_printf(Perl_debug_log, "(%s)", SvPV(sv, PL_na)); + PerlIO_printf(Perl_debug_log, "(%s)", SvPV(sv, n_a)); SvREFCNT_dec(sv); } else diff --git a/contrib/perl5/scope.c b/contrib/perl5/scope.c index 067e29e..ff893e6 100644 --- a/contrib/perl5/scope.c +++ b/contrib/perl5/scope.c @@ -1,6 +1,6 @@ /* scope.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -144,9 +144,7 @@ free_tmps(void) SV* sv = PL_tmps_stack[PL_tmps_ix]; PL_tmps_stack[PL_tmps_ix--] = Nullsv; if (sv) { -#ifdef DEBUGGING SvTEMP_off(sv); -#endif SvREFCNT_dec(sv); /* note, can modify tmps_ix!!! */ } } @@ -206,6 +204,18 @@ save_svref(SV **sptr) return save_scalar_at(sptr); } +/* Like save_svref(), but doesn't deal with magic. Can be used to + * restore a global SV to its prior contents, freeing new value. */ +void +save_generic_svref(SV **sptr) +{ + dTHR; + SSCHECK(3); + SSPUSHPTR(sptr); + SSPUSHPTR(SvREFCNT_inc(*sptr)); + SSPUSHINT(SAVEt_GENERIC_SVREF); +} + void save_gp(GV *gv, I32 empty) { @@ -562,6 +572,16 @@ leave_scope(I32 base) ptr = &GvSV(gv); SvREFCNT_dec(gv); goto restore_sv; + case SAVEt_GENERIC_SVREF: /* generic sv */ + value = (SV*)SSPOPPTR; + ptr = SSPOPPTR; + if (ptr) { + sv = *(SV**)ptr; + *(SV**)ptr = value; + SvREFCNT_dec(sv); + } + SvREFCNT_dec(value); + break; case SAVEt_SVREF: /* scalar reference */ value = (SV*)SSPOPPTR; ptr = SSPOPPTR; @@ -774,7 +794,7 @@ leave_scope(I32 base) if (ptr) { sv = *(SV**)ptr; if (sv && sv != &PL_sv_undef) { - if (SvRMAGICAL(av) && mg_find((SV*)av, 'P')) + if (SvTIED_mg((SV*)av, 'P')) (void)SvREFCNT_inc(sv); SvREFCNT_dec(av); goto restore_sv; @@ -792,7 +812,7 @@ leave_scope(I32 base) SV *oval = HeVAL((HE*)ptr); if (oval && oval != &PL_sv_undef) { ptr = &HeVAL((HE*)ptr); - if (SvRMAGICAL(hv) && mg_find((SV*)hv, 'P')) + if (SvTIED_mg((SV*)hv, 'P')) (void)SvREFCNT_inc(*(SV**)ptr); SvREFCNT_dec(hv); SvREFCNT_dec(sv); @@ -824,8 +844,8 @@ cx_dump(PERL_CONTEXT *cx) { #ifdef DEBUGGING dTHR; - PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), block_type[cx->cx_type]); - if (cx->cx_type != CXt_SUBST) { + PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), block_type[CxTYPE(cx)]); + if (CxTYPE(cx) != CXt_SUBST) { PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp); PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%lx\n", (long)cx->blk_oldcop); PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp); @@ -834,7 +854,7 @@ cx_dump(PERL_CONTEXT *cx) PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%lx\n", (long)cx->blk_oldpm); PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR"); } - switch (cx->cx_type) { + switch (CxTYPE(cx)) { case CXt_NULL: case CXt_BLOCK: break; diff --git a/contrib/perl5/scope.h b/contrib/perl5/scope.h index 0dde4e1..9fab6ee 100644 --- a/contrib/perl5/scope.h +++ b/contrib/perl5/scope.h @@ -26,6 +26,8 @@ #define SAVEt_HELEM 25 #define SAVEt_OP 26 #define SAVEt_HINTS 27 +/* #define SAVEt_ALLOC 28 */ /* defined in 5.005_5x */ +#define SAVEt_GENERIC_SVREF 29 #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)) @@ -62,7 +64,7 @@ #define LEAVE_SCOPE(old) if (PL_savestack_ix > old) leave_scope(old) /* - * Not using SOFT_CAST on SAVEFREESV and SAVEFREESV + * Not using SOFT_CAST on SAVESPTR, SAVEGENERICSV and SAVEFREESV * because these are used for several kinds of pointer values */ #define SAVEI16(i) save_I16(SOFT_CAST(I16*)&(i)) @@ -76,6 +78,7 @@ #define SAVEFREEOP(o) save_freeop(SOFT_CAST(OP*)(o)) #define SAVEFREEPV(p) save_freepv(SOFT_CAST(char*)(p)) #define SAVECLEARSV(sv) save_clearsv(SOFT_CAST(SV**)&(sv)) +#define SAVEGENERICSV(s) save_generic_svref((SV**)&(s)) #define SAVEDELETE(h,k,l) \ save_delete(SOFT_CAST(HV*)(h), SOFT_CAST(char*)(k), (I32)(l)) #ifdef PERL_OBJECT diff --git a/contrib/perl5/sv.c b/contrib/perl5/sv.c index a53e769..0778a72 100644 --- a/contrib/perl5/sv.c +++ b/contrib/perl5/sv.c @@ -1,6 +1,6 @@ /* sv.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -49,10 +49,10 @@ static IV asIV _((SV* sv)); static UV asUV _((SV* sv)); static SV *more_sv _((void)); -static XPVIV *more_xiv _((void)); -static XPVNV *more_xnv _((void)); -static XPV *more_xpv _((void)); -static XRV *more_xrv _((void)); +static void more_xiv _((void)); +static void more_xnv _((void)); +static void more_xpv _((void)); +static void more_xrv _((void)); static XPVIV *new_xiv _((void)); static XPVNV *new_xnv _((void)); static XPV *new_xpv _((void)); @@ -417,26 +417,29 @@ STATIC XPVIV* new_xiv(void) { IV* xiv; - if (PL_xiv_root) { - xiv = PL_xiv_root; - /* - * See comment in more_xiv() -- RAM. - */ - PL_xiv_root = *(IV**)xiv; - return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv)); - } - return more_xiv(); + LOCK_SV_MUTEX; + if (!PL_xiv_root) + more_xiv(); + xiv = PL_xiv_root; + /* + * See comment in more_xiv() -- RAM. + */ + PL_xiv_root = *(IV**)xiv; + UNLOCK_SV_MUTEX; + return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv)); } STATIC void del_xiv(XPVIV *p) { IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv)); + LOCK_SV_MUTEX; *(IV**)xiv = PL_xiv_root; PL_xiv_root = xiv; + UNLOCK_SV_MUTEX; } -STATIC XPVIV* +STATIC void more_xiv(void) { register IV* xiv; @@ -455,30 +458,32 @@ more_xiv(void) xiv++; } *(IV**)xiv = 0; - return new_xiv(); } STATIC XPVNV* new_xnv(void) { double* xnv; - if (PL_xnv_root) { - xnv = PL_xnv_root; - PL_xnv_root = *(double**)xnv; - return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv)); - } - return more_xnv(); + LOCK_SV_MUTEX; + if (!PL_xnv_root) + more_xnv(); + xnv = PL_xnv_root; + PL_xnv_root = *(double**)xnv; + UNLOCK_SV_MUTEX; + return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv)); } STATIC void del_xnv(XPVNV *p) { double* xnv = (double*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv)); - *(double**)xnv = PL_xnv_root; - PL_xnv_root = xnv; + LOCK_SV_MUTEX; + *(double**)xnv = PL_xnv_root; + PL_xnv_root = xnv; + UNLOCK_SV_MUTEX; } -STATIC XPVNV* +STATIC void more_xnv(void) { register double* xnv; @@ -492,29 +497,31 @@ more_xnv(void) xnv++; } *(double**)xnv = 0; - return new_xnv(); } STATIC XRV* new_xrv(void) { XRV* xrv; - if (PL_xrv_root) { - xrv = PL_xrv_root; - PL_xrv_root = (XRV*)xrv->xrv_rv; - return xrv; - } - return more_xrv(); + LOCK_SV_MUTEX; + if (!PL_xrv_root) + more_xrv(); + xrv = PL_xrv_root; + PL_xrv_root = (XRV*)xrv->xrv_rv; + UNLOCK_SV_MUTEX; + return xrv; } STATIC void del_xrv(XRV *p) { - p->xrv_rv = (SV*)PL_xrv_root; - PL_xrv_root = p; + LOCK_SV_MUTEX; + p->xrv_rv = (SV*)PL_xrv_root; + PL_xrv_root = p; + UNLOCK_SV_MUTEX; } -STATIC XRV* +STATIC void more_xrv(void) { register XRV* xrv; @@ -527,29 +534,31 @@ more_xrv(void) xrv++; } xrv->xrv_rv = 0; - return new_xrv(); } STATIC XPV* new_xpv(void) { XPV* xpv; - if (PL_xpv_root) { - xpv = PL_xpv_root; - PL_xpv_root = (XPV*)xpv->xpv_pv; - return xpv; - } - return more_xpv(); + LOCK_SV_MUTEX; + if (!PL_xpv_root) + more_xpv(); + xpv = PL_xpv_root; + PL_xpv_root = (XPV*)xpv->xpv_pv; + UNLOCK_SV_MUTEX; + return xpv; } STATIC void del_xpv(XPV *p) { - p->xpv_pv = (char*)PL_xpv_root; - PL_xpv_root = p; + LOCK_SV_MUTEX; + p->xpv_pv = (char*)PL_xpv_root; + PL_xpv_root = p; + UNLOCK_SV_MUTEX; } -STATIC XPV* +STATIC void more_xpv(void) { register XPV* xpv; @@ -562,7 +571,6 @@ more_xpv(void) xpv++; } xpv->xpv_pv = 0; - return new_xpv(); } #ifdef PURIFY @@ -1062,7 +1070,7 @@ sv_peek(SV *sv) while (unref--) sv_catpv(t, ")"); } - return SvPV(t, PL_na); + return SvPV(t, prevlen); #else /* DEBUGGING */ return ""; #endif /* DEBUGGING */ @@ -3484,6 +3492,8 @@ sv_inc(register SV *sv) if (!sv) return; + if (SvGMAGICAL(sv)) + mg_get(sv); if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv)) { dTHR; @@ -3500,8 +3510,6 @@ sv_inc(register SV *sv) sv_setiv(sv, i); } } - if (SvGMAGICAL(sv)) - mg_get(sv); flags = SvFLAGS(sv); if (flags & SVp_NOK) { (void)SvNOK_only(sv); @@ -3578,6 +3586,8 @@ sv_dec(register SV *sv) if (!sv) return; + if (SvGMAGICAL(sv)) + mg_get(sv); if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv)) { dTHR; @@ -3594,8 +3604,6 @@ sv_dec(register SV *sv) sv_setiv(sv, i); } } - if (SvGMAGICAL(sv)) - mg_get(sv); flags = SvFLAGS(sv); if (flags & SVp_NOK) { SvNVX(sv) -= 1.0; @@ -3845,12 +3853,18 @@ sv_reset(register char *s, HV *stash) } for (i = 0; i <= (I32) HvMAX(stash); i++) { for (entry = HvARRAY(stash)[i]; - entry; - entry = HeNEXT(entry)) { + entry; + entry = HeNEXT(entry)) + { if (!todo[(U8)*HeKEY(entry)]) continue; gv = (GV*)HeVAL(entry); sv = GvSV(gv); + if (SvTHINKFIRST(sv)) { + if (!SvREADONLY(sv) && SvROK(sv)) + sv_unref(sv); + continue; + } (void)SvOK_off(sv); if (SvTYPE(sv) >= SVt_PV) { SvCUR_set(sv, 0); @@ -3878,6 +3892,7 @@ sv_2io(SV *sv) { IO* io; GV* gv; + STRLEN n_a; switch (SvTYPE(sv)) { case SVt_PVIO: @@ -3894,13 +3909,13 @@ sv_2io(SV *sv) croak(no_usym, "filehandle"); if (SvROK(sv)) return sv_2io(SvRV(sv)); - gv = gv_fetchpv(SvPV(sv,PL_na), FALSE, SVt_PVIO); + gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO); if (gv) io = GvIO(gv); else io = 0; if (!io) - croak("Bad filehandle: %s", SvPV(sv,PL_na)); + croak("Bad filehandle: %s", SvPV(sv,n_a)); break; } return io; @@ -3911,6 +3926,7 @@ sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref) { GV *gv; CV *cv; + STRLEN n_a; if (!sv) return *gvp = Nullgv, Nullcv; @@ -3933,17 +3949,22 @@ sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref) if (SvGMAGICAL(sv)) mg_get(sv); if (SvROK(sv)) { - cv = (CV*)SvRV(sv); - if (SvTYPE(cv) != SVt_PVCV) + sv = SvRV(sv); + if (SvTYPE(sv) == SVt_PVCV) { + cv = (CV*)sv; + *gvp = Nullgv; + *st = CvSTASH(cv); + return cv; + } + else if(isGV(sv)) + gv = (GV*)sv; + else croak("Not a subroutine reference"); - *gvp = Nullgv; - *st = CvSTASH(cv); - return cv; } - if (isGV(sv)) + else if (isGV(sv)) gv = (GV*)sv; else - gv = gv_fetchpv(SvPV(sv, PL_na), lref, SVt_PVCV); + gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV); *gvp = gv; if (!gv) return Nullcv; @@ -3960,7 +3981,7 @@ sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref) Nullop); LEAVE; if (!GvCVu(gv)) - croak("Unable to create sub named \"%s\"", SvPV(sv,PL_na)); + croak("Unable to create sub named \"%s\"", SvPV(sv,n_a)); } return GvCVu(gv); } @@ -4437,8 +4458,10 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, STRLEN elen = 0; char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */ +#ifndef PERL_OBJECT static char *efloatbuf = Nullch; static STRLEN efloatsize = 0; +#endif char c; int i; @@ -5078,8 +5101,10 @@ sv_dump(SV *sv) PerlIO_printf(Perl_debug_log, " NAME = \"%s\"\n", HvNAME(sv)); break; case SVt_PVCV: - if (SvPOK(sv)) - PerlIO_printf(Perl_debug_log, " PROTOTYPE = \"%s\"\n", SvPV(sv,PL_na)); + if (SvPOK(sv)) { + STRLEN n_a; + PerlIO_printf(Perl_debug_log, " PROTOTYPE = \"%s\"\n", SvPV(sv,n_a)); + } /* FALL THROUGH */ case SVt_PVFM: PerlIO_printf(Perl_debug_log, " STASH = 0x%lx\n", (long)CvSTASH(sv)); diff --git a/contrib/perl5/sv.h b/contrib/perl5/sv.h index 3dac548..7448b83 100644 --- a/contrib/perl5/sv.h +++ b/contrib/perl5/sv.h @@ -1,6 +1,6 @@ /* sv.h * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -316,7 +316,8 @@ struct xpvio { #define IOf_START 2 /* check for null ARGV and substitute '-' */ #define IOf_FLUSH 4 /* this fp wants a flush after write op */ #define IOf_DIDTOP 8 /* just did top of form */ -#define IOf_UNTAINT 16 /* consider this fp (and it's data) "safe" */ +#define IOf_UNTAINT 16 /* consider this fp (and its data) "safe" */ +#define IOf_NOLINE 32 /* slurped a pseudo-line from empty file */ /* The following macros define implementation-independent predicates on SVs. */ diff --git a/contrib/perl5/t/base/lex.t b/contrib/perl5/t/base/lex.t index 045cb22..8e2452d 100755 --- a/contrib/perl5/t/base/lex.t +++ b/contrib/perl5/t/base/lex.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: lex.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:04 $ - -print "1..30\n"; +print "1..35\n"; $x = 'x'; @@ -117,3 +115,30 @@ $foo =~ s/^not /substr(<<EOF, 0, 0)/e; Ignored EOF print $foo; + +# see if eval '', s///e, and heredocs mix + +sub T { + my ($where, $num) = @_; + my ($p,$f,$l) = caller; + print "# $p:$f:$l vs /$where/\nnot " unless "$p:$f:$l" =~ /$where/; + print "ok $num\n"; +} + +my $test = 31; + +{ +# line 42 "plink" + local $_ = "not ok "; + eval q{ + s/^not /<<EOT/e and T '^main:\(eval \d+\):2$', $test++; +# fuggedaboudit +EOT + print $_, $test++, "\n"; + T('^main:\(eval \d+\):6$', $test++); +# line 1 "plunk" + T('^main:plunk:1$', $test++); + }; + print "# $@\nnot ok $test\n" if $@; + T '^main:plink:53$', $test++; +} diff --git a/contrib/perl5/t/cmd/for.t b/contrib/perl5/t/cmd/for.t index e45f050..d70af57 100755 --- a/contrib/perl5/t/cmd/for.t +++ b/contrib/perl5/t/cmd/for.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: for.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:09 $ - -print "1..7\n"; +print "1..10\n"; for ($i = 0; $i <= 10; $i++) { $x[$i] = $i; @@ -47,3 +45,13 @@ if ($foo eq '3210abcde') {print "ok 5\n";} else {print "not ok 5 $foo\n";} foreach $foo (("ok 6\n","ok 7\n")) { print $foo; } + +sub foo { + for $i (1..5) { + return $i if $_[0] == $i; + } +} + +print foo(1) == 1 ? "ok" : "not ok", " 8\n"; +print foo(2) == 2 ? "ok" : "not ok", " 9\n"; +print foo(5) == 5 ? "ok" : "not ok", " 10\n"; diff --git a/contrib/perl5/t/cmd/while.t b/contrib/perl5/t/cmd/while.t index c6e464d..392c137 100755 --- a/contrib/perl5/t/cmd/while.t +++ b/contrib/perl5/t/cmd/while.t @@ -2,7 +2,7 @@ # $RCSfile: while.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:15 $ -print "1..10\n"; +print "1..15\n"; open (tmp,'>Cmd_while.tmp') || die "Can't create Cmd_while.tmp."; print tmp "tvi925\n"; @@ -109,3 +109,22 @@ $i = 9; $i++; } print "ok $i\n"; + +# Check curpm is reset when jumping out of a scope +'abc' =~ /b/; +WHILE: +while (1) { + $i++; + print "#$`,$&,$',\nnot " unless $` . $& . $' eq "abc"; + print "ok $i\n"; + { # Localize changes to $` and friends + 'end' =~ /end/; + redo WHILE if $i == 11; + next WHILE if $i == 12; + # 13 do a normal loop + last WHILE if $i == 14; + } +} +$i++; +print "not " unless $` . $& . $' eq "abc"; +print "ok $i\n"; diff --git a/contrib/perl5/t/comp/package.t b/contrib/perl5/t/comp/package.t index d7d19ae..4982256 100755 --- a/contrib/perl5/t/comp/package.t +++ b/contrib/perl5/t/comp/package.t @@ -1,6 +1,6 @@ #!./perl -print "1..7\n"; +print "1..8\n"; $blurfl = 123; $foo = 3; @@ -37,3 +37,17 @@ print $blurfl == 5 ? "ok 4\n" : "not ok 4\n"; eval 'print $blurfl == 5 ? "ok 5\n" : "not ok 5\n";'; eval 'package main; print $blurfl == 123 ? "ok 6\n" : "not ok 6\n";'; print $blurfl == 5 ? "ok 7\n" : "not ok 7\n"; + +package main; + +sub c { caller(0) } + +sub foo { + my $s = shift; + if ($s) { + package PQR; + main::c(); + } +} + +print((foo(1))[0] eq 'PQR' ? "ok 8\n" : "not ok 8\n"); diff --git a/contrib/perl5/t/comp/proto.t b/contrib/perl5/t/comp/proto.t index 6a59107..db6a9b5 100755 --- a/contrib/perl5/t/comp/proto.t +++ b/contrib/perl5/t/comp/proto.t @@ -16,7 +16,7 @@ BEGIN { use strict; -print "1..82\n"; +print "1..87\n"; my $i = 1; @@ -413,3 +413,13 @@ sub X::foo4 ($); *X::foo4 = sub ($) {'ok'}; print "not " unless X->foo4 eq 'ok'; print "ok ", $i++, "\n"; + +# test if the (*) prototype allows barewords, constants, scalar expressions, +# globs and globrefs (just as CORE::open() does), all under stricture +sub star (*&) { &{$_[1]} } +my $star = 'FOO'; +star FOO, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++; +star "FOO", sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++; +star $star, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++; +star *FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++; +star \*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++; diff --git a/contrib/perl5/t/comp/require.t b/contrib/perl5/t/comp/require.t index 203b996..5c41f5c 100755 --- a/contrib/perl5/t/comp/require.t +++ b/contrib/perl5/t/comp/require.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = ('.'); + @INC = ('.', '../lib'); } # don't make this lexical @@ -35,7 +35,9 @@ print "ok ",$i++,"\n"; # compile-time failure in require do_require "1)\n"; -print "# $@\nnot " unless $@ =~ /syntax error/i; +# bison says 'parse error' instead of 'syntax error', +# various yaccs may or may not capitalize 'syntax'. +print "# $@\nnot " unless $@ =~ /(syntax|parse) error/mi; print "ok ",$i++,"\n"; # successful require diff --git a/contrib/perl5/t/io/argv.t b/contrib/perl5/t/io/argv.t index d99865e..c6565dc 100755 --- a/contrib/perl5/t/io/argv.t +++ b/contrib/perl5/t/io/argv.t @@ -1,10 +1,8 @@ #!./perl -# $RCSfile: argv.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:25 $ +print "1..6\n"; -print "1..5\n"; - -open(try, '>Io.argv.tmp') || (die "Can't open temp file."); +open(try, '>Io.argv.tmp') || (die "Can't open temp file: $!"); print try "a line\n"; close try; @@ -45,4 +43,17 @@ if ($y eq "1a line\n2a line\n3a line\n") else {print "not ok 5\n";} -unlink 'Io.argv.tmp'; +open(try, '>Io.argv.tmp') or die "Can't open temp file: $!"; +close try; +@ARGV = 'Io.argv.tmp'; +$^I = '.bak'; +$/ = undef; +while (<>) { + s/^/ok 6\n/; + print; +} +open(try, '<Io.argv.tmp') or die "Can't open temp file: $!"; +print while <try>; +close try; + +END { unlink 'Io.argv.tmp', 'Io.argv.tmp.bak' } diff --git a/contrib/perl5/t/io/fs.t b/contrib/perl5/t/io/fs.t index 164a667..f09d66c 100755 --- a/contrib/perl5/t/io/fs.t +++ b/contrib/perl5/t/io/fs.t @@ -9,24 +9,23 @@ BEGIN { use Config; -$Is_Dosish = ($^O eq 'dos' or $^O eq 'os2'); +$Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'dos' or + $^O eq 'os2' or $^O eq 'mint'); -# avoid win32 (for now) -do { print "1..0\n"; exit(0); } if $^O eq 'MSWin32'; - -print "1..26\n"; +print "1..28\n"; $wd = (($^O eq 'MSWin32') ? `cd` : `pwd`); chop($wd); -if ($^O eq 'MSWin32') { `del tmp`; `mkdir tmp`; } +if ($^O eq 'MSWin32') { `del tmp 2>nul`; `mkdir tmp`; } else { `rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`; } chdir './tmp'; `/bin/rm -rf a b c x` if -x '/bin/rm'; umask(022); -if ((umask(0)&0777) == 022) {print "ok 1\n";} else {print "not ok 1\n";} +if ($^O eq 'MSWin32') { print "ok 1 # skipped: bogus umask()\n"; } +elsif ((umask(0)&0777) == 022) {print "ok 1\n";} else {print "not ok 1\n";} open(fh,'>x') || die "Can't create x"; close(fh); open(fh,'>a') || die "Can't create a"; @@ -98,8 +97,9 @@ $foo = (utime 500000000,500000000 + $delta,'b'); if ($foo == 1) {print "ok 16\n";} else {print "not ok 16 $foo\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('b'); -if ($ino) {print "ok 17\n";} else {print "not ok 17\n";} -if ($wd =~ m#/afs/# || $^O eq 'amigaos') +if ($^O eq 'MSWin32') { print "ok 17 # skipped: bogus (stat)[1]\n"; } +elsif ($ino) {print "ok 17\n";} else {print "not ok 17\n";} +if ($wd =~ m#/afs/# || $^O eq 'amigaos' || $^O eq 'dos' || $^O eq 'MSWin32') {print "ok 18 # skipped: granularity of the filetime\n";} elsif ($atime == 500000000 && $mtime == 500000000 + $delta) {print "ok 18\n";} @@ -113,7 +113,6 @@ if ($ino == 0) {print "ok 20\n";} else {print "not ok 20\n";} unlink 'c'; chdir $wd || die "Can't cd back to $wd"; -rmdir 'tmp'; unlink 'c'; if ($^O ne 'MSWin32' and `ls -l perl 2>/dev/null` =~ /^l.*->/) { @@ -156,4 +155,11 @@ else { if (-z "Iofs.tmp") {print "ok 26\n"} else {print "not ok 26\n"} close FH; } -unlink "Iofs.tmp"; + +# check if rename() works on directories +rename 'tmp', 'tmp1' or print "not "; +print "ok 27\n"; +-d 'tmp1' or print "not "; +print "ok 28\n"; + +END { rmdir 'tmp1'; unlink "Iofs.tmp"; } diff --git a/contrib/perl5/t/lib/cgi-html.t b/contrib/perl5/t/lib/cgi-html.t index 16aa824..6a7ff1e 100755 --- a/contrib/perl5/t/lib/cgi-html.t +++ b/contrib/perl5/t/lib/cgi-html.t @@ -8,11 +8,11 @@ BEGIN { @INC = '../lib' if -d '../lib'; } -BEGIN {$| = 1; print "1..17\n"; } +BEGIN {$| = 1; print "1..20\n"; } BEGIN {$eol = $^O eq 'VMS' ? "\n" : "\cM\cJ"; $eol = "\r\n" if $^O eq 'os390'; } END {print "not ok 1\n" unless $loaded;} -use CGI (':standard','-no_debug'); +use CGI (':standard','-no_debug','*h3','start_table'); $loaded = 1; print "ok 1\n"; @@ -64,3 +64,6 @@ test(16,($cookie=cookie(-name=>'fred',-value=>['chocolate','chip'],-path=>'/')) 'fred=chocolate&chip; path=/',"cookie()"); test(17,header(-Cookie=>$cookie) =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${eol}Date:.*${eol}Content-Type: text/html${eol}${eol}!s, "header(-cookie)"); +test(18,start_h3 eq '<H3>'); +test(19,end_h3 eq '</H3>'); +test(20,start_table({-border=>undef}) eq '<TABLE BORDER>'); diff --git a/contrib/perl5/t/lib/complex.t b/contrib/perl5/t/lib/complex.t index 2bb14f0..c073f50 100755 --- a/contrib/perl5/t/lib/complex.t +++ b/contrib/perl5/t/lib/complex.t @@ -14,7 +14,7 @@ BEGIN { use Math::Complex; -$VERSION = sprintf("%s", q$Id: complex.t,v 1.8 1998/02/05 16:03:39 jhi Exp $ =~ /(\d+\.d+)/); +my $VERSION = sprintf("%s", q$Id: complex.t,v 1.9 1998/11/01 00:00:00 dsl Exp $ =~ /(\d+\.d+)/); my ($args, $op, $target, $test, $test_set, $try, $val, $zvalue, @set, @val); @@ -173,20 +173,6 @@ test_loz( 'acoth(-1)', ); -# test the 0**0 - -sub test_ztz { - $test++; - - push(@script, <<'EOT'); -eval 'cplx(0)**cplx(0)'; -print 'not ' unless ($@ =~ /zero raised to the zeroth/); -EOT - push(@script, qq(print "ok $test\\n";\n)); -} - -test_ztz; - # test the bad roots sub test_broot { @@ -387,6 +373,7 @@ __END__ (1,0):(2,3):(1,0) (2,3):(0,0):(1,0) (2,3):(1,0):(2,3) +(0,0):(0,0):(1,0) &Re (3,4):3 @@ -876,4 +863,3 @@ __END__ ( 2,-3):( 0.14694666622553, 0.23182380450040) # eof - diff --git a/contrib/perl5/t/lib/db-recno.t b/contrib/perl5/t/lib/db-recno.t index c89c3ca..da703c9 100755 --- a/contrib/perl5/t/lib/db-recno.t +++ b/contrib/perl5/t/lib/db-recno.t @@ -42,14 +42,16 @@ sub bad_one { print STDERR <<EOM unless $bad_ones++ ; # -# Some older versions of Berkeley DB will fail tests 51, 53 and 55. +# Some older versions of Berkeley DB version 1 will fail tests 51, +# 53 and 55. # # You can safely ignore the errors if you're never going to use the -# broken functionality (recno databases with a modified bval). +# broken functionality (recno databases with a modified bval). # Otherwise you'll have to upgrade your DB library. # -# If you want to upgrade Berkeley DB, the most recent version is 1.85. -# Check out http://www.bostic.com/db for more details. +# If you want to use Berkeley DB version 1, then 1.85 and 1.86 are the +# last versions that were released. Berkeley DB version 2 is continually +# being updated -- Check out http://www.sleepycat.com/ for more details. # EOM } diff --git a/contrib/perl5/t/lib/dumper.t b/contrib/perl5/t/lib/dumper.t index 70f8abe..8c8dc40 100755 --- a/contrib/perl5/t/lib/dumper.t +++ b/contrib/perl5/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; @@ -35,11 +37,11 @@ sub TEST { if (defined &Data::Dumper::Dumpxs) { print "### XS extension loaded, will run XS tests\n"; - $TMAX = 138; $XS = 1; + $TMAX = 162; $XS = 1; } else { print "### XS extensions not loaded, will NOT run XS tests\n"; - $TMAX = 69; $XS = 0; + $TMAX = 81; $XS = 0; } print "1..$TMAX\n"; @@ -234,13 +236,22 @@ EOT ############# 43 ## +if (!$Is_ebcdic) { $WANT = <<'EOT'; #$VAR1 = { -# "abc\000\efg" => "mno\000" +# "abc\0'\efg" => "mno\0" #}; EOT +} +else { +$WANT = <<'EOT'; +#$VAR1 = { +# "\201\202\203\340\360'\340\205\206\207" => "\224\225\226\340\360" +#}; +EOT +} -$foo = { "abc\000\efg" => "mno\000" }; +$foo = { "abc\000\'\efg" => "mno\000" }; { local $Data::Dumper::Useqq = 1; TEST q(Dumper($foo)); @@ -248,7 +259,7 @@ $foo = { "abc\000\efg" => "mno\000" }; $WANT = <<"EOT"; #\$VAR1 = { -# 'abc\000\efg' => 'mno\000' +# 'abc\0\\'\efg' => 'mno\0' #}; EOT @@ -444,18 +455,34 @@ EOT ############# 85 ## +if (!$Is_ebcdic) { $WANT = <<'EOT'; #%kennels = ( # First => \'Fido', # Second => \'Wags' #); #@dogs = ( -# $kennels{First}, -# $kennels{Second}, +# ${$kennels{First}}, +# ${$kennels{Second}}, +# \%kennels +#); +#%mutts = %kennels; +EOT +} +else { + $WANT = <<'EOT'; +#%kennels = ( +# Second => \'Wags', +# First => \'Fido' +#); +#@dogs = ( +# ${$kennels{First}}, +# ${$kennels{Second}}, # \%kennels #); #%mutts = %kennels; EOT +} TEST q( $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts], @@ -483,19 +510,34 @@ EOT ############# 97 ## +if (!$Is_ebcdic) { $WANT = <<'EOT'; #%kennels = ( # First => \'Fido', # Second => \'Wags' #); #@dogs = ( -# $kennels{First}, -# $kennels{Second}, +# ${$kennels{First}}, +# ${$kennels{Second}}, # \%kennels #); #%mutts = %kennels; EOT - +} +else { + $WANT = <<'EOT'; +#%kennels = ( +# Second => \'Wags', +# First => \'Fido' +#); +#@dogs = ( +# ${$kennels{First}}, +# ${$kennels{Second}}, +# \%kennels +#); +#%mutts = %kennels; +EOT +} TEST q($d->Reset; $d->Dump); if ($XS) { @@ -504,7 +546,8 @@ EOT ############# 103 ## - $WANT = <<'EOT'; +if (!$Is_ebcdic) { + $WANT = <<'EOT'; #@dogs = ( # 'Fido', # 'Wags', @@ -516,6 +559,21 @@ EOT #%kennels = %{$dogs[2]}; #%mutts = %{$dogs[2]}; EOT +} +else { + $WANT = <<'EOT'; +#@dogs = ( +# 'Fido', +# 'Wags', +# { +# Second => \$dogs[1], +# First => \$dogs[0] +# } +#); +#%kennels = %{$dogs[2]}; +#%mutts = %{$dogs[2]}; +EOT +} TEST q( $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts], @@ -539,6 +597,7 @@ EOT ############# 115 ## +if (!$Is_ebcdic) { $WANT = <<'EOT'; #@dogs = ( # 'Fido', @@ -553,6 +612,23 @@ EOT # Second => \'Wags' #); EOT +} +else { + $WANT = <<'EOT'; +#@dogs = ( +# 'Fido', +# 'Wags', +# { +# Second => \'Wags', +# First => \'Fido' +# } +#); +#%kennels = ( +# Second => \'Wags', +# First => \'Fido' +#); +EOT +} TEST q( $d = Data::Dumper->new( [\@dogs, \%kennel], [qw(*dogs *kennels)] ); @@ -566,8 +642,8 @@ EOT { -sub a { print "foo\n" } -$c = [ \&a ]; +sub z { print "foo\n" } +$c = [ \&z ]; ############# 121 ## @@ -578,8 +654,8 @@ $c = [ \&a ]; #]; EOT -TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'b' => \&a})->Dump;); -TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'b' => \&a})->Dumpxs;) +TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dump;); +TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dumpxs;) if $XS; ############# 127 @@ -591,8 +667,8 @@ TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'b' => \&a})->Dumpxs;) #]; EOT -TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'*b' => \&a})->Dump;); -TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'*b' => \&a})->Dumpxs;) +TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dump;); +TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dumpxs;) if $XS; ############# 133 @@ -604,8 +680,101 @@ TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'*b' => \&a})->Dumpxs;) #); EOT -TEST q(Data::Dumper->new([\&a,$c],['*a','*c'])->Seen({'*b' => \&a})->Dump;); -TEST q(Data::Dumper->new([\&a,$c],['*a','*c'])->Seen({'*b' => \&a})->Dumpxs;) +TEST q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dump;); +TEST q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dumpxs;) + if $XS; + +} + +{ + $a = []; + $a->[1] = \$a->[0]; + +############# 139 +## + $WANT = <<'EOT'; +#@a = ( +# undef, +# '' +#); +#$a[1] = \$a[0]; +EOT + +TEST q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dump;); +TEST q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dumpxs;) + if $XS; +} + +{ + $a = \\\\\'foo'; + $b = $$$a; + +############# 145 +## + $WANT = <<'EOT'; +#$a = \\\\\'foo'; +#$b = ${${$a}}; +EOT + +TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;); +TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;) if $XS; +} + +{ + $a = [{ a => \$b }, { b => undef }]; + $b = [{ c => \$b }, { d => \$a }]; + +############# 151 +## + $WANT = <<'EOT'; +#$a = [ +# { +# a => \[ +# { +# c => '' +# }, +# { +# d => \[] +# } +# ] +# }, +# { +# b => undef +# } +#]; +#${$a->[0]{a}}->[0]->{c} = $a->[0]{a}; +#${${$a->[0]{a}}->[1]->{d}} = $a; +#$b = ${$a->[0]{a}}; +EOT +TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;); +TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;) + if $XS; +} + +{ + $a = [[[[\\\\\'foo']]]]; + $b = $a->[0][0]; + $c = $${$b->[0][0]}; + +############# 157 +## + $WANT = <<'EOT'; +#$a = [ +# [ +# [ +# [ +# \\\\\'foo' +# ] +# ] +# ] +#]; +#$b = $a->[0][0]; +#$c = ${${$a->[0][0][0][0]}}; +EOT + +TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dump;); +TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dumpxs;) + if $XS; } diff --git a/contrib/perl5/t/lib/fatal.t b/contrib/perl5/t/lib/fatal.t new file mode 100755 index 0000000..fb3757f --- /dev/null +++ b/contrib/perl5/t/lib/fatal.t @@ -0,0 +1,27 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + print "1..9\n"; +} + +use strict; +use Fatal qw(open); + +my $i = 1; +eval { open FOO, '<lkjqweriuapofukndajsdlfjnvcvn' }; +print "not " unless $@ =~ /^Can't open/; +print "ok $i\n"; ++$i; + +my $foo = 'FOO'; +for ('$foo', "'$foo'", "*$foo", "\\*$foo") { + eval qq{ open $_, '<$0' }; + print "not " if $@; + print "ok $i\n"; ++$i; + + print "not " unless scalar(<FOO>) =~ m|^#!./perl|; + print "not " if $@; + print "ok $i\n"; ++$i; + close FOO; +} diff --git a/contrib/perl5/t/lib/h2ph.pht b/contrib/perl5/t/lib/h2ph.pht index 80867a6..e5b2932 100644 --- a/contrib/perl5/t/lib/h2ph.pht +++ b/contrib/perl5/t/lib/h2ph.pht @@ -1,3 +1,5 @@ +require '_h2ph_pre.ph'; + unless(defined(&SQUARE)) { sub SQUARE { local($x) = @_; @@ -27,7 +29,7 @@ unless(defined(&_H2PH_H_)) { if(!(defined (defined(&__SOMETHING_MORE_IMPORTANT) ? &__SOMETHING_MORE_IMPORTANT : 0))) { } elsif(!(defined (defined(&__SOMETHING_REALLY_REALLY_IMPORTANT) ? &__SOMETHING_REALLY_REALLY_IMPORTANT : 0))) { - die("Nup, can't go on "); + die("Nup\,\ can\'t\ go\ on\ "); } else { eval 'sub EVERYTHING_IS_OK () {1;}' unless defined(&EVERYTHING_IS_OK); } diff --git a/contrib/perl5/t/lib/io_udp.t b/contrib/perl5/t/lib/io_udp.t index 014e12d..ad2632d 100755 --- a/contrib/perl5/t/lib/io_udp.t +++ b/contrib/perl5/t/lib/io_udp.t @@ -13,7 +13,7 @@ BEGIN { if(-d "lib" && -f "TEST") { if ( ($Config{'extensions'} !~ /\bSocket\b/ || $Config{'extensions'} !~ /\bIO\b/ || - $^O eq 'os2') && + ($^O eq 'os2') || $^O eq 'apollo') && !(($^O eq 'VMS') && $Config{d_socket})) { print "1..0\n"; exit 0; diff --git a/contrib/perl5/t/lib/parsewords.t b/contrib/perl5/t/lib/parsewords.t index 9079179..3c5e75b 100755 --- a/contrib/perl5/t/lib/parsewords.t +++ b/contrib/perl5/t/lib/parsewords.t @@ -7,7 +7,7 @@ BEGIN { use Text::ParseWords; -print "1..17\n"; +print "1..18\n"; @words = shellwords(qq(foo "bar quiz" zoo)); print "not " if $words[0] ne 'foo'; @@ -101,3 +101,8 @@ $string = 'aaaa"bbbbb" cc\ cc \\\\\"dddd\' eee\\\\\"\\\'ffff\' gg'; $result = join('|', parse_line('\s+', 0, $string)); print "not " unless $result eq 'aaaabbbbb|cc cc|\"dddd eee\\\\"\'ffff|gg'; print "ok 17\n"; + +# test whitespace in the delimiters +@words = quotewords(' ', 1, '4 3 2 1 0'); +print "not " unless join(";", @words) eq qq(4;3;2;1;0); +print "ok 18\n"; diff --git a/contrib/perl5/t/lib/posix.t b/contrib/perl5/t/lib/posix.t index 8dafc80..f6d8e92 100755 --- a/contrib/perl5/t/lib/posix.t +++ b/contrib/perl5/t/lib/posix.t @@ -97,5 +97,5 @@ print POSIX::strftime("ok 18 # %H:%M, on %D\n", localtime()); $| = 0; # The following line assumes buffered output, which may be not true with EMX: -print '@#!*$@(!@#$' unless $^O eq 'os2'; +print '@#!*$@(!@#$' unless ($^O eq 'os2' || $^O eq 'uwin' || $^O eq 'os390'); _exit(0); diff --git a/contrib/perl5/t/lib/safe2.t b/contrib/perl5/t/lib/safe2.t index c9e3880..6afc117 100755 --- a/contrib/perl5/t/lib/safe2.t +++ b/contrib/perl5/t/lib/safe2.t @@ -8,8 +8,8 @@ BEGIN { print "1..0\n"; exit 0; } - # test 30 rather naughtily expects English error messages - $ENV{'LC_ALL'} = 'C'; + # test 30 rather naughtily expects English error messages + $ENV{'LC_ALL'} = 'C'; } # Tests Todo: @@ -122,11 +122,9 @@ print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n"; my $t = 30; $cpt->rdo('/non/existant/file.name'); -print +(($! =~ /No such file/ || $! =~ /file specification syntax error/) || - $! =~ /A file or directory in the path name does not exist/ || - $! =~ /Invalid argument/ || - $! =~ /Device not configured/ ? - "ok $t\n" : "not ok $t # $!\n"); $t++; +# The regexp is getting rather baroque. +print $! =~ /No such file|file specification syntax error|A file or directory in the path name does not exist|Invalid argument|Device not configured|file not found/i ? "ok $t\n" : "not ok $t # $!\n"; $t++; +# test #31 is gone. print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++; #my $rdo_file = "tmp_rdo.tpl"; diff --git a/contrib/perl5/t/lib/searchdict.t b/contrib/perl5/t/lib/searchdict.t index 447c425..c36fdb8 100755 --- a/contrib/perl5/t/lib/searchdict.t +++ b/contrib/perl5/t/lib/searchdict.t @@ -5,7 +5,7 @@ BEGIN { @INC = '../lib'; } -print "1..3\n"; +print "1..4\n"; $DICT = <<EOT; Aarhus @@ -44,22 +44,44 @@ open(DICT, "+>dict-$$") or die "Can't create dict-$$: $!"; binmode DICT; # To make length expected one. print DICT $DICT; -my $pos = look *DICT, "abash"; +my $pos = look *DICT, "Ababa"; chomp($word = <DICT>); -print "not " if $pos < 0 || $word ne "abash"; +print "not " if $pos < 0 || $word ne "Ababa"; print "ok 1\n"; -$pos = look *DICT, "foo"; -chomp($word = <DICT>); +if (ord('a') > ord('A') ) { # ASCII + + $pos = look *DICT, "foo"; + chomp($word = <DICT>); + + print "not " if $pos != length($DICT); # will search to end of file + print "ok 2\n"; -print "not " if $pos != length($DICT); # will search to end of file -print "ok 2\n"; + my $pos = look *DICT, "abash"; + chomp($word = <DICT>); + print "not " if $pos < 0 || $word ne "abash"; + print "ok 3\n"; + +} +else { # EBCDIC systems e.g. os390 + + $pos = look *DICT, "FOO"; + chomp($word = <DICT>); + + print "not " if $pos != length($DICT); # will search to end of file + print "ok 2\n"; + + my $pos = look *DICT, "Abba"; + chomp($word = <DICT>); + print "not " if $pos < 0 || $word ne "Abba"; + print "ok 3\n"; +} $pos = look *DICT, "aarhus", 1, 1; chomp($word = <DICT>); print "not " if $pos < 0 || $word ne "Aarhus"; -print "ok 3\n"; +print "ok 4\n"; close DICT or die "cannot close"; unlink "dict-$$"; diff --git a/contrib/perl5/t/lib/textfill.t b/contrib/perl5/t/lib/textfill.t new file mode 100755 index 0000000..19add69 --- /dev/null +++ b/contrib/perl5/t/lib/textfill.t @@ -0,0 +1,96 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +@tests = (split(/\nEND\n/s, <<DONE)); +TEST1 +Cyberdog Information + +Cyberdog & Netscape in the news +Important Press Release regarding Cyberdog and Netscape. Check it out! + +Cyberdog Plug-in Support! +Cyberdog support for Netscape Plug-ins is now available to download! Go +to the Cyberdog Beta Download page and download it now! + +Cyberdog Book +Check out Jesse Feiler's way-cool book about Cyberdog. You can find +details out about the book as well as ordering information at Philmont +Software Mill site. + +Java! +Looking to view Java applets in Cyberdog 1.1 Beta 3? Download and install +the Mac OS Runtime for Java and try it out! + +Cyberdog 1.1 Beta 3 +We hope that Cyberdog and OpenDoc 1.1 will be available within the next +two weeks. In the meantime, we have released another version of +Cyberdog, Cyberdog 1.1 Beta 3. This version fixes several bugs that were +reported to us during out public beta period. You can check out our release +notes to see what we fixed! +END + Cyberdog Information + Cyberdog & Netscape in the news Important Press Release regarding + Cyberdog and Netscape. Check it out! + Cyberdog Plug-in Support! Cyberdog support for Netscape Plug-ins is now + available to download! Go to the Cyberdog Beta Download page and download + it now! + Cyberdog Book Check out Jesse Feiler's way-cool book about Cyberdog. + You can find details out about the book as well as ordering information at + Philmont Software Mill site. + Java! Looking to view Java applets in Cyberdog 1.1 Beta 3? Download and + install the Mac OS Runtime for Java and try it out! + Cyberdog 1.1 Beta 3 We hope that Cyberdog and OpenDoc 1.1 will be + available within the next two weeks. In the meantime, we have released + another version of Cyberdog, Cyberdog 1.1 Beta 3. This version fixes + several bugs that were reported to us during out public beta period. You + can check out our release notes to see what we fixed! +END +DONE + + +$| = 1; + +print "1..", @tests/2, "\n"; + +use Text::Wrap; + +$rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; + +$tn = 1; +while (@tests) { + my $in = shift(@tests); + my $out = shift(@tests); + + $in =~ s/^TEST(\d+)?\n//; + + my $back = fill(' ', ' ', $in); + + if ($back eq $out) { + print "ok $tn\n"; + } elsif ($rerun) { + my $oi = $in; + open(F,">#o") and do { print F $back; close(F) }; + open(F,">#e") and do { print F $out; close(F) }; + foreach ($in, $back, $out) { + s/\t/^I\t/gs; + s/\n/\$\n/gs; + } + print "------------ input ------------\n"; + print $in; + print "\n------------ output -----------\n"; + print $back; + print "\n------------ expected ---------\n"; + print $out; + print "\n-------------------------------\n"; + $Text::Wrap::debug = 1; + fill(' ', ' ', $oi); + exit(1); + } else { + print "not ok $tn\n"; + } + $tn++; +} diff --git a/contrib/perl5/t/lib/textwrap.t b/contrib/perl5/t/lib/textwrap.t index 9c8d1b4..c3a455b 100755 --- a/contrib/perl5/t/lib/textwrap.t +++ b/contrib/perl5/t/lib/textwrap.t @@ -1,40 +1,128 @@ -#!./perl +#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } -print "1..5\n"; +@tests = (split(/\nEND\n/s, <<DONE)); +TEST1 +This +is +a +test +END + This + is + a + test +END +TEST2 +This is a test of a very long line. It should be broken up and put onto multiple lines. +This is a test of a very long line. It should be broken up and put onto multiple lines. -use Text::Wrap qw(wrap $columns); +This is a test of a very long line. It should be broken up and put onto multiple lines. +END + This is a test of a very long line. It should be broken up and put onto + multiple lines. + This is a test of a very long line. It should be broken up and put onto + multiple lines. + + This is a test of a very long line. It should be broken up and put onto + multiple lines. +END +TEST3 +This is a test of a very long line. It should be broken up and put onto multiple lines. +END + This is a test of a very long line. It should be broken up and put onto + multiple lines. +END +TEST4 +This is a test of a very long line. It should be broken up and put onto multiple lines. -$columns = 30; +END + This is a test of a very long line. It should be broken up and put onto + multiple lines. -$text = <<'EOT'; -Text::Wrap is a very simple paragraph formatter. It formats a -single paragraph at a time by breaking lines at word boundries. -Indentation is controlled for the first line ($initial_tab) and -all subsquent lines ($subsequent_tab) independently. $Text::Wrap::columns -should be set to the full width of your output device. -EOT +END +TEST5 +This is a test of a very long line. It should be broken up and put onto multiple This is a test of a very long line. It should be broken up and put +END + This is a test of a very long line. It should be broken up and put onto + multiple This is a test of a very long line. It should be broken up and + put +END +TEST6 +11111111 22222222 33333333 44444444 55555555 66666666 77777777 888888888 999999999 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd eeeeeeeee ffffffff gggggggg hhhhhhhh iiiiiiii jjjjjjjj kkkkkkkk llllllll mmmmmmmmm nnnnnnnnn ooooooooo ppppppppp qqqqqqqqq rrrrrrrrr sssssssss +END + 11111111 22222222 33333333 44444444 55555555 66666666 77777777 888888888 + 999999999 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd eeeeeeeee ffffffff + gggggggg hhhhhhhh iiiiiiii jjjjjjjj kkkkkkkk llllllll mmmmmmmmm nnnnnnnnn + ooooooooo ppppppppp qqqqqqqqq rrrrrrrrr sssssssss +END +TEST7 +c3t1d0s6 c4t1d0s6 c5t1d0s6 c6t1d0s6 c7t1d0s6 c8t1d0s6 c9t1d0s6 c10t1d0s6 c11t1d0s6 c12t1d0s6 c13t1d0s6 c14t1d0s6 c15t1d0s6 c16t1d0s6 c3t1d0s0 c4t1d0s0 c5t1d0s0 c6t1d0s0 c7t1d0s0 c8t1d0s0 c9t1d0s0 c10t1d0s0 c11t1d0s0 c12t1d0s0 c13t1d0s0 c14t1d0s0 c15t1d0s0 c16t1d0s0 +END + c3t1d0s6 c4t1d0s6 c5t1d0s6 c6t1d0s6 c7t1d0s6 c8t1d0s6 c9t1d0s6 c10t1d0s6 + c11t1d0s6 c12t1d0s6 c13t1d0s6 c14t1d0s6 c15t1d0s6 c16t1d0s6 c3t1d0s0 + c4t1d0s0 c5t1d0s0 c6t1d0s0 c7t1d0s0 c8t1d0s0 c9t1d0s0 c10t1d0s0 c11t1d0s0 + c12t1d0s0 c13t1d0s0 c14t1d0s0 c15t1d0s0 c16t1d0s0 +END +TEST8 +A test of a very very long word. +a123456789b123456789c123456789d123456789e123456789f123456789g123456789g1234567 +END + A test of a very very long word. + a123456789b123456789c123456789d123456789e123456789f123456789g123456789g123 + 4567 +END +TEST9 +A test of a very very long word. a123456789b123456789c123456789d123456789e123456789f123456789g123456789g1234567 +END + A test of a very very long word. + a123456789b123456789c123456789d123456789e123456789f123456789g123456789g123 + 4567 +END +DONE -$text =~ s/\n/ /g; -$_ = wrap "| ", "|", $text; -#print "$_\n"; +$| = 1; -print "not " unless /^\| Text::Wrap is/; # start is ok -print "ok 1\n"; +print "1..", @tests/2, "\n"; -print "not " if /^.{31,}$/m; # no line longer than 30 chars -print "ok 2\n"; +use Text::Wrap; -print "not " unless /^\|\w/m; # other lines start with -print "ok 3\n"; +$rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; -print "not " unless /\bsubsquent\b/; # look for a random word -print "ok 4\n"; +$tn = 1; +while (@tests) { + my $in = shift(@tests); + my $out = shift(@tests); -print "not " unless /\bdevice\./; # look for last word -print "ok 5\n"; + $in =~ s/^TEST(\d+)?\n//; + + my $back = wrap(' ', ' ', $in); + + if ($back eq $out) { + print "ok $tn\n"; + } elsif ($rerun) { + my $oi = $in; + foreach ($in, $back, $out) { + s/\t/^I\t/gs; + s/\n/\$\n/gs; + } + print "------------ input ------------\n"; + print $in; + print "\n------------ output -----------\n"; + print $back; + print "\n------------ expected ---------\n"; + print $out; + print "\n-------------------------------\n"; + $Text::Wrap::debug = 1; + wrap(' ', ' ', $oi); + exit(1); + } else { + print "not ok $tn\n"; + } + $tn++; +} diff --git a/contrib/perl5/t/lib/thread.t b/contrib/perl5/t/lib/thread.t index 83407a9..c127d0f 100755 --- a/contrib/perl5/t/lib/thread.t +++ b/contrib/perl5/t/lib/thread.t @@ -24,7 +24,7 @@ sub content } # create a thread passing args and immedaietly wait for it. -my $t = new Thread \&content,("ok 2\n","ok 3\n"); +my $t = new Thread \&content,("ok 2\n","ok 3\n", 1..1000); print $t->join; # check that lock works ... diff --git a/contrib/perl5/t/op/array.t b/contrib/perl5/t/op/array.t index 8dea44d..3409556 100755 --- a/contrib/perl5/t/op/array.t +++ b/contrib/perl5/t/op/array.t @@ -1,6 +1,6 @@ #!./perl -print "1..63\n"; +print "1..65\n"; # # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them @@ -206,3 +206,8 @@ t("@bar" eq "foo bar"); # 43 t("@bee" eq "foo bar burbl blah"); # 63 } +# make sure reification behaves +my $t = 63; +sub reify { $_[1] = ++$t; print "@_\n"; } +reify('ok'); +reify('ok'); diff --git a/contrib/perl5/t/op/die_exit.t b/contrib/perl5/t/op/die_exit.t index ffbb1e0..26b477a 100755 --- a/contrib/perl5/t/op/die_exit.t +++ b/contrib/perl5/t/op/die_exit.t @@ -31,7 +31,7 @@ my %tests = ( 15 => [ 255, 1], 16 => [ 255, 256], # see if implicit close preserves $? - 17 => [ 42, 42, '{ local *F; open F, q[TEST]; close F } die;'], + 17 => [ 0, 512, '{ local *F; open F, q[TEST]; close F } die;'], ); my $max = keys %tests; @@ -46,8 +46,8 @@ foreach my $test (1 .. $max) { ? system qq($perl -e "\$! = $bang; \$? = $query; $code" 2> nul) : system qq($perl -e '\$! = $bang; \$? = $query; $code' 2> /dev/null)); - printf "# 0x%04x 0x%04x 0x%04x\nnot ", $exit, $bang, $query - unless $exit == (($bang || ($query >> 8) || 255) << 8); + printf "# 0x%04x 0x%04x 0x%04x\n", $exit, $bang, $query; + print "not " unless $exit == (($bang || ($query >> 8) || 255) << 8); print "ok $test\n"; } diff --git a/contrib/perl5/t/op/eval.t b/contrib/perl5/t/op/eval.t index 9368281..dc163e9 100755 --- a/contrib/perl5/t/op/eval.t +++ b/contrib/perl5/t/op/eval.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: eval.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:48 $ - -print "1..23\n"; +print "1..36\n"; eval 'print "ok 1\n";'; @@ -79,3 +77,97 @@ eval { }; &$x(); } + +my $b = 'wrong'; +my $X = sub { + my $b = "right"; + print eval('"$b"') eq $b ? "ok 24\n" : "not ok 24\n"; +}; +&$X(); + + +# check navigation of multiple eval boundaries to find lexicals + +my $x = 25; +eval <<'EOT'; die if $@; + print "# $x\n"; # clone into eval's pad + sub do_eval1 { + eval $_[0]; die if $@; + } +EOT +do_eval1('print "ok $x\n"'); +$x++; +do_eval1('eval q[print "ok $x\n"]'); +$x++; +do_eval1('sub { eval q[print "ok $x\n"] }->()'); +$x++; + +# calls from within eval'' should clone outer lexicals + +eval <<'EOT'; die if $@; + sub do_eval2 { + eval $_[0]; die if $@; + } +do_eval2('print "ok $x\n"'); +$x++; +do_eval2('eval q[print "ok $x\n"]'); +$x++; +do_eval2('sub { eval q[print "ok $x\n"] }->()'); +$x++; +EOT + +# calls outside eval'' should NOT clone lexicals from called context + +$main::x = 'ok'; +eval <<'EOT'; die if $@; + # $x unbound here + sub do_eval3 { + eval $_[0]; die if $@; + } +EOT +do_eval3('print "$x ' . $x . '\n"'); +$x++; +do_eval3('eval q[print "$x ' . $x . '\n"]'); +$x++; +do_eval3('sub { eval q[print "$x ' . $x . '\n"] }->()'); +$x++; + +# can recursive subroutine-call inside eval'' see its own lexicals? +sub recurse { + my $l = shift; + if ($l < $x) { + ++$l; + eval 'print "# level $l\n"; recurse($l);'; + die if $@; + } + else { + print "ok $l\n"; + } +} +{ + local $SIG{__WARN__} = sub { die "not ok $x\n" if $_[0] =~ /^Deep recurs/ }; + recurse($x-5); +} +$x++; + +# do closures created within eval bind correctly? +eval <<'EOT'; + sub create_closure { + my $self = shift; + return sub { + print $self; + }; + } +EOT +create_closure("ok $x\n")->(); +$x++; + +# does lexical search terminate correctly at subroutine boundary? +$main::r = "ok $x\n"; +sub terminal { eval 'print $r' } +{ + my $r = "not ok $x\n"; + eval 'terminal($r)'; +} +$x++; + diff --git a/contrib/perl5/t/op/goto.t b/contrib/perl5/t/op/goto.t index 1b34acd..8096aff 100755 --- a/contrib/perl5/t/op/goto.t +++ b/contrib/perl5/t/op/goto.t @@ -1,10 +1,8 @@ #!./perl -# $RCSfile: goto.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:56 $ - # "This IS structured code. It's just randomly structured." -print "1..9\n"; +print "1..13\n"; while ($?) { $foo = 1; @@ -56,7 +54,7 @@ sub bar { exit; FINALE: -print "ok 9\n"; +print "ok 13\n"; exit; bypass: @@ -86,5 +84,22 @@ $wherever = NOWHERE; eval { goto $wherever }; print $@ =~ /Can't find label NOWHERE/ ? "ok 8\n" : "not ok 8\n"; +# see if a modified @_ propagates +{ + package Foo; + sub DESTROY { my $s = shift; print "ok $s->[0]\n"; } + sub show { print "# @_\nnot ok $_[0][0]\n" if @_ != 5; } + sub start { push @_, 1, "foo", {}; goto &show; } + for (9..11) { start(bless([$_]), 'bar'); } +} + +sub auto { + goto &loadit; +} + +sub AUTOLOAD { print @_ } + +auto("ok 12\n"); + $wherever = FINALE; goto $wherever; diff --git a/contrib/perl5/t/op/grep.t b/contrib/perl5/t/op/grep.t new file mode 100755 index 0000000..45d0e25 --- /dev/null +++ b/contrib/perl5/t/op/grep.t @@ -0,0 +1,31 @@ +#!./perl + +# +# grep() and map() tests +# + +print "1..3\n"; + +$test = 1; + +sub ok { + my ($got,$expect) = @_; + print "# expected [$expect], got [$got]\nnot " if $got ne $expect; + print "ok $test\n"; +} + +{ + my @lol = ([qw(a b c)], [], [qw(1 2 3)]); + my @mapped = map {scalar @$_} @lol; + ok "@mapped", "3 0 3"; + $test++; + + my @grepped = grep {scalar @$_} @lol; + ok "@grepped", "$lol[0] $lol[2]"; + $test++; + + @grepped = grep { $_ } @mapped; + ok "@grepped", "3 3"; + $test++; +} + diff --git a/contrib/perl5/t/op/local.t b/contrib/perl5/t/op/local.t index 2f674d1..b478e01 100755 --- a/contrib/perl5/t/op/local.t +++ b/contrib/perl5/t/op/local.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: local.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:04 $ - -print "1..58\n"; +print "1..69\n"; # XXX known to leak scalars $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; @@ -198,3 +196,42 @@ print +($ENV{_X_} eq 'a') ? "" : "not ", "ok 56\n"; print +($ENV{_Y_} eq 'b') ? "" : "not ", "ok 57\n"; print +($ENV{_Z_} eq 'c') ? "" : "not ", "ok 58\n"; +# does implicit localization in foreach skip magic? + +$_ = "ok 59,ok 60,"; +my $iter = 0; +while (/(o.+?),/gc) { + print "$1\n"; + foreach (1..1) { $iter++ } + if ($iter > 2) { print "not ok 60\n"; last; } +} + +{ + package UnderScore; + sub TIESCALAR { bless \my $self, shift } + sub FETCH { die "read \$_ forbidden" } + sub STORE { die "write \$_ forbidden" } + tie $_, __PACKAGE__; + my $t = 61; + my @tests = ( + "Nesting" => sub { print '#'; for (1..3) { print } + print "\n" }, 1, + "Reading" => sub { print }, 0, + "Matching" => sub { $x = /badness/ }, 0, + "Concat" => sub { $_ .= "a" }, 0, + "Chop" => sub { chop }, 0, + "Filetest" => sub { -x }, 0, + "Assignment" => sub { $_ = "Bad" }, 0, + # XXX whether next one should fail is debatable + "Local \$_" => sub { local $_ = 'ok?'; print }, 0, + "for local" => sub { for("#ok?\n"){ print } }, 1, + ); + while ( ($name, $code, $ok) = splice(@tests, 0, 3) ) { + print "# Testing $name\n"; + eval { &$code }; + print(($ok xor $@) ? "ok $t\n" : "not ok $t\n"); + ++$t; + } + untie $_; +} + diff --git a/contrib/perl5/t/op/misc.t b/contrib/perl5/t/op/misc.t index 7292ffe..c9050ef 100755 --- a/contrib/perl5/t/op/misc.t +++ b/contrib/perl5/t/op/misc.t @@ -36,7 +36,9 @@ for (@prgs){ $status = $?; $results = `$CAT $tmpfile`; $results =~ s/\n+$//; - $results =~ s/syntax error/syntax error/i; +# bison says 'parse error' instead of 'syntax error', +# various yaccs may or may not capitalize 'syntax'. + $results =~ s/^(syntax|parse) error/syntax error/mig; $expected =~ s/\n+$//; if ( $results ne $expected){ print STDERR "PROG: $switch\n$prog\n"; @@ -418,3 +420,29 @@ EXPECT destroyed destroyed ######## +BEGIN { + $| = 1; + $SIG{__WARN__} = sub { + eval { print $_[0] }; + die "bar\n"; + }; + warn "foo\n"; +} +EXPECT +foo +bar +BEGIN failed--compilation aborted at - line 8. +######## +use strict; +my $foo = "ZZZ\n"; +END { print $foo } +EXPECT +ZZZ +######## +eval ' +use strict; +my $foo = "ZZZ\n"; +END { print $foo } +'; +EXPECT +ZZZ diff --git a/contrib/perl5/t/op/mkdir.t b/contrib/perl5/t/op/mkdir.t index 5ba0a0f..acf16c1 100755 --- a/contrib/perl5/t/op/mkdir.t +++ b/contrib/perl5/t/op/mkdir.t @@ -15,4 +15,4 @@ print ($! =~ /exist|denied/ ? "ok 3\n" : "# $!\nnot ok 3\n"); print (-d 'blurfl' ? "ok 4\n" : "not ok 4\n"); print (rmdir('blurfl') ? "ok 5\n" : "not ok 5\n"); print (rmdir('blurfl') ? "not ok 6\n" : "ok 6\n"); -print ($! =~ /such|exist/ ? "ok 7\n" : "not ok 7\n"); +print ($! =~ /such|exist|not found/i ? "ok 7\n" : "not ok 7\n"); diff --git a/contrib/perl5/t/op/oct.t b/contrib/perl5/t/op/oct.t index 24b5c43..6623089 100755 --- a/contrib/perl5/t/op/oct.t +++ b/contrib/perl5/t/op/oct.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: oct.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:08 $ - -print "1..8\n"; +print "1..9\n"; print +(oct('01234') == 01234) ? "ok" : "not ok", " 1\n"; print +(oct('0x1234') == 0x1234) ? "ok" : "not ok", " 2\n"; @@ -12,3 +10,4 @@ print +(oct('x80000000') == 0x80000000) ? "ok" : "not ok", " 5\n"; print +(hex('80000000') == 0x80000000) ? "ok" : "not ok", " 6\n"; print +(oct('1234') == 668) ? "ok" : "not ok", " 7\n"; print +(hex('1234') == 4660) ? "ok" : "not ok", " 8\n"; +print +(hex('0x1234') == 0x1234) ? "ok" : "not ok", " 9\n"; diff --git a/contrib/perl5/t/op/pack.t b/contrib/perl5/t/op/pack.t index 9b7bc35..902fc28 100755 --- a/contrib/perl5/t/op/pack.t +++ b/contrib/perl5/t/op/pack.t @@ -1,8 +1,12 @@ #!./perl -# $RCSfile: pack.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:11 $ +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + require Config; import Config; +} -print "1..60\n"; +print "1..142\n"; $format = "c2 x5 C C x s d i l a6"; # Need the expression in here to force ary[5] to be numeric. This avoids @@ -31,7 +35,7 @@ print +($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")) == 9 ? "ok 6\n" : "not ok 6 $x\n"; my $sum = 129; # ASCII -$sum = 103 if ($^O eq 'os390'); # An EBCDIC variant. +$sum = 103 if ($Config{ebcdic} eq 'define'); print +($x = unpack("%32B*", "Now is the time for all good blurfl")) == $sum ? "ok 7\n" : "not ok 7 $x\n"; @@ -160,7 +164,12 @@ foreach my $t (@templates) { # 57..60: uuencode/decode -$in = join "", map { chr } 0..255; +# Note that first uuencoding known 'text' data and then checking the +# binary values of the uuencoded version would not be portable between +# character sets. Uuencoding is meant for encoding binary data, not +# text data. + +$in = pack 'C*', 0 .. 255; # just to be anal, we do some random tr/`/ / $uu = <<'EOUU'; @@ -199,7 +208,150 @@ EOUU print "not " unless unpack('u', $uu) eq $in; print "ok ", $test++, "\n"; -# Note that first uuencoding known 'text' data and then checking the -# binary values of the uuencoded version would not be portable between -# character sets. Uuencoding is meant for encoding binary data, not -# text data. +# 61..72: test the ascii template types (A, a, Z) + +print "not " unless pack('A*', "foo\0bar\0 ") eq "foo\0bar\0 "; +print "ok ", $test++, "\n"; + +print "not " unless pack('A11', "foo\0bar\0 ") eq "foo\0bar\0 "; +print "ok ", $test++, "\n"; + +print "not " unless unpack('A*', "foo\0bar \0") eq "foo\0bar"; +print "ok ", $test++, "\n"; + +print "not " unless unpack('A8', "foo\0bar \0") eq "foo\0bar"; +print "ok ", $test++, "\n"; + +print "not " unless pack('a*', "foo\0bar\0 ") eq "foo\0bar\0 "; +print "ok ", $test++, "\n"; + +print "not " unless pack('a11', "foo\0bar\0 ") eq "foo\0bar\0 \0\0"; +print "ok ", $test++, "\n"; + +print "not " unless unpack('a*', "foo\0bar \0") eq "foo\0bar \0"; +print "ok ", $test++, "\n"; + +print "not " unless unpack('a8', "foo\0bar \0") eq "foo\0bar "; +print "ok ", $test++, "\n"; + +print "not " unless pack('Z*', "foo\0bar\0 ") eq "foo\0bar\0 "; +print "ok ", $test++, "\n"; + +print "not " unless pack('Z11', "foo\0bar\0 ") eq "foo\0bar\0 \0\0"; +print "ok ", $test++, "\n"; + +print "not " unless unpack('Z*', "foo\0bar \0") eq "foo"; +print "ok ", $test++, "\n"; + +print "not " unless unpack('Z8', "foo\0bar \0") eq "foo"; +print "ok ", $test++, "\n"; + +# 73..78: packing native shorts/ints/longs + +# integrated from mainline and don't want to change numbers all the way +# down. native ints are not supported in _0x so comment out checks +#print "not " unless length(pack("s!", 0)) == $Config{shortsize}; +print "ok ", $test++, "\n"; + +#print "not " unless length(pack("i!", 0)) == $Config{intsize}; +print "ok ", $test++, "\n"; + +#print "not " unless length(pack("l!", 0)) == $Config{longsize}; +print "ok ", $test++, "\n"; + +#print "not " unless length(pack("s!", 0)) <= length(pack("i!", 0)); +print "ok ", $test++, "\n"; + +#print "not " unless length(pack("i!", 0)) <= length(pack("l!", 0)); +print "ok ", $test++, "\n"; + +#print "not " unless length(pack("i!", 0)) == length(pack("i", 0)); +print "ok ", $test++, "\n"; + +# 79..138: pack <-> unpack bijectionism + +# 79.. 83 c +foreach my $c (-128, -1, 0, 1, 127) { + print "not " unless unpack("c", pack("c", $c)) == $c; + print "ok ", $test++, "\n"; +} + +# 84.. 88: C +foreach my $C (0, 1, 127, 128, 255) { + print "not " unless unpack("C", pack("C", $C)) == $C; + print "ok ", $test++, "\n"; +} + +# 89.. 93: s +foreach my $s (-32768, -1, 0, 1, 32767) { + print "not " unless unpack("s", pack("s", $s)) == $s; + print "ok ", $test++, "\n"; +} + +# 94.. 98: S +foreach my $S (0, 1, 32767, 32768, 65535) { + print "not " unless unpack("S", pack("S", $S)) == $S; + print "ok ", $test++, "\n"; +} + +# 99..103: i +foreach my $i (-2147483648, -1, 0, 1, 2147483647) { + print "not " unless unpack("i", pack("i", $i)) == $i; + print "ok ", $test++, "\n"; +} + +# 104..108: I +foreach my $I (0, 1, 2147483647, 2147483648, 4294967295) { + print "not " unless unpack("I", pack("I", $I)) == $I; + print "ok ", $test++, "\n"; +} + +# 109..113: l +foreach my $l (-2147483648, -1, 0, 1, 2147483647) { + print "not " unless unpack("l", pack("l", $l)) == $l; + print "ok ", $test++, "\n"; +} + +# 114..118: L +foreach my $L (0, 1, 2147483647, 2147483648, 4294967295) { + print "not " unless unpack("L", pack("L", $L)) == $L; + print "ok ", $test++, "\n"; +} + +# 119..123: n +foreach my $n (0, 1, 32767, 32768, 65535) { + print "not " unless unpack("n", pack("n", $n)) == $n; + print "ok ", $test++, "\n"; +} + +# 124..128: v +foreach my $v (0, 1, 32767, 32768, 65535) { + print "not " unless unpack("v", pack("v", $v)) == $v; + print "ok ", $test++, "\n"; +} + +# 129..133: N +foreach my $N (0, 1, 2147483647, 2147483648, 4294967295) { + print "not " unless unpack("N", pack("N", $N)) == $N; + print "ok ", $test++, "\n"; +} + +# 134..138: V +foreach my $V (0, 1, 2147483647, 2147483648, 4294967295) { + print "not " unless unpack("V", pack("V", $V)) == $V; + print "ok ", $test++, "\n"; +} + +# 139..142: pack nvNV byteorders + +print "not " unless pack("n", 0xdead) eq "\xde\xad"; +print "ok ", $test++, "\n"; + +print "not " unless pack("v", 0xdead) eq "\xad\xde"; +print "ok ", $test++, "\n"; + +print "not " unless pack("N", 0xdeadbeef) eq "\xde\xad\xbe\xef"; +print "ok ", $test++, "\n"; + +print "not " unless pack("V", 0xdeadbeef) eq "\xef\xbe\xad\xde"; +print "ok ", $test++, "\n"; diff --git a/contrib/perl5/t/op/pat.t b/contrib/perl5/t/op/pat.t index 7d4278f..ed8c778 100755 --- a/contrib/perl5/t/op/pat.t +++ b/contrib/perl5/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..141\n"; +print "1..142\n"; BEGIN { chdir 't' if -d 't'; @@ -595,3 +595,8 @@ print "not " if @_; print "ok $test\n"; $test++; +# see if matching against temporaries (created via pp_helem()) is safe +{ foo => "ok $test\n".$^X }->{foo} =~ /^(.*)\n/g; +print "$1\n"; +$test++; + diff --git a/contrib/perl5/t/op/range.t b/contrib/perl5/t/op/range.t index 7999b86..01f5f70 100755 --- a/contrib/perl5/t/op/range.t +++ b/contrib/perl5/t/op/range.t @@ -1,6 +1,6 @@ #!./perl -print "1..10\n"; +print "1..12\n"; print join(':',1..5) eq '1:2:3:4:5' ? "ok 1\n" : "not ok 1\n"; @@ -46,3 +46,12 @@ foreach ('09'..'08') { print "not " unless join(",", @y) eq join(",", @x); print "ok 10\n"; +# check bounds +@a = 0x7ffffffe..0x7fffffff; +print "not " unless "@a" eq "2147483646 2147483647"; +print "ok 11\n"; + +@a = -0x7fffffff..-0x7ffffffe; +print "not " unless "@a" eq "-2147483647 -2147483646"; +print "ok 12\n"; + diff --git a/contrib/perl5/t/op/re_tests b/contrib/perl5/t/op/re_tests index a5295f5..3471cc3 100644 --- a/contrib/perl5/t/op/re_tests +++ b/contrib/perl5/t/op/re_tests @@ -335,6 +335,9 @@ a(?:b|(c|e){1,2}?|d)+?(.) ace y $1$2 ce ^(a(?(1)\1)){4}$ aaaaaaaaaa y $1 aaaa ^(a(?(1)\1)){4}$ aaaaaaaaa n - - ^(a(?(1)\1)){4}$ aaaaaaaaaaa n - - +((a{4})+) aaaaaaaaa y $1 aaaaaaaa +(((aa){2})+) aaaaaaaaaa y $1 aaaaaaaa +(((a{2}){2})+) aaaaaaaaaa y $1 aaaaaaaa (?:(f)(o)(o)|(b)(a)(r))* foobar y $1:$2:$3:$4:$5:$6 f:o:o:b:a:r (?<=a)b ab y $& b (?<=a)b cb n - - @@ -483,3 +486,6 @@ b\Z a\nb\n y - - b\z a\nb\n n - - b\Z a\nb y - - b\z a\nb y - - +(^|x)(c) ca y $2 c +a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz x n - - +round\(((?>[^()]+))\) _I(round(xs * sz),1) y $1 xs * sz diff --git a/contrib/perl5/t/op/repeat.t b/contrib/perl5/t/op/repeat.t index 54fa590..f935bf1 100755 --- a/contrib/perl5/t/op/repeat.t +++ b/contrib/perl5/t/op/repeat.t @@ -2,7 +2,7 @@ # $RCSfile: repeat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:21 $ -print "1..19\n"; +print "1..20\n"; # compile time @@ -40,3 +40,54 @@ print join(':', () x 4) eq '' ? "ok 16\n" : "not ok 16\n"; print join(':', (9) x 4) eq '9:9:9:9' ? "ok 17\n" : "not ok 17\n"; print join(':', (9,9) x 4) eq '9:9:9:9:9:9:9:9' ? "ok 18\n" : "not ok 18\n"; print join('', (split(//,"123")) x 2) eq '123123' ? "ok 19\n" : "not ok 19\n"; + +# +# The test #20 is actually testing for Digital C compiler optimizer bug. +# +# Dec C versions 5.* and 6.0 (used in Digital UNIX and VMS) used +# to produce (as of December 1998) broken code for util.c:repeatcpy() +# (a utility function for the 'x' operator) in the case *all* these +# four conditions held: +# +# (1) len == 1 +# (2) "from" had the 8th bit on in its single character +# (3) count > 7 (the 'x' count > 16) +# (4) the highest optimization level was used in compilation +# (which is the default when compiling Perl) +# +# The bug looked like this (. being the eight-bit character and ? being \xff): +# +# 16 ................ +# 17 .........???????. +# 18 .........???????.. +# 19 .........???????... +# 20 .........???????.... +# 21 .........???????..... +# 22 .........???????...... +# 23 .........???????....... +# 24 .........???????.??????? +# 25 .........???????.???????. +# +# The bug could be (obscurely) avoided by changing "from" to +# be an unsigned char pointer. +# +# The bug was triggered in the "if (len == 1)" branch. The fix +# was to introduce a new temporary variable. In diff -u format: +# +# register char *frombase = from; +# +# if (len == 1) { +#- todo = *from; +#+ register char c = *from; +# while (count-- > 0) +#- *to++ = todo; +#+ *to++ = c; +# return; +# } +# +# This obscure bug was not found by the then test suite but instead +# by Mark.Martinec@nsc.ijs.si while trying to install Digest-MD5-2.00. +# +# jhi@iki.fi +# +print "\xdd" x 24 eq "\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd" ? "ok 20\n" : "not ok 20\n"; diff --git a/contrib/perl5/t/op/runlevel.t b/contrib/perl5/t/op/runlevel.t index 307e2a0..bff3c36 100755 --- a/contrib/perl5/t/op/runlevel.t +++ b/contrib/perl5/t/op/runlevel.t @@ -315,3 +315,23 @@ main|-|9|main::__ANON__ In DIE main|-|10|(eval) main|-|10|main::foo +######## +package TEST; + +sub TIEARRAY { + return bless [qw(foo fee fie foe)], $_[0]; +} +sub FETCH { + my ($s,$i) = @_; + if ($i) { + goto bbb; + } +bbb: + return $s->[$i]; +} + +package main; +tie my @bar, 'TEST'; +print join('|', @bar[0..3]), "\n"; +EXPECT +foo|fee|fie|foe diff --git a/contrib/perl5/t/op/sort.t b/contrib/perl5/t/op/sort.t index 70341b9..fdb4e34 100755 --- a/contrib/perl5/t/op/sort.t +++ b/contrib/perl5/t/op/sort.t @@ -1,8 +1,9 @@ #!./perl -# $RCSfile: sort.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:24 $ +print "1..29\n"; -print "1..21\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 } @@ -125,3 +126,34 @@ eval <<'CODE'; my @result = sort 'one', 'two'; CODE print $@ ? "not ok 21\n# $@" : "ok 21\n"; + +{ + my $sortsub = \&backwards; + my $sortglob = *backwards; + 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"); + @b = sort $sortglob 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 23\n" : "not ok 23 |@b|\n"); + @b = sort $sortname 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n"); + @b = sort $sortglobr 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n"); +} + +{ + local $sortsub = \&backwards; + local $sortglob = *backwards; + 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"); + @b = sort $sortglob 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n"); + @b = sort $sortname 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n"); + @b = sort $sortglobr 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n"); +} + diff --git a/contrib/perl5/t/op/sysio.t b/contrib/perl5/t/op/sysio.t index 826cf38..22e60e3 100755 --- a/contrib/perl5/t/op/sysio.t +++ b/contrib/perl5/t/op/sysio.t @@ -1,12 +1,13 @@ #!./perl -print "1..36\n"; +print "1..39\n"; chdir('op') || die "sysio.t: cannot look for myself: $!"; open(I, 'sysio.t') || die "sysio.t: cannot find myself: $!"; -$reopen = ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos'); +$reopen = ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos' || + $^O eq 'mpeix'); $x = 'abc'; @@ -151,6 +152,21 @@ if ($reopen) { # must close file to update EOF marker for stat print 'not ' unless (-s $outfile == 7); print "ok 28\n"; +# with implicit length argument +print 'not ' unless (syswrite(O, $x) == 3); +print "ok 29\n"; + +# $a still intact +print 'not ' unless ($x eq "abc"); +print "ok 30\n"; + +# $outfile should have grown now +if ($reopen) { # must close file to update EOF marker for stat + close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; +} +print 'not ' unless (-s $outfile == 10); +print "ok 31\n"; + close(O); open(I, $outfile) || die "sysio.t: cannot read $outfile: $!"; @@ -158,30 +174,30 @@ open(I, $outfile) || die "sysio.t: cannot read $outfile: $!"; $b = 'xyz'; # reading too much only return as much as available -print 'not ' unless (sysread(I, $b, 100) == 7); -print "ok 29\n"; +print 'not ' unless (sysread(I, $b, 100) == 10); +print "ok 32\n"; # this we should have -print 'not ' unless ($b eq '#!ererl'); -print "ok 30\n"; +print 'not ' unless ($b eq '#!ererlabc'); +print "ok 33\n"; # test sysseek print 'not ' unless sysseek(I, 2, 0) == 2; -print "ok 31\n"; +print "ok 34\n"; sysread(I, $b, 3); print 'not ' unless $b eq 'ere'; -print "ok 32\n"; +print "ok 35\n"; print 'not ' unless sysseek(I, -2, 1) == 3; -print "ok 33\n"; +print "ok 36\n"; sysread(I, $b, 4); print 'not ' unless $b eq 'rerl'; -print "ok 34\n"; +print "ok 37\n"; print 'not ' unless sysseek(I, 0, 0) eq '0 but true'; -print "ok 35\n"; +print "ok 38\n"; print 'not ' if defined sysseek(I, -1, 1); -print "ok 36\n"; +print "ok 39\n"; close(I); diff --git a/contrib/perl5/t/op/taint.t b/contrib/perl5/t/op/taint.t index d2cae8e..379093f 100755 --- a/contrib/perl5/t/op/taint.t +++ b/contrib/perl5/t/op/taint.t @@ -366,7 +366,10 @@ else { test 72, $@ eq '', $@; # NB: This should be allowed # Try first new style but allow also old style. - test 73, $!{ENOENT} || $! == 2 || ($Is_Dos && $! == 22); # File not found + test 73, $!{ENOENT} || + $! == 2 || # File not found + ($Is_Dos && $! == 22) || + ($^O eq 'mint' && $! == 33); test 74, eval { open FOO, "> $foo" } eq '', 'open for write'; test 75, $@ =~ /^Insecure dependency/, $@; diff --git a/contrib/perl5/t/op/tie.t b/contrib/perl5/t/op/tie.t index 77e74db..472a6a7 100755 --- a/contrib/perl5/t/op/tie.t +++ b/contrib/perl5/t/op/tie.t @@ -153,3 +153,16 @@ $C = $B = tied %H ; } untie %H; EXPECT +######## + +# verify no leak when underlying object is selfsame tied variable +my ($a, $b); +sub Self::TIEHASH { bless $_[1], $_[0] } +sub Self::DESTROY { $b = $_[0] + 0; } +{ + my %b5; + $a = \%b5 + 0; + tie %b5, 'Self', \%b5; +} +die unless $a == $b; +EXPECT diff --git a/contrib/perl5/t/op/tiehandle.t b/contrib/perl5/t/op/tiehandle.t index e3d2472..d7e6a78 100755 --- a/contrib/perl5/t/op/tiehandle.t +++ b/contrib/perl5/t/op/tiehandle.t @@ -64,7 +64,7 @@ sub READ { sub WRITE { compare(WRITE => @_); $data = substr($_[1],$_[3] || 0, $_[2]); - 4; + length($data); } sub CLOSE { @@ -77,7 +77,7 @@ package main; use Symbol; -print "1..23\n"; +print "1..29\n"; my $fh = gensym; @@ -132,6 +132,20 @@ $r = syswrite $fh,$buf,4,1; ok($r == 4); ok($data eq "wert"); +$buf = "qwerty"; +@expect = (WRITE => $ob, $buf, 4); +$data = ""; +$r = syswrite $fh,$buf,4; +ok($r == 4); +ok($data eq "qwer"); + +$buf = "qwerty"; +@expect = (WRITE => $ob, $buf, 6); +$data = ""; +$r = syswrite $fh,$buf; +ok($r == 6); +ok($data eq "qwerty"); + @expect = (CLOSE => $ob); $r = close $fh; ok($r == 5); diff --git a/contrib/perl5/t/op/tr.t b/contrib/perl5/t/op/tr.t new file mode 100755 index 0000000..3503c3c --- /dev/null +++ b/contrib/perl5/t/op/tr.t @@ -0,0 +1,33 @@ +# tr.t + +print "1..4\n"; + +$_ = "abcdefghijklmnopqrstuvwxyz"; + +tr/a-z/A-Z/; + +print "not " unless $_ eq "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; +print "ok 1\n"; + +tr/A-Z/a-z/; + +print "not " unless $_ eq "abcdefghijklmnopqrstuvwxyz"; +print "ok 2\n"; + +tr/b-y/B-Y/; + +print "not " unless $_ eq "aBCDEFGHIJKLMNOPQRSTUVWXYz"; +print "ok 3\n"; + +# In EBCDIC 'I' is \xc9 and 'J' is \0xd1, 'i' is \x89 and 'j' is \x91. +# Yes, discontinuities. Regardless, the \xca in the below should stay +# untouched (and not became \x8a). + +$_ = "I\xcaJ"; + +tr/I-J/i-j/; + +print "not " unless $_ eq "i\xcaj"; +print "ok 4\n"; + +# diff --git a/contrib/perl5/t/op/undef.t b/contrib/perl5/t/op/undef.t index 8ab2ec4..5b3c7ef 100755 --- a/contrib/perl5/t/op/undef.t +++ b/contrib/perl5/t/op/undef.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: undef.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:34 $ - -print "1..21\n"; +print "1..23\n"; print defined($a) ? "not ok 1\n" : "ok 1\n"; @@ -54,3 +52,10 @@ sub foo { print "ok 19\n"; } print defined &foo ? "ok 20\n" : "not ok 20\n"; undef &foo; print defined(&foo) ? "not ok 21\n" : "ok 21\n"; + +eval { undef $1 }; +print $@ =~ /^Modification of a read/ ? "ok 22\n" : "not ok 22\n"; + +eval { $1 = undef }; +print $@ =~ /^Modification of a read/ ? "ok 23\n" : "not ok 23\n"; + diff --git a/contrib/perl5/t/op/write.t b/contrib/perl5/t/op/write.t index 705fa79..9918b2f 100755 --- a/contrib/perl5/t/op/write.t +++ b/contrib/perl5/t/op/write.t @@ -2,7 +2,7 @@ # $RCSfile: write.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:38 $ -print "1..5\n"; +print "1..6\n"; my $CAT = ($^O eq 'MSWin32') ? 'type' : 'cat'; @@ -167,3 +167,26 @@ for (0..10) { print $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n"; print $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n"; +$^A = ''; + +# more test + +format OUT3 = +^<<<<<<... +$foo +. + +open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp"; + +$foo = 'fit '; +write(OUT3); +close OUT3; + +$right = +"fit\n"; + +if (`$CAT Op_write.tmp` eq $right) + { print "ok 6\n"; unlink 'Op_write.tmp'; } +else + { print "not ok 6\n"; } + diff --git a/contrib/perl5/t/pragma/constant.t b/contrib/perl5/t/pragma/constant.t index 0b58bae..5b63dfa 100755 --- a/contrib/perl5/t/pragma/constant.t +++ b/contrib/perl5/t/pragma/constant.t @@ -14,7 +14,7 @@ END { print @warnings } ######################### We start with some black magic to print on failure. -BEGIN { $| = 1; print "1..39\n"; } +BEGIN { $| = 1; print "1..46\n"; } END {print "not ok 1\n" unless $loaded;} use constant; $loaded = 1; @@ -139,3 +139,19 @@ test 37, @warnings && test 38, @warnings == 0, "unexpected warning"; test 39, $^W & 1, "Who disabled the warnings?"; + +use constant CSCALAR => \"ok 40\n"; +use constant CHASH => { foo => "ok 41\n" }; +use constant CARRAY => [ undef, "ok 42\n" ]; +use constant CPHASH => [ { foo => 1 }, "ok 43\n" ]; +use constant CCODE => sub { "ok $_[0]\n" }; + +print ${+CSCALAR}; +print CHASH->{foo}; +print CARRAY->[1]; +print CPHASH->{foo}; +eval q{ CPHASH->{bar} }; +test 44, scalar($@ =~ /^No such array/); +print CCODE->(45); +eval q{ CCODE->{foo} }; +test 46, scalar($@ =~ /^Constant is not a HASH/); diff --git a/contrib/perl5/t/pragma/locale.t b/contrib/perl5/t/pragma/locale.t index 00baa66..7e3df8c 100755 --- a/contrib/perl5/t/pragma/locale.t +++ b/contrib/perl5/t/pragma/locale.t @@ -23,6 +23,9 @@ eval { # and mingw32 uses said silly CRT $have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i; +# 103 (the last test) may fail but that is okay. +# (It indicates something broken in the environment, not Perl) +# Therefore .. only until 102, not 103. print "1..", ($have_setlocale ? 102 : 98), "\n"; use vars qw($a @@ -404,6 +407,7 @@ print "ok 101\n"; # Test for read-onlys. +print "# testing 102\n"; { no locale; $a = "qwerty"; @@ -419,7 +423,7 @@ print "ok 102\n"; # Thanks to Hallvard Furuseth <h.b.furuseth@usit.uio.no> # for inventing a way to test for ordering consistency # without requiring any particular order. -# ++$jhi;#@iki.fi +# <jhi@iki.fi> print "# testing 103\n"; { diff --git a/contrib/perl5/t/pragma/overload.t b/contrib/perl5/t/pragma/overload.t index afba8a3..0682266 100755 --- a/contrib/perl5/t/pragma/overload.t +++ b/contrib/perl5/t/pragma/overload.t @@ -694,5 +694,17 @@ test($c, "bareword"); # 135 test( scalar ($seven =~ /i/), '1') } +{ + package sorting; + use overload 'cmp' => \∁ + sub new { my ($p, $v) = @_; bless \$v, $p } + sub comp { my ($x,$y) = @_; ($$x * 3 % 10) <=> ($$y * 3 % 10) or $$x cmp $$y } +} +{ + my @arr = map sorting->new($_), 0..12; + my @sorted1 = sort @arr; + my @sorted2 = map $$_, @sorted1; + test "@sorted2", '0 10 7 4 1 11 8 5 12 2 9 6 3'; +} # Last test is: -sub last {173} +sub last {174} diff --git a/contrib/perl5/t/pragma/subs.t b/contrib/perl5/t/pragma/subs.t index 680564f..6ebbf78 100755 --- a/contrib/perl5/t/pragma/subs.t +++ b/contrib/perl5/t/pragma/subs.t @@ -55,7 +55,9 @@ for (@prgs){ # allow expected output to be written as if $prog is on STDIN $results =~ s/tmp\d+/-/g; $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg - $results =~ s/Syntax/syntax/; # non-standard yacc +# bison says 'parse error' instead of 'syntax error', +# various yaccs may or may not capitalize 'syntax'. + $results =~ s/^(syntax|parse) error/syntax error/mig; $expected =~ s/\n+$//; my $prefix = ($results =~ s/^PREFIX\n//) ; if ( $results =~ s/^SKIPPED\n//) { diff --git a/contrib/perl5/t/pragma/warn-1global b/contrib/perl5/t/pragma/warn-1global index 07b5bc8..a7ca607 100644 --- a/contrib/perl5/t/pragma/warn-1global +++ b/contrib/perl5/t/pragma/warn-1global @@ -12,12 +12,14 @@ EXPECT $a =+ 3 ; EXPECT Reversed += operator at - line 3. +Name "main::a" used only once: possible typo at - line 3. ######## #! perl -w # warnable code, warnings enabled via #! line $a =+ 3 ; EXPECT Reversed += operator at - line 3. +Name "main::a" used only once: possible typo at - line 3. ######## # warnable code, warnings enabled via compile time $^W @@ -25,6 +27,7 @@ BEGIN { $^W = 1 } $a =+ 3 ; EXPECT Reversed += operator at - line 4. +Name "main::a" used only once: possible typo at - line 4. ######## # compile-time warnable code, warnings enabled via runtime $^W @@ -149,3 +152,8 @@ Use of uninitialized value at - line 5. -e undef EXPECT Use of uninitialized value at - line 2. +######## +BEGIN { $^W = 1 } +for (@{[0]}) { "$_" } # check warning isn't duplicated +EXPECT +Useless use of string in void context at - line 2. diff --git a/contrib/perl5/t/pragma/warning.t b/contrib/perl5/t/pragma/warning.t index fa0301e..35d9d48 100755 --- a/contrib/perl5/t/pragma/warning.t +++ b/contrib/perl5/t/pragma/warning.t @@ -4,11 +4,12 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; $ENV{PERL5LIB} = '../lib'; + require Config; import Config; } $| = 1; -my $Is_VMS = $^O eq 'VMS'; +my $Is_VMS = $^O eq 'VMS'; my $Is_MSWin32 = $^O eq 'MSWin32'; my $tmpfile = "tmp0000"; my $i = 0 ; @@ -19,6 +20,8 @@ my @prgs = () ; foreach (sort glob("pragma/warn-*")) { + next if /\.orig$/ ; + next if /(~|\.orig)$/; open F, "<$_" or die "Cannot open $_: $!\n" ; @@ -76,13 +79,29 @@ for (@prgs){ # allow expected output to be written as if $prog is on STDIN $results =~ s/tmp\d+/-/g; $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg +# bison says 'parse error' instead of 'syntax error', +# various yaccs may or may not capitalize 'syntax'. + $results =~ s/^(syntax|parse) error/syntax error/mig; $expected =~ s/\n+$//; my $prefix = ($results =~ s/^PREFIX\n//) ; + # any special options? (OPTIONS foo bar zap) + my $option_regex = 0; + if ($expected =~ s/^OPTIONS? (.+)\n//) { + foreach my $option (split(' ', $1)) { + if ($option eq 'regex') { # allow regular expressions + $option_regex = 1; + } else { + die "$0: Unknown OPTION '$option'\n"; + } + } + } if ( $results =~ s/^SKIPPED\n//) { print "$results\n" ; } - elsif (($prefix and $results !~ /^\Q$expected/) or - (!$prefix and $results ne $expected)){ + elsif (($prefix && (( $option_regex && $results !~ /^$expected/) || + (!$option_regex && $results !~ /^\Q$expected/))) or + (!$prefix && (( $option_regex && $results !~ /^$expected/) || + (!$option_regex && $results ne $expected)))) { print STDERR "PROG: $switch\n$prog\n"; print STDERR "EXPECTED:\n$expected\n"; print STDERR "GOT:\n$results\n"; diff --git a/contrib/perl5/taint.c b/contrib/perl5/taint.c index 4c031de..d5f8339 100644 --- a/contrib/perl5/taint.c +++ b/contrib/perl5/taint.c @@ -17,6 +17,8 @@ taint_proper(const char *f, char *s) "%s %d %d %d\n", s, PL_tainted, PL_uid, PL_euid)); if (PL_tainted) { + if (!f) + f = no_security; if (PL_euid != PL_uid) ug = " while running setuid"; else if (PL_egid != PL_gid) @@ -44,7 +46,11 @@ taint_env(void) NULL }; + if(!PL_envgv) + return; + #ifdef VMS + { int i = 0; char name[10 + TYPE_DIGITS(int)] = "DCL$PATH"; @@ -66,6 +72,7 @@ taint_env(void) } i++; } + } #endif /* VMS */ svp = hv_fetch(GvHVn(PL_envgv),"PATH",4,FALSE); @@ -87,9 +94,10 @@ taint_env(void) svp = hv_fetch(GvHVn(PL_envgv),"TERM",4,FALSE); if (svp && *svp && SvTAINTED(*svp)) { dTHR; /* just for taint */ + STRLEN n_a; bool was_tainted = PL_tainted; - char *t = SvPV(*svp, PL_na); - char *e = t + PL_na; + char *t = SvPV(*svp, n_a); + char *e = t + n_a; PL_tainted = was_tainted; if (t < e && isALNUM(*t)) t++; diff --git a/contrib/perl5/thread.h b/contrib/perl5/thread.h index 3eb061a..089077c 100644 --- a/contrib/perl5/thread.h +++ b/contrib/perl5/thread.h @@ -35,6 +35,68 @@ # endif #endif +#ifdef I_MACH_CTHREADS + +/* cthreads interface */ + +/* #include <mach/cthreads.h> is in perl.h #ifdef I_MACH_CTHREADS */ + +#define MUTEX_INIT(m) \ + STMT_START { \ + *m = mutex_alloc(); \ + if (*m) { \ + mutex_init(*m); \ + } else { \ + croak("panic: MUTEX_INIT"); \ + } \ + } STMT_END + +#define MUTEX_LOCK(m) mutex_lock(*m) +#define MUTEX_UNLOCK(m) mutex_unlock(*m) +#define MUTEX_DESTROY(m) \ + STMT_START { \ + mutex_free(*m); \ + *m = 0; \ + } STMT_END + +#define COND_INIT(c) \ + STMT_START { \ + *c = condition_alloc(); \ + if (*c) { \ + condition_init(*c); \ + } else { \ + croak("panic: COND_INIT"); \ + } \ + } STMT_END + +#define COND_SIGNAL(c) condition_signal(*c) +#define COND_BROADCAST(c) condition_broadcast(*c) +#define COND_WAIT(c, m) condition_wait(*c, *m) +#define COND_DESTROY(c) \ + STMT_START { \ + condition_free(*c); \ + *c = 0; \ + } STMT_END + +#define THREAD_CREATE(thr, f) (thr->self = cthread_fork(f, thr), 0) +#define THREAD_POST_CREATE(thr) + +#define THREAD_RET_TYPE any_t +#define THREAD_RET_CAST(x) ((any_t) x) + +#define DETACH(t) cthread_detach(t->self) +#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 INIT_THREADS cthread_init() +#define YIELD cthread_yield() +#define ALLOC_THREAD_KEY +#define SET_THREAD_SELF(thr) (thr->self = cthread_self()) + +#endif /* I_MACH_CTHREADS */ + #ifndef YIELD # ifdef HAS_SCHED_YIELD # define YIELD sched_yield() @@ -45,12 +107,26 @@ # endif #endif +#ifdef __hpux +# define MUTEX_INIT_NEEDS_MUTEX_ZEROED +#endif + #ifndef MUTEX_INIT +#ifdef MUTEX_INIT_NEEDS_MUTEX_ZEROED + /* Temporary workaround, true bug is deeper. --jhi 1999-02-25 */ +#define MUTEX_INIT(m) \ + STMT_START { \ + Zero((m), 1, perl_mutex); \ + if (pthread_mutex_init((m), pthread_mutexattr_default)) \ + croak("panic: MUTEX_INIT"); \ + } STMT_END +#else #define MUTEX_INIT(m) \ STMT_START { \ if (pthread_mutex_init((m), pthread_mutexattr_default)) \ croak("panic: MUTEX_INIT"); \ } STMT_END +#endif #define MUTEX_LOCK(m) \ STMT_START { \ if (pthread_mutex_lock((m))) \ @@ -138,6 +214,8 @@ struct perl_thread *getTHR _((void)); * from thrsv which is cached in the per-interpreter structure. * Systems with very fast pthread_get_specific (which should be all systems * but unfortunately isn't) may wish to simplify to "...*thr = THR". + * + * The use of PL_threadnum should be safe here. */ #ifndef dTHR # define dTHR \ @@ -160,17 +238,27 @@ struct perl_thread *getTHR _((void)); * try only locking them if there may be more than one thread in existence. * Systems with very fast mutexes (and/or slow conditionals) may wish to * remove the "if (threadnum) ..." test. + * XXX do NOT use C<if (PL_threadnum) ...> -- it sets up race conditions! */ -#define LOCK_SV_MUTEX \ - STMT_START { \ - if (PL_threadnum) \ - MUTEX_LOCK(&PL_sv_mutex); \ +#define LOCK_SV_MUTEX \ + STMT_START { \ + MUTEX_LOCK(&PL_sv_mutex); \ } STMT_END -#define UNLOCK_SV_MUTEX \ - STMT_START { \ - if (PL_threadnum) \ - MUTEX_UNLOCK(&PL_sv_mutex); \ +#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 @@ -223,6 +311,8 @@ typedef struct condpair { #define COND_DESTROY(c) #define LOCK_SV_MUTEX #define UNLOCK_SV_MUTEX +#define LOCK_STRTAB_MUTEX +#define UNLOCK_STRTAB_MUTEX #define THR /* Rats: if dTHR is just blank then the subsequent ";" throws an error */ diff --git a/contrib/perl5/toke.c b/contrib/perl5/toke.c index c069978..52a42af 100644 --- a/contrib/perl5/toke.c +++ b/contrib/perl5/toke.c @@ -1,6 +1,6 @@ /* toke.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -53,6 +53,9 @@ static void restore_rsfp _((void *f)); static SV *new_constant _((char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)); static void restore_expect _((void *e)); static void restore_lex_expect _((void *e)); + +static char *PL_super_bufptr; +static char *PL_super_bufend; #endif /* PERL_OBJECT */ static char ident_too_long[] = "Identifier too long"; @@ -382,13 +385,20 @@ skipspace(register char *s) } for (;;) { STRLEN prevlen; - while (s < PL_bufend && isSPACE(*s)) - s++; + while (s < PL_bufend && isSPACE(*s)) { + if (*s++ == '\n' && PL_in_eval && !PL_rsfp) + incline(s); + } if (s < PL_bufend && *s == '#') { while (s < PL_bufend && *s != '\n') s++; - if (s < PL_bufend) + if (s < PL_bufend) { s++; + if (PL_in_eval && !PL_rsfp) { + incline(s); + continue; + } + } } if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL) return s; @@ -862,6 +872,7 @@ scan_const(char *start) /* expand a range A-Z to the full set of characters. AIE! */ if (dorange) { I32 i; /* current expanded character */ + I32 min; /* first character in range */ I32 max; /* last character in range */ i = d - SvPVX(sv); /* remember current offset */ @@ -869,10 +880,26 @@ scan_const(char *start) d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */ d -= 2; /* eat the first char and the - */ - max = (U8)d[1]; /* last char in range */ - - for (i = (U8)*d; i <= max; i++) - *d++ = i; + min = (U8)*d; /* first char in range */ + max = (U8)d[1]; /* last char in range */ + +#ifndef ASCIIish + if ((isLOWER(min) && isLOWER(max)) || + (isUPPER(min) && isUPPER(max))) { + if (isLOWER(min)) { + for (i = min; i <= max; i++) + if (isLOWER(i)) + *d++ = i; + } else { + for (i = min; i <= max; i++) + if (isUPPER(i)) + *d++ = i; + } + } + else +#endif + for (i = min; i <= max; i++) + *d++ = i; /* mark the range as done, and continue */ dorange = FALSE; @@ -1284,7 +1311,9 @@ incl_perldb(void) * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for * private use must be set using malloc'd pointers. */ +#ifndef PERL_OBJECT static int filter_debug = 0; +#endif SV * filter_add(filter_t funcp, SV *datasv) @@ -1300,8 +1329,10 @@ filter_add(filter_t funcp, SV *datasv) if (!SvUPGRADE(datasv, SVt_PVIO)) die("Can't upgrade filter_add data to SVt_PVIO"); IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */ - if (filter_debug) - warn("filter_add func %p (%s)", funcp, SvPV(datasv,PL_na)); + if (filter_debug) { + STRLEN n_a; + warn("filter_add func %p (%s)", funcp, SvPV(datasv,n_a)); + } av_unshift(PL_rsfp_filters, 1); av_store(PL_rsfp_filters, 0, datasv) ; return(datasv); @@ -1317,7 +1348,7 @@ filter_del(filter_t funcp) if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0) return; /* if filter is on top of stack (usual case) just pop it off */ - if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (void*)funcp){ + if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){ sv_free(av_pop(PL_rsfp_filters)); return; @@ -1377,9 +1408,11 @@ filter_read(int idx, SV *buf_sv, int maxlen) } /* Get function pointer hidden within datasv */ funcp = (filter_t)IoDIRP(datasv); - if (filter_debug) + if (filter_debug) { + STRLEN n_a; warn("filter_read %d: via function %p (%s)\n", - idx, funcp, SvPV(datasv,PL_na)); + idx, funcp, SvPV(datasv,n_a)); + } /* Call function. The function is expected to */ /* call "FILTER_READ(idx+1, buf_sv)" first. */ /* Return: <0:error, =0:eof, >0:not eof */ @@ -1955,7 +1988,7 @@ yylex(void) else newargv = PL_origargv; newargv[0] = ipath; - execv(ipath, newargv); + PerlProc_execv(ipath, newargv); croak("Can't exec %s", ipath); } if (d) { @@ -2443,7 +2476,11 @@ yylex(void) } if (PL_lex_brackets < PL_lex_formbrack) { char *t; +#ifdef PERL_STRICT_CR for (t = s; *t == ' ' || *t == '\t'; t++) ; +#else + for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ; +#endif if (*t == '\n' || *t == '#') { s--; PL_expect = XBLOCK; @@ -2567,7 +2604,8 @@ yylex(void) for (t++; isSPACE(*t); t++) ; if (isIDFIRST(*t)) { t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len); - if (*t != '(' && perl_get_cv(tmpbuf, FALSE)) + for (; isSPACE(*t); t++) ; + if (*t == ';' && perl_get_cv(tmpbuf, FALSE)) warn("You need to quote \"%s\"", tmpbuf); } } @@ -2613,9 +2651,9 @@ yylex(void) PL_expect = XTERM; /* e.g. print $fh 3 */ else if (*s == '.' && isDIGIT(s[1])) PL_expect = XTERM; /* e.g. print $fh .3 */ - else if (strchr("/?-+", *s) && !isSPACE(s[1])) + else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=') PL_expect = XTERM; /* e.g. print $fh -1 */ - else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])) + else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=') PL_expect = XTERM; /* print $fh <<"EOF" */ } PL_pending_ident = '$'; @@ -2672,8 +2710,14 @@ yylex(void) OPERATOR(tmp); case '.': - if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack && s[1] == '\n' && - (s == PL_linestart || s[-1] == '\n') ) { + if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack +#ifdef PERL_STRICT_CR + && s[1] == '\n' +#else + && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n')) +#endif + && (s == PL_linestart || s[-1] == '\n') ) + { PL_lex_formbrack = 0; PL_expect = XSTATE; goto rightbracket; @@ -2794,6 +2838,7 @@ yylex(void) case 'z': case 'Z': keylookup: { + STRLEN n_a; gv = Nullgv; gvp = 0; @@ -2868,7 +2913,8 @@ yylex(void) tmp = -tmp; gv = Nullgv; gvp = 0; - if (PL_dowarn && hgv) + if (PL_dowarn && hgv + && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */ warn("Ambiguous call resolved as CORE::%s(), %s", GvENAME(hgv), "qualify as such or use &"); } @@ -2985,8 +3031,11 @@ yylex(void) if (*s == '(') { CLINE; if (gv && GvCVu(gv)) { + CV *cv; + if ((cv = GvCV(gv)) && SvPOK(cv)) + PL_last_proto = SvPV((SV*)cv, n_a); for (d = s + 1; *d == ' ' || *d == '\t'; d++) ; - if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) { + if (*d == ')' && (sv = cv_const_sv(cv))) { s = d + 1; goto its_constant; } @@ -2995,6 +3044,7 @@ yylex(void) PL_expect = XOPERATOR; force_next(WORD); yylval.ival = 0; + PL_last_lop_op = OP_ENTERSUB; TOKEN('&'); } @@ -3033,6 +3083,7 @@ yylex(void) /* Resolve to GV now. */ op_free(yylval.opval); yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv)); + PL_last_lop_op = OP_ENTERSUB; /* Is there a prototype? */ if (SvPOK(cv)) { STRLEN len; @@ -3059,7 +3110,10 @@ yylex(void) PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */ PL_last_lop_op != OP_ACCEPT && PL_last_lop_op != OP_PIPE_OP && - PL_last_lop_op != OP_SOCKPAIR) + PL_last_lop_op != OP_SOCKPAIR && + !(PL_last_lop_op == OP_ENTERSUB + && PL_last_proto + && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) { warn( "Bareword \"%s\" not allowed while \"strict subs\" in use", @@ -3935,7 +3989,7 @@ yylex(void) PL_lex_stuff = Nullsv; } - if (*SvPV(PL_subname,PL_na) == '?') { + if (*SvPV(PL_subname,n_a) == '?') { sv_setpv(PL_subname,"__ANON__"); TOKEN(ANONSUB); } @@ -5074,6 +5128,9 @@ scan_subst(char *start) if (es) { SV *repl; + PL_super_bufptr = s; + PL_super_bufend = PL_bufend; + PL_multi_end = 0; pm->op_pmflags |= PMf_EVAL; repl = newSVpv("",0); while (es-- > 0) @@ -5236,7 +5293,33 @@ scan_heredoc(register char *s) PL_multi_start = PL_curcop->cop_line; PL_multi_open = PL_multi_close = '<'; term = *PL_tokenbuf; - if (!outer) { + if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) { + char *bufptr = PL_super_bufptr; + char *bufend = PL_super_bufend; + char *olds = s - SvCUR(herewas); + s = strchr(bufptr, '\n'); + if (!s) + s = bufend; + d = s; + while (s < bufend && + (*s != term || memNE(s,PL_tokenbuf,len)) ) { + if (*s++ == '\n') + PL_curcop->cop_line++; + } + if (s >= bufend) { + PL_curcop->cop_line = PL_multi_start; + missingterm(PL_tokenbuf); + } + sv_setpvn(herewas,bufptr,d-bufptr+1); + sv_setpvn(tmpstr,d+1,s-d); + s += len - 1; + sv_catpvn(herewas,s,bufend-s); + (void)strcpy(bufptr,SvPVX(herewas)); + + s = olds; + goto retval; + } + else if (!outer) { d = s; while (s < PL_bufend && (*s != term || memNE(s,PL_tokenbuf,len)) ) { @@ -5300,8 +5383,9 @@ scan_heredoc(register char *s) sv_catsv(tmpstr,PL_linestr); } } - PL_multi_end = PL_curcop->cop_line; s++; +retval: + PL_multi_end = PL_curcop->cop_line; if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) { SvLEN_set(tmpstr, SvCUR(tmpstr) + 1); Renew(SvPVX(tmpstr), SvLEN(tmpstr), char); @@ -5887,8 +5971,12 @@ scan_formline(register char *s) while (!needargs) { if (*s == '.' || *s == '}') { /*SUPPRESS 530*/ - for (t = s+1; *t == ' ' || *t == '\t'; t++) ; - if (*t == '\n') +#ifdef PERL_STRICT_CR + for (t = s+1;*t == ' ' || *t == '\t'; t++) ; +#else + for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ; +#endif + if (*t == '\n' || t == PL_bufend) break; } if (PL_in_eval && !PL_rsfp) { diff --git a/contrib/perl5/universal.c b/contrib/perl5/universal.c index bf03261..aba150e 100644 --- a/contrib/perl5/universal.c +++ b/contrib/perl5/universal.c @@ -106,24 +106,23 @@ sv_derived_from(SV *sv, char *name) #include "XSUB.h" -static XS(XS_UNIVERSAL_isa) { dXSARGS; SV *sv; char *name; + STRLEN n_a; if (items != 2) croak("Usage: UNIVERSAL::isa(reference, kind)"); sv = ST(0); - name = (char *)SvPV(ST(1),PL_na); + name = (char *)SvPV(ST(1),n_a); ST(0) = boolSV(sv_derived_from(sv, name)); XSRETURN(1); } -static XS(XS_UNIVERSAL_can) { dXSARGS; @@ -131,12 +130,13 @@ XS(XS_UNIVERSAL_can) char *name; SV *rv; HV *pkg = NULL; + STRLEN n_a; if (items != 2) croak("Usage: UNIVERSAL::can(object-ref, method)"); sv = ST(0); - name = (char *)SvPV(ST(1),PL_na); + name = (char *)SvPV(ST(1),n_a); rv = &PL_sv_undef; if(SvROK(sv)) { @@ -158,7 +158,6 @@ XS(XS_UNIVERSAL_can) XSRETURN(1); } -static XS(XS_UNIVERSAL_VERSION) { dXSARGS; @@ -192,9 +191,11 @@ XS(XS_UNIVERSAL_VERSION) undef = "(undef)"; } - if (items > 1 && (undef || (req = SvNV(ST(1)), req > SvNV(sv)))) + if (items > 1 && (undef || (req = SvNV(ST(1)), req > SvNV(sv)))) { + STRLEN n_a; croak("%s version %s required--this is only version %s", - HvNAME(pkg), SvPV(ST(1),PL_na), undef ? undef : SvPV(sv,PL_na)); + HvNAME(pkg), SvPV(ST(1),n_a), undef ? undef : SvPV(sv,n_a)); + } ST(0) = sv; diff --git a/contrib/perl5/unixish.h b/contrib/perl5/unixish.h index 2f81294..5bcff33 100644 --- a/contrib/perl5/unixish.h +++ b/contrib/perl5/unixish.h @@ -89,7 +89,7 @@ */ /* #define ALTERNATE_SHEBANG "#!" / **/ -#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) +#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) || defined(__NetBSD__) # include <signal.h> #endif diff --git a/contrib/perl5/util.c b/contrib/perl5/util.c index 431c5fa..39f5f7a 100644 --- a/contrib/perl5/util.c +++ b/contrib/perl5/util.c @@ -1,6 +1,6 @@ /* util.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -621,6 +621,9 @@ perl_init_i18nl10n(int printwarn) #ifdef USE_LOCALE_NUMERIC char *curnum = NULL; #endif /* USE_LOCALE_NUMERIC */ +#ifdef __GLIBC__ + char *language = PerlEnv_getenv("LANGUAGE"); +#endif char *lc_all = PerlEnv_getenv("LC_ALL"); char *lang = PerlEnv_getenv("LANG"); bool setlocale_failure = FALSE; @@ -641,65 +644,53 @@ perl_init_i18nl10n(int printwarn) else setlocale_failure = TRUE; } - if (!setlocale_failure) -#endif /* LC_ALL */ - { + if (!setlocale_failure) { #ifdef USE_LOCALE_CTYPE - if (! (curctype = setlocale(LC_CTYPE, - (!done && (lang || PerlEnv_getenv("LC_CTYPE"))) + if (! (curctype = + setlocale(LC_CTYPE, + (!done && (lang || PerlEnv_getenv("LC_CTYPE"))) ? "" : Nullch))) setlocale_failure = TRUE; #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE - if (! (curcoll = setlocale(LC_COLLATE, - (!done && (lang || PerlEnv_getenv("LC_COLLATE"))) + if (! (curcoll = + setlocale(LC_COLLATE, + (!done && (lang || PerlEnv_getenv("LC_COLLATE"))) ? "" : Nullch))) setlocale_failure = TRUE; #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC - if (! (curnum = setlocale(LC_NUMERIC, - (!done && (lang || PerlEnv_getenv("LC_NUMERIC"))) + if (! (curnum = + setlocale(LC_NUMERIC, + (!done && (lang || PerlEnv_getenv("LC_NUMERIC"))) ? "" : Nullch))) setlocale_failure = TRUE; #endif /* USE_LOCALE_NUMERIC */ } -#else /* !LOCALE_ENVIRON_REQUIRED */ +#endif /* LC_ALL */ -#ifdef LC_ALL +#endif /* !LOCALE_ENVIRON_REQUIRED */ +#ifdef LC_ALL if (! setlocale(LC_ALL, "")) setlocale_failure = TRUE; - else { -#ifdef USE_LOCALE_CTYPE - curctype = setlocale(LC_CTYPE, Nullch); -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE - curcoll = setlocale(LC_COLLATE, Nullch); -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC - curnum = setlocale(LC_NUMERIC, Nullch); -#endif /* USE_LOCALE_NUMERIC */ - } - -#else /* !LC_ALL */ +#endif /* LC_ALL */ + if (!setlocale_failure) { #ifdef USE_LOCALE_CTYPE - if (! (curctype = setlocale(LC_CTYPE, ""))) - setlocale_failure = TRUE; + if (! (curctype = setlocale(LC_CTYPE, ""))) + setlocale_failure = TRUE; #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE - if (! (curcoll = setlocale(LC_COLLATE, ""))) - setlocale_failure = TRUE; + if (! (curcoll = setlocale(LC_COLLATE, ""))) + setlocale_failure = TRUE; #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC - if (! (curnum = setlocale(LC_NUMERIC, ""))) - setlocale_failure = TRUE; + if (! (curnum = setlocale(LC_NUMERIC, ""))) + setlocale_failure = TRUE; #endif /* USE_LOCALE_NUMERIC */ - -#endif /* LC_ALL */ - -#endif /* !LOCALE_ENVIRON_REQUIRED */ + } if (setlocale_failure) { char *p; @@ -736,6 +727,14 @@ perl_init_i18nl10n(int printwarn) PerlIO_printf(PerlIO_stderr(), "perl: warning: Please check that your locale settings:\n"); +#ifdef __GLIBC__ + PerlIO_printf(PerlIO_stderr(), + "\tLANGUAGE = %c%s%c,\n", + language ? '"' : '(', + language ? language : "unset", + language ? '"' : ')'); +#endif + PerlIO_printf(PerlIO_stderr(), "\tLC_ALL = %c%s%c,\n", lc_all ? '"' : '(', @@ -897,14 +896,15 @@ mem_collxfrm(const char *s, STRLEN len, STRLEN *xlen) void fbm_compile(SV *sv, U32 flags /* not used yet */) { - register unsigned char *s; - register unsigned char *table; + register U8 *s; + register U8 *table; register U32 i; - register U32 len = SvCUR(sv); + STRLEN len; I32 rarest = 0; U32 frequency = 256; - sv_upgrade(sv, SVt_PVBM); + s = (U8*)SvPV_force(sv, len); + (void)SvUPGRADE(sv, SVt_PVBM); if (len > 255 || len == 0) /* TAIL might be on on a zero-length string. */ return; /* can't have offsets that big */ if (len > 2) { @@ -1501,21 +1501,16 @@ my_setenv(char *nam,char *val) #else /* !USE_WIN32_RTL_ENV */ - /* The sane way to deal with the environment. - * Has these advantages over putenv() & co.: - * * enables us to store a truly empty value in the - * environment (like in UNIX). - * * we don't have to deal with RTL globals, bugs and leaks. - * * Much faster. - * Why you may want to enable USE_WIN32_RTL_ENV: - * * environ[] and RTL functions will not reflect changes, - * which might be an issue if extensions want to access - * the env. via RTL. This cuts both ways, since RTL will - * not see changes made by extensions that call the Win32 - * functions directly, either. - * GSAR 97-06-07 - */ - SetEnvironmentVariable(nam,val); + register char *envstr; + STRLEN len = strlen(nam) + 3; + if (!val) { + val = ""; + } + len += strlen(val); + New(904, envstr, len, char); + (void)sprintf(envstr,"%s=%s",nam,val); + (void)PerlEnv_putenv(envstr); + Safefree(envstr); #endif } @@ -2198,9 +2193,9 @@ repeatcpy(register char *to, register char *from, I32 len, register I32 count) register char *frombase = from; if (len == 1) { - todo = *from; + register char c = *from; while (count-- > 0) - *to++ = todo; + *to++ = c; return; } while (count-- > 0) { @@ -2354,18 +2349,26 @@ scan_hex(char *start, I32 len, I32 *retlen) register UV retval = 0; bool overflowed = FALSE; char *tmp = s; + register UV n; - while (len-- && *s && (tmp = strchr((char *) PL_hexdigit, *s))) { - register UV n = retval << 4; + while (len-- && *s) { + tmp = strchr((char *) PL_hexdigit, *s++); + if (!tmp) { + if (*(s-1) == '_' || (*(s-1) == 'x' && retval == 0)) + continue; + else { + --s; + if (PL_dowarn) + warn("Illegal hex digit ignored"); + break; + } + } + n = retval << 4; if (!overflowed && (n >> 4) != retval) { warn("Integer overflow in hex number"); overflowed = TRUE; } retval = n | ((tmp - PL_hexdigit) & 15); - s++; - } - if (PL_dowarn && !tmp) { - warn("Illegal hex digit ignored"); } *retlen = s - start; return retval; @@ -2469,7 +2472,8 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) #endif DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",cur)); - if (PerlLIO_stat(cur,&PL_statbuf) >= 0) { + if (PerlLIO_stat(cur,&PL_statbuf) >= 0 + && !S_ISDIR(PL_statbuf.st_mode)) { dosearch = 0; scriptname = cur; #ifdef SEARCH_EXTS @@ -2538,6 +2542,9 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) #endif DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf)); retval = PerlLIO_stat(tmpbuf,&PL_statbuf); + if (S_ISDIR(PL_statbuf.st_mode)) { + retval = -1; + } #ifdef SEARCH_EXTS } while ( retval < 0 /* not there */ && extidx>=0 && ext[extidx] /* try an extension? */ @@ -2560,7 +2567,9 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) xfailed = savepv(tmpbuf); } #ifndef DOSISH - if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&PL_statbuf) < 0)) + if (!xfound && !seen_dot && !xfailed && + (PerlLIO_stat(scriptname,&PL_statbuf) < 0 + || S_ISDIR(PL_statbuf.st_mode))) #endif seen_dot = 1; /* Disable message. */ if (!xfound) { @@ -2729,7 +2738,7 @@ new_struct_thread(struct perl_thread *t) SvGROW(sv, sizeof(struct perl_thread) + 1); SvCUR_set(sv, sizeof(struct perl_thread)); thr = (Thread) SvPVX(sv); - /* debug */ +#ifdef DEBUGGING memset(thr, 0xab, sizeof(struct perl_thread)); PL_markstack = 0; PL_scopestack = 0; @@ -2737,7 +2746,10 @@ new_struct_thread(struct perl_thread *t) PL_retstack = 0; PL_dirty = 0; PL_localizing = 0; - /* end debug */ + Zero(&PL_hv_fetch_ent_mh, 1, HE); +#else + Zero(thr, 1, struct perl_thread); +#endif thr->oursv = sv; init_stacks(ARGS); @@ -2751,10 +2763,6 @@ new_struct_thread(struct perl_thread *t) thr->flags = THRf_R_JOINABLE; MUTEX_INIT(&thr->mutex); - PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */ - PL_defstash = t->Tdefstash; /* XXX maybe these should */ - PL_curstash = t->Tcurstash; /* always be set to main? */ - /* top_env needs to be non-zero. It points to an area in which longjmp() stuff is stored, as C callstack @@ -2772,6 +2780,25 @@ new_struct_thread(struct perl_thread *t) PL_in_eval = FALSE; PL_restartop = 0; + PL_statname = NEWSV(66,0); + PL_maxscream = -1; + PL_regcompp = FUNC_NAME_TO_PTR(pregcomp); + PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags); + PL_regindent = 0; + PL_reginterp_cnt = 0; + PL_lastscream = Nullsv; + PL_screamfirst = 0; + PL_screamnext = 0; + PL_reg_start_tmp = 0; + PL_reg_start_tmpl = 0; + + /* parent thread's data needs to be locked while we make copy */ + MUTEX_LOCK(&t->mutex); + + PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */ + PL_defstash = t->Tdefstash; /* XXX maybe these should */ + PL_curstash = t->Tcurstash; /* always be set to main? */ + PL_tainted = t->Ttainted; PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */ PL_nrs = newSVsv(t->Tnrs); @@ -2785,18 +2812,6 @@ new_struct_thread(struct perl_thread *t) PL_bodytarget = newSVsv(t->Tbodytarget); PL_toptarget = newSVsv(t->Ttoptarget); - PL_statname = NEWSV(66,0); - PL_maxscream = -1; - PL_regcompp = FUNC_NAME_TO_PTR(pregcomp); - PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags); - PL_regindent = 0; - PL_reginterp_cnt = 0; - PL_lastscream = Nullsv; - PL_screamfirst = 0; - PL_screamnext = 0; - PL_reg_start_tmp = 0; - PL_reg_start_tmpl = 0; - /* Initialise all per-thread SVs that the template thread used */ svp = AvARRAY(t->threadsv); for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) { @@ -2819,6 +2834,9 @@ new_struct_thread(struct perl_thread *t) thr->next->prev = thr; MUTEX_UNLOCK(&PL_threads_mutex); + /* done copying parent's state */ + MUTEX_UNLOCK(&t->mutex); + #ifdef HAVE_THREAD_INTERN init_thread_intern(thr); #endif /* HAVE_THREAD_INTERN */ @@ -2877,3 +2895,100 @@ get_specialsv_list(void) { return PL_specialsv_list; } + + +MGVTBL* +get_vtbl(int vtbl_id) +{ + MGVTBL* result = Null(MGVTBL*); + + switch(vtbl_id) { + case want_vtbl_sv: + result = &vtbl_sv; + break; + case want_vtbl_env: + result = &vtbl_env; + break; + case want_vtbl_envelem: + result = &vtbl_envelem; + break; + case want_vtbl_sig: + result = &vtbl_sig; + break; + case want_vtbl_sigelem: + result = &vtbl_sigelem; + break; + case want_vtbl_pack: + result = &vtbl_pack; + break; + case want_vtbl_packelem: + result = &vtbl_packelem; + break; + case want_vtbl_dbline: + result = &vtbl_dbline; + break; + case want_vtbl_isa: + result = &vtbl_isa; + break; + case want_vtbl_isaelem: + result = &vtbl_isaelem; + break; + case want_vtbl_arylen: + result = &vtbl_arylen; + break; + case want_vtbl_glob: + result = &vtbl_glob; + break; + case want_vtbl_mglob: + result = &vtbl_mglob; + break; + case want_vtbl_nkeys: + result = &vtbl_nkeys; + break; + case want_vtbl_taint: + result = &vtbl_taint; + break; + case want_vtbl_substr: + result = &vtbl_substr; + break; + case want_vtbl_vec: + result = &vtbl_vec; + break; + case want_vtbl_pos: + result = &vtbl_pos; + break; + case want_vtbl_bm: + result = &vtbl_bm; + break; + case want_vtbl_fm: + result = &vtbl_fm; + break; + case want_vtbl_uvar: + result = &vtbl_uvar; + break; +#ifdef USE_THREADS + case want_vtbl_mutex: + result = &vtbl_mutex; + break; +#endif + case want_vtbl_defelem: + result = &vtbl_defelem; + break; + case want_vtbl_regexp: + result = &vtbl_regexp; + break; +#ifdef USE_LOCALE_COLLATE + case want_vtbl_collxfrm: + result = &vtbl_collxfrm; + break; +#endif + case want_vtbl_amagic: + result = &vtbl_amagic; + break; + case want_vtbl_amagicelem: + result = &vtbl_amagicelem; + break; + } + return result; +} + diff --git a/contrib/perl5/util.h b/contrib/perl5/util.h index 7dcf9ce..3082a20 100644 --- a/contrib/perl5/util.h +++ b/contrib/perl5/util.h @@ -1,6 +1,6 @@ /* util.h * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. diff --git a/contrib/perl5/utils/h2ph.PL b/contrib/perl5/utils/h2ph.PL index 066f2c9..6011d98 100644 --- a/contrib/perl5/utils/h2ph.PL +++ b/contrib/perl5/utils/h2ph.PL @@ -63,6 +63,8 @@ $inif = 0; @ARGV = ('-') unless @ARGV; +build_preamble_if_necessary(); + while (defined ($file = next_file())) { if (-l $file and -d $file) { link_if_possible($file) if ($opt_l); @@ -97,6 +99,8 @@ while (defined ($file = next_file())) { open(IN,"$file") || (($Exit = 1),(warn "Can't open $file: $!\n"),next); open(OUT,">$Dest_dir/$outfile") || die "Can't create $outfile: $!\n"; } + + print OUT "require '_h2ph_pre.ph';\n\n"; while (<IN>) { chop; while (/\\$/) { @@ -105,6 +109,7 @@ while (defined ($file = next_file())) { chop; } print OUT "# $_\n" if $opt_D; + if (s:/\*:\200:g) { s:\*/:\201:g; s/\200[^\201]*\201//g; # delete single line comments @@ -158,6 +163,7 @@ while (defined ($file = next_file())) { $args = reindent($args); if ($t ne '') { $new =~ s/(['\\])/\\$1/g; #']); + if ($opt_h) { print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n"; $eval_index++; @@ -165,6 +171,9 @@ while (defined ($file = next_file())) { print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n"; } } else { + # Shunt around such directives as `#define FOO FOO': + next if " \&$name" eq $new; + print OUT $t,"unless(defined(\&$name)) {\n sub $name () {\t",$new,";}\n}\n"; } } @@ -230,10 +239,12 @@ while (defined ($file = next_file())) { print OUT $t,"}\n"; } elsif(/^undef\s+(\w+)/) { print OUT $t, "undef(&$1) if defined(&$1);\n"; + } elsif(/^error\s+(".*")/) { + print OUT $t, "die($1);\n"; } elsif(/^error\s+(.*)/) { - print OUT $t, "die(\"$1\");\n"; + print OUT $t, "die(\"", quotemeta($1), "\");\n"; } elsif(/^warning\s+(.*)/) { - print OUT $t, "warn(\"$1\");\n"; + print OUT $t, "warn(\"", quotemeta($1), "\");\n"; } elsif(/^ident\s+(.*)/) { print OUT $t, "# $1\n"; } @@ -512,6 +523,71 @@ sub inc_dirs } +# Create "_h2ph_pre.ph", if it doesn't exist or was built by a different +# version of h2ph. +sub build_preamble_if_necessary +{ + # Increment $VERSION every time this function is modified: + my $VERSION = 1; + my $preamble = "$Dest_dir/_h2ph_pre.ph"; + + # Can we skip building the preamble file? + if (-r $preamble) { + # Extract version number from first line of preamble: + open PREAMBLE, $preamble or die "Cannot open $preamble: $!"; + my $line = <PREAMBLE>; + $line =~ /(\b\d+\b)/; + close PREAMBLE or die "Cannot close $preamble: $!"; + + # Don't build preamble if a compatible preamble exists: + return if $1 == $VERSION; + } + + my (%define) = _extract_cc_defines(); + + open PREAMBLE, ">$preamble" or die "Cannot open $preamble: $!"; + print PREAMBLE "# This file was created by h2ph version $VERSION\n"; + + foreach (sort keys %define) { + if ($opt_D) { + print PREAMBLE "# $_=$define{$_}\n"; + } + + if ($define{$_} =~ /^\d+$/) { + print PREAMBLE + "unless (defined &$_) { sub $_() { $define{$_} } }\n\n"; + } else { + print PREAMBLE + "unless (defined &$_) { sub $_() { \"", + quotemeta($define{$_}), "\" } }\n\n"; + } + } + close PREAMBLE or die "Cannot close $preamble: $!"; +} + + +# %Config contains information on macros that are pre-defined by the +# system's compiler. We need this information to make the .ph files +# function with perl as the .h files do with cc. +sub _extract_cc_defines +{ + my %define; + my $allsymbols = join " ", @Config{ccsymbols, cppsymbols, cppccsymbols}; + + # Split compiler pre-definitions into `key=value' pairs: + foreach (split /\s+/, $allsymbols) { + /(.*?)=(.*)/; + $define{$1} = $2; + + if ($opt_D) { + print STDERR "$_: $1 -> $2\n"; + } + } + + return %define; +} + + 1; ############################################################################## @@ -590,6 +666,10 @@ However, the B<.ph> files almost double in size when built using B<-h>. Include the code from the B<.h> file as a comment in the B<.ph> file. This is primarily used for debugging I<h2ph>. +=item -Q + +``Quiet'' mode; don't print out the names of the files being converted. + =back =head1 ENVIRONMENT @@ -626,6 +706,24 @@ that it can translate. It's only intended as a rough tool. You may need to dicker with the files produced. +Doesn't run with C<use strict> + +You have to run this program by hand; it's not run as part of the Perl +installation. + +Doesn't handle complicated expressions built piecemeal, a la: + + enum { + FIRST_VALUE, + SECOND_VALUE, + #ifdef ABC + THIRD_VALUE + #endif + }; + +Doesn't necessarily locate all of your C compiler's internally-defined +symbols. + =cut !NO!SUBS! diff --git a/contrib/perl5/utils/h2xs.PL b/contrib/perl5/utils/h2xs.PL index 52f590b..129b01b 100644 --- a/contrib/perl5/utils/h2xs.PL +++ b/contrib/perl5/utils/h2xs.PL @@ -211,7 +211,7 @@ The usual warnings if it cannot read or write the files involved. =cut -my( $H2XS_VERSION ) = ' $Revision: 1.18 $ ' =~ /\$Revision:\s+([^\s]+)/; +my( $H2XS_VERSION ) = ' $Revision: 1.19 $ ' =~ /\$Revision:\s+([^\s]+)/; my $TEMPLATE_VERSION = '0.01'; use Getopt::Std; @@ -499,6 +499,7 @@ sub AUTOLOAD { croak "Your vendor has not defined $module macro \$constname"; } } + no strict 'refs'; *\$AUTOLOAD = sub () { \$val }; goto &\$AUTOLOAD; } @@ -591,15 +592,9 @@ if( ! $opt_X ){ # print XS, unless it is disabled warn "Writing $ext$modpname/$modfname.xs\n"; print XS <<"END"; -#ifdef __cplusplus -extern "C" { -#endif #include "EXTERN.h" #include "perl.h" #include "XSUB.h" -#ifdef __cplusplus -} -#endif END if( @path_h ){ @@ -615,17 +610,14 @@ if( @path_h ){ if( ! $opt_c ){ print XS <<"END"; static int -not_here(s) -char *s; +not_here(char *s) { croak("$module::%s not implemented on this architecture", s); return -1; } static double -constant(name, arg) -char *name; -int arg; +constant(char *name, int arg) { errno = 0; switch (*name) { diff --git a/contrib/perl5/utils/perlbug.PL b/contrib/perl5/utils/perlbug.PL index 589e7e6..6f87589 100644 --- a/contrib/perl5/utils/perlbug.PL +++ b/contrib/perl5/utils/perlbug.PL @@ -528,7 +528,7 @@ EOF Environment for perl $]: EOF for my $env (sort - (qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR), + (qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR LANGUAGE), grep /^(?:PERL|LC_)/, keys %ENV) ) { print OUT " $env", @@ -901,6 +901,13 @@ it all, but at least have a look at the sections that I<seem> relevant). Be aware of the familiar traps that perl programmers of various hues fall into. See L<perltrap>. +Check in L<perldiag> to see what any Perl error message(s) mean. +If message isn't in perldiag, it probably isn't generated by Perl. +Consult your operating system documentation instead. + +If you are on a non-UNIX platform check also L<perlport>, some +features may not be implemented or work differently. + Try to study the problem under the perl debugger, if necessary. See L<perldebug>. @@ -916,6 +923,17 @@ A good test case is almost always a good candidate to be on the perl test suite. If you have the time, consider making your test case so that it will readily fit into the standard test suite. +Remember also to include the B<exact> error messages, if any. +"Perl complained something" is not an exact error message. + +If you get a core dump (or equivalent), you may use a debugger +(B<dbx>, B<gdb>, etc) to produce a stack trace to include in the bug +report. NOTE: unless your Perl has been compiled with debug info +(often B<-g>), the stack trace is likely to be somewhat hard to use +because it will most probably contain only the function names, not +their arguments. If possible, recompile your Perl with debug info and +reproduce the dump and the stack trace. + =item Can you describe the bug in plain English? The easier it is to understand a reproducible bug, the more likely it @@ -954,6 +972,11 @@ it to B<perlbug@perl.com>. If, for some reason, you cannot run C<perlbug> at all on your system, be sure to include the entire output produced by running C<perl -V> (note the uppercase V). +Whether you use C<perlbug> or send the email manually, please make +your subject informative. "a bug" not informative. Neither is "perl +crashes" nor "HELP!!!", these all are null information. A compact +description of what's wrong is fine. + =back Having done your bit, please be prepared to wait, to be told the bug @@ -1071,12 +1094,14 @@ Kenneth Albanowski (E<lt>kjahds@kjahds.comE<gt>), subsequently I<doc>tored by Gurusamy Sarathy (E<lt>gsar@umich.eduE<gt>), Tom Christiansen (E<lt>tchrist@perl.comE<gt>), 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>) -and Hugo van der Sanden (E<lt>hv@crypt0.demon.co.ukE<gt>). +(E<lt>mjtg@cam.a.ukE<gt>), Dominic Dunlop (E<lt>domo@computer.orgE<gt>), +Hugo van der Sanden (E<lt>hv@crypt0.demon.co.ukE<gt>), and +Jarkko Hietaniemi (E<lt>jhi@iki.fiE<gt>). =head1 SEE ALSO -perl(1), perldebug(1), perltrap(1), diff(1), patch(1) +perl(1), perldebug(1), perldiag(1), perlport(1), perltrap(1), +diff(1), patch(1), dbx(1), gdb(1) =head1 BUGS @@ -1090,4 +1115,3 @@ close OUT or die "Can't close $file: $!"; chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; chdir $origdir; - diff --git a/contrib/perl5/utils/perldoc.PL b/contrib/perl5/utils/perldoc.PL index 875cd25..2633510 100644 --- a/contrib/perl5/utils/perldoc.PL +++ b/contrib/perl5/utils/perldoc.PL @@ -91,7 +91,7 @@ Options: -F Arguments are file names, not modules -v Verbosely describe what's going on -X use index if present (looks for pod.idx at $Config{archlib}) - + -q Search the text of questions (not answers) in perlfaq[1-9] PageName|ModuleName... is the name of a piece of documentation that you want to look at. You @@ -188,7 +188,7 @@ sub minus_f_nocase { if (!$opt_i or $Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') { # on a case-forgiving file system or if case is important # that is it all we can do - warn "Ignored $file: unreadable\n" if -f _; + warn "Ignored $path: unreadable\n" if -f _; return ''; } local *DIR; @@ -227,7 +227,7 @@ sub minus_f_nocase { return "" unless $found; push @p, $cip; return "@p" if -f "@p" and -r _; - warn "Ignored $file: unreadable\n" if -f _; + warn "Ignored @p: unreadable\n" if -f _; } } return ""; @@ -408,6 +408,9 @@ if ($opt_f) { my $perlfunc = shift @found; open(PFUNC, $perlfunc) or die "Can't open $perlfunc: $!"; + # Functions like -r, -e, etc. are listed under `-X'. + my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) ? 'I<-X' : $opt_f ; + # Skip introduction while (<PFUNC>) { last if /^=head2 Alphabetical Listing of Perl Functions/; @@ -417,7 +420,7 @@ if ($opt_f) { my $found = 0; my @pod; while (<PFUNC>) { - if (/^=item\s+\Q$opt_f\E\b/o) { + if (/^=item\s+\Q$search_string\E\b/o) { $found = 1; } elsif (/^=item/) { last if $found > 1; @@ -456,7 +459,7 @@ if ($opt_q) { my @pod; while (<>) { - if (/^=head2\s+.*$opt_q/oi) { + if (/^=head2\s+.*(?:$opt_q)/oi) { $found = 1; push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++; } elsif (/^=head2/) { diff --git a/contrib/perl5/x2p/Makefile.SH b/contrib/perl5/x2p/Makefile.SH index 5bec7a0..1f92d5d 100755 --- a/contrib/perl5/x2p/Makefile.SH +++ b/contrib/perl5/x2p/Makefile.SH @@ -36,8 +36,10 @@ BYACC = $byacc LDFLAGS = $ldflags SMALL = $small LARGE = $large $split -mallocsrc = $mallocsrc -mallocobj = $mallocobj +# XXX Perl malloc temporarily unusable (declaration collisions with +# stdlib.h) +#mallocsrc = $mallocsrc +#mallocobj = $mallocobj shellflags = $shellflags libs = $libs diff --git a/contrib/perl5/x2p/s2p.PL b/contrib/perl5/x2p/s2p.PL index dbcb27c..463465d 100644 --- a/contrib/perl5/x2p/s2p.PL +++ b/contrib/perl5/x2p/s2p.PL @@ -671,7 +671,7 @@ EOT } if (/^H/) { - $_ = '$hold .= "\n"; $hold .= $_;'; + $_ = '$hold .= "\n", $hold .= $_;'; next; } @@ -681,7 +681,7 @@ EOT } if (/^G/) { - $_ = '$_ .= "\n"; $_ .= $hold;'; + $_ = '$_ .= "\n", $_ .= $hold;'; next; } diff --git a/contrib/perl5/x2p/walk.c b/contrib/perl5/x2p/walk.c index 0b40655..24b86aa 100644 --- a/contrib/perl5/x2p/walk.c +++ b/contrib/perl5/x2p/walk.c @@ -133,7 +133,7 @@ walk(int useval, int level, register int node, int *numericptr, int minprec) if (saw_FS && !const_FS) do_chop = TRUE; if (do_chop) { - str_cat(str,"chop;\t# strip record separator\n"); + str_cat(str,"chomp;\t# strip record separator\n"); tab(str,level); } if (do_split) @@ -190,7 +190,7 @@ walk(int useval, int level, register int node, int *numericptr, int minprec) i = 0; if (do_chop) { i++; - str_cat(str,"chop;\t# strip record separator\n"); + str_cat(str,"chomp;\t# strip record separator\n"); tab(str,level); } if (do_split && !(len & 1)) { |
