diff options
155 files changed, 7235 insertions, 3266 deletions
@@ -79,6 +79,651 @@ Version 5.005_62 Development release working toward 5.006 ---------------- ____________________________________________________________________________ +[ 4273] By: gsar on 1999/10/01 22:58:55 + Log: typo, whitespace adjustments + Branch: perl + ! utils/h2xs.PL +____________________________________________________________________________ +[ 4272] By: gsar on 1999/10/01 22:46:06 + Log: remove dup hunks + Branch: perl + ! configure.com vms/vms.c +____________________________________________________________________________ +[ 4271] By: gsar on 1999/10/01 22:33:02 + Log: integrate cfgperl contents into mainline; resolve h2xs.PL conflict + by declaring new globals "our" (XXX this means h2xs generated code + won't run on earlier versions; a switch to generate compatible + source is needed) + Branch: perl + !> (integrate 35 files) +____________________________________________________________________________ +[ 4270] By: jhi on 1999/10/01 12:05:56 + Log: Integrate with Sarathy. + Branch: cfgperl + !> ext/B/B/C.pm lib/ExtUtils/typemap lib/ExtUtils/xsubpp + !> pod/perldiag.pod util.c +____________________________________________________________________________ +[ 4269] By: jhi on 1999/10/01 10:26:19 + Log: From: Piotr Klaban <makler@oryl.man.torun.pl> + To: perl5-porters@perl.org + Subject: [ID 19991001.001] perlguts man page error + Date: Fri, 1 Oct 1999 10:23:49 +0200 (MET DST) + Message-Id: <199910010823.KAA05796@oryl.man.torun.pl> + Branch: cfgperl + ! pod/perlguts.pod +____________________________________________________________________________ +[ 4268] By: jhi on 1999/10/01 07:32:33 + Log: There *is* a month called October. + Branch: cfgperl + ! t/op/time.t +____________________________________________________________________________ +[ 4267] By: jhi on 1999/10/01 06:58:10 + Log: Temp file cleanliness. + Branch: cfgperl + ! t/lib/filecopy.t +____________________________________________________________________________ +[ 4266] By: jhi on 1999/10/01 06:46:56 + Log: From: Barrie Slaymaker <barries@slaysys.com> + To: perl5-porters@perl.org + Subject: [PATCH 5.005_61] Benchmark.pm: Export countit(), cmpthese() by default + Date: Thu, 30 Sep 1999 22:16:26 -0400 + Message-Id: <199910010216.WAA08309@jester.slaysys.com> + Branch: cfgperl + ! lib/Benchmark.pm +____________________________________________________________________________ +[ 4265] By: jhi on 1999/09/30 20:25:35 + Log: From: Barrie Slaymaker <barries@slaysys.com> + To: perl5-porters@perl.org + Subject: [PATCH 5.005_61] Benchmark tweaks, fixes, cmpthese() + Date: Thu, 30 Sep 1999 15:44:00 -0400 + Message-Id: <199909301944.PAA07166@jester.slaysys.com> + (Replaces #4175.) + Branch: cfgperl + ! lib/Benchmark.pm +____________________________________________________________________________ +[ 4264] By: gsar on 1999/09/30 17:59:26 + Log: re-add missing "Out of memory!" entry + Branch: perl + ! pod/perldiag.pod +____________________________________________________________________________ +[ 4263] By: jhi on 1999/09/30 17:05:43 + Log: Regenerate Configure. + Branch: cfgperl + ! Configure Porting/Glossary Porting/config.sh Porting/config_H + ! config_h.SH +____________________________________________________________________________ +[ 4261] By: jhi on 1999/09/30 16:15:05 + Log: From: Andy Dougherty <doughera@lafayette.edu> + To: Perl Porters <perl5-porters@perl.org> + Subject: [PATCH 5.005_61] rand() advisory for perldelta.pod + Date: Thu, 30 Sep 1999 12:24:00 -0400 (EDT) + Message-ID: <Pine.SOL.4.10.9909301218390.3343-100000@maxwell.phys.lafayette.edu> + Branch: cfgperl + ! pod/perldelta.pod +____________________________________________________________________________ +[ 4260] By: jhi on 1999/09/30 15:48:56 + Log: From: Andy Dougherty <doughera@lafayette.edu> + To: Jarkko Hietaniemi <jhi@iki.fi>, Gurusamy Sarathy <gsar@activestate.com> + Subject: Re: Possible skeletal structure for searching multiple versions + Date: Thu, 30 Sep 1999 11:52:00 -0400 (EDT) + Message-ID: <Pine.SOL.4.10.9909301149090.3343-100000@maxwell.phys.lafayette.edu> + Branch: metaconfig + ! U/mkglossary + Branch: metaconfig/U/perl + + xs_apiversion.U + ! patchlevel.U +____________________________________________________________________________ +[ 4259] By: jhi on 1999/09/30 15:07:16 + Log: Further ?idsize.U fixing. + Branch: metaconfig + ! U/typedefs/gidsize.U U/typedefs/pidsize.U U/typedefs/uidsize.U +____________________________________________________________________________ +[ 4258] By: jhi on 1999/09/30 15:00:14 + Log: Fix the ?idsi{gn,ze} units, from Andy Dougherty. + Branch: metaconfig + ! U/typedefs/gidsign.U U/typedefs/gidsize.U U/typedefs/pidsign.U + ! U/typedefs/pidsize.U U/typedefs/uidsign.U U/typedefs/uidsize.U +____________________________________________________________________________ +[ 4257] By: jhi on 1999/09/30 09:48:33 + Log: From: "Kurt D. Starsinic" <kstar@chapin.edu> + To: Gurusamy Sarathy <gsar@ActiveState.com> + Cc: tchrist@perl.com, Larry Wall <larry@wall.org>, + The Perl Porters Mailing List <perl5-porters@perl.org> + Subject: [PATCH] (Was: deprecating SIGDIE) + Date: Wed, 29 Sep 1999 15:16:50 -0400 + Message-ID: <19990929151650.E26675@O2.chapin.edu> + Branch: cfgperl + ! Porting/findvars embedvar.h intrpvar.h mg.c objXSUB.h perl.c +____________________________________________________________________________ +[ 4256] By: jhi on 1999/09/30 09:45:22 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + To: Gurusamy Sarathy <gsar@activestate.com> + Cc: Barrie Slaymaker <barries@slaysys.com>, perl5-porters@perl.org + Subject: Re: _58, _61 Argument "" is not numeric in sprintf + Date: Wed, 29 Sep 1999 18:58:23 -0400 + Message-ID: <19990929185823.A22099@monk.mps.ohio-state.edu> + Branch: cfgperl + ! Makefile.SH opcode.pl +____________________________________________________________________________ +[ 4255] By: gsar on 1999/09/30 09:03:48 + Log: remove prehistoric XFree() gunk + Branch: perl + ! lib/ExtUtils/typemap lib/ExtUtils/xsubpp +____________________________________________________________________________ +[ 4254] By: gsar on 1999/09/30 08:40:14 + Log: From: Vishal Bhatia <vishal@gol.com> + Date: Wed, 29 Sep 1999 23:27:28 +0900 (JST) + Message-ID: <Pine.LNX.4.10.9909292326280.5599-100000@localhost.localdomain> + Subject: [patch _61] Minor corrections in C.pm + Branch: perl + ! ext/B/B/C.pm +____________________________________________________________________________ +[ 4253] By: gsar on 1999/09/30 08:36:27 + Log: off-by-one in fbm_compile() (spotted by John Bley + <jbley@cs.cmu.edu>); whitespace adjustments + Branch: perl + ! util.c +____________________________________________________________________________ +[ 4251] By: jhi on 1999/09/30 08:09:13 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + To: perl5-porters@perl.org (Mailing list Perl5) + Subject: [PATCH 5.00561+] Followup h2xs patch + Date: Thu, 30 Sep 1999 04:15:52 -0400 (EDT) + Message-Id: <199909300815.EAA25425@monk.mps.ohio-state.edu> + Branch: cfgperl + ! utils/h2xs.PL +____________________________________________________________________________ +[ 4250] By: jhi on 1999/09/29 19:11:32 + Log: Integrate with Sarathy. + Branch: cfgperl + !> djgpp/configure.bat embed.h embed.pl lib/Exporter/Heavy.pm + !> lib/ExtUtils/MM_Unix.pm lib/Time/Local.pm proto.h + !> t/pragma/locale/latin1 win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 4249] By: bailey on 1999/09/29 02:21:31 + Log: resync with mainline + Branch: vmsperl + +> (branch 32 files) + - ext/B/defsubs.h.PL lib/unicode/arabshp.txt + - lib/unicode/blocks.txt lib/unicode/index2.txt + - lib/unicode/jamo2.txt lib/unicode/names2.txt + - lib/unicode/props2.txt lib/unicode/readme.txt + - t/lib/bigfloatpm.t + !> (integrate 240 files) +____________________________________________________________________________ +[ 4248] By: jhi on 1999/09/28 18:14:39 + Log: From: Andy Dougherty <doughera@lafayette.edu> + To: Perl Porters <perl5-porters@perl.org> + Subject: [PATCH 5.005_xx] Re: [Config 5.005_03] -DDEBUGGING + Date: Tue, 28 Sep 1999 12:20:50 -0400 (EDT) + Message-ID: <Pine.SOL.4.10.9909281019360.1890-100000@maxwell.phys.lafayette.edu> + + From: Andy Dougherty <doughera@lafayette.edu> + To: Perl Porters <perl5-porters@perl.org> + Subject: [ANOTHER PATCH 5.005_61] Re: [Config 5.005_03] -DDEBUGGING + Date: Tue, 28 Sep 1999 13:39:49 -0400 (EDT) + Message-ID: <Pine.SOL.4.10.9909281338180.2012-100000@maxwell.phys.lafayette.edu> + Branch: cfgperl + ! hints/README.hints hints/amigaos.sh hints/cygwin.sh + ! hints/dynixptx.sh hints/epix.sh hints/esix4.sh hints/mint.sh + ! hints/mpeix.sh hints/next_3.sh hints/next_3_0.sh + ! hints/next_4.sh +____________________________________________________________________________ +[ 4247] By: gsar on 1999/09/28 17:36:59 + Log: revert change#4115 (breaks libwww's base/date.t); could be + reworked to enable it conditional on $Time::Local::nocroak + or some such + Branch: perl + ! lib/Time/Local.pm +____________________________________________________________________________ +[ 4246] By: gsar on 1999/09/28 17:33:14 + Log: tweak for win32 build + Branch: perl + ! win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 4245] By: gsar on 1999/09/28 17:31:34 + Log: change#4236 fallout + Branch: perl + ! lib/ExtUtils/MM_Unix.pm +____________________________________________________________________________ +[ 4244] By: gsar on 1999/09/28 17:29:31 + Log: remove doubled new_xpv + Branch: perl + ! embed.h embed.pl proto.h +____________________________________________________________________________ +[ 4243] By: jhi on 1999/09/27 19:13:20 + Log: Artistic fine-tuning. + Branch: cfgperl + ! ext/B/defsubs_h.PL +____________________________________________________________________________ +[ 4242] By: gsar on 1999/09/27 17:05:22 + Log: avoid implicit split to @_ in change#4181; binary -> text file + types in p4 + Branch: perl + ! djgpp/configure.bat lib/Exporter/Heavy.pm + ! t/pragma/locale/latin1 +____________________________________________________________________________ +[ 4241] By: jhi on 1999/09/27 07:48:19 + Log: Integrate with Sarathy. + Branch: cfgperl + !> INSTALL embed.h embed.pl malloc.c pod/perldiag.pod pp.c + !> pp_ctl.c pp_hot.c pp_sys.c win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 4240] By: jhi on 1999/09/27 07:47:11 + Log: Finalize change #4232. + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + To: Jarkko Hietaniemi <jhi@iki.fi> + Cc: gsar@activestate.com, Mailing list Perl5 <perl5-porters@perl.org> + Subject: Re: xsubpp change breaks B, DB_File, POSIX builds + Date: Sun, 26 Sep 1999 16:52:31 -0400 + Message-ID: <19990926165230.A26933@monk.mps.ohio-state.edu> + Branch: cfgperl + ! lib/ExtUtils/xsubpp +____________________________________________________________________________ +[ 4239] By: gsar on 1999/09/27 02:48:42 + Log: add notes in INSTALL about Configure -Accflags=-DFOO + Branch: perl + ! INSTALL +____________________________________________________________________________ +[ 4238] By: gsar on 1999/09/27 02:03:48 + Log: PERL_POLLUTE isn't required for bincompat, so don't enable + it automatically + Branch: perl + ! embed.h embed.pl +____________________________________________________________________________ +[ 4237] By: gsar on 1999/09/27 01:52:47 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Fri, 24 Sep 1999 23:25:36 -0400 + Message-ID: <19990924232536.A16257@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_61] Malloc fixes and docs + Branch: perl + ! malloc.c pod/perldiag.pod +____________________________________________________________________________ +[ 4236] By: gsar on 1999/09/27 01:31:32 + Log: avoid .exe in $Config{cc} (spotted by Vadim Konovalov + <vkonovalov@lucent.com>) + Branch: perl + ! win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 4235] By: gsar on 1999/09/26 17:02:03 + Log: fix buggy popping of subroutine contexts in the lvalue + subroutines implementation (change#4081); correct the + plethora of cases where DIE() was more appropriate than + croak() + Branch: perl + ! pp.c pp_ctl.c pp_hot.c pp_sys.c +____________________________________________________________________________ +[ 4234] By: jhi on 1999/09/26 12:06:28 + Log: Fix #endif. + Branch: cfgperl + ! XSUB.h +____________________________________________________________________________ +[ 4233] By: jhi on 1999/09/26 11:59:18 + Log: Integrate with Sarathy. h2xs.PL had to be manually resolved, + I kept my (Ilya's) version. + Branch: cfgperl + !> gv.c gv.h intrpvar.h keywords.h keywords.pl lib/Shell.pm op.c + !> pod/perldiag.pod pod/perlembed.pod pod/perlfaq3.pod + !> pod/perlfaq7.pod pod/perlfunc.pod pod/perlmod.pod + !> pod/perlmodlib.pod pod/perlsub.pod pod/perltoot.pod + !> pod/perlxstut.pod sv.h t/pragma/strict-vars toke.c + !> utils/h2xs.PL win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 4232] By: jhi on 1999/09/26 09:53:43 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + To: Mailing list Perl5 <perl5-porters@perl.org> + Subject: [PATCH 5.005_61] teach xsubpp function pointers + Date: Sun, 26 Sep 1999 01:36:09 -0400 + Message-ID: <19990926013609.A21148@monk.mps.ohio-state.edu> + + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + To: Mailing list Perl5 <perl5-porters@perl.org> + Subject: [PATCH 5.005_61] Make h2xs -x almost bullet-proof + Date: Sun, 26 Sep 1999 03:00:50 -0400 + Message-ID: <19990926030050.A21498@monk.mps.ohio-state.edu> + Branch: cfgperl + ! lib/ExtUtils/xsubpp utils/h2xs.PL +____________________________________________________________________________ +[ 4231] By: jhi on 1999/09/26 09:48:49 + Log: From: "Konovalov, Vadim" <vkonovalov@lucent.com> + To: perl5-porters@perl.org + Subject: misprint in perlguts + Date: Sun, 26 Sep 1999 12:48:36 +0400 + Message-ID: <402099F49BEED211999700805FC7359F20D7A5@ru0028exch01.spb.lucent.com> + Branch: cfgperl + ! pod/perlguts.pod +____________________________________________________________________________ +[ 4230] By: gsar on 1999/09/26 00:50:08 + Log: add $installarchlib/CORE to default linker search path on windows + Branch: perl + ! win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 4229] By: gsar on 1999/09/25 20:05:03 + Log: support C<use Shell> on Windows (reworked a patch suggested + by Jenda Krynicky <Jenda@McCann.cz>) + Branch: perl + ! lib/Shell.pm +____________________________________________________________________________ +[ 4228] By: gsar on 1999/09/25 07:03:34 + Log: integrate cfgperl contents into mainline + Branch: perl + +> hints/svr5.sh + !> Configure MANIFEST Makefile.SH config_h.SH hints/sco.sh + !> lib/unicode/Eq/Latin1 lib/unicode/Eq/Unicode + !> lib/unicode/mktables.PL pod/perldelta.pod pod/perlfaq9.pod + !> regcomp.c regexec.c t/lib/syslfs.t t/op/lfs.t +____________________________________________________________________________ +[ 4227] By: gsar on 1999/09/25 06:44:47 + Log: From: Larry Wall <larry@wall.org> + Date: Fri, 24 Sep 1999 21:59:37 PDT + Message-Id: <199909250459.VAA27506@kiev.wall.org> + Subject: Re: [PATCH 5.005_61] "our" declarations + Branch: perl + ! gv.c gv.h intrpvar.h keywords.h keywords.pl op.c + ! pod/perldiag.pod pod/perlembed.pod pod/perlfaq3.pod + ! pod/perlfaq7.pod pod/perlfunc.pod pod/perlmod.pod + ! pod/perlmodlib.pod pod/perlsub.pod pod/perltoot.pod + ! pod/perlxstut.pod sv.h t/pragma/strict-vars toke.c + ! utils/h2xs.PL +____________________________________________________________________________ +[ 4226] By: jhi on 1999/09/24 23:10:52 + Log: Integrate with Sarathy. + Branch: cfgperl + !> XSUB.h ext/POSIX/POSIX.pod ext/POSIX/POSIX.xs + !> ext/POSIX/hints/linux.pl pod/perldiag.pod pod/perlfunc.pod + !> pp.c t/lib/posix.t t/op/pack.t toke.c utils/perlcc.PL +____________________________________________________________________________ +[ 4225] By: gsar on 1999/09/24 18:19:54 + Log: avoid infinite recursive exec()s of perl.exe when shebang + contains "Perl" rather than "perl" on DOSISH platforms + Branch: perl + ! toke.c +____________________________________________________________________________ +[ 4224] By: gsar on 1999/09/24 16:09:23 + Log: support cygwin and other platforms that link to import libraries + rather than directly with shared libraries (from a suggestion + by Lucian Cionca <Lucian.Cionca@algoritma.ro>) + Branch: perl + ! utils/perlcc.PL +____________________________________________________________________________ +[ 4223] By: gsar on 1999/09/24 05:05:06 + Log: normalize time for strftime() (without the isdst effects of + mktime()) using a custom mini_mktime() + From: spider-perl@Orb.Nashua.NH.US + Date: Thu, 23 Sep 1999 17:54:53 -0400 + Message-Id: <199909232154.RAA25151@leggy.zk3.dec.com> + Subject: Re: [ID 19990913.003] Possible bug using POSIX::strftime Digital UNIX Perl 5.005_03 + Branch: perl + ! ext/POSIX/POSIX.pod ext/POSIX/POSIX.xs + ! ext/POSIX/hints/linux.pl t/lib/posix.t +____________________________________________________________________________ +[ 4222] By: gsar on 1999/09/23 06:44:42 + Log: change "#" to a comment starter in pack templates; "/" now + used for specifying counted types + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Wed, 22 Sep 1999 19:41:30 -0400 + Message-ID: <19990922194130.A864@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_61] Enable comments in pack()/unpack() templates + Branch: perl + ! pod/perldiag.pod pod/perlfunc.pod pp.c t/op/pack.t +____________________________________________________________________________ +[ 4221] By: gsar on 1999/09/23 06:26:54 + Log: From: Vishal Bhatia <vishal@gol.com> + Date: Thu, 23 Sep 1999 12:45:19 +0900 (JST) + Message-ID: <Pine.LNX.4.10.9909231218360.3428-100000@localhost.localdomain> + Subject: [patch _61] perlcc changes + Branch: perl + ! utils/perlcc.PL +____________________________________________________________________________ +[ 4220] By: gsar on 1999/09/23 01:12:24 + Log: add include guard + Branch: perl + ! XSUB.h +____________________________________________________________________________ +[ 4219] By: jhi on 1999/09/22 20:38:15 + Log: Cleanup cleanup. + Branch: cfgperl + ! Makefile.SH t/lib/syslfs.t t/op/lfs.t +____________________________________________________________________________ +[ 4218] By: jhi on 1999/09/22 19:26:58 + Log: Tweak the equivalence tables once again. + Branch: cfgperl + ! lib/unicode/Eq/Latin1 lib/unicode/Eq/Unicode + ! lib/unicode/mktables.PL +____________________________________________________________________________ +[ 4215] By: jhi on 1999/09/22 06:47:03 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + To: Mailing list Perl5 <perl5-porters@perl.org> + Subject: [PATCH 5.005_61] regfree could segfault with -Mre=debug + Date: Tue, 21 Sep 1999 19:50:00 -0400 + Message-ID: <19990921195000.A23938@monk.mps.ohio-state.edu> + + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + To: Mailing list Perl5 <perl5-porters@perl.org> + Subject: [PATCH 5.005_61] More verbose -Mre=debug + Date: Tue, 21 Sep 1999 22:29:55 -0400 + Message-ID: <19990921222955.A25094@monk.mps.ohio-state.edu> + Branch: cfgperl + ! regcomp.c regexec.c +____________________________________________________________________________ +[ 4214] By: jhi on 1999/09/21 21:08:43 + Log: From: 0000-Admin (0000) <root@devsys0.zenez.com> + Reply-To: gerberb@zenez.com + To: perl5-porters@perl.org + Subject: [ID 19990921.004] Changes for SCO OpenServer and UnixWare 7 + Date: Tue, 21 Sep 1999 11:07:46 -0600 (MDT) + Message-Id: <199909211707.LAA23611@devsys0.zenez.com> + + (Snipped away the last lines of svr5.sh a la change #3725) + Branch: cfgperl + + hints/svr5.sh + ! Configure MANIFEST config_h.SH hints/sco.sh + Branch: metaconfig + ! U/modified/Cppsym.U U/modified/Oldconfig.U +____________________________________________________________________________ +[ 4213] By: jhi on 1999/09/21 20:48:01 + Log: From: Kragen Sitaker <kragen@dnaco.net> + To: perl5-porters@perl.org + Subject: [ID 19990921.013] accidental list context in perlfaq9 + Date: Tue, 21 Sep 1999 16:27:53 -0400 (EDT) + Reply-To: kragen@pobox.com + Message-Id: <199909212027.QAA03450@kirk.dnaco.net> + Branch: cfgperl + ! pod/perlfaq9.pod +____________________________________________________________________________ +[ 4212] By: jhi on 1999/09/20 19:55:42 + Log: Integrate with Sarathy. + Branch: cfgperl + +> README.Y2K + !> Changes MANIFEST +____________________________________________________________________________ +[ 4211] By: jhi on 1999/09/20 19:44:44 + Log: Rename -Duselfs to -Duselargefiles. We don't need no stnkngbbrvtns. + Branch: cfgperl + ! Configure config_h.SH pod/perldelta.pod + Branch: metaconfig/U/perl + ! use64bits.U uselfs.U uselongdbl.U +____________________________________________________________________________ +[ 4210] By: jhi on 1999/09/20 19:38:26 + Log: Configure -A change: -Afoo=bar is equal to -Aappend:foo=" bar". + Branch: cfgperl + ! Configure config_h.SH + Branch: metaconfig + ! U/modified/Options.U +____________________________________________________________________________ +[ 4209] By: gsar on 1999/09/20 19:35:39 + Log: integrate cfgperl changes into mainline + Branch: perl + +> lib/unicode/Unicode.html + ! Changes + !> Configure Porting/Glossary Porting/config.sh Porting/config_H + !> config_h.SH doio.c perl.h pod/perldelta.pod pod/perlfunc.pod +____________________________________________________________________________ +[ 4208] By: gsar on 1999/09/20 18:28:44 + Log: add README.Y2K (from Dominic Dunlop <domo@vo.lu>) + Branch: perl + + README.Y2K + ! MANIFEST +____________________________________________________________________________ +[ 4207] By: jhi on 1999/09/20 11:06:13 + Log: Document -Duselfs, -Duselongdouble, and -Dusemorebits. + Branch: cfgperl + ! pod/perldelta.pod +____________________________________________________________________________ +[ 4206] By: jhi on 1999/09/20 09:53:15 + Log: Do not test for gccish things in non-gccish platforms. + Branch: cfgperl + ! Configure config_h.SH + Branch: metaconfig + ! U/compline/ccflags.U +____________________________________________________________________________ +[ 4205] By: jhi on 1999/09/20 09:41:22 + Log: Prompt for uselfs. + Branch: cfgperl + ! Configure Porting/Glossary Porting/config.sh Porting/config_H + ! config_h.SH + Branch: metaconfig + ! U/mksample + Branch: metaconfig/U/perl + ! use64bits.U uselfs.U +____________________________________________________________________________ +[ 4204] By: jhi on 1999/09/20 09:09:29 + Log: Add usemorebits and uselfs. + Branch: cfgperl + ! Configure Porting/Glossary Porting/config.sh Porting/config_H + ! config_h.SH doio.c perl.h + Branch: metaconfig/U/perl + + uselfs.U usemorebits.U + ! use64bits.U uselongdbl.U +____________________________________________________________________________ +[ 4203] By: jhi on 1999/09/20 07:48:48 + Log: Dethinko. + Branch: cfgperl + ! pod/perlfunc.pod +____________________________________________________________________________ +[ 4202] By: jhi on 1999/09/20 07:33:32 + Log: Fix a bug in the description of endianness. Reported in + From: "Konovalov, Vadim" <vkonovalov@lucent.com> + To: perl5-porters@perl.org + Subject: BUG: perldoc -f pack + Date: Mon, 20 Sep 1999 09:43:49 +0400 + Message-ID: <402099F49BEED211999700805FC7359F20D3F5@ru0028exch01.spb.lucent.com> + Branch: cfgperl + ! pod/perlfunc.pod +____________________________________________________________________________ +[ 4201] By: jhi on 1999/09/20 07:01:26 + Log: Integrate with Sarathy. + Branch: cfgperl + +> t/op/args.t + !> (integrate 31 files) +____________________________________________________________________________ +[ 4200] By: gsar on 1999/09/20 03:45:06 + Log: From: Russ Allbery <rra@stanford.edu> + Date: 19 Aug 1999 04:35:44 -0700 + Message-Id: <yl7lms9f5b.fsf@windlord.stanford.edu> + Subject: [ID 19990819.002] File::Find error when pruning top-level directories + Branch: perl + ! lib/File/Find.pm +____________________________________________________________________________ +[ 4199] By: gsar on 1999/09/20 03:27:49 + Log: suppress warning (from John Tobey <jtobey@epsilondev.com>) + Branch: perl + ! ext/B/B/Terse.pm +____________________________________________________________________________ +[ 4198] By: gsar on 1999/09/20 03:25:25 + Log: add arenas for managing allocations of remaining xpv*v structures + From: Vishal Bhatia <vishal@gol.com> + Date: Wed, 25 Aug 1999 00:31:33 +0900 (JST) + Message-ID: <Pine.LNX.4.10.9908250031000.11727-100000@localhost.localdomain> + Subject: [PATCH 5.005_60] removing extra ref count (compiler) + Branch: perl + ! embed.h embed.pl embedvar.h ext/B/B/C.pm intrpvar.h objXSUB.h + ! proto.h sv.c +____________________________________________________________________________ +[ 4197] By: gsar on 1999/09/20 03:06:10 + Log: queue errors due to strictures rather than printing them as + warnings; symbols that violate strictures do *not* end up in + the symbol table anyway, making multiple evals of the same piece + of code produce the same errors; errors indicate all locations + of a global symbol rather than just the first one; these + changes make compile-time failures within evals reliably + visible via the return value or contents of $@, and trappable + using __DIE__ hooks + Branch: perl + ! embed.h embed.pl embedvar.h ext/DynaLoader/dlutils.c + ! ext/Thread/Thread.xs global.sym gv.c objXSUB.h op.c perl.c + ! perlapi.c pp_ctl.c proto.h regcomp.c t/pragma/strict-refs + ! t/pragma/strict-vars thrdvar.h toke.c util.c +____________________________________________________________________________ +[ 4196] By: gsar on 1999/09/19 22:14:29 + Log: control change#1914 via hints (causes problems on some platforms) + Branch: perl + ! ext/POSIX/POSIX.pod ext/POSIX/POSIX.xs + ! ext/POSIX/hints/linux.pl +____________________________________________________________________________ +[ 4195] By: gsar on 1999/09/19 21:30:18 + Log: avoid clearing @_ at all for faster subroutine calls; fix bugs + in passing around references to @_, eg C<sub foo { \@_ }>; add + tests for the same + Branch: perl + + t/op/args.t + ! MANIFEST cop.h pp.c pp_ctl.c pp_hot.c +____________________________________________________________________________ +[ 4194] By: jhi on 1999/09/18 18:57:45 + Log: Integrate with Sarathy. + Branch: cfgperl + !> opcode.h opcode.pl +____________________________________________________________________________ +[ 4193] By: nick on 1999/09/18 15:24:56 + Log: Re-integrate mainline + Basic SvUTF8 stuff in headers, no functional changes yet. + Branch: utfperl + + lib/byte.pm lib/byte_heavy.pl + +> ext/B/defsubs_h.PL ext/DB_File/version.c jpl/JNI/Closer.java + +> jpl/JNI/JNIConfig jpl/JNI/JNIConfig.Win32 + +> jpl/JNI/JNIConfig.kaffe jpl/JNI/JNIConfig.noembed + +> jpl/JNI/JNIConfig.standard jpl/JNI/typemap.gcc + +> jpl/JNI/typemap.win32 jpl/SETVARS.PL lib/unicode/ArabShap.txt + +> lib/unicode/Blocks.txt lib/unicode/CompExcl.txt + +> lib/unicode/EAWidth.txt lib/unicode/Index.txt + +> lib/unicode/Jamo-2.txt lib/unicode/LineBrk.txt + +> lib/unicode/Names.txt lib/unicode/Props.txt + +> lib/unicode/ReadMe.txt lib/unicode/SpecCase.txt + +> t/lib/bigfltpm.t + - ext/B/defsubs.h.PL lib/unicode/arabshp.txt + - lib/unicode/blocks.txt lib/unicode/index2.txt + - lib/unicode/jamo2.txt lib/unicode/names2.txt + - lib/unicode/props2.txt lib/unicode/readme.txt + - t/lib/bigfloatpm.t + ! doop.c embed.h embed.pl gv.c mg.c objXSUB.h op.c op.h perl.h + ! perlapi.c pp.c pp_ctl.c pp_hot.c proto.h regcomp.c regcomp.h + ! regexec.c regexp.h regnodes.h sv.c sv.h toke.c utf8.c utf8.h + ! warnings.h + !> (integrate 142 files) +____________________________________________________________________________ +[ 4192] By: gsar on 1999/09/18 15:11:47 + Log: more op description tweaks + Branch: perl + ! opcode.h opcode.pl +____________________________________________________________________________ +[ 4191] By: jhi on 1999/09/18 07:47:16 + Log: Integrate with Sarathy. + Branch: cfgperl + !> Changes opcode.h opcode.pl t/io/open.t t/op/misc.t + !> t/pragma/warn/op +____________________________________________________________________________ +[ 4190] By: jhi on 1999/09/18 07:35:45 + Log: Add description of the Unicode database files. + Branch: cfgperl + + lib/unicode/Unicode.html +____________________________________________________________________________ +[ 4189] By: gsar on 1999/09/18 03:14:58 + Log: tweak some op names in change#4177 (will any of this break code that + gropes $@ ?) + Branch: perl + ! Changes opcode.h opcode.pl t/io/open.t t/op/misc.t + ! t/pragma/warn/op +____________________________________________________________________________ [ 4188] By: jhi on 1999/09/17 21:30:08 Log: Pick up the typo fix. Branch: cfgperl @@ -1096,22 +1741,11 @@ ____________________________________________________________________________ Branch: cfgperl ! toke.c ____________________________________________________________________________ -[ 4058] By: jhi on 1999/08/31 08:57:35 - Log: For some odd reason #4056 didn't undo #3922 completely. - Branch: cfgperl - ! pp.c -____________________________________________________________________________ [ 4057] By: gsar on 1999/08/30 22:08:19 Log: avoid hiding child process window Branch: perl ! win32/win32.c ____________________________________________________________________________ -[ 4056] By: jhi on 1999/08/30 21:36:24 - Log: Retract #3922 (Rule #1 was invoked). - (See also #4058). - Branch: cfgperl - ! pod/perldiag.pod pp.c regexp.h -____________________________________________________________________________ [ 4055] By: jhi on 1999/08/30 21:20:50 Log: Document the undefinedness of overshifting. Branch: cfgperl @@ -1689,11 +2323,6 @@ ____________________________________________________________________________ Branch: metaconfig/U/perl ! d_dlsymun.U io64.U uselongdbl.U ____________________________________________________________________________ -[ 3981] By: jhi on 1999/08/13 15:11:51 - Log: Retract change #3977 (do_open9() adds O_LARGEFILE automagically). - Branch: cfgperl - ! t/lib/syslfs.t -____________________________________________________________________________ [ 3980] By: jhi on 1999/08/13 15:09:11 Log: Introduce HAS_LLSEEK. Branch: cfgperl @@ -1714,11 +2343,6 @@ ____________________________________________________________________________ Branch: cfgperl ! t/op/64bit.t ____________________________________________________________________________ -[ 3977] By: jhi on 1999/08/13 09:56:25 - Log: Use O_LARGEFILE if available. - Branch: cfgperl - ! t/lib/syslfs.t -____________________________________________________________________________ [ 3976] By: jhi on 1999/08/12 21:49:16 Log: IRIX64 needs more -mabi=64 with gcc. Branch: cfgperl @@ -2093,18 +2717,6 @@ ____________________________________________________________________________ Branch: cfgperl ! pp.c ____________________________________________________________________________ -[ 3924] By: jhi on 1999/08/05 09:23:00 - Log: Warning fix to change #3922. - From: paul.marquess@bt.com - To: ilya@math.ohio-state.edu, gsar@activestate.com - Cc: tchrist@jhereg.perl.com, chaimf@pobox.com, ed@chronos.net, - perl5-porters@perl.org - Subject: RE: [PATCH 5.00557] split /^/ - Date: Thu, 5 Aug 1999 09:01:15 +0100 - Message-ID: <5104D4DBC598D211B5FE0000F8FE7EB202D49B23@mbtlipnt02.btlabs.bt.co.uk> - Branch: cfgperl - ! pp.c -____________________________________________________________________________ [ 3923] By: jhi on 1999/08/05 09:16:57 Log: From: paul.marquess@bt.com To: jhi@iki.fi, paul.marquess@bt.com @@ -2115,19 +2727,6 @@ ____________________________________________________________________________ Branch: cfgperl ! t/lib/anydbm.t ____________________________________________________________________________ -[ 3922] By: jhi on 1999/08/05 08:09:59 - Log: Deprecate /^/ implictly meaning /^/m. - - From: Ilya Zakharevich <ilya@math.ohio-state.edu> - To: Gurusamy Sarathy <gsar@activestate.com> - Cc: Tom Christiansen <tchrist@jhereg.perl.com>, chaimf@pobox.com, - ed@chronos.net, perl5-porters@perl.org - Subject: [PATCH 5.00557] split /^/ - Date: Wed, 4 Aug 1999 16:46:57 -0400 - Message-ID: <19990804164657.A3776@monk.mps.ohio-state.edu> - Branch: cfgperl - ! pod/perldiag.pod pp.c regexp.h -____________________________________________________________________________ [ 3921] By: jhi on 1999/08/05 08:05:13 Log: From: paul.marquess@bt.com To: perl5-porters@perl.org @@ -2211,26 +2810,6 @@ ____________________________________________________________________________ Branch: cfgperl ! t/op/filetest.t ____________________________________________________________________________ -[ 3913] By: jhi on 1999/08/03 21:07:57 - Log: Retract #3912, much too many compilation warnings - under Digital UNIX. - Branch: cfgperl - ! doio.c iperlsys.h perl.h perlio.c perlsdio.h perlsfio.h - ! pp_sys.c sv.c -____________________________________________________________________________ -[ 3912] By: jhi on 1999/08/03 20:13:59 - Log: (Retracted). See #3913. - - From: Sven Verdoolaege <skimo@kotnet.org> - To: perl5-porters@perl.org - Subject: [ID 19990803.003] Not OK: perl 5.00560 on i586-linux-thread - 2.1.125 [PATCH] - Date: Tue, 3 Aug 1999 13:14:07 +0200 - Message-Id: <19990803131407.A30911@pool.kotnet.org> - Branch: cfgperl - ! doio.c iperlsys.h perl.h perlio.c perlsdio.h perlsfio.h - ! pp_sys.c sv.c -____________________________________________________________________________ [ 3911] By: jhi on 1999/08/03 19:52:38 Log: The "-Dusethreads -Duseperlio" combination failed. @@ -20,7 +20,7 @@ # $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $ # -# Generated on Fri Sep 17 12:06:13 EET DST 1999 [metaconfig 3.0 PL70] +# Generated on Thu Sep 30 19:41:54 EET DST 1999 [metaconfig 3.0 PL70] # (with additional metaconfig patches by perlbug@perl.com) cat >/tmp/c1$$ <<EOF @@ -817,7 +817,9 @@ trnl='' uidtype='' archname64='' use64bits='' +uselargefiles='' uselongdouble='' +usemorebits='' usemultiplicity='' nm_opt='' nm_so_opt='' @@ -872,7 +874,7 @@ al="$al MIPSEB MIPSEL MSDOS MTXINU MULTIMAX MVS" al="$al M_COFF M_I186 M_I286 M_I386 M_I8086 M_I86 M_I86SM" al="$al M_SYS3 M_SYS5 M_SYSIII M_SYSV M_UNIX M_XENIX" al="$al NeXT OCS88 OSF1 PARISC PC532 PORTAR POSIX" -al="$al PWB R3000 RES RISC6000 RT Sun386i SVR3 SVR4" +al="$al PWB R3000 RES RISC6000 RT Sun386i SVR3 SVR4 SVR5" al="$al SYSTYPE_BSD SYSTYPE_SVR4 SYSTYPE_SYSV Tek4132 Tek4300" al="$al UMAXV USGr4 USGr4_2 UTEK UTS UTek UnicomPBB UnicomPBD Utek" al="$al VMS Xenix286" @@ -1219,55 +1221,53 @@ while test $# -gt 0; do shift xxx='' yyy="$1" - case "$yyy" in - *:*) xxx=`echo $yyy|sed 's!:.*!!'` - yyy=`echo $yyy|sed 's!^[^:]*:!!'` - ;; - esac - case "$xxx" in - '') xxx=define ;; - esac zzz='' - uuu='undef' + uuu=undef case "$yyy" in - *=*) zzz=`echo $yyy|sed 's!^[^=]*=!!'` - yyy=`echo $yyy|sed 's!=.*!!'` - case "$yyy:$zzz" in - undef:) uuu='' ;; - esac - ;; - esac + *=*) zzz=`echo $yyy|sed 's!=.*!!'` + case "$zzz" in + *:*) zzz='' ;; + *) xxx=append + zzz=" "`echo $yyy|sed 's!^[^=]*=!!'` + yyy=`echo $yyy|sed 's!=.*!!'` ;; + esac + ;; + esac + case "$xxx" in + '') case "$yyy" in + *:*) xxx=`echo $yyy|sed 's!:.*!!'` + yyy=`echo $yyy|sed 's!^[^:]*:!!'` + zzz=`echo $yyy|sed 's!^[^=]*=!!'` + yyy=`echo $yyy|sed 's!=.*!!'` ;; + *) xxx=`echo $yyy|sed 's!:.*!!'` + yyy=`echo $yyy|sed 's!^[^:]*:!!'` ;; + esac + ;; + esac case "$xxx" in append) - echo "$yyy=\"\${$yyy}$zzz\"" >> posthint.sh - ;; + echo "$yyy=\"\${$yyy}$zzz\"" >> posthint.sh ;; clear) - echo "$yyy=''" >> posthint.sh - ;; + echo "$yyy=''" >> posthint.sh ;; define) case "$zzz" in '') zzz=define ;; esac - echo "$yyy='$zzz'" >> posthint.sh - ;; + echo "$yyy='$zzz'" >> posthint.sh ;; eval) - echo "eval \"$yyy=$zzz\"" >> posthint.sh - ;; + echo "eval \"$yyy=$zzz\"" >> posthint.sh ;; prepend) - echo "$yyy=\"$zzz\${$yyy}\"" >> posthint.sh - ;; + echo "$yyy=\"$zzz\${$yyy}\"" >> posthint.sh ;; undef) case "$zzz" in '') zzz="$uuu" ;; esac - echo "$yyy=$zzz" >> posthint.sh - ;; - *) echo "$me: unknown -A command '$xxx', ignoring -A $1" >&2 - ;; + echo "$yyy=$zzz" >> posthint.sh ;; + *) echo "$me: unknown -A command '$xxx', ignoring -A $1" >&2 ;; esac ;; -V) echo "$me generated by metaconfig 3.0 PL70." >&2 - exit 0;; + exit 0;; --) break;; -*) echo "$me: unknown option $1" >&2; shift; error=true;; *) break;; @@ -1296,9 +1296,9 @@ Usage: $me [-dehrsEKOSV] [-f config.sh] [-D symbol] [-D symbol=value] -U symbol symbol gets the value 'undef' -U symbol= symbol gets completely empty -A : manipulate symbol after the platform specific hints have been applied: + -A symbol=value append " "value to symbol -A append:symbol=value append value to symbol -A define:symbol=value define symbol to have value - -A symbol=value define symbol to have value -A clear:symbol define symbol to be '' -A define:symbol define symbol to be 'define' -A eval:symbol=value define symbol to be eval of value @@ -1332,7 +1332,6 @@ touch optdef.sh . ./optdef.sh : create the posthint manipulation script and leave the file out there... touch posthint.sh -. ./posthint.sh : set package name package=perl5 @@ -2311,7 +2310,10 @@ EOM mips) osname=mips_osf1 ;; esac ;; - uts) osname=uts + unixware) osname=svr5 + osvers="$4" + ;; + uts) osname=uts osvers="$3" ;; qnx) osname=qnx @@ -3014,12 +3016,47 @@ case "$gccversion" in 1*) cpp=`./loc gcc-cpp $cpp $pth` ;; esac + +case "$usemorebits" in +"$define"|true|[yY]*) + use64bits="$define" + uselongdouble="$define" + usemorebits="$define" + ;; +*) usemorebits="$undef" + ;; +esac + + +cat <<EOM + +Perl can be built to understand large files (files larger than 2 gigabytes) +on some systems. To do so, Configure must be run with -Duselargefiles. + +If this doesn't make any sense to you, just accept the default. +EOM +case "$uselargefiles" in +"$define"|true|[yY]*) dflt='y' ;; +*) dflt='n' ;; +esac +rp='Try to understand large files?' +. ./myread +case "$ans" in +y|Y) val="$define" ;; +*) val="$undef" ;; +esac +set uselargefiles +eval $setvar +case "$uselargefiles" in +"$define") use64bits="$define" ;; +esac + cat <<EOM Perl can be built to take advantage of explicit 64-bit interfaces, on some systems. To do so, Configure must be run with -Duse64bits. -If this doesn't make any sense to you, just accept the default 'n'. +If this doesn't make any sense to you, just accept the default. EOM case "$use64bits" in $define|true|[yY]*) dflt='y';; @@ -3539,9 +3576,11 @@ echo "Getting the current patchlevel..." >&4 if $test -r $rsrc/patchlevel.h;then patchlevel=`awk '/define[ ]+PERL_VERSION/ {print $3}' $rsrc/patchlevel.h` subversion=`awk '/define[ ]+PERL_SUBVERSION/ {print $3}' $rsrc/patchlevel.h` + apiversion=`awk '/define[ ]+PERL_APIVERSION/ {print $3}' $rsrc/patchlevel.h` else patchlevel=0 subversion=0 + apiversion=0 fi $echo $n "(You have $package" $c case "$package" in @@ -3561,15 +3600,6 @@ else echo $baserev $patchlevel $subversion | \ $awk '{ printf "%.5f\n", $1 + $2/1000.0 + $3/100000.0 }'` fi -: Figure out perl API version. Perhaps this should be in patchlevel.h -if test "$subversion" -lt 50; then - apiversion=`LC_ALL=C; export LC_ALL; \ - LANGUAGE=C; export LANGUAGE; \ - echo $baserev $patchlevel | \ - $awk '{ printf "%.3f\n", $1 + $2/1000.0 }'` -else - apiversion="$version" -fi : determine installation style : For now, try to deduce it from prefix unless it is already set. @@ -4261,7 +4291,7 @@ default|recommended) case "$gccversion" in 1*) ;; 2.[0-8]*) ;; - *) echo " " + ?*) echo " " echo "Checking if your compiler accepts -fno-strict-aliasing" 2>&1 echo 'int main(void) { return 0; }' > gcctest.c if $cc -O2 -fno-strict-aliasing -o gcctest gcctest.c; then @@ -13969,7 +13999,9 @@ uname='$uname' uniq='$uniq' use64bits='$use64bits' usedl='$usedl' +uselargefiles='$uselargefiles' uselongdouble='$uselongdouble' +usemorebits='$usemorebits' usemultiplicity='$usemultiplicity' usemymalloc='$usemymalloc' usenm='$usenm' @@ -41,11 +41,18 @@ pod/perldelta.pod file. For more detailed information about specific changes, see the Changes file. IMPORTANT NOTE: 5.005_53 and later releases do not export unadorned -global symbols anymore. This means most CPAN modules probably won't -build under this release without adding '-DPERL_POLLUTE' to ccflags -in config.sh. This is not the default because we want the modules -to get fixed *before* the 5.6 release. pod/perldelta.pod contains -additional notes about this. +global symbols anymore. This means you may need to build older +extensions that have not been updated for the new naming convention +with: + + perl Makefile.PL POLLUTE=1 + +Alternatively, you can enable CPP symbol pollution wholesale by +building perl itself with: + + sh Configure -Accflags=-DPERL_POLLUTE + +pod/perldelta.pod contains more details about this. =head1 DESCRIPTION @@ -71,18 +78,26 @@ system. (Unixware users should use the svr4.sh hint file.) If there is a README file for your platform, then you should read that too. Additional information is in the Porting/ directory. -=head1 WARNING: This version is not binary compatible with Perl 5.005. +=head1 WARNING: This version may not be binary compatible with Perl 5.005. + +Using the default Configure options for building perl should get you +a perl that will be binary compatible with the 5.005 release. -If you have dynamically loaded extensions that you built under perl -5.005, you will need to rebuild and reinstall those extensions to use -them with 5.6. Pure perl modules should continue to work just fine -without reinstallation. See the discussions below on L<"Coexistence -with earlier versions of perl5"> and L<"Upgrading from 5.005 to -5.6"> for more details. +However, if you run Configure with any custom options, such as +-Dusethreads, -Dusemultiplicity, -Dusemymalloc, -Ubincompat5005 etc., +the resulting perl will not be binary compatible. Under these +circumstances, if you have dynamically loaded extensions that were +built under perl 5.005, you will need to rebuild and reinstall all +those extensions to use them with 5.6. + +Pure perl modules without XS or C code should continue to work fine +without reinstallation. See the discussions below on +L<"Coexistence with earlier versions of perl5"> and +L<"Upgrading from 5.005 to 5.6"> for more details. The standard extensions supplied with Perl will be handled automatically. -In a related issue, old modules may possibly be affected by the +On a related issue, old modules may possibly be affected by the changes in the Perl language in the current release. Please see pod/perldelta.pod (and pod/perl500Xdelta.pod) for a description of what's changed. See also your installed copy of the perllocal.pod @@ -180,6 +195,21 @@ defaults from then on. After it runs, Configure will perform variable substitution on all the *.SH files and offer to run make depend. +=head2 Altering config.sh variables for C compiler switches etc. + +For most users, all of the Configure defaults are fine. Configure +also has several convenient options which are all described below. +However, if Configure doesn't have an option to do what you want, +you can change Configure variables after the platform hints have been +run, by using Configure's -A switch. For example, here's how to add +a couple of extra flags to C compiler invocations: + + sh Configure -Accflags="-DPERL_Y2KWARN -DPERL_POLLUTE_MALLOC" + +For more help on Configure switches, run: + + sh Configure -h + =head2 Common Configure options Configure supports a number of useful options. Run B<Configure -h> to @@ -819,16 +849,6 @@ it's convenient to have both. If you are using a shared libperl, see the warnings about multiple versions of perl under L<Building a shared libperl.so Perl library>. -=head2 Other Compiler Flags - -For most users, all of the Configure defaults are fine. However, 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. - -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.) - =head2 Extensions By default, Configure will offer to build every extension which appears @@ -1359,10 +1379,13 @@ with B<make depend; make>. =item CRIPPLED_CC -If you still can't compile successfully, try adding a -DCRIPPLED_CC -flag. (Just because you get no errors doesn't mean it compiled right!) -This simplifies some complicated expressions for compilers that get -indigestion easily. +If you still can't compile successfully, try: + + sh Configure -Accflags=-DCRIPPLED_CC + +This flag simplifies some complicated expressions for compilers that get +indigestion easily. (Just because you get no errors doesn't mean it +compiled right!) =item Missing functions @@ -31,6 +31,7 @@ Porting/patching.pod How to report changes made to Perl Porting/patchls Flexible patch file listing utility Porting/pumpkin.pod Guidelines and hints for Perl maintainers README The Instructions +README.Y2K Notes about Year 2000 concerns README.amiga Notes about AmigaOS port README.apollo Notes about Apollo DomainOS port README.beos Notes about BeOS port @@ -471,6 +472,7 @@ hints/stellar.sh Hints for named architecture hints/sunos_4_0.sh Hints for named architecture hints/sunos_4_1.sh Hints for named architecture hints/svr4.sh Hints for named architecture +hints/svr5.sh Hints for named architecture hints/ti1500.sh Hints for named architecture hints/titanos.sh Hints for named architecture hints/ultrix_4.sh Hints for named architecture @@ -612,9 +614,8 @@ lib/Pod/Functions.pm used by pod/splitpod lib/Pod/Html.pm Convert POD data to HTML lib/Pod/InputObjects.pm Pod-Parser - define objects for input streams lib/Pod/Parser.pm Pod-Parser - define base class for parsing POD -lib/Pod/PlainText.pm Pod-Parser - convert POD data to formatted ASCII text lib/Pod/Select.pm Pod-Parser - select portions of POD docs -lib/Pod/Text.pm Convert POD data to formatted ASCII text +lib/Pod/Text.pm Pod-Parser - convert POD data to formatted ASCII text lib/Pod/Text/Color.pm Convert POD data to color ASCII text lib/Pod/Text/Termcap.pm Convert POD data to ASCII text with format escapes lib/Pod/Usage.pm Pod-Parser - print usage messages @@ -1236,6 +1237,7 @@ t/lib/timelocal.t See if Time::Local works t/lib/trig.t See if Math::Trig works t/op/64bit.t See if 64 bitness works t/op/append.t See if . works +t/op/args.t See if operations on @_ work t/op/arith.t See if arithmetic works t/op/array.t See if array operations work t/op/assignwarn.t See if OP= operators warn correctly for undef targets @@ -1341,14 +1343,20 @@ t/pod/included.t Test =include directive t/pod/included.xr Expected results for included.t t/pod/lref.t Test L<...> sequences t/pod/lref.xr Expected results for lref.t +t/pod/multiline_items.t Test multiline =items +t/pod/multiline_items.xr Test multiline =items t/pod/nested_items.t Test nested =items t/pod/nested_items.xr Expected results for nested_items.t t/pod/nested_seqs.t Test nested interior sequences t/pod/nested_seqs.xr Expected results for nested_seqs.t t/pod/oneline_cmds.t Test single paragraph ==cmds t/pod/oneline_cmds.xr Expected results for oneline_cmds.t +t/pod/pod2usage.t Test Pod::Usage +t/pod/pod2usage.xr Expected results for pod2usage.t t/pod/poderrs.t Test POD errors t/pod/poderrs.xr Expected results for emptycmd.t +t/pod/podselect.t Test Pod::Select +t/pod/podselect.xr Expected results for podselect.t t/pod/special_seqs.t Test "special" interior sequences t/pod/special_seqs.xr Expected results for emptycmd.t t/pod/testcmp.pl Module to compare output against expected results diff --git a/Makefile.SH b/Makefile.SH index e7fb039f33..bf98183e06 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -539,6 +539,8 @@ SYM = global.sym globvar.sym perlio.sym pp.sym SYMH = perlvars.h intrpvar.h thrdvar.h +CHMOD_W = chmod +w + # The following files are generated automatically # keywords.h: keywords.pl # opcode.h: opcode.pl @@ -557,6 +559,7 @@ SYMH = perlvars.h intrpvar.h thrdvar.h # To force them to run, type # make regen_headers regen_headers: FORCE + $(CHMOD_W) proto.h warning.h lib/warning.pm perl keywords.pl perl opcode.pl perl embed.pl @@ -623,7 +626,7 @@ _cleaner: -@for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) $(nonxs_ext) ; do \ $(LDLIBPTH) sh ext/util/make_ext realclean $$x MAKE=$(MAKE) ; \ done - rm -f *.orig */*.orig *~ */*~ core core.*perl.*.? *perl.core t/core t/core.perl.*.? t/*perl.core t/misctmp* t/tmp* t/Io.dup t/tmon.out t/big t/c t/perl t/nonexistent1 so_locations $(LIBPERL_NONSHR) $(MINIPERL_NONSHR) + rm -f *.orig */*.orig *~ */*~ core core.*perl.*.? *perl.core t/core t/core.perl.*.? t/*perl.core t/misctmp* t/tmp* t/c t/perl so_locations $(LIBPERL_NONSHR) $(MINIPERL_NONSHR) rm -rf $(addedbyconf) rm -f $(FIRSTMAKEFILE) $(FIRSTMAKEFILE).old rm -f $(private) diff --git a/Porting/Glossary b/Porting/Glossary index 30c75b656c..46fb810f0a 100644 --- a/Porting/Glossary +++ b/Porting/Glossary @@ -38,16 +38,18 @@ aphostname (d_gethname.U): it safe when used by a process with super-user privileges. apiversion (patchlevel.U): - This is a number which identifies the lowest version of perl - to have an API (for XS extensions) compatible with the present - version. For example, for 5.005_01, the apiversion should be - 5.005, since 5.005_01 should be binary compatible with 5.005. - This should probably be incremented manually somehow, perhaps - from patchlevel.h. For now, we'll guess maintenance subversions - will retain binary compatibility. + MakeMaker will install add-on modules in a directory with the + PERL_APIVERSION version number. The value is set manually in + patchlevel.h. Normally, for maintenance releases, this is + just something like 5.005 or 5.6 or 5.7. That is, it does not + include the subversion number and does not change across + maintenance releases. This is so that add-on extensions can + be shared across maintenance versions. It is unclear how this + ought to work for developer versions. If a release breaks + binary compatibility, this number should be increased. 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. @@ -77,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. @@ -107,7 +109,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. @@ -131,7 +133,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. @@ -192,7 +194,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. @@ -207,7 +209,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. @@ -216,7 +218,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. @@ -275,7 +277,7 @@ cryptlib (d_crypt.U): 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. @@ -1540,7 +1542,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. @@ -1597,12 +1599,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. @@ -1619,7 +1621,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. @@ -1697,7 +1699,7 @@ glibpth (libpth.U): this platform, libpth is the cleaned-up version. 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. @@ -1713,7 +1715,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. @@ -2172,7 +2174,7 @@ ldlibpthname (libperl.U): string, the hints file must set this to 'none'. 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. @@ -2216,7 +2218,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. @@ -2260,7 +2262,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. @@ -2283,7 +2285,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. @@ -2344,7 +2346,7 @@ man3ext (man3dir.U): See man3dir. 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. @@ -2359,7 +2361,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. @@ -2379,7 +2381,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. @@ -2441,7 +2443,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. @@ -2461,7 +2463,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. @@ -2539,7 +2541,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. @@ -2620,7 +2622,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. @@ -2649,7 +2651,7 @@ 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. @@ -2809,7 +2811,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. @@ -2976,7 +2978,7 @@ tee (Loc.U): The value is a plain '' 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. @@ -2989,12 +2991,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. @@ -3013,12 +3015,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. @@ -3031,10 +3033,20 @@ usedl (dlsrc.U): This variable indicates if the the system supports dynamic loading of some sort. See also dlsrc and dlobj. +uselargefiles (uselfs.U): + This variable conditionally defines the USE_LARGE_FILES symbol, + and indicates that large file interfaces should be used when + available. The use64bits symbol will also be turned on if necessary. + uselongdouble (uselongdbl.U): This variable conditionally defines the USE_LONG_DOUBLE symbol, and indicates that long doubles should be used when available. +usemorebits (usemorebits.U): + This variable conditionally defines the USE_MORE_BITS symbol, + and indicates that explicit 64-bit interfaces and long doubles + should be used when available. + usemultiplicity (usemultiplicity.U): This variable conditionally defines the MULTIPLICITY symbol, and indicates that Perl should be built to use multiplicity. @@ -3151,7 +3163,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/Porting/config.sh b/Porting/config.sh index d0d5b2a669..af71eadd3c 100644 --- a/Porting/config.sh +++ b/Porting/config.sh @@ -8,7 +8,7 @@ # Package name : perl5 # Source directory : . -# Configuration time: Fri Sep 17 12:08:19 EET DST 1999 +# Configuration time: Thu Sep 30 19:44:33 EET DST 1999 # Configured by : jhi # Target system : osf1 alpha.hut.fi v4.0 878 alpha @@ -30,7 +30,7 @@ afs='false' alignbytes='8' ansi2knr='' aphostname='' -apiversion='5.00561' +apiversion='' ar='ar' archlib='/opt/perl/lib/5.00561/alpha-dec_osf-thread' archlibexp='/opt/perl/lib/5.00561/alpha-dec_osf-thread' @@ -56,7 +56,7 @@ ccflags='-pthread -std -DLANGUAGE_C' ccsymbols='__LANGUAGE_C__=1 _LONGLONG=1 LANGUAGE_C=1 SYSTYPE_BSD=1' cf_by='jhi' cf_email='yourname@yourhost.yourplace.com' -cf_time='Fri Sep 17 12:08:19 EET DST 1999' +cf_time='Thu Sep 30 19:44:33 EET DST 1999' chgrp='' chmod='' chown='' @@ -478,7 +478,7 @@ installprefix='/opt/perl' installprefixexp='/opt/perl' installprivlib='/opt/perl/lib/5.00561' installscript='/opt/perl/bin' -installsitearch='/opt/perl/lib/site_perl/5.00561/alpha-dec_osf-thread' +installsitearch='/opt/perl/lib/site_perl//alpha-dec_osf-thread' installsitelib='/opt/perl/lib/site_perl' installstyle='lib' installusrbinperl='define' @@ -618,8 +618,8 @@ sig_name_init='"ZERO", "HUP", "INT", "QUIT", "ILL", "TRAP", "ABRT", "EMT", "FPE" sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 6 6 16 20 23 23 23 29 48 ' sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 6, 6, 16, 20, 23, 23, 23, 29, 48, 0' signal_t='void' -sitearch='/opt/perl/lib/site_perl/5.00561/alpha-dec_osf-thread' -sitearchexp='/opt/perl/lib/site_perl/5.00561/alpha-dec_osf-thread' +sitearch='/opt/perl/lib/site_perl//alpha-dec_osf-thread' +sitearchexp='/opt/perl/lib/site_perl//alpha-dec_osf-thread' sitelib='/opt/perl/lib/site_perl' sitelibexp='/opt/perl/lib/site_perl' siteprefix='/opt/perl' @@ -667,7 +667,9 @@ uname='uname' uniq='uniq' use64bits='define' usedl='define' +uselargefiles='undef' uselongdouble='undef' +usemorebits='undef' usemultiplicity='undef' usemymalloc='n' usenm='true' @@ -694,18 +696,19 @@ zcat='' zip='zip' # Configure command line arguments. config_arg0='Configure' -config_args='-Dprefix=/opt/perl -Doptimize=-O -Dusethreads -Duse64bits -Dcf_by=yourname -Dcf_email=yourname@yourhost.yourplace.com -Dperladmin=yourname@yourhost.yourplace.com -Dmydomain=.yourplace.com -Dmyhostname=yourhost -dE' -config_argc=10 +config_args='-Dprefix=/opt/perl -Doptimize=-O -Dusethreads -Duse64bits -Duselfs -Dcf_by=yourname -Dcf_email=yourname@yourhost.yourplace.com -Dperladmin=yourname@yourhost.yourplace.com -Dmydomain=.yourplace.com -Dmyhostname=yourhost -dE' +config_argc=11 config_arg1='-Dprefix=/opt/perl' config_arg2='-Doptimize=-O' config_arg3='-Dusethreads' config_arg4='-Duse64bits' -config_arg5='-Dcf_by=yourname' -config_arg6='-Dcf_email=yourname@yourhost.yourplace.com' -config_arg7='-Dperladmin=yourname@yourhost.yourplace.com' -config_arg8='-Dmydomain=.yourplace.com' -config_arg9='-Dmyhostname=yourhost' -config_arg10='-dE' +config_arg5='-Duselfs' +config_arg6='-Dcf_by=yourname' +config_arg7='-Dcf_email=yourname@yourhost.yourplace.com' +config_arg8='-Dperladmin=yourname@yourhost.yourplace.com' +config_arg9='-Dmydomain=.yourplace.com' +config_arg10='-Dmyhostname=yourhost' +config_arg11='-dE' PERL_REVISION=5 PERL_VERSION=5 PERL_SUBVERSION=61 diff --git a/Porting/config_H b/Porting/config_H index bdf4aee8bd..d099550d2b 100644 --- a/Porting/config_H +++ b/Porting/config_H @@ -17,7 +17,7 @@ /* * Package name : perl5 * Source directory : . - * Configuration time: Fri Sep 17 12:08:19 EET DST 1999 + * Configuration time: Thu Sep 30 19:44:33 EET DST 1999 * Configured by : jhi * Target system : osf1 alpha.hut.fi v4.0 878 alpha */ @@ -1469,8 +1469,8 @@ * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITEARCH "/opt/perl/lib/site_perl/5.00561/alpha-dec_osf-thread" /**/ -#define SITEARCH_EXP "/opt/perl/lib/site_perl/5.00561/alpha-dec_osf-thread" /**/ +#define SITEARCH "/opt/perl/lib/site_perl//alpha-dec_osf-thread" /**/ +#define SITEARCH_EXP "/opt/perl/lib/site_perl//alpha-dec_osf-thread" /**/ /* SITELIB: * This symbol contains the name of the private library for this package. @@ -2461,6 +2461,13 @@ */ #define USE_64_BITS /**/ +/* USE_LARGE_FILES: + * This symbol, if defined, indicates that large file support + * should be used when available. The USE_64_BITS symbol will + * also be turned on if necessary. + */ +/*#define USE_LARGE_FILES / **/ + /* USE_LONG_DOUBLE: * This symbol, if defined, indicates that long doubles should * be used when available. diff --git a/Porting/findvars b/Porting/findvars index 2e81244ac8..b91753bbbe 100755 --- a/Porting/findvars +++ b/Porting/findvars @@ -238,7 +238,6 @@ osname pad_reset_pending padix padix_floor -parsehook patchlevel patleave pending_ident diff --git a/README.Y2K b/README.Y2K new file mode 100644 index 0000000000..378db15c11 --- /dev/null +++ b/README.Y2K @@ -0,0 +1,47 @@ +The following information about Perl and the year 2000 is a modified +version of the information that can be found in the Frequently Asked +Question (FAQ) documents. + +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 (whatever that means). The + programmers you've hired to use it, however, probably are + not. If you want perl to complain when your programmers + create programs with certain types of possible year 2000 + problems, a build option allows you to turn on warnings. + +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. + + 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 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, $timestamp = + gmtime(1005613200) sets $timestamp to "Tue Nov 13 01:00:00 + 2001". There's no year 2000 problem here. + + That doesn't mean that Perl can't be used to create non- + Y2K compliant programs. It can. But so can your pencil. + It's the fault of the user, not the language. At the risk + of inflaming the NRA: ``Perl doesn't break Y2K, people + do.'' See http://language.perl.com/news/y2k.html for a + longer exposition. + + If you want perl to warn you when it sees a program which + catenates a number with the string "19" -- a common + indication of a year 2000 problem -- build perl using the + Configure option "-Accflags=-DPERL_Y2KWARN". + (See the file INSTALL for more information about building + perl.) @@ -1,3 +1,6 @@ +#ifndef _INC_PERL_XSUB_H +#define _INC_PERL_XSUB_H 1 + #define ST(off) PL_stack_base[ax + (off)] #if defined(CYGWIN) && defined(USE_DYNAMIC_LOADING) @@ -279,3 +282,5 @@ # define socketpair PerlSock_socketpair # endif /* NO_XSLOCKS */ #endif /* PERL_CAPI */ + +#endif /* _INC_PERL_XSUB_H */ /* include guard */ @@ -637,11 +637,34 @@ Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash) return av_fetch(av, avhv_index_sv(HeVAL(he)), lval); } +/* Check for the existence of an element named by a given key. + * + * This relies on the fact that uninitialized array elements + * are set to &PL_sv_undef. + */ bool Perl_avhv_exists_ent(pTHX_ AV *av, SV *keysv, U32 hash) { HV *keys = avhv_keys(av); - return hv_exists_ent(keys, keysv, hash); + HE *he; + IV ix; + + he = hv_fetch_ent(keys, keysv, FALSE, hash); + if (!he || !SvOK(HeVAL(he))) + return FALSE; + + ix = SvIV(HeVAL(he)); + + /* If the array hasn't been extended to reach the key yet then + * it hasn't been accessed and thus does not exist. We use + * AvFILL() rather than AvFILLp() to handle tied av. */ + if (ix > 0 && ix <= AvFILL(av) + && (SvRMAGICAL(av) + || (AvARRAY(av)[ix] && AvARRAY(av)[ix] != &PL_sv_undef))) + { + return TRUE; + } + return FALSE; } HE * diff --git a/config_h.SH b/config_h.SH index 2f8a835259..5aa68c27be 100644 --- a/config_h.SH +++ b/config_h.SH @@ -2475,6 +2475,13 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$use64bits USE_64_BITS /**/ +/* USE_LARGE_FILES: + * This symbol, if defined, indicates that large file support + * should be used when available. The USE_64_BITS symbol will + * also be turned on if necessary. + */ +#$uselargefiles USE_LARGE_FILES /**/ + /* USE_LONG_DOUBLE: * This symbol, if defined, indicates that long doubles should * be used when available. diff --git a/configure.com b/configure.com index 96e86335a7..a9ed05be38 100644 --- a/configure.com +++ b/configure.com @@ -1762,27 +1762,6 @@ $ ELSE $ use_64bit="N" $ ENDIF $ ENDIF -$! -$! Ask if they want to build with 64-bit support -$ if (Archname.eqs."VMS_AXP").and.("''f$extract(1,3, f$getsyi(""version""))'".ges."7.1") -$ THEN -$ echo "This version of perl has experimental support for building wtih -$ echo "64 bit integers and 128 bit floating point variables. This gives -$ echo "a much larger range for perl's mathematical operations. (Note that -$ echo "does *not* enable 64-bit fileops at the moment, as Dec C doesn't -$ echo "do that yet)" -$ echo "" -$ dflt = use_64bit -$ rp = "Build with 64 bits? [''dflt'] " -$ GOSUB myread -$ if ans.eqs."" then ans = dflt -$ if (f$extract(0, 1, "''ans'").eqs."Y").or.(f$extract(0, 1, "''ans'").eqs."y") -$ THEN -$ use_64bit="Y" -$ ELSE -$ use_64bit="N" -$ ENDIF -$ ENDIF $! Ask about threads, if appropriate $ if (Using_Dec_C.eqs."Yes") $ THEN @@ -66,17 +66,22 @@ struct block_sub { #define POPSAVEARRAY() \ STMT_START { \ SvREFCNT_dec(GvAV(PL_defgv)); \ - GvAV(PL_defgv) = cxsub.savearray; \ + GvAV(PL_defgv) = cxsub.savearray; \ } STMT_END #endif /* USE_THREADS */ #define POPSUB2() \ if (cxsub.hasargs) { \ POPSAVEARRAY(); \ - /* destroy arg array */ \ - av_clear(cxsub.argarray); \ - AvREAL_off(cxsub.argarray); \ - AvREIFY_on(cxsub.argarray); \ + /* abandon @_ if it got reified */ \ + if (AvREAL(cxsub.argarray)) { \ + SSize_t fill = AvFILLp(cxsub.argarray); \ + SvREFCNT_dec(cxsub.argarray); \ + cxsub.argarray = newAV(); \ + av_extend(cxsub.argarray, fill); \ + AvFLAGS(cxsub.argarray) = AVf_REIFY; \ + PL_curpad[0] = (SV*)cxsub.argarray; \ + } \ } \ if (cxsub.cv) { \ if (!(CvDEPTH(cxsub.cv) = cxsub.olddepth)) \ @@ -141,7 +141,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } if (as_raw) { -#if defined(USE_64_BIT_OFFSETS) && defined(O_LARGEFILE) +#if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE) rawmode |= O_LARGEFILE; #endif diff --git a/emacs/ptags b/emacs/ptags index 7570220218..54770a0a14 100755 --- a/emacs/ptags +++ b/emacs/ptags @@ -21,7 +21,7 @@ if test ! -z "$OS2_SHELL"; then alias find=gnufind; fi # Move autogenerated less-informative files to the end: # Hard to do embed.h and embedvar.h in one sweep: -topfiles="`echo ' ' *.y *.c *.h ' ' | sed 's/ \(embed\(var\|\)\.h\|obj\(pp\|XSUB\)\.h\|globals\.c\) \(\(embedvar\|objpp\).h \|\)/ /g'`" +topfiles="`echo ' ' *.y *.c *.h ' ' | sed 's/ / /g' | sed 's/ embedvar\.h\|embed\.h\|obj\(pp\|XSUB\)\.h\|\(globals\|perlapi\)\.c / /g'`" subdirs="`find ./* -maxdepth 0 -type d`" subdirfiles="`find $subdirs -name '*.[cy]' -print | sort`" subdirfiles1="`find $subdirs -name '*.[hH]' -print | sort`" @@ -74,10 +74,37 @@ perl -w014pe 'if (s/^( .* PERLVAR A?I? # 1: TAG group }' TAGS.tmp > TAGS.tm1 && mv TAGS.tm1 TAGS.tmp +# Now remove these Perl_, add empty- and perl_-flavors: +perl -w014pe 'if (s/^(Perl_ # 1: First group + (\w+) \( # 2: Stripped name + \x7F # End of description + ) # End of description + (\d+,\d+\n) # 3: TAGS Trail + /$1$3$1$2\x01$3$1perl_$2\x01$3/mgx) { # Repeat, add empty and perl_ flavors + $chars = chomp; + s/^((\n.+,)\d+)/ $2 . (length($_) - length($1) - 1) /e; + $_ .= ("\f" x $chars); + }' TAGS.tmp > TAGS.tm1 && mv TAGS.tm1 TAGS.tmp + +# Now remove these S_, add empty-flavor: +perl -w014pe 'if (s/^(S_ # 1: First group + (\w+) \( # 2: Stripped name + \x7F # End of description + ) # End of description + (\d+,\d+\n) # 3: TAGS Trail + /$1$3$1$2\x01$3/mgx) { # Repeat, add empty_ flavor + $chars = chomp; + s/^((\n.+,)\d+)/ $2 . (length($_) - length($1) - 1) /e; + $_ .= ("\f" x $chars); + }' TAGS.tmp > TAGS.tm1 && mv TAGS.tm1 TAGS.tmp etags -o TAGS.tmp -a -D -l none -r '/#define.*\t\(Perl_.*\)/\1/' embed.h -etags -o TAGS.tmp -a globals.c embedvar.h objXSUB.h objpp.h +etags -o TAGS.tmp -a globals.c embedvar.h objXSUB.h perlapi.c +# The above processes created a lot of descriptions with an +# an explicitly specified tag. Such descriptions have higher +# precedence than descriptions without an explicitely specified tag. +# To restore the justice, make all the descriptions explicit. perl -w014pe 'if (s/^( [^\n\x7F\x01]*\b # 1: TAG group (\w+) # 2: word [^\w\x7F\x01\n]* # Most anything @@ -29,7 +29,6 @@ # define Perl_safesysrealloc Perl_saferealloc # define Perl_set_numeric_local perl_set_numeric_local # define Perl_set_numeric_standard perl_set_numeric_standard -# define PERL_POLLUTE /* malloc() pollution was the default in earlier versions, so enable * it for bincompat; but not for systems that used to do prevent that, * or when they ask for {HIDE,EMBED}MYMALLOC */ @@ -97,6 +96,7 @@ #define die_nocontext Perl_die_nocontext #define deb_nocontext Perl_deb_nocontext #define form_nocontext Perl_form_nocontext +#define mess_nocontext Perl_mess_nocontext #define warn_nocontext Perl_warn_nocontext #define warner_nocontext Perl_warner_nocontext #define newSVpvf_nocontext Perl_newSVpvf_nocontext @@ -364,6 +364,8 @@ #define mem_collxfrm Perl_mem_collxfrm #endif #define mess Perl_mess +#define vmess Perl_vmess +#define qerror Perl_qerror #define mg_clear Perl_mg_clear #define mg_copy Perl_mg_copy #define mg_find Perl_mg_find @@ -945,14 +947,38 @@ #define more_xiv S_more_xiv #define more_xnv S_more_xnv #define more_xpv S_more_xpv +#define more_xpviv S_more_xpviv +#define more_xpvnv S_more_xpvnv +#define more_xpvcv S_more_xpvcv +#define more_xpvav S_more_xpvav +#define more_xpvhv S_more_xpvhv +#define more_xpvmg S_more_xpvmg +#define more_xpvlv S_more_xpvlv +#define more_xpvbm S_more_xpvbm #define more_xrv S_more_xrv #define new_xiv S_new_xiv #define new_xnv S_new_xnv #define new_xpv S_new_xpv +#define new_xpviv S_new_xpviv +#define new_xpvnv S_new_xpvnv +#define new_xpvcv S_new_xpvcv +#define new_xpvav S_new_xpvav +#define new_xpvhv S_new_xpvhv +#define new_xpvmg S_new_xpvmg +#define new_xpvlv S_new_xpvlv +#define new_xpvbm S_new_xpvbm #define new_xrv S_new_xrv #define del_xiv S_del_xiv #define del_xnv S_del_xnv #define del_xpv S_del_xpv +#define del_xpviv S_del_xpviv +#define del_xpvnv S_del_xpvnv +#define del_xpvcv S_del_xpvcv +#define del_xpvav S_del_xpvav +#define del_xpvhv S_del_xpvhv +#define del_xpvmg S_del_xpvmg +#define del_xpvlv S_del_xpvlv +#define del_xpvbm S_del_xpvbm #define del_xrv S_del_xrv #define sv_unglob S_sv_unglob #define not_a_number S_not_a_number @@ -1708,7 +1734,8 @@ #if defined(USE_LOCALE_COLLATE) #define mem_collxfrm(a,b,c) Perl_mem_collxfrm(aTHX_ a,b,c) #endif -#define mess(a,b) Perl_mess(aTHX_ a,b) +#define vmess(a,b) Perl_vmess(aTHX_ a,b) +#define qerror(a) Perl_qerror(aTHX_ a) #define mg_clear(a) Perl_mg_clear(aTHX_ a) #define mg_copy(a,b,c,d) Perl_mg_copy(aTHX_ a,b,c,d) #define mg_find(a,b) Perl_mg_find(aTHX_ a,b) @@ -2280,14 +2307,38 @@ #define more_xiv() S_more_xiv(aTHX) #define more_xnv() S_more_xnv(aTHX) #define more_xpv() S_more_xpv(aTHX) +#define more_xpviv() S_more_xpviv(aTHX) +#define more_xpvnv() S_more_xpvnv(aTHX) +#define more_xpvcv() S_more_xpvcv(aTHX) +#define more_xpvav() S_more_xpvav(aTHX) +#define more_xpvhv() S_more_xpvhv(aTHX) +#define more_xpvmg() S_more_xpvmg(aTHX) +#define more_xpvlv() S_more_xpvlv(aTHX) +#define more_xpvbm() S_more_xpvbm(aTHX) #define more_xrv() S_more_xrv(aTHX) #define new_xiv() S_new_xiv(aTHX) #define new_xnv() S_new_xnv(aTHX) #define new_xpv() S_new_xpv(aTHX) +#define new_xpviv() S_new_xpviv(aTHX) +#define new_xpvnv() S_new_xpvnv(aTHX) +#define new_xpvcv() S_new_xpvcv(aTHX) +#define new_xpvav() S_new_xpvav(aTHX) +#define new_xpvhv() S_new_xpvhv(aTHX) +#define new_xpvmg() S_new_xpvmg(aTHX) +#define new_xpvlv() S_new_xpvlv(aTHX) +#define new_xpvbm() S_new_xpvbm(aTHX) #define new_xrv() S_new_xrv(aTHX) #define del_xiv(a) S_del_xiv(aTHX_ a) #define del_xnv(a) S_del_xnv(aTHX_ a) #define del_xpv(a) S_del_xpv(aTHX_ a) +#define del_xpviv(a) S_del_xpviv(aTHX_ a) +#define del_xpvnv(a) S_del_xpvnv(aTHX_ a) +#define del_xpvcv(a) S_del_xpvcv(aTHX_ a) +#define del_xpvav(a) S_del_xpvav(aTHX_ a) +#define del_xpvhv(a) S_del_xpvhv(aTHX_ a) +#define del_xpvmg(a) S_del_xpvmg(aTHX_ a) +#define del_xpvlv(a) S_del_xpvlv(aTHX_ a) +#define del_xpvbm(a) S_del_xpvbm(aTHX_ a) #define del_xrv(a) S_del_xrv(aTHX_ a) #define sv_unglob(a) S_sv_unglob(aTHX_ a) #define not_a_number(a) S_not_a_number(aTHX_ a) @@ -2838,6 +2889,8 @@ #define deb_nocontext Perl_deb_nocontext #define Perl_form_nocontext CPerlObj::Perl_form_nocontext #define form_nocontext Perl_form_nocontext +#define Perl_mess_nocontext CPerlObj::Perl_mess_nocontext +#define mess_nocontext Perl_mess_nocontext #define Perl_warn_nocontext CPerlObj::Perl_warn_nocontext #define warn_nocontext Perl_warn_nocontext #define Perl_warner_nocontext CPerlObj::Perl_warner_nocontext @@ -3353,6 +3406,10 @@ #endif #define Perl_mess CPerlObj::Perl_mess #define mess Perl_mess +#define Perl_vmess CPerlObj::Perl_vmess +#define vmess Perl_vmess +#define Perl_qerror CPerlObj::Perl_qerror +#define qerror Perl_qerror #define Perl_mg_clear CPerlObj::Perl_mg_clear #define mg_clear Perl_mg_clear #define Perl_mg_copy CPerlObj::Perl_mg_copy @@ -4457,6 +4514,22 @@ #define more_xnv S_more_xnv #define S_more_xpv CPerlObj::S_more_xpv #define more_xpv S_more_xpv +#define S_more_xpviv CPerlObj::S_more_xpviv +#define more_xpviv S_more_xpviv +#define S_more_xpvnv CPerlObj::S_more_xpvnv +#define more_xpvnv S_more_xpvnv +#define S_more_xpvcv CPerlObj::S_more_xpvcv +#define more_xpvcv S_more_xpvcv +#define S_more_xpvav CPerlObj::S_more_xpvav +#define more_xpvav S_more_xpvav +#define S_more_xpvhv CPerlObj::S_more_xpvhv +#define more_xpvhv S_more_xpvhv +#define S_more_xpvmg CPerlObj::S_more_xpvmg +#define more_xpvmg S_more_xpvmg +#define S_more_xpvlv CPerlObj::S_more_xpvlv +#define more_xpvlv S_more_xpvlv +#define S_more_xpvbm CPerlObj::S_more_xpvbm +#define more_xpvbm S_more_xpvbm #define S_more_xrv CPerlObj::S_more_xrv #define more_xrv S_more_xrv #define S_new_xiv CPerlObj::S_new_xiv @@ -4465,6 +4538,22 @@ #define new_xnv S_new_xnv #define S_new_xpv CPerlObj::S_new_xpv #define new_xpv S_new_xpv +#define S_new_xpviv CPerlObj::S_new_xpviv +#define new_xpviv S_new_xpviv +#define S_new_xpvnv CPerlObj::S_new_xpvnv +#define new_xpvnv S_new_xpvnv +#define S_new_xpvcv CPerlObj::S_new_xpvcv +#define new_xpvcv S_new_xpvcv +#define S_new_xpvav CPerlObj::S_new_xpvav +#define new_xpvav S_new_xpvav +#define S_new_xpvhv CPerlObj::S_new_xpvhv +#define new_xpvhv S_new_xpvhv +#define S_new_xpvmg CPerlObj::S_new_xpvmg +#define new_xpvmg S_new_xpvmg +#define S_new_xpvlv CPerlObj::S_new_xpvlv +#define new_xpvlv S_new_xpvlv +#define S_new_xpvbm CPerlObj::S_new_xpvbm +#define new_xpvbm S_new_xpvbm #define S_new_xrv CPerlObj::S_new_xrv #define new_xrv S_new_xrv #define S_del_xiv CPerlObj::S_del_xiv @@ -4473,6 +4562,22 @@ #define del_xnv S_del_xnv #define S_del_xpv CPerlObj::S_del_xpv #define del_xpv S_del_xpv +#define S_del_xpviv CPerlObj::S_del_xpviv +#define del_xpviv S_del_xpviv +#define S_del_xpvnv CPerlObj::S_del_xpvnv +#define del_xpvnv S_del_xpvnv +#define S_del_xpvcv CPerlObj::S_del_xpvcv +#define del_xpvcv S_del_xpvcv +#define S_del_xpvav CPerlObj::S_del_xpvav +#define del_xpvav S_del_xpvav +#define S_del_xpvhv CPerlObj::S_del_xpvhv +#define del_xpvhv S_del_xpvhv +#define S_del_xpvmg CPerlObj::S_del_xpvmg +#define del_xpvmg S_del_xpvmg +#define S_del_xpvlv CPerlObj::S_del_xpvlv +#define del_xpvlv S_del_xpvlv +#define S_del_xpvbm CPerlObj::S_del_xpvbm +#define del_xpvbm S_del_xpvbm #define S_del_xrv CPerlObj::S_del_xrv #define del_xrv S_del_xrv #define S_sv_unglob CPerlObj::S_sv_unglob @@ -5405,6 +5510,7 @@ # define deb Perl_deb_nocontext # define die Perl_die_nocontext # define form Perl_form_nocontext +# define mess Perl_mess_nocontext # define newSVpvf Perl_newSVpvf_nocontext # define sv_catpvf Perl_sv_catpvf_nocontext # define sv_setpvf Perl_sv_setpvf_nocontext @@ -5422,6 +5528,7 @@ # define Perl_die_nocontext Perl_die # define Perl_deb_nocontext Perl_deb # define Perl_form_nocontext Perl_form +# define Perl_mess_nocontext Perl_mess # define Perl_newSVpvf_nocontext Perl_newSVpvf # define Perl_sv_catpvf_nocontext Perl_sv_catpvf # define Perl_sv_setpvf_nocontext Perl_sv_setpvf @@ -302,7 +302,6 @@ print EM <<'END'; # define Perl_safesysrealloc Perl_saferealloc # define Perl_set_numeric_local perl_set_numeric_local # define Perl_set_numeric_standard perl_set_numeric_standard -# define PERL_POLLUTE /* malloc() pollution was the default in earlier versions, so enable * it for bincompat; but not for systems that used to do prevent that, * or when they ask for {HIDE,EMBED}MYMALLOC */ @@ -492,6 +491,7 @@ print EM <<'END'; # define deb Perl_deb_nocontext # define die Perl_die_nocontext # define form Perl_form_nocontext +# define mess Perl_mess_nocontext # define newSVpvf Perl_newSVpvf_nocontext # define sv_catpvf Perl_sv_catpvf_nocontext # define sv_setpvf Perl_sv_setpvf_nocontext @@ -509,6 +509,7 @@ print EM <<'END'; # define Perl_die_nocontext Perl_die # define Perl_deb_nocontext Perl_deb # define Perl_form_nocontext Perl_form +# define Perl_mess_nocontext Perl_mess # define Perl_newSVpvf_nocontext Perl_newSVpvf # define Perl_sv_catpvf_nocontext Perl_sv_catpvf # define Perl_sv_setpvf_nocontext Perl_sv_setpvf @@ -843,6 +844,7 @@ my %vfuncs = qw( Perl_warner Perl_vwarner Perl_die Perl_vdie Perl_form Perl_vform + Perl_mess Perl_vmess Perl_deb Perl_vdeb Perl_newSVpvf Perl_vnewSVpvf Perl_sv_setpvf Perl_sv_vsetpvf @@ -871,7 +873,6 @@ sub emit_func { ? '' : 'return '); my $emitval = ''; if (@args and $args[$#args] =~ /\.\.\./) { - pop @args; pop @aargs; my $retarg = ''; my $ctxfunc = $func; @@ -1049,6 +1050,7 @@ npr |void |croak_nocontext|const char* pat|... np |OP* |die_nocontext |const char* pat|... np |void |deb_nocontext |const char* pat|... np |char* |form_nocontext |const char* pat|... +np |SV* |mess_nocontext |const char* pat|... np |void |warn_nocontext |const char* pat|... np |void |warner_nocontext|U32 err|const char* pat|... np |SV* |newSVpvf_nocontext|const char* pat|... @@ -1326,7 +1328,9 @@ p |void |markstack_grow #if defined(USE_LOCALE_COLLATE) p |char* |mem_collxfrm |const char* s|STRLEN len|STRLEN* xlen #endif -p |SV* |mess |const char* pat|va_list* args +p |SV* |mess |const char* pat|... +p |SV* |vmess |const char* pat|va_list* args +p |void |qerror |SV* err p |int |mg_clear |SV* sv p |int |mg_copy |SV* sv|SV* nsv|const char* key|I32 klen p |MAGIC* |mg_find |SV* sv|int type @@ -1971,14 +1975,38 @@ s |SV* |more_sv s |void |more_xiv s |void |more_xnv s |void |more_xpv +s |void |more_xpviv +s |void |more_xpvnv +s |void |more_xpvcv +s |void |more_xpvav +s |void |more_xpvhv +s |void |more_xpvmg +s |void |more_xpvlv +s |void |more_xpvbm s |void |more_xrv s |XPVIV* |new_xiv s |XPVNV* |new_xnv s |XPV* |new_xpv +s |XPVIV* |new_xpviv +s |XPVNV* |new_xpvnv +s |XPVCV* |new_xpvcv +s |XPVAV* |new_xpvav +s |XPVHV* |new_xpvhv +s |XPVMG* |new_xpvmg +s |XPVLV* |new_xpvlv +s |XPVBM* |new_xpvbm s |XRV* |new_xrv s |void |del_xiv |XPVIV* p s |void |del_xnv |XPVNV* p s |void |del_xpv |XPV* p +s |void |del_xpviv |XPVIV* p +s |void |del_xpvnv |XPVNV* p +s |void |del_xpvcv |XPVCV* p +s |void |del_xpvav |XPVAV* p +s |void |del_xpvhv |XPVHV* p +s |void |del_xpvmg |XPVMG* p +s |void |del_xpvlv |XPVLV* p +s |void |del_xpvbm |XPVBM* p s |void |del_xrv |XRV* p s |void |sv_unglob |SV* sv s |void |not_a_number |SV *sv diff --git a/embedvar.h b/embedvar.h index 65a31f1ec7..beaa960874 100644 --- a/embedvar.h +++ b/embedvar.h @@ -51,6 +51,7 @@ #define PL_dumpindent (vTHX->Tdumpindent) #define PL_efloatbuf (vTHX->Tefloatbuf) #define PL_efloatsize (vTHX->Tefloatsize) +#define PL_errors (vTHX->Terrors) #define PL_extralen (vTHX->Textralen) #define PL_firstgv (vTHX->Tfirstgv) #define PL_formtarget (vTHX->Tformtarget) @@ -352,7 +353,6 @@ #define PL_pad_reset_pending (PERL_GET_INTERP->Ipad_reset_pending) #define PL_padix (PERL_GET_INTERP->Ipadix) #define PL_padix_floor (PERL_GET_INTERP->Ipadix_floor) -#define PL_parsehook (PERL_GET_INTERP->Iparsehook) #define PL_patchlevel (PERL_GET_INTERP->Ipatchlevel) #define PL_pending_ident (PERL_GET_INTERP->Ipending_ident) #define PL_perl_destruct_level (PERL_GET_INTERP->Iperl_destruct_level) @@ -428,6 +428,14 @@ #define PL_xiv_root (PERL_GET_INTERP->Ixiv_root) #define PL_xnv_root (PERL_GET_INTERP->Ixnv_root) #define PL_xpv_root (PERL_GET_INTERP->Ixpv_root) +#define PL_xpvav_root (PERL_GET_INTERP->Ixpvav_root) +#define PL_xpvbm_root (PERL_GET_INTERP->Ixpvbm_root) +#define PL_xpvcv_root (PERL_GET_INTERP->Ixpvcv_root) +#define PL_xpvhv_root (PERL_GET_INTERP->Ixpvhv_root) +#define PL_xpviv_root (PERL_GET_INTERP->Ixpviv_root) +#define PL_xpvlv_root (PERL_GET_INTERP->Ixpvlv_root) +#define PL_xpvmg_root (PERL_GET_INTERP->Ixpvmg_root) +#define PL_xpvnv_root (PERL_GET_INTERP->Ixpvnv_root) #define PL_xrv_root (PERL_GET_INTERP->Ixrv_root) #define PL_yychar (PERL_GET_INTERP->Iyychar) #define PL_yydebug (PERL_GET_INTERP->Iyydebug) @@ -621,7 +629,6 @@ #define PL_pad_reset_pending (vTHX->Ipad_reset_pending) #define PL_padix (vTHX->Ipadix) #define PL_padix_floor (vTHX->Ipadix_floor) -#define PL_parsehook (vTHX->Iparsehook) #define PL_patchlevel (vTHX->Ipatchlevel) #define PL_pending_ident (vTHX->Ipending_ident) #define PL_perl_destruct_level (vTHX->Iperl_destruct_level) @@ -697,6 +704,14 @@ #define PL_xiv_root (vTHX->Ixiv_root) #define PL_xnv_root (vTHX->Ixnv_root) #define PL_xpv_root (vTHX->Ixpv_root) +#define PL_xpvav_root (vTHX->Ixpvav_root) +#define PL_xpvbm_root (vTHX->Ixpvbm_root) +#define PL_xpvcv_root (vTHX->Ixpvcv_root) +#define PL_xpvhv_root (vTHX->Ixpvhv_root) +#define PL_xpviv_root (vTHX->Ixpviv_root) +#define PL_xpvlv_root (vTHX->Ixpvlv_root) +#define PL_xpvmg_root (vTHX->Ixpvmg_root) +#define PL_xpvnv_root (vTHX->Ixpvnv_root) #define PL_xrv_root (vTHX->Ixrv_root) #define PL_yychar (vTHX->Iyychar) #define PL_yydebug (vTHX->Iyydebug) @@ -892,7 +907,6 @@ #define PL_Ipad_reset_pending PL_pad_reset_pending #define PL_Ipadix PL_padix #define PL_Ipadix_floor PL_padix_floor -#define PL_Iparsehook PL_parsehook #define PL_Ipatchlevel PL_patchlevel #define PL_Ipending_ident PL_pending_ident #define PL_Iperl_destruct_level PL_perl_destruct_level @@ -968,6 +982,14 @@ #define PL_Ixiv_root PL_xiv_root #define PL_Ixnv_root PL_xnv_root #define PL_Ixpv_root PL_xpv_root +#define PL_Ixpvav_root PL_xpvav_root +#define PL_Ixpvbm_root PL_xpvbm_root +#define PL_Ixpvcv_root PL_xpvcv_root +#define PL_Ixpvhv_root PL_xpvhv_root +#define PL_Ixpviv_root PL_xpviv_root +#define PL_Ixpvlv_root PL_xpvlv_root +#define PL_Ixpvmg_root PL_xpvmg_root +#define PL_Ixpvnv_root PL_xpvnv_root #define PL_Ixrv_root PL_xrv_root #define PL_Iyychar PL_yychar #define PL_Iyydebug PL_yydebug @@ -1000,6 +1022,7 @@ #define PL_dumpindent (aTHX->Tdumpindent) #define PL_efloatbuf (aTHX->Tefloatbuf) #define PL_efloatsize (aTHX->Tefloatsize) +#define PL_errors (aTHX->Terrors) #define PL_extralen (aTHX->Textralen) #define PL_firstgv (aTHX->Tfirstgv) #define PL_formtarget (aTHX->Tformtarget) @@ -1136,6 +1159,7 @@ #define PL_Tdumpindent PL_dumpindent #define PL_Tefloatbuf PL_efloatbuf #define PL_Tefloatsize PL_efloatsize +#define PL_Terrors PL_errors #define PL_Textralen PL_extralen #define PL_Tfirstgv PL_firstgv #define PL_Tformtarget PL_formtarget diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm index 3230ebdf10..b57d1ad2b3 100644 --- a/ext/B/B/C.pm +++ b/ext/B/B/C.pm @@ -375,7 +375,7 @@ sub B::NULL::save { #if ($$sv == 0) { # warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n"; #} - $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT + 1, $sv->FLAGS)); + $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS)); return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); } @@ -385,7 +385,7 @@ sub B::IV::save { return $sym if defined $sym; $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX)); $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x", - $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvivsect->index, $sv->REFCNT , $sv->FLAGS)); return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); } @@ -397,7 +397,7 @@ sub B::NV::save { $val .= '.00' if $val =~ /^-?\d+$/; $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val)); $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x", - $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS)); return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); } @@ -413,7 +413,7 @@ sub B::PVLV::save { $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX, $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE))); $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x", - $xpvlvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS)); if (!$pv_copy_on_grow) { $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);", $xpvlvsect->index, cstring($pv), $len)); @@ -431,7 +431,7 @@ sub B::PVIV::save { my ($pvsym, $pvmax) = savepv($pv); $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX)); $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x", - $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvivsect->index, $sv->REFCNT , $sv->FLAGS)); if (!$pv_copy_on_grow) { $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);", $xpvivsect->index, cstring($pv), $len)); @@ -452,7 +452,7 @@ sub B::PVNV::save { $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s", $pvsym, $len, $pvmax, $sv->IVX, $val)); $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x", - $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS)); if (!$pv_copy_on_grow) { $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);", $xpvnvsect->index, cstring($pv), $len)); @@ -470,7 +470,7 @@ sub B::BM::save { $len, $len + 258, $sv->IVX, $sv->NVX, $sv->USEFUL, $sv->PREVIOUS, $sv->RARE)); $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x", - $xpvbmsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS)); $sv->save_magic; $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);", $xpvbmsect->index, cstring($pv), $len), @@ -488,7 +488,7 @@ sub B::PV::save { my ($pvsym, $pvmax) = savepv($pv); $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax)); $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x", - $xpvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvsect->index, $sv->REFCNT , $sv->FLAGS)); if (!$pv_copy_on_grow) { $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);", $xpvsect->index, cstring($pv), $len)); @@ -506,7 +506,7 @@ sub B::PVMG::save { $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0", $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX)); $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x", - $xpvmgsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS)); if (!$pv_copy_on_grow) { $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);", $xpvmgsect->index, cstring($pv), $len)); @@ -560,7 +560,7 @@ sub B::RV::save { $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/; $xrvsect->add($rv); $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x", - $xrvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xrvsect->index, $sv->REFCNT , $sv->FLAGS)); return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); } @@ -595,8 +595,11 @@ sub B::CV::save { } # Reserve a place in svsect and xpvcvsect and record indices my $gv = $cv->GV; - my $cvstashname = $gv->STASH->NAME; - my $cvname = $gv->NAME; + my ($cvname, $cvstashname); + if ($$gv){ + $cvname = $gv->NAME; + $cvstashname = $gv->STASH->NAME; + } my $root = $cv->ROOT; my $cvxsub = $cv->XSUB; #INIT is removed from the symbol table, so this call must come @@ -712,7 +715,7 @@ sub B::CV::save { $$stash, $$cv) if $debug_cv; } $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x", - $sv_ix, $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS)); + $sv_ix, $xpvcv_ix, $cv->REFCNT +1 , $cv->FLAGS)); return $sym; } @@ -819,7 +822,7 @@ sub B::AV::save { $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x", $avflags)); $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x", - $xpvavsect->index, $av->REFCNT + 1, $av->FLAGS)); + $xpvavsect->index, $av->REFCNT , $av->FLAGS)); my $sv_list_index = $svsect->index; my $fill = $av->FILL; $av->save_magic; @@ -885,7 +888,7 @@ sub B::HV::save { $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0", $hv->MAX, $hv->RITER)); $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x", - $xpvhvsect->index, $hv->REFCNT + 1, $hv->FLAGS)); + $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS)); my $sv_list_index = $svsect->index; my @contents = $hv->ARRAY; if (@contents) { @@ -921,7 +924,7 @@ sub B::IO::save { cstring($io->BOTTOM_NAME), $io->SUBPROCESS, cchar($io->IoTYPE), $io->IoFLAGS)); $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x", - $xpviosect->index, $io->REFCNT + 1, $io->FLAGS)); + $xpviosect->index, $io->REFCNT , $io->FLAGS)); $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index)); my ($field, $fsym); foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) { @@ -1243,7 +1246,7 @@ sub mark_package { no strict 'refs'; $unused_sub_packages{$package} = 1; - if (@{$package.'::ISA'}) + if (defined @{$package.'::ISA'}) { foreach my $isa (@{$package.'::ISA'}) { diff --git a/ext/B/B/Terse.pm b/ext/B/B/Terse.pm index 35bf9b8d0d..bc9d9434c9 100644 --- a/ext/B/B/Terse.pm +++ b/ext/B/B/Terse.pm @@ -79,7 +79,7 @@ sub B::COP::terse { if ($label) { $label = " label ".cstring($label); } - print indent($level), peekop($op), $label, "\n"; + print indent($level), peekop($op), $label || "", "\n"; } sub B::PV::terse { diff --git a/ext/B/defsubs_h.PL b/ext/B/defsubs_h.PL index 8dfa3a5fe2..78c82f20bd 100644 --- a/ext/B/defsubs_h.PL +++ b/ext/B/defsubs_h.PL @@ -6,7 +6,7 @@ my ($out) = __FILE__ =~ /(^.*)\.PL/; if ($^O eq 'VMS') { ($out) = __FILE__ =~ /^(.+)_PL$/i; } $out =~ s/_h$/.h/; open(OUT,">$out") || die "Cannot open $file:$!"; -print "Extracting $out . . .\n"; +print "Extracting $out...\n"; foreach my $const (qw(AVf_REAL HEf_SVKEY SVf_IOK SVf_IVisUV SVf_NOK SVf_POK diff --git a/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c index 6da532392f..73911565d9 100644 --- a/ext/DynaLoader/dlutils.c +++ b/ext/DynaLoader/dlutils.c @@ -55,7 +55,7 @@ SaveError(pTHXo_ char* pat, ...) /* This code is based on croak/warn, see mess() in util.c */ va_start(args, pat); - msv = mess(pat, &args); + msv = vmess(pat, &args); va_end(args); message = SvPV(msv,len); diff --git a/ext/POSIX/POSIX.pod b/ext/POSIX/POSIX.pod index 6ad74b74b9..08300e4337 100644 --- a/ext/POSIX/POSIX.pod +++ b/ext/POSIX/POSIX.pod @@ -1024,7 +1024,8 @@ If you want your code to be portable, your format (C<fmt>) argument should use only the conversion specifiers defined by the ANSI C standard. These are C<aAbBcdHIjmMpSUwWxXyYZ%>. The given arguments are made consistent -by calling C<mktime()> before calling your system's C<strftime()> function. +as though by calling C<mktime()> before calling your system's +C<strftime()> function, except that the C<isdst> value is not affected. The string for Tuesday, December 12, 1995. diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index 16217f0936..23c38b5e20 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -332,6 +332,196 @@ init_tm(struct tm *ptm) /* see mktime, strftime and asctime */ # define init_tm(ptm) #endif +/* + * mini_mktime - normalise struct tm values without the localtime() + * semantics (and overhead) of mktime(). + */ +static void +mini_mktime(struct tm *ptm) +{ + int yearday; + int secs; + int month, mday, year, jday; + int odd_cent, odd_year; + +#define DAYS_PER_YEAR 365 +#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1) +#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1) +#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1) +#define SECS_PER_HOUR (60*60) +#define SECS_PER_DAY (24*SECS_PER_HOUR) +/* parentheses deliberately absent on these two, otherwise they don't work */ +#define MONTH_TO_DAYS 153/5 +#define DAYS_TO_MONTH 5/153 +/* offset to bias by March (month 4) 1st between month/mday & year finding */ +#define YEAR_ADJUST (4*MONTH_TO_DAYS+1) +/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */ +#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */ + +/* + * Year/day algorithm notes: + * + * With a suitable offset for numeric value of the month, one can find + * an offset into the year by considering months to have 30.6 (153/5) days, + * using integer arithmetic (i.e., with truncation). To avoid too much + * messing about with leap days, we consider January and February to be + * the 13th and 14th month of the previous year. After that transformation, + * we need the month index we use to be high by 1 from 'normal human' usage, + * so the month index values we use run from 4 through 15. + * + * Given that, and the rules for the Gregorian calendar (leap years are those + * divisible by 4 unless also divisible by 100, when they must be divisible + * by 400 instead), we can simply calculate the number of days since some + * arbitrary 'beginning of time' by futzing with the (adjusted) year number, + * the days we derive from our month index, and adding in the day of the + * month. The value used here is not adjusted for the actual origin which + * it normally would use (1 January A.D. 1), since we're not exposing it. + * We're only building the value so we can turn around and get the + * normalised values for the year, month, day-of-month, and day-of-year. + * + * For going backward, we need to bias the value we're using so that we find + * the right year value. (Basically, we don't want the contribution of + * March 1st to the number to apply while deriving the year). Having done + * that, we 'count up' the contribution to the year number by accounting for + * full quadracenturies (400-year periods) with their extra leap days, plus + * the contribution from full centuries (to avoid counting in the lost leap + * days), plus the contribution from full quad-years (to count in the normal + * leap days), plus the leftover contribution from any non-leap years. + * At this point, if we were working with an actual leap day, we'll have 0 + * days left over. This is also true for March 1st, however. So, we have + * to special-case that result, and (earlier) keep track of the 'odd' + * century and year contributions. If we got 4 extra centuries in a qcent, + * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb. + * Otherwise, we add back in the earlier bias we removed (the 123 from + * figuring in March 1st), find the month index (integer division by 30.6), + * and the remainder is the day-of-month. We then have to convert back to + * 'real' months (including fixing January and February from being 14/15 in + * the previous year to being in the proper year). After that, to get + * tm_yday, we work with the normalised year and get a new yearday value for + * January 1st, which we subtract from the yearday value we had earlier, + * representing the date we've re-built. This is done from January 1 + * because tm_yday is 0-origin. + * + * Since POSIX time routines are only guaranteed to work for times since the + * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm + * applies Gregorian calendar rules even to dates before the 16th century + * doesn't bother me. Besides, you'd need cultural context for a given + * date to know whether it was Julian or Gregorian calendar, and that's + * outside the scope for this routine. Since we convert back based on the + * same rules we used to build the yearday, you'll only get strange results + * for input which needed normalising, or for the 'odd' century years which + * were leap years in the Julian calander but not in the Gregorian one. + * I can live with that. + * + * This algorithm also fails to handle years before A.D. 1 gracefully, but + * that's still outside the scope for POSIX time manipulation, so I don't + * care. + */ + + year = 1900 + ptm->tm_year; + month = ptm->tm_mon; + mday = ptm->tm_mday; + /* allow given yday with no month & mday to dominate the result */ + if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) { + month = 0; + mday = 0; + jday = 1 + ptm->tm_yday; + } + else { + jday = 0; + } + if (month >= 2) + month+=2; + else + month+=14, year--; + yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400; + yearday += month*MONTH_TO_DAYS + mday + jday; + /* + * Note that we don't know when leap-seconds were or will be, + * so we have to trust the user if we get something which looks + * like a sensible leap-second. Wild values for seconds will + * be rationalised, however. + */ + if ((unsigned) ptm->tm_sec <= 60) { + secs = 0; + } + else { + secs = ptm->tm_sec; + ptm->tm_sec = 0; + } + secs += 60 * ptm->tm_min; + secs += SECS_PER_HOUR * ptm->tm_hour; + if (secs < 0) { + if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) { + /* got negative remainder, but need positive time */ + /* back off an extra day to compensate */ + yearday += (secs/SECS_PER_DAY)-1; + secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1); + } + else { + yearday += (secs/SECS_PER_DAY); + secs -= SECS_PER_DAY * (secs/SECS_PER_DAY); + } + } + else if (secs >= SECS_PER_DAY) { + yearday += (secs/SECS_PER_DAY); + secs %= SECS_PER_DAY; + } + ptm->tm_hour = secs/SECS_PER_HOUR; + secs %= SECS_PER_HOUR; + ptm->tm_min = secs/60; + secs %= 60; + ptm->tm_sec += secs; + /* done with time of day effects */ + /* + * The algorithm for yearday has (so far) left it high by 428. + * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to + * bias it by 123 while trying to figure out what year it + * really represents. Even with this tweak, the reverse + * translation fails for years before A.D. 0001. + * It would still fail for Feb 29, but we catch that one below. + */ + jday = yearday; /* save for later fixup vis-a-vis Jan 1 */ + yearday -= YEAR_ADJUST; + year = (yearday / DAYS_PER_QCENT) * 400; + yearday %= DAYS_PER_QCENT; + odd_cent = yearday / DAYS_PER_CENT; + year += odd_cent * 100; + yearday %= DAYS_PER_CENT; + year += (yearday / DAYS_PER_QYEAR) * 4; + yearday %= DAYS_PER_QYEAR; + odd_year = yearday / DAYS_PER_YEAR; + year += odd_year; + yearday %= DAYS_PER_YEAR; + if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */ + month = 1; + yearday = 29; + } + else { + yearday += YEAR_ADJUST; /* recover March 1st crock */ + month = yearday*DAYS_TO_MONTH; + yearday -= month*MONTH_TO_DAYS; + /* recover other leap-year adjustment */ + if (month > 13) { + month-=14; + year++; + } + else { + month-=2; + } + } + ptm->tm_year = year - 1900; + ptm->tm_mon = month; + ptm->tm_mday = yearday; + /* re-build yearday based on Jan 1 to get tm_yday */ + year--; + yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400; + yearday += 14*MONTH_TO_DAYS + 1; + ptm->tm_yday = jday - yearday; + /* fix tm_wday if not overridden by caller */ + if ((unsigned)ptm->tm_wday > 6) + ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7; +} #ifdef HAS_LONG_DOUBLE # if LONG_DOUBLESIZE > DOUBLESIZE @@ -3652,7 +3842,7 @@ strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1) mytm.tm_wday = wday; mytm.tm_yday = yday; mytm.tm_isdst = isdst; - (void) mktime(&mytm); + mini_mktime(&mytm); len = strftime(tmpbuf, sizeof tmpbuf, fmt, &mytm); /* ** The following is needed to handle to the situation where diff --git a/ext/Thread/Thread.xs b/ext/Thread/Thread.xs index 772d41a495..e01f29de06 100644 --- a/ext/Thread/Thread.xs +++ b/ext/Thread/Thread.xs @@ -181,6 +181,7 @@ threadstart(void *arg) SvREFCNT_dec(PL_rs); SvREFCNT_dec(PL_nrs); SvREFCNT_dec(PL_statname); + SvREFCNT_dec(PL_errors); Safefree(PL_screamfirst); Safefree(PL_screamnext); Safefree(PL_reg_start_tmp); diff --git a/ext/attrs/attrs.pm b/ext/attrs/attrs.pm index e97fa1ee39..cec5ea5fcd 100644 --- a/ext/attrs/attrs.pm +++ b/ext/attrs/attrs.pm @@ -8,7 +8,7 @@ $VERSION = "1.0"; =head1 NAME -attrs - set/get attributes of a subroutine +attrs - set/get attributes of a subroutine (deprecated) =head1 SYNOPSIS @@ -21,11 +21,17 @@ attrs - set/get attributes of a subroutine =head1 DESCRIPTION -This module lets you set and get attributes for subroutines. +NOTE: Use of this pragma is deprecated. Use the syntax + + sub foo : locked, method { } + +to declare attributes instead. See also L<attributes>. + +This pragma lets you set and get attributes for subroutines. Setting attributes takes place at compile time; trying to set invalid attribute names causes a compile-time error. Calling -C<attr::get> on a subroutine reference or name returns its list -of attribute names. Notice that C<attr::get> is not exported. +C<attrs::get> on a subroutine reference or name returns its list +of attribute names. Notice that C<attrs::get> is not exported. Valid attributes are as follows. =over @@ -46,11 +52,6 @@ execution. The semantics of the lock are exactly those of one explicitly taken with the C<lock> operator immediately after the subroutine is entered. -=item lvalue - -Setting this attribute enables the subroutine to be used in -lvalue context. See L<perlsub/"Lvalue subroutines">. - =back =cut diff --git a/ext/attrs/attrs.xs b/ext/attrs/attrs.xs index a92922d497..4c00cd7cb2 100644 --- a/ext/attrs/attrs.xs +++ b/ext/attrs/attrs.xs @@ -10,8 +10,6 @@ get_flag(char *attr) return CVf_METHOD; else if (strnEQ(attr, "locked", 6)) return CVf_LOCKED; - else if (strnEQ(attr, "lvalue", 6)) - return CVf_LVALUE; else return 0; } @@ -29,6 +27,10 @@ char * Class PPCODE: if (!PL_compcv || !(cv = CvOUTSIDE(PL_compcv))) croak("can't set attributes outside a subroutine scope"); + if (ckWARN(WARN_DEPRECATED)) + Perl_warner(aTHX_ WARN_DEPRECATED, + "pragma \"attrs\" is deprecated, " + "use \"sub NAME : ATTRS\" instead"); for (i = 1; i < items; i++) { STRLEN n_a; char *attr = SvPV(ST(i), n_a); diff --git a/global.sym b/global.sym index 5ee74d7477..9a52b98567 100644 --- a/global.sym +++ b/global.sym @@ -48,6 +48,7 @@ Perl_croak_nocontext Perl_die_nocontext Perl_deb_nocontext Perl_form_nocontext +Perl_mess_nocontext Perl_warn_nocontext Perl_warner_nocontext Perl_newSVpvf_nocontext @@ -296,6 +297,8 @@ Perl_malloced_size Perl_markstack_grow Perl_mem_collxfrm Perl_mess +Perl_vmess +Perl_qerror Perl_mg_clear Perl_mg_copy Perl_mg_find @@ -512,11 +515,15 @@ Perl_sv_2iv Perl_sv_2mortal Perl_sv_2nv Perl_sv_2pv +Perl_sv_2pvutf8 +Perl_sv_2pvbyte Perl_sv_2uv Perl_sv_iv Perl_sv_uv Perl_sv_nv Perl_sv_pvn +Perl_sv_pvutf8n +Perl_sv_pvbyten Perl_sv_true Perl_sv_add_arena Perl_sv_backoff @@ -556,6 +563,8 @@ Perl_sv_peek Perl_sv_pos_u2b Perl_sv_pos_b2u Perl_sv_pvn_force +Perl_sv_pvutf8n_force +Perl_sv_pvbyten_force Perl_sv_reftype Perl_sv_replace Perl_sv_report_used @@ -661,7 +670,11 @@ Perl_default_protect Perl_vdefault_protect Perl_reginitcolors Perl_sv_2pv_nolen +Perl_sv_2pvutf8_nolen +Perl_sv_2pvbyte_nolen Perl_sv_pv +Perl_sv_pvutf8 +Perl_sv_pvbyte Perl_sv_force_normal Perl_tmps_grow Perl_sv_rvweaken @@ -531,6 +531,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) else if ((COP*)PL_curcop == &PL_compiling) { stash = PL_curstash; if (add && (PL_hints & HINT_STRICT_VARS) && + !(add & GV_ADDOUR) && sv_type != SVt_PVCV && sv_type != SVt_PVGV && sv_type != SVt_PVFM && @@ -568,26 +569,15 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) /* By this point we should have a stash and a name */ if (!stash) { - if (!add) - return Nullgv; - { - char sv_type_char = ((sv_type == SVt_PV) ? '$' - : (sv_type == SVt_PVAV) ? '@' - : (sv_type == SVt_PVHV) ? '%' - : 0); - if (sv_type_char) - Perl_warn(aTHX_ "Global symbol \"%c%s\" requires explicit package name", - sv_type_char, name); - else - Perl_warn(aTHX_ "Global symbol \"%s\" requires explicit package name", - name); + if (add) { + qerror(Perl_mess(aTHX_ + "Global symbol \"%s%s\" requires explicit package name", + (sv_type == SVt_PV ? "$" + : sv_type == SVt_PVAV ? "@" + : sv_type == SVt_PVHV ? "%" + : ""), name)); } - ++PL_error_count; - stash = PL_curstash ? PL_curstash : PL_defstash; /* avoid core dumps */ - add_gvflags = ((sv_type == SVt_PV) ? GVf_IMPORTED_SV - : (sv_type == SVt_PVAV) ? GVf_IMPORTED_AV - : (sv_type == SVt_PVHV) ? GVf_IMPORTED_HV - : 0); + return Nullgv; } if (!SvREFCNT(stash)) /* symbol table under destruction */ @@ -135,3 +135,4 @@ HV *GvHVn(); #define GV_ADDWARN 0x04 /* add, but warn if symbol wasn't already there */ #define GV_ADDINEVAL 0x08 /* add, as though we're doing so within an eval */ #define GV_NOINIT 0x10 /* add, but don't init symbol, if type != PVGV */ +#define GV_ADDOUR 0x20 /* add "our" variable */ diff --git a/hints/README.hints b/hints/README.hints index 015e1c12c2..5f23b29c2c 100644 --- a/hints/README.hints +++ b/hints/README.hints @@ -11,7 +11,9 @@ over from perl4. Please send any problems or suggested changes to perlbug@perl.com. -Hint file naming convention: Each hint file name should have only +=head1 Hint file naming convention. + +Each hint file name should have only one '.'. (This is for portability to non-unix file systems.) Names should also fit in <= 14 characters, for portability to older SVR3 systems. File names are of the form $osname_$osvers.sh, with all '.' @@ -51,6 +53,56 @@ detect what is needed. A glossary of config.sh variables is in the file Porting/Glossary. +=head1 Setting variables + +=head2 Optimizer + +If you want to set a variable, try to allow for Configure command-line +overrides. For example, suppose you think the default optimizer +setting to be -O2 for a particular platform. You should allow for +command line overrides with something like + + case "$optimize" in + '') optimize='-O2' ;; + esac + +or, if your system has a decent test(1) command, + + test -z "$optimize" && optimize='-O2' + +This allows the user to select a different optimization level, e.g. +-O6 or -g. + +=head2 Compiler and Linker flags + +If you want to set $ccflags or $ldflags, you should append to the existing +value to allow Configure command-line settings, e.g. use + + ccflags="$ccflags -DANOTHER_OPTION_I_NEED" + +so that the user can do something like + + sh Configure -Dccflags='FIX_NEGATIVE_ZERO' + +and have the FIX_NEGATIVE_ZERO value preserved by the hints file. + +=head2 Libraries + +Configure will attempt to use the libraries listed in the variable +$libswanted. If necessary, you should remove broken libraries from +that list, or add additional libraries to that list. You should +*not* simply set $libs -- that ignores the possibilities of local +variations. For example, a setting of libs='-lgdbm -lm -lc' would +fail if another user were to try to compile Perl on a system without +GDBM but with Berkeley DB. See hints/dec_osf.sh and hints/solaris_2.sh +for examples. + +=head2 Other + +In general, try to avoid hard-wiring something that Configure will +figure out anyway. Also try to allow for Configure command-line +overrides. + =head1 Hint file tricks =head2 Printing critical messages @@ -204,4 +256,4 @@ say things like "sh Configure -Dcc=gcc -Dusethreads" on the command line. Have the appropriate amount of fun :-) - Andy Dougherty doughera@lafcol.lafayette.edu + Andy Dougherty doughera@lafayette.edu diff --git a/hints/amigaos.sh b/hints/amigaos.sh index 9d86e52bc0..fff55b082c 100644 --- a/hints/amigaos.sh +++ b/hints/amigaos.sh @@ -22,15 +22,20 @@ libpth="$prefix/lib /local/lib" glibpth="$libpth" xlibpth="$libpth" +# This should remove unwanted libraries instead of limiting the set +# to just these few. E.g. what about Berkeley DB? libswanted='gdbm m dld' so=' ' # compiler & linker flags +# Respect command-line values. -ccflags='-DAMIGAOS -mstackextend' -ldflags='' -optimize='-O2 -fomit-frame-pointer' +ccflags="$ccflags -DAMIGAOS -mstackextend" +case "$optimize" in +'') optimize='-O2 -fomit-frame-pointer';; +esac dlext='o' +# Are these two different from the defaults? cccdlflags='none' ccdlflags='none' lddlflags='-oformat a.out-amiga -r' diff --git a/hints/cygwin.sh b/hints/cygwin.sh index 23d055faa6..de48cdfeb2 100644 --- a/hints/cygwin.sh +++ b/hints/cygwin.sh @@ -1,6 +1,11 @@ #! /bin/sh # cygwin.sh - hints for building perl using the Cygwin environment for Win32 # +# Many of these inflexible settings should be changed to allow command- +# line overrides and allow for variations in local set-ups. +# I have made first guesses at some of these, but would welcome +# corrections from someone actually using Cygwin. +# Andy Dougherty <doughera@lafayette.edu> Tue Sep 28 12:39:38 EDT 1999 _exe='.exe' exe_ext='.exe' @@ -10,25 +15,31 @@ sharpbang='#!' startsh='#!/bin/sh' archname='cygwin' -cc='gcc' +test -z "$cc" && cc='gcc' libpth='/usr/i586-cygwin32/lib /usr/lib /usr/local/lib' so='dll' libs='-lcygwin -lm -lkernel32' #optimize='-g' -ccflags='-DCYGWIN -I/usr/include -I/usr/local/include' -ldflags='-L/usr/i586-cygwin32/lib -L/usr/lib -L/usr/local/lib' -usemymalloc='n' +# Is -I/usr/include *really* needed? +# Is -I/usr/local/include *really* needed? I thought gcc always looked there. +ccflags="$ccflags -DCYGWIN -I/usr/include -I/usr/local/include" +# Is -L/usr/lib *really* needed? +ldflags="$ldflags -L/usr/i586-cygwin32/lib -L/usr/lib -L/usr/local/lib" +test -z "$usemymalloc" && usemymalloc='n' dlsrc='dl_cygwin.xs' cccdlflags=' ' ld='ld2' -lddlflags='-L/usr/local/lib' +# Is -L/usr/local/lib *really* needed? +lddlflags="$lddlflags -L/usr/local/lib" useshrplib='true' libperl='libperl.a' dlext='dll' dynamic_ext=' ' -man1dir=/usr/local/man/man1 -man3dir=/usr/local/man/man3 +# What if they aren't using $prefix=/usr/local ?? +# Why is this needed at all? Doesn't Configure suggest this? +test -z "$man1dir" && man1dir=/usr/local/man/man1 +test -z "$man3dir" && man3dir=/usr/local/man/man3 case "$ldlibpthname" in '') ldlibpthname=PATH ;; diff --git a/hints/dynixptx.sh b/hints/dynixptx.sh index 2edf026305..5320030176 100644 --- a/hints/dynixptx.sh +++ b/hints/dynixptx.sh @@ -22,7 +22,9 @@ usenm='n' # for performance, apparently this makes a huge difference (~krader) d_vfork='define' -optimize='-Wc,-O3 -W0,-xstring' +case "$optimize" in +'') optimize='-Wc,-O3 -W0,-xstring' ;; +esac # We override d_socket because it's very hard for Configure to get it right # in Dynix/Ptx, for several reasons. @@ -49,9 +51,9 @@ case "$osvers" in 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' + cppflags="$cppflags -Wc,+bsd-socket" + ccflags="$ccflags -Wc,+bsd-socket" + ldflags="$ldflags -Wc,+bsd-socket" d_socket='define' d_oldsock='undef' d_sockpair='define' diff --git a/hints/epix.sh b/hints/epix.sh index 03d5be536c..dcad3c5d47 100644 --- a/hints/epix.sh +++ b/hints/epix.sh @@ -43,9 +43,9 @@ d_flock='undef' # of libswanted excludes some libraries found there. You may want to # prevent "ucb" from being removed from libswanted and see if perl will # build on your system. -ldflags='-non_shared -systype svr4 -L/svr4/usr/lib -L/svr4/usr/lib/cmplrs/cc -L/usr/ccs/lib -L/svr4/usr/ucblib' -ccflags='-systype svr4 -D__STDC__=0 -I/svr4/usr/include -I/svr4/usr/ucbinclude' -cppflags='-D__STDC__=0 -I/svr4/usr/include -I/svr4/usr/ucbinclude' +ldflags="$ldflags -non_shared -systype svr4 -L/svr4/usr/lib -L/svr4/usr/lib/cmplrs/cc -L/usr/ccs/lib -L/svr4/usr/ucblib" +ccflags="$ccflags -systype svr4 -D__STDC__=0 -I/svr4/usr/include -I/svr4/usr/ucbinclude" +cppflags="$ccflags -D__STDC__=0 -I/svr4/usr/include -I/svr4/usr/ucbinclude" # Don't use problematic libraries: diff --git a/hints/esix4.sh b/hints/esix4.sh index 695f8b870f..9967207d37 100644 --- a/hints/esix4.sh +++ b/hints/esix4.sh @@ -3,14 +3,18 @@ # Kevin O'Gorman ( kevin@kosman.UUCP, kevin%kosman.uucp@nrc.com ) # # Use Configure -Dcc=gcc to use gcc. + +# Why can't we just use PATH? It contains /usr/ccs/bin. case "$cc" in '') cc='/bin/cc' test -f $cc || cc='/usr/ccs/bin/cc' ;; esac -ldflags='-L/usr/ccs/lib -L/usr/ucblib' + +ldflags="$ldflags -L/usr/ccs/lib -L/usr/ucblib" test -d /usr/local/man || mansrc='none' -ccflags='-I/usr/include -I/usr/ucbinclude' +# Do we really need to tell cc to look in /usr/include? +ccflags="$ccflags -I/usr/include -I/usr/ucbinclude" libswanted=`echo " $libswanted " | sed -e 's/ malloc / /' ` d_index='undef' d_suidsafe=define diff --git a/hints/mint.sh b/hints/mint.sh index 22d854c397..ab55e612e1 100644 --- a/hints/mint.sh +++ b/hints/mint.sh @@ -18,7 +18,7 @@ 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" +ccflags="$ccflags -D__MINT__ -Uatarist -DDEBUGGING -I$here/../mint" # libs @@ -44,6 +44,7 @@ util_cflags='ccflags="$ccflags -DLOCALE_ENVIRON_REQUIRED"' # # Some good answers to the questions in Configure: +# Does Configure really get all these wrong? usenm='true' d_suidsafe='true' clocktype='long' diff --git a/hints/mpeix.sh b/hints/mpeix.sh index 9ebb0bad1e..556d22148c 100644 --- a/hints/mpeix.sh +++ b/hints/mpeix.sh @@ -12,7 +12,7 @@ # Revised again for 5.004_69 by Mark Bixby, markb@cccd.edu. # osname='mpeix' -osvers='5.5' +osvers='5.5' # Isn't there a way to determine this dynamically? # # Force Configure to use our wrapper mpeix/nm script # @@ -24,7 +24,8 @@ usenm='true' # # Various directory locations. # -prefix='/PERL/PUB' +# Which ones of these does Configure get wrong? +test -z "$prefix" && prefix='/PERL/PUB' archname='PA-RISC1.1' bin="$prefix" installman1dir="$prefix/man/man1" @@ -38,24 +39,30 @@ startsh='#!/bin/sh' # # Compiling. # -cc='gcc' +test -z "$cc" && cc='gcc' cccdlflags='none' -ccflags='-DMPE -D_POSIX_SOURCE -D_SOCKET_SOURCE -D_POSIX_JOB_CONTROL -DIS_SOCKET_CLIB_ITSELF' -locincpth='/usr/local/include /usr/contrib/include /BIND/PUB/include' -optimize='-O2' +ccflags="$ccflags -DMPE -D_POSIX_SOURCE -D_SOCKET_SOURCE -D_POSIX_JOB_CONTROL -DIS_SOCKET_CLIB_ITSELF" +locincpth="$locincpth /usr/local/include /usr/contrib/include /BIND/PUB/include" +test -z "$optimize" && optimize="-O2" ranlib='/bin/true' # Special compiling options for certain source files. +# But what if you want -g? regcomp_cflags='optimize=-O' toke_cflags='ccflags="$ccflags -DARG_ZERO_IS_SCRIPT"' # # Linking. # lddlflags='-b' -libs='-lbind -lsyslog -lcurses -lsvipc -lsocket -lm -lc' -loclibpth='/usr/local/lib /usr/contrib/lib /BIND/PUB/lib /SYSLOG/PUB' +# What if you want additional libs (e.g. gdbm)? +# This should remove the unwanted libraries from $libswanted and +# add on whatever ones are needed instead. +libs="$libs -lbind -lsyslog -lcurses -lsvipc -lsocket -lm -lc" +loclibpth="$loclibpth /usr/local/lib /usr/contrib/lib /BIND/PUB/lib /SYSLOG/PUB" # # External functions and data items. # +# Does Configure *really* get *all* of these wrong? +# d_crypt='define' d_difftime='define' d_dlerror='undef' diff --git a/hints/next_3.sh b/hints/next_3.sh index 1a174b8d54..27c9bd9877 100644 --- a/hints/next_3.sh +++ b/hints/next_3.sh @@ -47,7 +47,7 @@ # use the following two lines if you have perl5.003_22 or better and # do not encounter intermittent core dumps. -ccflags='-DUSE_NEXT_CTYPE' +ccflags="$ccflags -DUSE_NEXT_CTYPE" usemymalloc='n' ###################################################################### diff --git a/hints/next_3_0.sh b/hints/next_3_0.sh index b8cc2c2d90..b444578830 100644 --- a/hints/next_3_0.sh +++ b/hints/next_3_0.sh @@ -16,11 +16,11 @@ echo find it. By default, it is placed in /usr/local/include/gdbm.h. >&4 echo It will not be found there. Try moving it to >&4 echo /NextDeveloper/Headers/bsd/gdbm.h. >&4 -ccflags='-DUSE_NEXT_CTYPE -DNEXT30_NO_ATTRIBUTE' +ccflags="$ccflags -DUSE_NEXT_CTYPE -DNEXT30_NO_ATTRIBUTE" POSIX_cflags='ccflags="-posix $ccflags"' useposix='undef' -ldflags='-u libsys_s' -libswanted='dbm gdbm db' +ldflags="$ldflags -u libsys_s" +libswanted="$libswanted dbm gdbm db" # lddlflags='-r' # Give cccdlflags an empty value since Configure will detect we are diff --git a/hints/next_4.sh b/hints/next_4.sh index ba096ac9fd..d5c8ba7d64 100644 --- a/hints/next_4.sh +++ b/hints/next_4.sh @@ -6,9 +6,9 @@ libpth='/lib /usr/lib /usr/local/lib' libswanted=' ' libc='/NextLibrary/Frameworks/System.framework/System' -ldflags='-dynamic -prebind' -lddlflags='-dynamic -bundle -undefined suppress' -ccflags='-dynamic -fno-common -DUSE_NEXT_CTYPE -DUSE_PERL_SBRK' +ldflags="$ldflags -dynamic -prebind" +lddlflags="$lddlflags -dynamic -bundle -undefined suppress" +ccflags="$ccflags -dynamic -fno-common -DUSE_NEXT_CTYPE -DUSE_PERL_SBRK" cccdlflags='none' ld='cc' #optimize='-g -O' diff --git a/hints/sco.sh b/hints/sco.sh index eb598452a1..1c70a4d540 100644 --- a/hints/sco.sh +++ b/hints/sco.sh @@ -9,6 +9,8 @@ # Mostly rewritten on # Tue Jan 19 23:00:00 CET 1999 # by Francois Desarmenien <desar@club-internet.fr> +# Modified by Boyd Gerber <gerberb@zenez.com> +# Tue Sep 21 1999 ############################################################### # # To use cc, use sh Configure @@ -82,6 +84,7 @@ case `/bin/uname -X | egrep '3\.2v'` in echo "" >&4 echo "" >&4 echo " For UnixWare, use svr4.sh hints instead" >&4 + echo " For UnixWare 7.*, use svr5.sh hints instead" >&4 echo "" >&4 echo "***********************************************************" >&4 exit @@ -102,7 +105,7 @@ if test "$scorls" = "3" then dlext='' case "$cc" in - gcc) optimize='-O2' ;; + *gcc*) optimize='-O2' ;; *) ccflags="$ccflags -W0 -quiet" optimize='-O' ;; esac @@ -114,7 +117,7 @@ else ############################################################### # In Release 5, always compile ELF objects case "$cc" in - gcc) + *gcc*) ccflags="$ccflags -melf" optimize='-O2' ;; @@ -139,7 +142,7 @@ else if test "$usedl" != "n"; then ld='ld' case "$cc" in - gcc) + *gcc*) ccdlflags='-Xlinker -Bexport -L/usr/local/lib' cccdlflags='-fpic' lddlflags='-G -L/usr/local/lib' diff --git a/hints/svr5.sh b/hints/svr5.sh new file mode 100644 index 0000000000..44c03c9fc9 --- /dev/null +++ b/hints/svr5.sh @@ -0,0 +1,222 @@ +# svr5 hints, System V Release 5.x +# Last modified 1999/09/21 by Boyd Gerber, gerberb@zenez.com + +# Use Configure -Dcc=gcc to use gcc. +case "$cc" in +'') cc='/bin/cc' + test -f $cc || cc='/usr/ccs/bin/cc' + ;; + *) + case "$gccversion" in + *2.95*) + ccflags='-fno-strict-aliasing' + ;; + *);; + esac + ;; +esac + +# want_ucb='' +# want_dbm='yes' +want_gdbm='yes' + +# We include support for using libraries in /usr/ucblib, but the setting +# of libswanted excludes some libraries found there. If you run into +# problems, you may have to remove "ucb" from libswanted. Just delete +# the comment '#' from the sed command below. +# ldflags='-L/usr/ccs/lib -L/usr/ucblib' +# ccflags='-I/usr/include -I/usr/ucbinclude' +# Don't use problematic libraries: +libswanted=`echo " $libswanted " | sed -e 's/ malloc / /'` # -e 's/ ucb / /'` +# libmalloc.a - Probably using Perl's malloc() anyway. +# libucb.a - Remove it if you have problems ld'ing. We include it because +# it is needed for ODBM_File and NDBM_File extensions. + +if [ "$want_ucb" ] ; then + ldflags= '-L/usr/ccs/lib -L/usr/ucblib' + ccflags='-I/usr/include -I/usr/ucbinclude' + if [ -r /usr/ucblib/libucb.a ]; then # If using BSD-compat. library: + d_Gconvert='gcvt((x),(n),(b))' # Try gcvt() before gconvert(). + # Use the "native" counterparts, not the BSD emulation stuff: + d_bcmp='undef' d_bcopy='undef' d_bzero='undef' d_safebcpy='undef' + d_index='undef' d_killpg='undef' d_getprior='undef' d_setprior='undef' + d_setlinebuf='undef' + # d_setregid='undef' d_setreuid='undef' # ??? + fi +else +# libswanted=`echo " $libswanted " | sed -e 's/ ucb / /' -e 's/ dbm / /'` + libswanted=`echo " $libswanted " | sed -e 's/ ucb / /'` + glibpth=`echo " $glibpth " | sed -e 's/ \/usr\/ucblib / /'` + + # a non ucb native version of libdbm for /usr/local is available from + # http://www.sco.com/skunkware + # if its installed (and not overidden) we'll use it. + if [ ! -f /usr/local/lib/libdbm.so -o ! "$want_dbm" ] ; then + libswanted=`echo " $libswanted " | sed -e 's/ dbm / /'` + fi +fi + +if [ "$want_gdbm" -a -f /usr/local/lib/libgdbm.so ] ; then + i_gdbm='define' +else + i_gdbm='undef' + libswanted=`echo " $libswanted " | sed -e 's/ gdbm / /'` +fi + +# Don't use problematic libraries: +# libmalloc.a - Probably using Perl's malloc() anyway. +# libc: on UW7 don't want -lc explicitly - cc gives warnings/errors +libswanted=`echo " $libswanted " | sed -e 's/ malloc / /' -e 's/ c / /'` + +# remove /shlib and /lib from library search path as both symlink to /usr/lib +# where runtime shared libc is +glibpth=`echo " $glibpth " | sed -e 's/ \/shlib / /' -e 's/ \/lib / /` + +# UnixWare has /usr/lib/libc.so.1, /usr/lib/libc.so.1.1, and +# /usr/ccs/lib/libc.so. Configure chooses libc.so.1.1 while it +# appears that /usr/ccs/lib/libc.so contains more symbols: +# +# Try the following if you want to use nm-extraction. We'll just +# skip the nm-extraction phase, since searching for all the different +# library versions will be hard to keep up-to-date. +# +# if [ "" = "$libc" -a -f /usr/ccs/lib/libc.so -a \ +# -f /usr/lib/libc.so.1 -a -f /usr/lib/libc.so.1.1 ]; then +# if nm -h /usr/ccs/lib/libc.so | egrep '\<_?select$' >/dev/null; then +# if nm -h /usr/lib/libc.so.1 | egrep '\<_?select$'` >/dev/null || +# nm -h /usr/lib/libc.so.1.1 | egrep '\<_?select$'` >/dev/null; then +# : +# else +# libc=/usr/ccs/lib/libc.so +# fi +# fi +# fi +# +# Don't bother with nm. Just compile & link a small C program. +case "$usenm" in +'') usenm=false;; +esac + +# Broken C-Shell tests (Thanks to Tye McQueen): +# The OS-specific checks may be obsoleted by the this generic test. + sh_cnt=`sh -c 'echo /*' | wc -c` + csh_cnt=`csh -f -c 'glob /*' 2>/dev/null | wc -c` + csh_cnt=`expr 1 + $csh_cnt` +if [ "$sh_cnt" -ne "$csh_cnt" ]; then + echo "You're csh has a broken 'glob', disabling..." >&2 + d_csh='undef' +fi + +# Unixware-specific problems. The undocumented -X argument to uname +# is probably a reasonable way of detecting UnixWare. +# UnixWare has a broken csh. (This might already be detected above). +# Configure can't detect memcpy or memset on Unixware 2 or 7 +# +# Leave leading tabs on the next two lines so Configure doesn't +# propagate these variables to config.sh + uw_ver=`uname -v` + uw_isuw=`uname -X 2>&1 | grep Release` + +if [ "$uw_isuw" = "Release = 5" ]; then + case $uw_ver in + 7*) + d_csh='undef' + d_memcpy='define' + d_memset='define' + stdio_cnt='((fp)->__cnt)' + d_stdio_cnt_lval='define' + stdio_ptr='((fp)->__ptr)' + d_stdio_ptr_lval='define' + ;; + esac +fi + +############################################################### +# Dynamic loading section: +# +# ccdlflags : must tell the linker to export all global symbols +# cccdlflags: must tell the compiler to generate relocatable code +# lddlflags : must tell the linker to output a shared library +# +# /usr/local/lib is added for convenience, since additional libraries +# are usually put there +# +# use shared perl lib +useshrplib='true' + +case "$cc" in + *gcc*) + ccdlflags='-Xlinker -Bexport -L/usr/local/lib' + cccdlflags='-fpic' + lddlflags='-G -L/usr/local/lib' + ;; + *) + ccdlflags='-Wl,-Bexport -L/usr/local/lib' + cccdlflags='-KPIC' + lddlflags='-G -Wl,-Bexport -L/usr/local/lib' + ;; +esac + +############################################################### +# Use dynamic loading +usedl='define' +dlext='so' +dlsrc='dl_dlopen.xs' + +# Configure may fail to find lstat() since it's a static/inline function +# in <sys/stat.h> on Unisys U6000 SVR4, UnixWare 2.x, and possibly other +# SVR4 derivatives. (Though UnixWare has it in /usr/ccs/lib/libc.so.) +d_lstat=define + + +# DDE SMES Supermax Enterprise Server +case "`uname -sm`" in +"UNIX_SV SMES") + # the *grent functions are in libgen. + libswanted="$libswanted gen" + # csh is broken (also) in SMES + # This may already be detected by the generic test above. + d_csh='undef' + case "$cc" in + *gcc*) ;; + *) # for cc we need -K PIC (not -K pic) + cccdlflags="$cccdlflags -K PIC" + ;; + esac + ;; +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="$ccflags" + set `echo X "$libswanted "| sed -e 's/ c / pthread c /'` + shift + libswanted="$*" + case "$cc" in + *gcc*) + ccflags="-D_REENTRANT $ccflags -fpic -pthread" + cccdlflags='-fpic' + lddlflags='-pthread -G -L/usr/local/lib ' + ;; + *) + ccflags="-D_REENTRANT $ccflags -KPIC -Kthread" + ccdlflags='-Kthread -Wl,-Bexport -L/usr/local/lib' + cccdlflags='-KPIC -Kthread' + lddlflags='-G -Kthread -Wl,-Bexport -L/usr/local/lib' + ldflags='-Kthread -L/usr/local/lib -L/usr/gnu/lib' + ;; + esac +esac +EOCBU + +# End of Unixware-specific tests. +# Configure may fail to find lstat() since it's a static/inline function +# in <sys/stat.h> on Unisys U6000 SVR4, UnixWare 2.x, and possibly other +# SVR4 derivatives. (Though UnixWare has it in /usr/ccs/lib/libc.so.) +d_lstat=define + +d_suidsafe='define' # "./Configure -d" can't figure this out easilly + diff --git a/intrpvar.h b/intrpvar.h index 669e6f97ad..cc3eff5e0b 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -23,7 +23,6 @@ PERLVAR(Ihintgv, GV *) PERLVAR(Iorigfilename, char *) PERLVAR(Idiehook, SV *) PERLVAR(Iwarnhook, SV *) -PERLVAR(Iparsehook, SV *) PERLVAR(Icddir, char *) /* switches */ PERLVAR(Iminus_c, bool) PERLVARA(Ipatchlevel,10,char) @@ -222,6 +221,14 @@ PERLVAR(Ixiv_root, IV *) /* free xiv list--shared by interpreters */ PERLVAR(Ixnv_root, NV *) /* free xnv list--shared by interpreters */ PERLVAR(Ixrv_root, XRV *) /* free xrv list--shared by interpreters */ PERLVAR(Ixpv_root, XPV *) /* free xpv list--shared by interpreters */ +PERLVAR(Ixpviv_root, XPVIV *) /* free xpviv list--shared by interpreters */ +PERLVAR(Ixpvnv_root, XPVNV *) /* free xpvnv list--shared by interpreters */ +PERLVAR(Ixpvcv_root, XPVCV *) /* free xpvcv list--shared by interpreters */ +PERLVAR(Ixpvav_root, XPVAV *) /* free xpvav list--shared by interpreters */ +PERLVAR(Ixpvhv_root, XPVHV *) /* free xpvhv list--shared by interpreters */ +PERLVAR(Ixpvmg_root, XPVMG *) /* free xpvmg list--shared by interpreters */ +PERLVAR(Ixpvlv_root, XPVLV *) /* free xpvlv list--shared by interpreters */ +PERLVAR(Ixpvbm_root, XPVBM *) /* free xpvbm list--shared by interpreters */ PERLVAR(Ihe_root, HE *) /* free he list--shared by interpreters */ PERLVAR(Inice_chunk, char *) /* a nice chunk of memory to reuse */ PERLVAR(Inice_chunk_size, U32) /* how nice the chunk of memory is */ @@ -287,7 +294,7 @@ PERLVAR(Ithisexpr, I32) /* name id for nothing_in_common() */ PERLVAR(Ilast_uni, char *) /* position of last named-unary op */ PERLVAR(Ilast_lop, char *) /* position of last list operator */ PERLVAR(Ilast_lop_op, OPCODE) /* last list operator */ -PERLVAR(Iin_my, bool) /* we're compiling a "my" declaration */ +PERLVAR(Iin_my, I32) /* we're compiling a "my" (or "our") declaration */ PERLVAR(Iin_my_stash, HV *) /* declared class of this "my" declaration */ #ifdef FCRYPT PERLVAR(Icryptseen, I32) /* has fast crypt() been initialized? */ diff --git a/keywords.h b/keywords.h index e818831148..f6b98aa802 100644 --- a/keywords.h +++ b/keywords.h @@ -140,111 +140,112 @@ #define KEY_opendir 139 #define KEY_or 140 #define KEY_ord 141 -#define KEY_pack 142 -#define KEY_package 143 -#define KEY_pipe 144 -#define KEY_pop 145 -#define KEY_pos 146 -#define KEY_print 147 -#define KEY_printf 148 -#define KEY_prototype 149 -#define KEY_push 150 -#define KEY_q 151 -#define KEY_qq 152 -#define KEY_qr 153 -#define KEY_quotemeta 154 -#define KEY_qw 155 -#define KEY_qx 156 -#define KEY_rand 157 -#define KEY_read 158 -#define KEY_readdir 159 -#define KEY_readline 160 -#define KEY_readlink 161 -#define KEY_readpipe 162 -#define KEY_recv 163 -#define KEY_redo 164 -#define KEY_ref 165 -#define KEY_rename 166 -#define KEY_require 167 -#define KEY_reset 168 -#define KEY_return 169 -#define KEY_reverse 170 -#define KEY_rewinddir 171 -#define KEY_rindex 172 -#define KEY_rmdir 173 -#define KEY_s 174 -#define KEY_scalar 175 -#define KEY_seek 176 -#define KEY_seekdir 177 -#define KEY_select 178 -#define KEY_semctl 179 -#define KEY_semget 180 -#define KEY_semop 181 -#define KEY_send 182 -#define KEY_setgrent 183 -#define KEY_sethostent 184 -#define KEY_setnetent 185 -#define KEY_setpgrp 186 -#define KEY_setpriority 187 -#define KEY_setprotoent 188 -#define KEY_setpwent 189 -#define KEY_setservent 190 -#define KEY_setsockopt 191 -#define KEY_shift 192 -#define KEY_shmctl 193 -#define KEY_shmget 194 -#define KEY_shmread 195 -#define KEY_shmwrite 196 -#define KEY_shutdown 197 -#define KEY_sin 198 -#define KEY_sleep 199 -#define KEY_socket 200 -#define KEY_socketpair 201 -#define KEY_sort 202 -#define KEY_splice 203 -#define KEY_split 204 -#define KEY_sprintf 205 -#define KEY_sqrt 206 -#define KEY_srand 207 -#define KEY_stat 208 -#define KEY_study 209 -#define KEY_sub 210 -#define KEY_substr 211 -#define KEY_symlink 212 -#define KEY_syscall 213 -#define KEY_sysopen 214 -#define KEY_sysread 215 -#define KEY_sysseek 216 -#define KEY_system 217 -#define KEY_syswrite 218 -#define KEY_tell 219 -#define KEY_telldir 220 -#define KEY_tie 221 -#define KEY_tied 222 -#define KEY_time 223 -#define KEY_times 224 -#define KEY_tr 225 -#define KEY_truncate 226 -#define KEY_uc 227 -#define KEY_ucfirst 228 -#define KEY_umask 229 -#define KEY_undef 230 -#define KEY_unless 231 -#define KEY_unlink 232 -#define KEY_unpack 233 -#define KEY_unshift 234 -#define KEY_untie 235 -#define KEY_until 236 -#define KEY_use 237 -#define KEY_utime 238 -#define KEY_values 239 -#define KEY_vec 240 -#define KEY_wait 241 -#define KEY_waitpid 242 -#define KEY_wantarray 243 -#define KEY_warn 244 -#define KEY_while 245 -#define KEY_write 246 -#define KEY_x 247 -#define KEY_xor 248 -#define KEY_y 249 +#define KEY_our 142 +#define KEY_pack 143 +#define KEY_package 144 +#define KEY_pipe 145 +#define KEY_pop 146 +#define KEY_pos 147 +#define KEY_print 148 +#define KEY_printf 149 +#define KEY_prototype 150 +#define KEY_push 151 +#define KEY_q 152 +#define KEY_qq 153 +#define KEY_qr 154 +#define KEY_quotemeta 155 +#define KEY_qw 156 +#define KEY_qx 157 +#define KEY_rand 158 +#define KEY_read 159 +#define KEY_readdir 160 +#define KEY_readline 161 +#define KEY_readlink 162 +#define KEY_readpipe 163 +#define KEY_recv 164 +#define KEY_redo 165 +#define KEY_ref 166 +#define KEY_rename 167 +#define KEY_require 168 +#define KEY_reset 169 +#define KEY_return 170 +#define KEY_reverse 171 +#define KEY_rewinddir 172 +#define KEY_rindex 173 +#define KEY_rmdir 174 +#define KEY_s 175 +#define KEY_scalar 176 +#define KEY_seek 177 +#define KEY_seekdir 178 +#define KEY_select 179 +#define KEY_semctl 180 +#define KEY_semget 181 +#define KEY_semop 182 +#define KEY_send 183 +#define KEY_setgrent 184 +#define KEY_sethostent 185 +#define KEY_setnetent 186 +#define KEY_setpgrp 187 +#define KEY_setpriority 188 +#define KEY_setprotoent 189 +#define KEY_setpwent 190 +#define KEY_setservent 191 +#define KEY_setsockopt 192 +#define KEY_shift 193 +#define KEY_shmctl 194 +#define KEY_shmget 195 +#define KEY_shmread 196 +#define KEY_shmwrite 197 +#define KEY_shutdown 198 +#define KEY_sin 199 +#define KEY_sleep 200 +#define KEY_socket 201 +#define KEY_socketpair 202 +#define KEY_sort 203 +#define KEY_splice 204 +#define KEY_split 205 +#define KEY_sprintf 206 +#define KEY_sqrt 207 +#define KEY_srand 208 +#define KEY_stat 209 +#define KEY_study 210 +#define KEY_sub 211 +#define KEY_substr 212 +#define KEY_symlink 213 +#define KEY_syscall 214 +#define KEY_sysopen 215 +#define KEY_sysread 216 +#define KEY_sysseek 217 +#define KEY_system 218 +#define KEY_syswrite 219 +#define KEY_tell 220 +#define KEY_telldir 221 +#define KEY_tie 222 +#define KEY_tied 223 +#define KEY_time 224 +#define KEY_times 225 +#define KEY_tr 226 +#define KEY_truncate 227 +#define KEY_uc 228 +#define KEY_ucfirst 229 +#define KEY_umask 230 +#define KEY_undef 231 +#define KEY_unless 232 +#define KEY_unlink 233 +#define KEY_unpack 234 +#define KEY_unshift 235 +#define KEY_untie 236 +#define KEY_until 237 +#define KEY_use 238 +#define KEY_utime 239 +#define KEY_values 240 +#define KEY_vec 241 +#define KEY_wait 242 +#define KEY_waitpid 243 +#define KEY_wantarray 244 +#define KEY_warn 245 +#define KEY_while 246 +#define KEY_write 247 +#define KEY_x 248 +#define KEY_xor 249 +#define KEY_y 250 diff --git a/keywords.pl b/keywords.pl index f907e3f115..438849a057 100755 --- a/keywords.pl +++ b/keywords.pl @@ -166,6 +166,7 @@ open opendir or ord +our pack package pipe diff --git a/lib/Benchmark.pm b/lib/Benchmark.pm index 767cb67d13..a7debd73ee 100644 --- a/lib/Benchmark.pm +++ b/lib/Benchmark.pm @@ -8,8 +8,12 @@ timethis - run a chunk of code several times timethese - run several chunks of code several times +cmpthese - print results of timethese as a comparison chart + timeit - run a chunk of code and see how long it goes +countit - see how many times a chunk of code runs in a given time + =head1 SYNOPSIS timethis ($count, "code"); @@ -26,9 +30,34 @@ timeit - run a chunk of code and see how long it goes 'Name2' => sub { ...code2... }, }); + # cmpthese can be used both ways as well + cmpthese($count, { + 'Name1' => '...code1...', + 'Name2' => '...code2...', + }); + + cmpthese($count, { + 'Name1' => sub { ...code1... }, + 'Name2' => sub { ...code2... }, + }); + + # ...or in two stages + $results = timethese($count, + { + 'Name1' => sub { ...code1... }, + 'Name2' => sub { ...code2... }, + }, + 'none' + ); + cmpthese( $results ) ; + $t = timeit($count, '...other code...') print "$count loops of other code took:",timestr($t),"\n"; + $t = countit($time, '...other code...') + $count = $t->iters ; + print "$count loops of other code took:",timestr($t),"\n"; + =head1 DESCRIPTION The Benchmark module encapsulates a number of routines to help you @@ -57,6 +86,10 @@ Enables or disable debugging by setting the C<$Benchmark::Debug> flag: $t = timeit(10, ' 5 ** $Global '); debug Benchmark 0; +=item iters + +Returns the number of iterations. + =back =head2 Standard Exports @@ -66,6 +99,34 @@ if you use the Benchmark module: =over 10 +=item cmpthese ( COUT, CODEHASHREF, [ STYLE ] ) + +=item cmpthese ( RESULTSHASHREF ) + +Optionally calls timethese(), then outputs comparison chart. This +chart is sorted from slowest to highest, and shows the percent +speed difference between each pair of tests. Can also be passed +the data structure that timethese() returns: + + $results = timethese( .... ); + cmpthese( $results ); + +Returns the data structure returned by timethese(). + +=item countit(TIME, CODE) + +Arguments: TIME is the minimum length of time to run CODE for, and CODE is +the code to run. CODE may be either a code reference or a string to +be eval'd; either way it will be run in the caller's package. + +TIME is I<not> negative. countit() will run the loop many times to +calculate the speed of CODE before running it for TIME. The actual +time run for will usually be greater than TIME due to system clock +resolution, so it's best to look at the number of iterations divided +by the times that you are concerned with, not just the iterations. + +Returns: a Benchmark object. + =item timeit(COUNT, CODE) Arguments: COUNT is the number of times to run the loop, and CODE is @@ -119,6 +180,8 @@ The routines are called in string comparison order of KEY. The COUNT can be zero or negative, see timethis(). +Returns a hash of Benchmark objects, keyed by name. + =item timediff ( T1, T2 ) Returns the difference between two Benchmark times as a Benchmark @@ -135,12 +198,13 @@ Returns a string that formats the times in the TIMEDIFF object in the requested STYLE. TIMEDIFF is expected to be a Benchmark object similar to that returned by timediff(). -STYLE can be any of 'all', 'noc', 'nop' or 'auto'. 'all' shows each -of the 5 times available ('wallclock' time, user time, system time, +STYLE can be any of 'all', 'none', 'noc', 'nop' or 'auto'. 'all' shows +each of the 5 times available ('wallclock' time, user time, system time, user time of children, and system time of children). 'noc' shows all except the two children times. 'nop' shows only wallclock and the two children times. 'auto' (the default) will act as 'all' unless the children times are both zero, in which case it acts as 'noc'. +'none' prevents output. FORMAT is the L<printf(3)>-style format specifier (without the leading '%') to use to print the times. It defaults to '5.2f'. @@ -180,7 +244,7 @@ different COUNT used. The data is stored as a list of values from the time and times functions: - ($real, $user, $system, $children_user, $children_system) + ($real, $user, $system, $children_user, $children_system, $iters) in seconds for the whole loop (not divided by the number of rounds). @@ -192,7 +256,7 @@ The time of the null loop (a loop with the same number of rounds but empty loop body) is subtracted from the time of the real loop. -The null loop times are cached, the key being the +The null loop times can be cached, the key being the number of rounds. The caching can be controlled using calls like these: @@ -202,6 +266,9 @@ calls like these: disablecache(); enablecache(); +Caching is off by default, as it can (usually slightly) decrease +accuracy and does not usually noticably affect runtimes. + =head1 INHERITANCE Benchmark inherits from no other class, except of course @@ -210,7 +277,7 @@ for Exporter. =head1 CAVEATS Comparing eval'd strings with code references will give you -inaccurate results: a code reference will show a slower +inaccurate results: a code reference will show a slightly slower execution time than the equivalent eval'd string. The real time timing is done using time(2) and @@ -241,6 +308,10 @@ documentation. April 04-07th, 1997: by Jarkko Hietaniemi, added the run-for-some-time functionality. +September, 1999; by Barrie Slaymaker: math fixes and accuracy and +efficiency tweaks. Added cmpthese(). A result is now returned from +timethese(). Exposed countit() (was runfor()). + =cut # evaluate something in a clean lexical environment @@ -253,7 +324,7 @@ sub _doeval { eval shift } use Carp; use Exporter; @ISA=(Exporter); -@EXPORT=qw(timeit timethis timethese timediff timesum timestr); +@EXPORT=qw(cmpthese countit timeit timethis timethese timediff timestr); @EXPORT_OK=qw(clearcache clearallcache disablecache enablecache); &init; @@ -290,6 +361,7 @@ sub cpu_p { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps ; } sub cpu_c { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $cu+$cs ; } sub cpu_a { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps+$cu+$cs ; } sub real { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $r ; } +sub iters { $_[0]->[5] ; } sub timediff { my($a, $b) = @_; @@ -364,15 +436,16 @@ sub runloop { croak "runloop unable to compile '$c': $@\ncode: $subcode\n" if $@; print STDERR "runloop $n '$subcode'\n" if $debug; - # Wait for the user timer to tick. This makes the error range more like -0.01, +0. If - # we don't wait, then it's more like -0.01, +0.01. This may not seem important, but it - # significantly reduces the chances of getting too low initial $n in the initial, 'find - # the minimum' loop in &runfor. This, in turn, can reduce the number of calls to + # Wait for the user timer to tick. This makes the error range more like + # -0.01, +0. If we don't wait, then it's more like -0.01, +0.01. This + # may not seem important, but it significantly reduces the chances of + # getting a too low initial $n in the initial, 'find the minimum' loop + # in &countit. This, in turn, can reduce the number of calls to # &runloop a lot, and thus reduce additive errors. my $tbase = Benchmark->new(0)->[1]; do { $t0 = Benchmark->new(0); - } while ( $t0->[1] == $tbase ) ; + } while ( $t0->[1] == $tbase ); &$subref; $t1 = Benchmark->new($n); $td = &timediff($t1, $t0); @@ -386,18 +459,20 @@ sub timeit { my($wn, $wc, $wd); printf STDERR "timeit $n $code\n" if $debug; - my $cache_key = $n . ( ref( $code ) ? 'c' : 's' ) ; + my $cache_key = $n . ( ref( $code ) ? 'c' : 's' ); if ($cache && exists $cache{$cache_key} ) { $wn = $cache{$cache_key}; } else { $wn = &runloop($n, ref( $code ) ? sub { undef } : '' ); + # Can't let our baseline have any iterations, or they get subtracted + # out of the result. + $wn->[5] = 0; $cache{$cache_key} = $wn; } $wc = &runloop($n, $code); $wd = timediff($wc, $wn); - timedebug("timeit: ",$wc); timedebug(" - ",$wn); timedebug(" = ",$wd); @@ -409,8 +484,9 @@ sub timeit { my $default_for = 3; my $min_for = 0.1; -sub runfor { - my ($code, $tmax) = @_; + +sub countit { + my ( $tmax, $code ) = @_; if ( not defined $tmax or $tmax == 0 ) { $tmax = $default_for; @@ -418,52 +494,61 @@ sub runfor { $tmax = -$tmax; } - die "runfor(..., $tmax): timelimit cannot be less than $min_for.\n" + die "countit($tmax, ...): timelimit cannot be less than $min_for.\n" if $tmax < $min_for; - my ($n, $td, $tc, $ntot, $rtot, $utot, $stot, $cutot, $cstot ); + my ($n, $tc); # First find the minimum $n that gives a significant timing. - - my $nmin; + for ($n = 1; ; $n *= 2 ) { + my $td = timeit($n, $code); + $tc = $td->[1] + $td->[2]; + last if $tc > 0.1; + } - for ($n = 1, $tc = 0; ; $n *= 2 ) { - $td = timeit($n, $code); + my $nmin = $n; + + # Get $n high enough that we can guess the final $n with some accuracy. + my $tpra = 0.1 * $tmax; # Target/time practice. + while ( $tc < $tpra ) { + # The 5% fudge is to keep us from iterating again all + # that often (this speeds overall responsiveness when $tmax is big + # and we guess a little low). This does not noticably affect + # accuracy since we're not couting these times. + $n = int( $tpra * 1.05 * $n / $tc ); # Linear approximation. + my $td = timeit($n, $code); $tc = $td->[1] + $td->[2]; - last if $tc > 0.1 ; } - $nmin = $n; - - my $ttot = 0; - my $tpra = 0.05 * $tmax; # Target/time practice. - # Double $n until we have think we have practiced enough. - for ( ; $ttot < $tpra; $n *= 2 ) { - $td = timeit($n, $code); - $ntot += $n; - $rtot += $td->[0]; - $utot += $td->[1]; - $stot += $td->[2]; - $ttot = $utot + $stot; + # Now, do the 'for real' timing(s), repeating until we exceed + # the max. + my $ntot = 0; + my $rtot = 0; + my $utot = 0.0; + my $stot = 0.0; + my $cutot = 0.0; + my $cstot = 0.0; + my $ttot = 0.0; + + # The 5% fudge is because $n is often a few % low even for routines + # with stable times and avoiding extra timeit()s is nice for + # accuracy's sake. + $n = int( $n * ( 1.05 * $tmax / $tc ) ); + + while () { + my $td = timeit($n, $code); + $ntot += $n; + $rtot += $td->[0]; + $utot += $td->[1]; + $stot += $td->[2]; $cutot += $td->[3]; $cstot += $td->[4]; - } - - my $r; + $ttot = $utot + $stot; + last if $ttot >= $tmax; - # Then iterate towards the $tmax. - while ( $ttot < $tmax ) { - $r = $tmax / $ttot - 1; # Linear approximation. + my $r = $tmax / $ttot - 1; # Linear approximation. $n = int( $r * $ntot ); $n = $nmin if $n < $nmin; - $td = timeit($n, $code); - $ntot += $n; - $rtot += $td->[0]; - $utot += $td->[1]; - $stot += $td->[2]; - $ttot = $utot + $stot; - $cutot += $td->[3]; - $cstot += $td->[4]; } return bless [ $rtot, $utot, $stot, $cutot, $cstot, $ntot ]; @@ -486,14 +571,14 @@ sub timethis{ $title = "timethis $n" unless defined $title; } else { $fort = n_to_for( $n ); - $t = runfor($code, $fort); + $t = countit( $fort, $code ); $title = "timethis for $fort" unless defined $title; $forn = $t->[-1]; } local $| = 1; $style = "" unless defined $style; - printf("%10s: ", $title); - print timestr($t, $style, $defaultfmt),"\n"; + printf("%10s: ", $title) unless $style eq 'none'; + print timestr($t, $style, $defaultfmt),"\n" unless $style eq 'none'; $n = $forn if defined $forn; @@ -513,25 +598,163 @@ sub timethese{ unless ref $alt eq HASH; my @names = sort keys %$alt; $style = "" unless defined $style; - print "Benchmark: "; + print "Benchmark: " unless $style eq 'none'; if ( $n > 0 ) { croak "non-integer loopcount $n, stopped" if int($n)<$n; - print "timing $n iterations of"; + print "timing $n iterations of" unless $style eq 'none'; } else { - print "running"; + print "running" unless $style eq 'none'; } - print " ", join(', ',@names); + print " ", join(', ',@names) unless $style eq 'none'; unless ( $n > 0 ) { my $for = n_to_for( $n ); - print ", each for at least $for CPU seconds"; + print ", each for at least $for CPU seconds" unless $style eq 'none'; } - print "...\n"; + print "...\n" unless $style eq 'none'; # we could save the results in an array and produce a summary here # sum, min, max, avg etc etc + my %results; foreach my $name (@names) { - timethis ($n, $alt -> {$name}, $name, $style); + $results{$name} = timethis ($n, $alt -> {$name}, $name, $style); + } + + return \%results; +} + +sub cmpthese{ + my $results = ref $_[0] ? $_[0] : timethese( @_ ); + + return $results + if defined $_[2] && $_[2] eq 'none'; + + # Flatten in to an array of arrays with the name as the first field + my @vals = map{ [ $_, @{$results->{$_}} ] } keys %$results; + + for (@vals) { + # The epsilon fudge here is to prevent div by 0. Since clock + # resolutions are much larger, it's below the noise floor. + my $rate = $_->[6] / ( $_->[2] + $_->[3] + 0.000000000000001 ); + $_->[7] = $rate; + } + + # Sort by rate + @vals = sort { $a->[7] <=> $b->[7] } @vals; + + # If more than half of the rates are greater than one... + my $display_as_rate = $vals[$#vals>>1]->[7] > 1; + + my @rows; + my @col_widths; + + my @top_row = ( + '', + $display_as_rate ? 'Rate' : 's/iter', + map { $_->[0] } @vals + ); + + push @rows, \@top_row; + @col_widths = map { length( $_ ) } @top_row; + + # Build the data rows + # We leave the last column in even though it never has any data. Perhaps + # it should go away. Also, perhaps a style for a single column of + # percentages might be nice. + for my $row_val ( @vals ) { + my @row; + + # Column 0 = test name + push @row, $row_val->[0]; + $col_widths[0] = length( $row_val->[0] ) + if length( $row_val->[0] ) > $col_widths[0]; + + # Column 1 = performance + my $row_rate = $row_val->[7]; + + # We assume that we'll never get a 0 rate. + my $a = $display_as_rate ? $row_rate : 1 / $row_rate; + + # Only give a few decimal places before switching to sci. notation, + # since the results aren't usually that accurate anyway. + my $format = + $a >= 100 ? + "%0.0f" : + $a >= 10 ? + "%0.1f" : + $a >= 1 ? + "%0.2f" : + $a >= 0.1 ? + "%0.3f" : + "%0.2e"; + + $format .= "/s" + if $display_as_rate; + # Using $b here due to optimizing bug in _58 through _61 + my $b = sprintf( $format, $a ); + push @row, $b; + $col_widths[1] = length( $b ) + if length( $b ) > $col_widths[1]; + + # Columns 2..N = performance ratios + my $skip_rest = 0; + for ( my $col_num = 0 ; $col_num < @vals ; ++$col_num ) { + my $col_val = $vals[$col_num]; + my $out; + if ( $skip_rest ) { + $out = ''; + } + elsif ( $col_val->[0] eq $row_val->[0] ) { + $out = "--"; + # $skip_rest = 1; + } + else { + my $col_rate = $col_val->[7]; + $out = sprintf( "%.0f%%", 100*$row_rate/$col_rate - 100 ); + } + push @row, $out; + $col_widths[$col_num+2] = length( $out ) + if length( $out ) > $col_widths[$col_num+2]; + + # A little wierdness to set the first column width properly + $col_widths[$col_num+2] = length( $col_val->[0] ) + if length( $col_val->[0] ) > $col_widths[$col_num+2]; + } + push @rows, \@row; + } + + # Equalize column widths in the chart as much as possible without + # exceeding 80 characters. This does not use or affect cols 0 or 1. + my @sorted_width_refs = + sort { $$a <=> $$b } map { \$_ } @col_widths[2..$#col_widths]; + my $max_width = ${$sorted_width_refs[-1]}; + + my $total = 0; + for ( @col_widths ) { $total += $_ } + + STRETCHER: + while ( $total < 80 ) { + my $min_width = ${$sorted_width_refs[0]}; + last + if $min_width == $max_width; + for ( @sorted_width_refs ) { + last + if $$_ > $min_width; + ++$$_; + ++$total; + last STRETCHER + if $total >= 80; + } } + + # Dump the output + my $format = join( ' ', map { "%${_}s" } @col_widths ) . "\n"; + substr( $format, 1, 0 ) = '-'; + for ( @rows ) { + printf $format, @$_; + } + + return $results; } + 1; diff --git a/lib/Exporter/Heavy.pm b/lib/Exporter/Heavy.pm index 91ad61322b..95ffc554be 100644 --- a/lib/Exporter/Heavy.pm +++ b/lib/Exporter/Heavy.pm @@ -179,8 +179,7 @@ sub heavy_export_to_level { my $pkg = shift; my $level = shift; - # need to get rid of the first argument, its junk - shift; + (undef) = shift; # XXX redundant arg my $callpkg = caller($level); $pkg->export($callpkg, @_); } diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index 5e12773953..88240764d4 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -377,7 +377,7 @@ sub cflags { if ($Is_PERL_OBJECT) { $self->{CCFLAGS} =~ s/-DPERL_OBJECT(\b|$)/-DPERL_CAPI/g; - if ($Is_Win32 && $Config{'cc'} =~ /^cl.exe/i) { + if ($Is_Win32 && $Config{'cc'} =~ /^cl/i) { # Turn off C++ mode of the MSC compiler $self->{CCFLAGS} =~ s/-TP(\s|$)//; $self->{OPTIMIZE} =~ s/-TP(\s|$)//; diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap index d84435e50f..a34cd4f9ea 100644 --- a/lib/ExtUtils/typemap +++ b/lib/ExtUtils/typemap @@ -251,7 +251,7 @@ T_REFOBJ T_OPAQUE sv_setpvn($arg, (char *)&$var, sizeof($var)); T_OPAQUEPTR - sv_setpvn($arg, (char *)$var, sizeof(*$var)), XFree((char *)$var); + sv_setpvn($arg, (char *)$var, sizeof(*$var)); T_PACKED XS_pack_$ntype($arg, $var); T_PACKEDARRAY diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index e5c7e0989e..6db993c521 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -367,7 +367,17 @@ sub INPUT_handler { $thisdone |= $var_name eq "THIS"; $retvaldone |= $var_name eq "RETVAL"; $var_types{$var_name} = $var_type; - print "\t" . &map_type($var_type); + # XXXX This check is a safeguard against the unfinished conversion of + # generate_init(). When generate_init() is fixed, + # one can use 2-args map_type() unconditionally. + if ($var_type =~ / \( \s* \* \s* \) /x) { + # Function pointers are not yet supported with &output_init! + print "\t" . &map_type($var_type, $var_name); + $name_printed = 1; + } else { + print "\t" . &map_type($var_type); + $name_printed = 0; + } $var_num = $args_match{$var_name}; $proto_arg[$var_num] = ProtoString($var_type) @@ -377,12 +387,16 @@ sub INPUT_handler { $func_args =~ s/\b($var_name)\b/&$1/; } if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/) { + if ($name_printed) { + print ";\n"; + } else { print "\t$var_name;\n"; + } } elsif ($var_init =~ /\S/) { - &output_init($var_type, $var_num, $var_name, $var_init); + &output_init($var_type, $var_num, $var_name, $var_init, $name_printed); } elsif ($var_num) { # generate initialization code - &generate_init($var_type, $var_num, $var_name); + &generate_init($var_type, $var_num, $var_name, $name_printed); } else { print ";\n"; } @@ -1081,7 +1095,7 @@ EOF $_ = '' ; } else { if ($ret_type ne "void") { - print "\t" . &map_type($ret_type) . "\tRETVAL;\n" + print "\t" . &map_type($ret_type, 'RETVAL') . ";\n" if !$retvaldone; $args_match{"RETVAL"} = 0; $var_types{"RETVAL"} = $ret_type; @@ -1305,15 +1319,22 @@ warn("Please specify prototyping behavior for $filename (see perlxs manual)\n") &Exit; sub output_init { - local($type, $num, $var, $init) = @_; + local($type, $num, $var, $init, $name_printed) = @_; local($arg) = "ST(" . ($num - 1) . ")"; if( $init =~ /^=/ ) { - eval qq/print "\\t$var $init\\n"/; + if ($name_printed) { + eval qq/print " $init\\n"/; + } else { + eval qq/print "\\t$var $init\\n"/; + } warn $@ if $@; } else { if( $init =~ s/^\+// && $num ) { - &generate_init($type, $num, $var); + &generate_init($type, $num, $var, $name_printed); + } elsif ($name_printed) { + print ";\n"; + $init =~ s/^;//; } else { eval qq/print "\\t$var;\\n"/; warn $@ if $@; @@ -1382,16 +1403,26 @@ sub generate_init { if (defined($defaults{$var})) { $expr =~ s/(\t+)/$1 /g; $expr =~ s/ /\t/g; - eval qq/print "\\t$var;\\n"/; - warn $@ if $@; + if ($name_printed) { + print ";\n"; + } else { + eval qq/print "\\t$var;\\n"/; + warn $@ if $@; + } $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/; warn $@ if $@; } elsif ($ScopeThisXSUB or $expr !~ /^\t\$var =/) { - eval qq/print "\\t$var;\\n"/; - warn $@ if $@; + if ($name_printed) { + print ";\n"; + } else { + eval qq/print "\\t$var;\\n"/; + warn $@ if $@; + } $deferred .= eval qq/"\\n$expr;\\n"/; warn $@ if $@; } else { + die "panic: do not know how to handle this branch for function pointers" + if $name_printed; eval qq/print "$expr;\\n"/; warn $@ if $@; } @@ -1405,7 +1436,7 @@ sub generate_output { $type = TidyType($type) ; if ($type =~ /^array\(([^,]*),(.*)\)/) { - print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n"; + print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n"; print "\tSvSETMAGIC($arg);\n" if $do_setmagic; } else { blurt("Error: '$type' not in typemap"), return @@ -1468,10 +1499,17 @@ sub generate_output { } sub map_type { - my($type) = @_; + my($type, $varname) = @_; $type =~ tr/:/_/; $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s; + if ($varname) { + if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) { + (substr $type, pos $type, 0) = " $varname "; + } else { + $type .= "\t$varname"; + } + } $type; } diff --git a/lib/File/Find.pm b/lib/File/Find.pm index 284bf678ac..28e2e90e44 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -130,6 +130,8 @@ sub find_opt { warn "Can't cd to $dir: $!\n"; } } + } + continue { chdir $cwd; } } diff --git a/lib/Pod/Checker.pm b/lib/Pod/Checker.pm index 6607ad9375..8f6d1d17f9 100644 --- a/lib/Pod/Checker.pm +++ b/lib/Pod/Checker.pm @@ -1,10 +1,7 @@ ############################################################################# # Pod/Checker.pm -- check pod documents for syntax errors # -# Based on Tom Christiansen's Pod::Text::pod2text() function -# (with modifications). -# -# Copyright (C) 1994-1999 Tom Christiansen. All rights reserved. +# Copyright (C) 1994-1999 by Bradford Appleton. All rights reserved. # This file is part of "PodParser". PodParser is free software; # you can redistribute it and/or modify it under the same terms # as Perl itself. @@ -13,7 +10,7 @@ package Pod::Checker; use vars qw($VERSION); -$VERSION = 1.081; ## Current version of this package +$VERSION = 1.085; ## Current version of this package require 5.004; ## requires this Perl version or later =head1 NAME @@ -140,7 +137,27 @@ sub new { sub initialize { my $self = shift; - $self->num_errors(0); + ## Initialize number of errors, and setup an error function to + ## increment this number and then print to the designated output. + $self->{_NUM_ERRORS} = 0; + $self->errorsub('poderror'); +} + +## Invoked as $self->poderror( @args ), or $self->poderror( {%opts}, @args ) +sub poderror { + my $self = shift; + my %opts = (ref $_[0]) ? %{shift()} : (); + + ## Retrieve options + chomp( my $msg = ($opts{-msg} || "")."@_" ); + my $line = (exists $opts{-line}) ? " at line $opts{-line}" : ""; + my $file = (exists $opts{-file}) ? " in file $opts{-file}" : ""; + my $severity = (exists $opts{-severity}) ? "*** $opts{-severity}: " : ""; + + ## Increment error count and print message + ++($self->{_NUM_ERRORS}); + my $out_fh = $self->output_handle(); + print $out_fh ($severity, $msg, $line, $file, "\n"); } sub num_errors { @@ -164,18 +181,16 @@ sub end_pod { } sub command { - my ($self, $command, $paragraph, $line_num, $pod_para) = @_; + my ($self, $cmd, $paragraph, $line_num, $pod_para) = @_; my ($file, $line) = $pod_para->file_line; - my $out_fh = $self->output_handle(); ## Check the command syntax - if (! $VALID_COMMANDS{$command}) { - ++($self->{_NUM_ERRORS}); - _invalid_cmd($out_fh, $command, $paragraph, $file, $line); + if (! $VALID_COMMANDS{$cmd}) { + $self->poderror({ -line => $line, -file => $file, -severity => 'ERROR', + -msg => "Unknown command \"$cmd\"" }); } else { ## check syntax of particular command } - ## Check the interior sequences in the command-text my $expansion = $self->interpolate($paragraph, $line_num); } @@ -186,39 +201,19 @@ sub verbatim { sub textblock { my ($self, $paragraph, $line_num, $pod_para) = @_; - my $out_fh = $self->output_handle(); - ## Check the interior sequences in the text (set $SIG{__WARN__} to - ## send parse_text warnings about untermnated sequences to $out_fh) - local $SIG{__WARN__} = sub { - ++($self->{_NUM_ERRORS}); - print $out_fh @_ - }; my $expansion = $self->interpolate($paragraph, $line_num); } sub interior_sequence { my ($self, $seq_cmd, $seq_arg, $pod_seq) = @_; my ($file, $line) = $pod_seq->file_line; - my $out_fh = $self->output_handle(); ## Check the sequence syntax if (! $VALID_SEQUENCES{$seq_cmd}) { - ++($self->{_NUM_ERRORS}); - _invalid_seq($out_fh, $seq_cmd, $seq_arg, $file, $line); + $self->poderror({ -line => $line, -file => $file, -severity => 'ERROR', + -msg => "Unknown interior-sequence \"$seq_cmd\"" }); } else { ## check syntax of the particular sequence } } -sub _invalid_cmd { - my ($fh, $cmd, $text, $file, $line) = @_; - print $fh "*** ERROR: Unknown command \"$cmd\"" - . " at line $line of file $file\n"; -} - -sub _invalid_seq { - my ($fh, $cmd, $text, $file, $line) = @_; - print $fh "*** ERROR: Unknown interior-sequence \"$cmd\"" - . " at line $line of file $file\n"; -} - diff --git a/lib/Pod/InputObjects.pm b/lib/Pod/InputObjects.pm index 007fd74ebc..f7231e596c 100644 --- a/lib/Pod/InputObjects.pm +++ b/lib/Pod/InputObjects.pm @@ -2,7 +2,7 @@ # Pod/InputObjects.pm -- package which defines objects for input streams # and paragraphs and commands when parsing POD docs. # -# Copyright (C) 1996-1999 Tom Christiansen. All rights reserved. +# Copyright (C) 1996-1999 by Bradford Appleton. All rights reserved. # This file is part of "PodParser". PodParser is free software; # you can redistribute it and/or modify it under the same terms # as Perl itself. @@ -11,7 +11,7 @@ package Pod::InputObjects; use vars qw($VERSION); -$VERSION = 1.081; ## Current version of this package +$VERSION = 1.085; ## Current version of this package require 5.004; ## requires this Perl version or later ############################################################################# @@ -434,6 +434,9 @@ It has the following methods/attributes: -file => $filename, -line => $line_number); + my $pod_seq4 = new Pod::InteriorSequence(-name => $cmd, $ptree); + my $pod_seq5 = new Pod::InteriorSequence($cmd, $ptree); + This is a class method that constructs a C<Pod::InteriorSequence> object and returns a reference to the new interior sequence object. It should be given two keyword arguments. The C<-ldelim> keyword indicates the @@ -441,7 +444,10 @@ corresponding left-delimiter of the interior sequence (e.g. 'E<lt>'). The C<-name> keyword indicates the name of the corresponding interior sequence command, such as C<I> or C<B> or C<C>. The C<-file> and C<-line> keywords indicate the filename and line number corresponding -to the beginning of the interior sequence. +to the beginning of the interior sequence. If the C<$ptree> argument is +given, it must be the last argument, and it must be either string, or +else an array-ref suitable for passing to B<Pod::ParseTree::new> (or +it may be a reference to an Pod::ParseTree object). =cut @@ -450,6 +456,18 @@ sub new { my $this = shift; my $class = ref($this) || $this; + ## See if first argument has no keyword + if (((@_ <= 2) or (@_ % 2)) and $_[0] !~ /^-\w/) { + ## Yup - need an implicit '-name' before first parameter + unshift @_, '-name'; + } + + ## See if odd number of args + if ((@_ % 2) != 0) { + ## Yup - need an implicit '-ptree' before the last parameter + splice @_, $#_, 0, '-ptree'; + } + ## Any remaining arguments are treated as initial values for the ## hash that is used to represent this object. Note that we default ## certain values by specifying them *before* the arguments passed. @@ -460,10 +478,18 @@ sub new { -line => 0, -ldelim => '<', -rdelim => '>', - -ptree => new Pod::ParseTree(), @_ }; + ## Initialize contents if they havent been already + my $ptree = $self->{'-ptree'} || new Pod::ParseTree(); + if ( ref $ptree =~ /^(ARRAY)?$/ ) { + ## We have an array-ref, or a normal scalar. Pass it as an + ## an argument to the ptree-constructor + $ptree = new Pod::ParseTree($1 ? [$ptree] : $ptree); + } + $self->{'-ptree'} = $ptree; + ## Bless ourselves into the desired class and perform any initialization bless $self, $class; return $self; @@ -496,7 +522,7 @@ sub _set_child2parent_links { my ($self, @children) = @_; ## Make sure any sequences know who their parent is for (@children) { - next unless ref; + next unless (ref || ref eq 'SCALAR'); if ($_->isa('Pod::InteriorSequence') or $_->can('nested')) { $_->nested($self); } @@ -510,8 +536,8 @@ sub _unset_child2parent_links { $self->{'-parent_sequence'} = undef; my $ptree = $self->{'-ptree'}; for (@$ptree) { - next unless (length and ref and $_->isa('Pod::InteriorSequence')); - $_->_unset_child2parent_links(); + next unless (length and ref and ref ne 'SCALAR'); + $_->_unset_child2parent_links() if $_->isa('Pod::InteriorSequence'); } } @@ -718,7 +744,7 @@ itself contain a parse-tree (since interior sequences may be nested). This is a class method that constructs a C<Pod::Parse_tree> object and returns a reference to the new parse-tree. If a single-argument is given, -it mist be a reference to an array, and is used to initialize the root +it must be a reference to an array, and is used to initialize the root (top) of the parse tree. =cut @@ -863,8 +889,8 @@ sub _unset_child2parent_links { my $self = shift; local *ptree = $self; for (@ptree) { - next unless (length and ref and $_->isa('Pod::InteriorSequence')); - $_->_unset_child2parent_links(); + next unless (length and ref and ref ne 'SCALAR'); + $_->_unset_child2parent_links() if $_->isa('Pod::InteriorSequence'); } } diff --git a/lib/Pod/Man.pm b/lib/Pod/Man.pm new file mode 100644 index 0000000000..7a1c69f5a9 --- /dev/null +++ b/lib/Pod/Man.pm @@ -0,0 +1,1185 @@ +# Pod::Man -- Convert POD data to formatted *roff input. +# $Id: Man.pm,v 0.5 1999/09/25 19:49:49 eagle Exp $ +# +# Copyright 1999 by Russ Allbery <rra@stanford.edu> +# +# This program is free software; you can redistribute it and/or modify it +# under the same terms as Perl itself. +# +# This module is intended to be a replacement for pod2man, and attempts to +# match its output except for some specific circumstances where other +# decisions seemed to produce better output. It uses Pod::Parser and is +# designed to be very easy to subclass. + +############################################################################ +# Modules and declarations +############################################################################ + +package Pod::Man; + +require 5.004; + +use Carp qw(carp croak); +use Pod::Parser (); + +use strict; +use subs qw(makespace); +use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION); + +@ISA = qw(Pod::Parser); + +($VERSION = (split (' ', q$Revision: 0.5 $ ))[1]) =~ s/\.(\d)$/.0$1/; + + +############################################################################ +# Preamble and *roff output tables +############################################################################ + +# The following is the static preamble which starts all *roff output we +# generate. It's completely static except for the font to use as a +# fixed-width font, which is designed by @CFONT@. $PREAMBLE should +# therefore be run through s/\@CFONT\@/<font>/g before output. +$PREAMBLE = <<'----END OF PREAMBLE----'; +.de Sh \" Subsection heading +.br +.if t .Sp +.ne 5 +.PP +\fB\\$1\fR +.PP +.. +.de Sp \" Vertical space (when we can't use .PP) +.if t .sp .5v +.if n .sp +.. +.de Ip \" List item +.br +.ie \\n(.$>=3 .ne \\$3 +.el .ne 3 +.IP "\\$1" \\$2 +.. +.de Vb \" Begin verbatim text +.ft @CFONT@ +.nf +.ne \\$1 +.. +.de Ve \" End verbatim text +.ft R + +.fi +.. +.\" Set up some character translations and predefined strings. \*(-- will +.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left +.\" double quote, and \*(R" will give a right double quote. | will give a +.\" real vertical bar. \*(C+ will give a nicer C++. Capital omega is used +.\" to do unbreakable dashes and therefore won't be available. \*(C` and +.\" \*(C' expand to `' in nroff, nothing in troff, for use with C<> +.tr \(*W-|\(bv\*(Tr +.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p' +.ie n \{\ +. ds -- \(*W- +. ds PI pi +. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch +. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch +. ds L" "" +. ds R" "" +. ds C` ` +. ds C' ' +'br\} +.el\{\ +. ds -- \|\(em\| +. ds PI \(*p +. ds L" `` +. ds R" '' +'br\} +.\" +.\" If the F register is turned on, we'll generate index entries on stderr +.\" for titles (.TH), headers (.SH), subsections (.Sh), items (.Ip), and +.\" index entries marked with X<> in POD. Of course, you'll have to process +.\" the output yourself in some meaningful fashion. +.if \nF \{\ +. de IX +. tm Index:\\$1\t\\n%\t"\\$2" +. . +. nr % 0 +. rr F +.\} +.\" +.\" For nroff, turn off justification. Always turn off hyphenation; it +.\" makes way too many mistakes in technical documents. +.hy 0 +.if n .na +.\" +.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2). +.\" Fear. Run. Save yourself. No user-serviceable parts. +.bd B 3 +. \" fudge factors for nroff and troff +.if n \{\ +. ds #H 0 +. ds #V .8m +. ds #F .3m +. ds #[ \f1 +. ds #] \fP +.\} +.if t \{\ +. ds #H ((1u-(\\\\n(.fu%2u))*.13m) +. ds #V .6m +. ds #F 0 +. ds #[ \& +. ds #] \& +.\} +. \" simple accents for nroff and troff +.if n \{\ +. ds ' \& +. ds ` \& +. ds ^ \& +. ds , \& +. ds ~ ~ +. ds / +.\} +.if t \{\ +. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u" +. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u' +. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u' +. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u' +. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u' +. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u' +.\} +. \" troff and (daisy-wheel) nroff accents +.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V' +.ds 8 \h'\*(#H'\(*b\h'-\*(#H' +.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#] +.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H' +.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u' +.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#] +.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#] +.ds ae a\h'-(\w'a'u*4/10)'e +.ds Ae A\h'-(\w'A'u*4/10)'E +. \" corrections for vroff +.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u' +.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u' +. \" for low resolution devices (crt and lpr) +.if \n(.H>23 .if \n(.V>19 \ +\{\ +. ds : e +. ds 8 ss +. ds o a +. ds d- d\h'-1'\(ga +. ds D- D\h'-1'\(hy +. ds th \o'bp' +. ds Th \o'LP' +. ds ae ae +. ds Ae AE +.\} +.rm #[ #] #H #V #F C +----END OF PREAMBLE---- + +# This table is taken nearly verbatim from Tom Christiansen's pod2man. It +# assumes that the standard preamble has already been printed, since that's +# what defines all of the accent marks. Note that some of these are quoted +# with double quotes since they contain embedded single quotes, so use \\ +# uniformly for backslash for readability. +%ESCAPES = ( + 'amp' => '&', # ampersand + 'lt' => '<', # left chevron, less-than + 'gt' => '>', # right chevron, greater-than + 'quot' => '"', # double quote + + 'Aacute' => "A\\*'", # capital A, acute accent + 'aacute' => "a\\*'", # small a, acute accent + 'Acirc' => 'A\\*^', # capital A, circumflex accent + 'acirc' => 'a\\*^', # small a, circumflex accent + 'AElig' => '\*(AE', # capital AE diphthong (ligature) + 'aelig' => '\*(ae', # small ae diphthong (ligature) + 'Agrave' => "A\\*`", # capital A, grave accent + 'agrave' => "A\\*`", # small a, grave accent + 'Aring' => 'A\\*o', # capital A, ring + 'aring' => 'a\\*o', # small a, ring + 'Atilde' => 'A\\*~', # capital A, tilde + 'atilde' => 'a\\*~', # small a, tilde + 'Auml' => 'A\\*:', # capital A, dieresis or umlaut mark + 'auml' => 'a\\*:', # small a, dieresis or umlaut mark + 'Ccedil' => 'C\\*,', # capital C, cedilla + 'ccedil' => 'c\\*,', # small c, cedilla + 'Eacute' => "E\\*'", # capital E, acute accent + 'eacute' => "e\\*'", # small e, acute accent + 'Ecirc' => 'E\\*^', # capital E, circumflex accent + 'ecirc' => 'e\\*^', # small e, circumflex accent + 'Egrave' => 'E\\*`', # capital E, grave accent + 'egrave' => 'e\\*`', # small e, grave accent + 'ETH' => '\\*(D-', # capital Eth, Icelandic + 'eth' => '\\*(d-', # small eth, Icelandic + 'Euml' => 'E\\*:', # capital E, dieresis or umlaut mark + 'euml' => 'e\\*:', # small e, dieresis or umlaut mark + 'Iacute' => "I\\*'", # capital I, acute accent + 'iacute' => "i\\*'", # small i, acute accent + 'Icirc' => 'I\\*^', # capital I, circumflex accent + 'icirc' => 'i\\*^', # small i, circumflex accent + 'Igrave' => 'I\\*`', # capital I, grave accent + 'igrave' => 'i\\*`', # small i, grave accent + 'Iuml' => 'I\\*:', # capital I, dieresis or umlaut mark + 'iuml' => 'i\\*:', # small i, dieresis or umlaut mark + 'Ntilde' => 'N\*~', # capital N, tilde + 'ntilde' => 'n\*~', # small n, tilde + 'Oacute' => "O\\*'", # capital O, acute accent + 'oacute' => "o\\*'", # small o, acute accent + 'Ocirc' => 'O\\*^', # capital O, circumflex accent + 'ocirc' => 'o\\*^', # small o, circumflex accent + 'Ograve' => 'O\\*`', # capital O, grave accent + 'ograve' => 'o\\*`', # small o, grave accent + 'Oslash' => 'O\\*/', # capital O, slash + 'oslash' => 'o\\*/', # small o, slash + 'Otilde' => 'O\\*~', # capital O, tilde + 'otilde' => 'o\\*~', # small o, tilde + 'Ouml' => 'O\\*:', # capital O, dieresis or umlaut mark + 'ouml' => 'o\\*:', # small o, dieresis or umlaut mark + 'szlig' => '\*8', # small sharp s, German (sz ligature) + 'THORN' => '\\*(Th', # capital THORN, Icelandic + 'thorn' => '\\*(th', # small thorn, Icelandic + 'Uacute' => "U\\*'", # capital U, acute accent + 'uacute' => "u\\*'", # small u, acute accent + 'Ucirc' => 'U\\*^', # capital U, circumflex accent + 'ucirc' => 'u\\*^', # small u, circumflex accent + 'Ugrave' => 'U\\*`', # capital U, grave accent + 'ugrave' => 'u\\*`', # small u, grave accent + 'Uuml' => 'U\\*:', # capital U, dieresis or umlaut mark + 'uuml' => 'u\\*:', # small u, dieresis or umlaut mark + 'Yacute' => "Y\\*'", # capital Y, acute accent + 'yacute' => "y\\*'", # small y, acute accent + 'yuml' => 'y\\*:', # small y, dieresis or umlaut mark +); + + +############################################################################ +# Static helper functions +############################################################################ + +# Protect leading quotes and periods against interpretation as commands. +sub protect { local $_ = shift; s/^([.\'])/\\&$1/mg; $_ } + +# Given a command and a single argument that may or may not contain double +# quotes, handle double-quote formatting for it. If there are no double +# quotes, just return the command followed by the argument in double quotes. +# If there are double quotes, use an if statement to test for nroff, and for +# nroff output the command followed by the argument in double quotes with +# embedded double quotes doubled. For other formatters, remap paired double +# quotes to `` and ''. +sub switchquotes { + my $command = shift; + local $_ = shift; + my $extra = shift; + s/\\\*\([LR]\"/\"/g; + if (/\"/) { + s/\"/\"\"/g; + my $troff = $_; + $troff =~ s/\"\"([^\"]*)\"\"/\`\`$1\'\'/g; + s/\"/\"\"/g if $extra; + $troff =~ s/\"/\"\"/g if $extra; + $_ = qq("$_") . ($extra ? " $extra" : ''); + $troff = qq("$troff") . ($extra ? " $extra" : ''); + return ".if n $command $_\n.el $command $troff\n"; + } else { + $_ = qq("$_") . ($extra ? " $extra" : ''); + return "$command $_\n"; + } +} + +# Translate a font string into an escape. +sub toescape { (length ($_[0]) > 1 ? '\f(' : '\f') . $_[0] } + + +############################################################################ +# Initialization +############################################################################ + +# Initialize the object. Here, we also process any additional options +# passed to the constructor or set up defaults if none were given. center +# is the centered title, release is the version number, and date is the date +# for the documentation. Note that we can't know what file name we're +# processing due to the architecture of Pod::Parser, so that *has* to either +# be passed to the constructor or set separately with Pod::Man::name(). +sub initialize { + my $self = shift; + + # Figure out the fixed-width font. If user-supplied, make sure that + # they are the right length. + for (qw/fixed fixedbold fixeditalic fixedbolditalic/) { + if (defined $$self{$_}) { + if (length ($$self{$_}) < 1 || length ($$self{$_}) > 2) { + croak "roff font should be 1 or 2 chars, not `$$self{$_}'"; + } + } else { + $$self{$_} = ''; + } + } + + # Set the default fonts. We can't be sure what fixed bold-italic is + # going to be called, so default to just bold. + $$self{fixed} ||= 'CW'; + $$self{fixedbold} ||= 'CB'; + $$self{fixeditalic} ||= 'CI'; + $$self{fixedbolditalic} ||= 'CB'; + + # Set up a table of font escapes. First number is fixed-width, second + # is bold, third is italic. + $$self{FONTS} = { '000' => '\fR', '001' => '\fI', + '010' => '\fB', '011' => '\f(BI', + '100' => toescape ($$self{fixed}), + '101' => toescape ($$self{fixeditalic}), + '110' => toescape ($$self{fixedbold}), + '111' => toescape ($$self{fixedbolditalic})}; + + # Extra stuff for page titles. + $$self{center} = 'User Contributed Perl Documentation' + unless defined $$self{center}; + $$self{indent} = 4 unless defined $$self{indent}; + + # We used to try first to get the version number from a local binary, + # but we shouldn't need that any more. Get the version from the running + # Perl. + if (!defined $$self{release}) { + my ($version, $patch) = ($] =~ /^(.{5})(\d{2})?/); + $$self{release} = "perl $version"; + $$self{release} .= ", patch $patch" if $patch; + } + + # Double quotes in things that will be quoted. + for (qw/center date release/) { $$self{$_} =~ s/\"/\"\"/g } + + $$self{INDENT} = 0; # Current indentation level. + $$self{INDENTS} = []; # Stack of indentations. + $$self{INDEX} = []; # Index keys waiting to be printed. + + $self->SUPER::initialize; +} + +# For each document we process, output the preamble first. Note that the +# fixed width font is a global default; once we interpolate it into the +# PREAMBLE, it ain't ever changing. Maybe fix this later. +sub begin_pod { + my $self = shift; + + # Try to figure out the name and section from the file name. + my $section = $$self{section} || 1; + my $name = $$self{name}; + if (!defined $name) { + $name = $self->input_file; + $section = 3 if (!$$self{section} && $name =~ /\.pm$/i); + $name =~ s/\.p(od|[lm])$//i; + if ($section =~ /^1/) { + require File::Basename; + $name = uc File::Basename::basename ($name); + } else { + # Lose everything up to the first of + # */lib/*perl* standard or site_perl module + # */*perl*/lib from -D prefix=/opt/perl + # */*perl*/ random module hierarchy + # which works. Should be fixed to use File::Spec. + for ($name) { + s%//+%/%g; + if ( s%^.*?/lib/[^/]*perl[^/]*/%%i + or s%^.*?/[^/]*perl[^/]*/(?:lib/)?%%i) { + s%^site(_perl)?/%%; # site and site_perl + s%^(.*-$^O|$^O-.*)/%%o; # arch + s%^\d+\.\d+%%; # version + } + s%/%::%g; + } + } + } + + # Modification date header. Try to use the modification time of our + # input. + if (!defined $$self{date}) { + my $time = (stat $self->input_file)[9] || time; + my ($day, $month, $year) = (localtime $time)[3,4,5]; + $month++; + $year += 1900; + $$self{date} = join ('-', $year, $month, $day); + } + + # Now, print out the preamble and the title. + $PREAMBLE =~ s/\@CFONT\@/$$self{fixed}/; + chomp $PREAMBLE; + print { $self->output_handle } <<"----END OF HEADER----"; +.\\" Automatically generated by Pod::Man version $VERSION +.\\" @{[ scalar localtime ]} +.\\" +.\\" Standard preamble: +.\\" ====================================================================== +$PREAMBLE +.\\" ====================================================================== +.\\" +.IX Title "$name $section" +.TH $name $section "$$self{release}" "$$self{date}" "$$self{center}" +.UC +----END OF HEADER---- +#"# for cperl-mode + + # Initialize a few per-file variables. + $$self{INDENT} = 0; + $$self{NEEDSPACE} = 0; +} + + +############################################################################ +# Core overrides +############################################################################ + +# Called for each command paragraph. Gets the command, the associated +# paragraph, the line number, and a Pod::Paragraph object. Just dispatches +# the command to a method named the same as the command. =cut is handled +# internally by Pod::Parser. +sub command { + my $self = shift; + my $command = shift; + return if $command eq 'pod'; + return if ($$self{EXCLUDE} && $command ne 'end'); + $command = 'cmd_' . $command; + $self->$command (@_); +} + +# Called for a verbatim paragraph. Gets the paragraph, the line number, and +# a Pod::Paragraph object. Rofficate backslashes, untabify, put a +# zero-width character at the beginning of each line to protect against +# commands, and wrap in .Vb/.Ve. +sub verbatim { + my $self = shift; + return if $$self{EXCLUDE}; + local $_ = shift; + return if /^\s+$/; + s/\s+$/\n/; + my $lines = tr/\n/\n/; + 1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me; + s/\\/\\e/g; + s/^(\s*\S)/'\&' . $1/gme; + $self->makespace if $$self{NEEDSPACE}; + $self->output (".Vb $lines\n$_.Ve\n"); + $$self{NEEDSPACE} = 0; +} + +# Called for a regular text block. Gets the paragraph, the line number, and +# a Pod::Paragraph object. Perform interpolation and output the results. +sub textblock { + my $self = shift; + return if $$self{EXCLUDE}; + $self->output ($_[0]), return if $$self{VERBATIM}; + + # Perform a little magic to collapse multiple L<> references. We'll + # just rewrite the whole thing into actual text at this part, bypassing + # the whole internal sequence parsing thing. + s{ + (L< # A link of the form L</something>. + / + ( + [:\w]+ # The item has to be a simple word... + (\(\))? # ...or simple function. + ) + > + ( + ,?\s+(and\s+)? # Allow lots of them, conjuncted. + L< + / + ( [:\w]+ ( \(\) )? ) + > + )+ + ) + } { + local $_ = $1; + s{ L< / ([^>]+ ) } {$1}g; + my @items = split /(?:,?\s+(?:and\s+)?)/; + my $string = "the "; + my $i; + for ($i = 0; $i < @items; $i++) { + $string .= $items[$i]; + $string .= ", " if @items > 2 && $i != $#items; + $string .= " and " if ($i == $#items - 1); + } + $string .= " entries elsewhere in this document"; + $string; + }gex; + + # Parse the tree and output it. collapse knows about references to + # scalars as well as scalars and does the right thing with them. + local $_ = $self->parse (@_); + s/\n\s*$/\n/; + $self->makespace if $$self{NEEDSPACE}; + $self->output (protect $self->mapfonts ($_)); + $self->outindex; + $$self{NEEDSPACE} = 1; +} + +# Called for an interior sequence. Takes a Pod::InteriorSequence object and +# returns a reference to a scalar. This scalar is the final formatted text. +# It's returned as a reference so that other interior sequences above us +# know that the text has already been processed. +sub sequence { + my ($self, $seq) = @_; + my $command = $seq->cmd_name; + + # Zero-width characters. + if ($command eq 'Z') { return bless \ '\&', 'Pod::Man::String' } + + # C<>, L<>, X<>, and E<> don't apply guesswork to their contents. + local $_ = $self->collapse ($seq->parse_tree, $command =~ /^[CELX]$/); + + # Handle E<> escapes. + if ($command eq 'E') { + if (exists $ESCAPES{$_}) { + return bless \ "$ESCAPES{$_}", 'Pod::Man::String'; + } else { + carp "Unknown escape E<$1>"; + return bless \ "E<$_>", 'Pod::Man::String'; + } + } + + # For all the other sequences, empty content produces no output. + return '' if $_ eq ''; + + # Handle formatting sequences. + if ($command eq 'B') { + return bless \ ('\f(BS' . $_ . '\f(BE'), 'Pod::Man::String'; + } elsif ($command eq 'F') { + return bless \ ('\f(IS' . $_ . '\f(IE'), 'Pod::Man::String'; + } elsif ($command eq 'I') { + return bless \ ('\f(IS' . $_ . '\f(IE'), 'Pod::Man::String'; + } elsif ($command eq 'C') { + s/-/\\-/g; + s/__/_\\|_/g; + return bless \ ('\f(FS\*(C`' . $_ . "\\*(C'\\f(FE"), + 'Pod::Man::String'; + } + + # Handle links. + if ($command eq 'L') { + return bless \ ($self->buildlink ($_)), 'Pod::Man::String'; + } + + # Whitespace protection replaces whitespace with "\ ". + if ($command eq 'S') { + s/\s+/\\ /g; + return bless \ "$_", 'Pod::Man::String'; + } + + # Add an index entry to the list of ones waiting to be output. + if ($command eq 'X') { push (@{ $$self{INDEX} }, $_); return '' } + + # Anything else is unknown. + carp "Unknown sequence $command<$_>"; +} + + +############################################################################ +# Command paragraphs +############################################################################ + +# All command paragraphs take the paragraph and the line number. + +# First level heading. We can't output .IX in the NAME section due to a bug +# in some versions of catman, so don't output a .IX for that section. .SH +# already uses small caps, so remove any E<> sequences that would cause +# them. +sub cmd_head1 { + my $self = shift; + local $_ = $self->parse (@_); + s/\s+$//; + s/\\s-?\d//g; + $self->output (switchquotes ('.SH', $self->mapfonts ($_))); + $self->outindex (($_ eq 'NAME') ? () : ('Header', $_)); + $$self{NEEDSPACE} = 0; +} + +# Second level heading. +sub cmd_head2 { + my $self = shift; + local $_ = $self->parse (@_); + s/\s+$//; + $self->output (switchquotes ('.Sh', $self->mapfonts ($_))); + $self->outindex ('Subsection', $_); + $$self{NEEDSPACE} = 0; +} + +# Start a list. For indents after the first, wrap the outside indent in .RS +# so that hanging paragraph tags will be correct. +sub cmd_over { + my $self = shift; + local $_ = shift; + unless (/^[-+]?\d+\s+$/) { $_ = $$self{indent} } + if (@{ $$self{INDENTS} } > 0) { + $self->output (".RS $$self{INDENT}\n"); + } + push (@{ $$self{INDENTS} }, $$self{INDENT}); + $$self{INDENT} = ($_ + 0); +} + +# End a list. If we've closed an embedded indent, we've mangled the hanging +# paragraph indent, so temporarily replace it with .RS and set WEIRDINDENT. +# We'll close that .RS at the next =back or =item. +sub cmd_back { + my $self = shift; + $$self{INDENT} = pop @{ $$self{INDENTS} }; + unless (defined $$self{INDENT}) { + carp "Unmatched =back"; + $$self{INDENT} = 0; + } + if ($$self{WEIRDINDENT}) { + $self->output (".RE\n"); + $$self{WEIRDINDENT} = 0; + } + if (@{ $$self{INDENTS} } > 0) { + $self->output (".RE\n"); + $self->output (".RS $$self{INDENT}\n"); + $$self{WEIRDINDENT} = 1; + } + $$self{NEEDSPACE} = 1; +} + +# An individual list item. Emit an index entry for anything that's +# interesting, but don't emit index entries for things like bullets and +# numbers. rofficate bullets too while we're at it (so for nice output, use +# * for your lists rather than o or . or - or some other thing). +sub cmd_item { + my $self = shift; + local $_ = $self->parse (@_); + s/\s+$//; + my $index; + if (/\w/ && !/^\w[.\)]\s*$/) { + $index = $_; + $index =~ s/^\s*[-*+o.]?\s*//; + } + s/^\*(\s|\Z)/\\\(bu$1/; + if ($$self{WEIRDINDENT}) { + $self->output (".RE\n"); + $$self{WEIRDINDENT} = 0; + } + $_ = $self->mapfonts ($_); + $self->output (switchquotes ('.Ip', $_, $$self{INDENT})); + $self->outindex ($index ? ('Item', $index) : ()); + $$self{NEEDSPACE} = 0; +} + +# Begin a block for a particular translator. Setting VERBATIM triggers +# special handling in textblock(). +sub cmd_begin { + my $self = shift; + local $_ = shift; + my ($kind) = /^(\S+)/ or return; + if ($kind eq 'man' || $kind eq 'roff') { + $$self{VERBATIM} = 1; + } else { + $$self{EXCLUDE} = 1; + } +} + +# End a block for a particular translator. We assume that all =begin/=end +# pairs are properly closed. +sub cmd_end { + my $self = shift; + $$self{EXCLUDE} = 0; + $$self{VERBATIM} = 0; +} + +# One paragraph for a particular translator. Ignore it unless it's intended +# for man or roff, in which case we output it verbatim. +sub cmd_for { + my $self = shift; + local $_ = shift; + my $line = shift; + return unless s/^(?:man|roff)\b[ \t]*\n?//; + $self->output ($_); +} + + +############################################################################ +# Link handling +############################################################################ + +# Handle links. We can't actually make real hyperlinks, so this is all to +# figure out what text and formatting we print out. +sub buildlink { + my $self = shift; + local $_ = shift; + + # Smash whitespace in case we were split across multiple lines. + s/\s+/ /g; + + # If we were given any explicit text, just output it. + if (m{ ^ ([^|]+) \| }x) { return $1 } + + # Okay, leading and trailing whitespace isn't important. + s/^\s+//; + s/\s+$//; + + # Default to using the whole content of the link entry as a section + # name. Note that L<manpage/> forces a manpage interpretation, as does + # something looking like L<manpage(section)>. Do the same thing to + # L<manpage(section)> as we would to manpage(section) without the L<>; + # see guesswork(). If we've added italics, don't add the "manpage" + # text; markup is sufficient. + my ($manpage, $section) = ('', $_); + if (/^"\s*(.*?)\s*"$/) { + $section = '"' . $1 . '"'; + } elsif (m{ ^ [-:.\w]+ (?: \( \S+ \) )? $ }x) { + ($manpage, $section) = ($_, ''); + $manpage =~ s/^([^\(]+)\(/'\f(IS' . $1 . '\f(IE\|('/e; + } elsif (m%/%) { + ($manpage, $section) = split (/\s*\/\s*/, $_, 2); + if ($manpage =~ /^[-:.\w]+(?:\(\S+\))?$/) { + $manpage =~ s/^([^\(]+)\(/'\f(IS' . $1 . '\f(IE\|'/e; + } + $section =~ s/^\"\s*//; + $section =~ s/\s*\"$//; + } + if ($manpage && $manpage !~ /\\f\(IS/) { + $manpage = "the $manpage manpage"; + } + + # Now build the actual output text. + my $text = ''; + if (!length ($section) && !length ($manpage)) { + carp "Invalid link $_"; + } elsif (!length ($section)) { + $text = $manpage; + } elsif ($section =~ /^[:\w]+(?:\(\))?/) { + $text .= 'the ' . $section . ' entry'; + $text .= (length $manpage) ? " in $manpage" + : " elsewhere in this document"; + } else { + $text .= 'the section on "' . $section . '"'; + $text .= " in $manpage" if length $manpage; + } + $text; +} + + +############################################################################ +# Escaping and fontification +############################################################################ + +# At this point, we'll have embedded font codes of the form \f(<font>[SE] +# where <font> is one of B, I, or F. Turn those into the right font start +# or end codes. B<someI<thing> else> should map to \fBsome\f(BIthing\fB +# else\fR. The old pod2man didn't get this right; the second \fB was \fR, +# so nested sequences didn't work right. We take care of this by using +# variables as a combined pointer to our current font sequence, and set each +# to the number of current nestings of start tags for that font. Use them +# as a vector to look up what font sequence to use. +sub mapfonts { + my $self = shift; + local $_ = shift; + + my ($fixed, $bold, $italic) = (0, 0, 0); + my %magic = (F => \$fixed, B => \$bold, I => \$italic); + s { \\f\((.)(.) } { + ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1; + $$self{FONTS}{($fixed && 1) . ($bold && 1) . ($italic && 1)}; + }gxe; + $_; +} + + +############################################################################ +# *roff-specific parsing +############################################################################ + +# Called instead of parse_text, calls parse_text with the right flags. +sub parse { + my $self = shift; + $self->parse_text ({ -expand_seq => 'sequence', + -expand_ptree => 'collapse' }, @_); +} + +# Takes a parse tree and a flag saying whether or not to treat it as literal +# text (not call guesswork on it), and returns the concatenation of all of +# the text strings in that parse tree. If the literal flag isn't true, +# guesswork() will be called on all plain scalars in the parse tree. +# Assumes that everything in the parse tree is either a scalar or a +# reference to a scalar. +sub collapse { + my ($self, $ptree, $literal) = @_; + if ($literal) { + return join ('', map { + if (ref $_) { + $$_; + } else { + s/\\/\\e/g; + $_; + } + } $ptree->children); + } else { + return join ('', map { + ref ($_) ? $$_ : $self->guesswork ($_) + } $ptree->children); + } +} + +# Takes a text block to perform guesswork on; this is guaranteed not to +# contain any interior sequences. Returns the text block with remapping +# done. +sub guesswork { + my $self = shift; + local $_ = shift; + + # rofficate backslashes. + s/\\/\\e/g; + + # Ensure double underbars have a tiny space between them. + s/__/_\\|_/g; + + # Make all caps a little smaller. Be careful here, since we don't want + # to make @ARGV into small caps, nor do we want to fix the MIME in + # MIME-Version, since it looks weird with the full-height V. + s{ + ( ^ | [\s\(\"\'\`\[\{<>] ) + ( [A-Z] [A-Z] [/A-Z+:\d_\$&-]* ) + (?: (?= [\s>\}\]\)\'\".?!,;:] | -- ) | $ ) + } { $1 . '\s-1' . $2 . '\s0' . $3 }egx; + + # Turn PI into a pretty pi. + s{ (?: \\s-1 | \b ) PI (?: \\s0 | \b ) } {\\*\(PI}gx; + + # Italize functions in the form func(). + s{ + \b + ( + [:\w]+ (?:\\s-1)? \(\) + ) + } { '\f(IS' . $1 . '\f(IE' }egx; + + # func(n) is a reference to a manual page. Make it \fIfunc\fR\|(n). + s{ + \b + (\w[-:.\w]+ (?:\\s-1)?) + ( + \( [^\)] \) + ) + } { '\f(IS' . $1 . '\f(IE\|' . $2 }egx; + + # Convert simple Perl variable references to a fixed-width font. + s{ + ( \s+ ) + ( [\$\@%] [\w:]+ ) + (?! \( ) + } { $1 . '\f(FS' . $2 . '\f(FE'}egx; + + # Translate -- into a real em dash if it's used like one and fix up + # dashes, but keep hyphens hyphens. + s{ (\G|^|.) (-+) (\b|.) } { + my ($pre, $dash, $post) = ($1, $2, $3); + if (length ($dash) == 1) { + ($pre =~ /[a-zA-Z]/) ? "$pre-$post" : "$pre\\-$post"; + } elsif (length ($dash) == 2 + && ((!$pre && !$post) + || ($pre =~ /\w/ && !$post) + || ($pre eq ' ' && $post eq ' ') + || ($pre eq '=' && $post ne '=') + || ($pre ne '=' && $post eq '='))) { + "$pre\\*(--$post"; + } else { + $pre . ('\-' x length $dash) . $post; + } + }egxs; + + # Fix up double quotes. + s{ \" ([^\"]+) \" } { '\*(L"' . $1 . '\*(R"' }egx; + + # Make C++ into \*(C+, which is a squinched version. + s{ \b C\+\+ } {\\*\(C+}gx; + + # All done. + $_; +} + + +############################################################################ +# Output formatting +############################################################################ + +# Make vertical whitespace. +sub makespace { + my $self = shift; + $self->output ($$self{INDENT} > 0 ? ".Sp\n" : ".PP\n"); +} + +# Output any pending index entries, and optionally an index entry given as +# an argument. Support multiple index entries in X<> separated by slashes, +# and strip special escapes from index entries. +sub outindex { + my ($self, $section, $index) = @_; + my @entries = map { split m%\s*/\s*% } @{ $$self{INDEX} }; + return unless ($section || @entries); + $$self{INDEX} = []; + my $output; + if (@entries) { + my $output = '.IX Xref "' + . join (' ', map { s/\"/\"\"/; $_ } @entries) + . '"' . "\n"; + } + if ($section) { + $index =~ s/\"/\"\"/; + $index =~ s/\\-/-/g; + $index =~ s/\\(?:s-?\d|.\(..|.)//g; + $output .= ".IX $section " . '"' . $index . '"' . "\n"; + } + $self->output ($output); +} + +# Output text to the output device. +sub output { print { $_[0]->output_handle } $_[1] } + +__END__ + +.\" These are some extra bits of roff that I don't want to lose track of +.\" but that have been removed from the preamble to make it a bit shorter +.\" since they're not currently being used. They're accents and special +.\" characters we don't currently have escapes for. +.if n \{\ +. ds ? ? +. ds ! ! +. ds q +.\} +.if t \{\ +. ds ? \s-2c\h'-\w'c'u*7/10'\u\h'\*(#H'\zi\d\s+2\h'\w'c'u*8/10' +. ds ! \s-2\(or\s+2\h'-\w'\(or'u'\v'-.8m'.\v'.8m' +. ds q o\h'-\w'o'u*8/10'\s-4\v'.4m'\z\(*i\v'-.4m'\s+4\h'\w'o'u*8/10' +.\} +.ds v \\k:\h'-(\\n(.wu*9/10-\*(#H)'\v'-\*(#V'\*(#[\s-4v\s0\v'\*(#V'\h'|\\n:u'\*(#] +.ds _ \\k:\h'-(\\n(.wu*9/10-\*(#H+(\*(#F*2/3))'\v'-.4m'\z\(hy\v'.4m'\h'|\\n:u' +.ds . \\k:\h'-(\\n(.wu*8/10)'\v'\*(#V*4/10'\z.\v'-\*(#V*4/10'\h'|\\n:u' +.ds 3 \*(#[\v'.2m'\s-2\&3\s0\v'-.2m'\*(#] +.ds oe o\h'-(\w'o'u*4/10)'e +.ds Oe O\h'-(\w'O'u*4/10)'E +.if \n(.H>23 .if \n(.V>19 \ +\{\ +. ds v \h'-1'\o'\(aa\(ga' +. ds _ \h'-1'^ +. ds . \h'-1'. +. ds 3 3 +. ds oe oe +. ds Oe OE +.\} + +############################################################################ +# Documentation +############################################################################ + +=head1 NAME + +Pod::Man - Convert POD data to formatted *roff input + +=head1 SYNOPSIS + + use Pod::Man; + my $parser = Pod::Man->new (release => $VERSION, section => 8); + + # Read POD from STDIN and write to STDOUT. + $parser->parse_from_filehandle; + + # Read POD from file.pod and write to file.1. + $parser->parse_from_file ('file.pod', 'file.1'); + +=head1 DESCRIPTION + +Pod::Man is a module to convert documentation in the POD format (the +preferred language for documenting Perl) into *roff input using the man +macro set. The resulting *roff code is suitable for display on a terminal +using nroff(1), normally via man(1), or printing using troff(1). It is +conventionally invoked using the driver script B<pod2roff>, but it can also +be used directly. + +As a derived class from Pod::Parser, Pod::Man supports the same methods and +interfaces. See L<Pod::Parser> for all the details; briefly, one creates a +new parser with C<Pod::Man-E<gt>new()> and then calls either +parse_from_filehandle() or parse_from_file(). + +new() can take options, in the form of key/value pairs that control the +behavior of the parser. See below for details. + +If no options are given, Pod::Man uses the name of the input file with any +trailing C<.pod>, C<.pm>, or C<.pl> stripped as the man page title, to +section 1 unless the file ended in C<.pm> in which case it defaults to +section 3, to a centered title of "User Contributed Perl Documentation", to +a centered footer of the Perl version it is run with, and to a left-hand +footer of the modification date of its input (or the current date if given +STDIN for input). + +Pod::Man assumes that your *roff formatters have a fixed-width font named +CW. If yours is called something else (like CR), use the C<fixed> option to +specify it. This generally only matters for troff output for printing. +Similarly, you can set the fonts used for bold, italic, and bold italic +fixed-width output. + +Besides the obvious pod conversions, Pod::Man also takes care of formatting +func(), func(n), and simple variable references like $foo or @bar so you +don't have to use code escapes for them; complex expressions like +C<$fred{'stuff'}> will still need to be escaped, though. It also translates +dashes that aren't used as hyphens into en dashes, makes long dashes--like +this--into proper em dashes, fixes "paired quotes," makes C++ and PI look +right, puts a little space between double underbars, makes ALLCAPS a teeny +bit smaller in troff(1), and escapes stuff that *roff treats as special so +that you don't have to. + +The recognized options to new() are as follows. All options take a single +argument. + +=over 4 + +=item center + +Sets the centered page header to use instead of "User Contributed Perl +Documentation". + +=item date + +Sets the left-hand footer. By default, the modification date of the input +file will be used, or the current date if stat() can't find that file (the +case if the input is from STDIN), and the date will be formatted as +YYYY-MM-DD. + +=item fixed + +The fixed-width font to use for vertabim text and code. Defaults to CW. +Some systems may want CR instead. Only matters for troff(1) output. + +=item fixedbold + +Bold version of the fixed-width font. Defaults to CB. Only matters for +troff(1) output. + +=item fixeditalic + +Italic version of the fixed-width font (actually, something of a misnomer, +since most fixed-width fonts only have an oblique version, not an italic +version). Defaults to CI. Only matters for troff(1) output. + +=item fixedbolditalic + +Bold italic (probably actually oblique) version of the fixed-width font. +Pod::Man doesn't assume you have this, and defaults to CB. Some systems +(such as Solaris) have this font available as CX. Only matters for troff(1) +output. + +=item release + +Set the centered footer. By default, this is the version of Perl you run +Pod::Man under. Note that some system an macro sets assume that the +centered footer will be a modification date and will prepend something like +"Last modified: "; if this is the case, you may want to set C<release> to +the last modified date and C<date> to the version number. + +=item section + +Set the section for the C<.TH> macro. The standard section numbering +convention is to use 1 for user commands, 2 for system calls, 3 for +functions, 4 for devices, 5 for file formats, 6 for games, 7 for +miscellaneous information, and 8 for administrator commands. There is a lot +of variation here, however; some systems (like Solaris) use 4 for file +formats, 5 for miscellaneous information, and 7 for devices. Still others +use 1m instead of 8, or some mix of both. About the only section numbers +that are reliably consistent are 1, 2, and 3. + +By default, section 1 will be used unless the file ends in .pm in which case +section 3 will be selected. + +=back + +The standard Pod::Parser method parse_from_filehandle() takes up to two +arguments, the first being the file handle to read POD from and the second +being the file handle to write the formatted output to. The first defaults +to STDIN if not given, and the second defaults to STDOUT. The method +parse_from_file() is almost identical, except that its two arguments are the +input and output disk files instead. See L<Pod::Parser> for the specific +details. + +=head1 DIAGNOSTICS + +=over 4 + +=item roff font should be 1 or 2 chars, not `%s' + +(F) You specified a *roff font (using C<fixed>, C<fixedbold>, etc.) that +wasn't either one or two characters. Pod::Man doesn't support *roff fonts +longer than two characters, although some *roff extensions do (the canonical +versions of nroff(1) and troff(1) don't either). + +=item Invalid link %s + +(W) The POD source contained a C<LE<lt>E<gt>> sequence that Pod::Man was +unable to parse. You should never see this error message; it probably +indicates a bug in Pod::Man. + +=item Unknown escape EE<lt>%sE<gt> + +(W) The POD source contained an C<EE<lt>E<gt>> escape that Pod::Man didn't +know about. C<EE<lt>%sE<gt>> was printed verbatim in the output. + +=item Unknown sequence %s + +(W) The POD source contained a non-standard interior sequence (something of +the form C<XE<lt>E<gt>>) that Pod::Man didn't know about. It was ignored. + +=item Unmatched =back + +(W) Pod::Man encountered a C<=back> command that didn't correspond to an +C<=over> command. + +=back + +=head1 BUGS + +The lint-like features and strict POD format checking done by B<pod2man> are +not yet implemented and should be, along with the corresponding C<lax> +option. + +The NAME section should be recognized specially and index entries emitted +for everything in that section. This would have to be deferred until the +next section, since extraneous things in NAME tends to confuse various man +page processors. + +The handling of hyphens, en dashes, and em dashes is somewhat fragile, and +one may get the wrong one under some circumstances. This should only matter +for troff(1) output. + +When and whether to use small caps is somewhat tricky, and Pod::Man doesn't +necessarily get it right. + +Pod::Man doesn't handle font names longer than two characters. Neither do +most troff(1) implementations, but GNU troff does as an extension. It would +be nice to support as an option for those who want to use it. + +The preamble added to each output file is rather verbose, and most of it is +only necessary in the presence of EE<lt>E<gt> escapes for non-ASCII +characters. It would ideally be nice if all of those definitions were only +output if needed, perhaps on the fly as the characters are used. + +Some of the automagic applied to file names assumes Unix directory +separators. + +Pod::Man is excessively slow. + +=head1 NOTES + +The intention is for this module and its driver script to eventually replace +B<pod2man> in Perl core. + +=head1 SEE ALSO + +L<Pod::Parser|Pod::Parser>, perlpod(1), pod2roff(1), nroff(1), troff(1), +man(1), man(7) + +Ossanna, Joseph F., and Brian W. Kernighan. "Troff User's Manual," +Computing Science Technical Report No. 54, AT&T Bell Laboratories. This is +the best documentation of standard nroff(1) and troff(1). At the time of +this writing, it's available at http://www.cs.bell-labs.com/cm/cs/cstr.html. + +The man page documenting the man macro set may be man(5) instead of man(7) +on your system. Also, please see pod2roff(1) for extensive documentation on +writing manual pages if you've not done it before and aren't familiar with +the conventions. + +=head1 AUTHOR + +Russ Allbery E<lt>rra@stanford.eduE<gt>, based I<very> heavily on the +original B<pod2man> by Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>. + +=cut diff --git a/lib/Pod/Parser.pm b/lib/Pod/Parser.pm index cb1e3a61c1..c96f86b298 100644 --- a/lib/Pod/Parser.pm +++ b/lib/Pod/Parser.pm @@ -1,10 +1,7 @@ ############################################################################# # Pod/Parser.pm -- package which defines a base class for parsing POD docs. # -# Based on Tom Christiansen's Pod::Text module -# (with extensive modifications). -# -# Copyright (C) 1996-1999 Tom Christiansen. All rights reserved. +# Copyright (C) 1996-1999 by Bradford Appleton. All rights reserved. # This file is part of "PodParser". PodParser is free software; # you can redistribute it and/or modify it under the same terms # as Perl itself. @@ -13,7 +10,7 @@ package Pod::Parser; use vars qw($VERSION); -$VERSION = 1.081; ## Current version of this package +$VERSION = 1.085; ## Current version of this package require 5.004; ## requires this Perl version or later ############################################################################# @@ -145,6 +142,50 @@ For the most part, the B<Pod::Parser> base class should be able to do most of the input parsing for you and leave you free to worry about how to intepret the commands and translate the result. +Note that all we have described here in this quick overview overview is +the simplest most striaghtforward use of B<Pod::Parser> to do stream-based +parsing. It is also possible to use the B<Pod::Parser::parse_text> function +to do more sophisticated tree-based parsing. See L<"TREE-BASED PARSING">. + +=head1 PARSING OPTIONS + +A I<parse-option> is simply a named option of B<Pod::Parser> with a +value that corresponds to a certain specified behavior. These various +behaviors of B<Pod::Parser> may be enabled/disabled by setting or +or unsetting one or more I<parse-options> using the B<parseopts()> method. +The set of currently accepted parse-options is as follows: + +=over 3 + +=item B<-want_nonPODs> (default: unset) + +Normally (by default) B<Pod::Parser> will only provide access to +the POD sections of the input. Input paragraphs that are not part +of the POD-format documentation are not made available to the caller +(not even using B<preprocess_paragraph()>). Setting this option to a +non-empty, non-zero value will allow B<preprocess_paragraph()> to see +non-POD sectioins of the input as well as POD sections. The B<cutting()> +method can be used to determine if the corresponding paragraph is a POD +paragraph, or some other input paragraph. + +=item B<-process_cut_cmd> (default: unset) + +Normally (by default) B<Pod::Parser> handles the C<=cut> POD directive +by itself and does not pass it on to the caller for processing. Setting +this option to non-empty, non-zero value will cause B<Pod::Parser> to +pass the C<=cut> directive to the caller just like any other POD command +(and hence it may be processed by the B<command()> method). + +B<Pod::Parser> will still interpret the C<=cut> directive to mean that +"cutting mode" has been (re)entered, but the caller will get a chance +to capture the actual C<=cut> paragraph itself for whatever purpose +it desires. + +=back + +Please see L<"parseopts()"> for a complete description of the interface +for the setting and unsetting of parse-options. + =cut ############################################################################# @@ -159,7 +200,7 @@ use Exporter; @ISA = qw(Exporter); ## These "variables" are used as local "glob aliases" for performance -use vars qw(%myData @input_stack); +use vars qw(%myData %myOpts @input_stack); ############################################################################# @@ -574,8 +615,9 @@ sub preprocess_paragraph { =head1 METHODS FOR PARSING AND PROCESSING B<Pod::Parser> provides several methods to process input text. These -methods typically won't need to be overridden, but subclasses may want -to invoke them to exploit their functionality. +methods typically won't need to be overridden (and in some cases they +can't be overridden), but subclasses may want to invoke them to exploit +their functionality. =cut @@ -629,6 +671,31 @@ is a reference to the interior-sequence object. [I<NOTE>: If the B<interior_sequence()> method is specified, then it is invoked according to the interface specified in L<"interior_sequence()">]. +=item B<-expand_text> =E<gt> I<code-ref>|I<method-name> + +Normally, the parse-tree returned by B<parse_text()> will contain a +text-string for each contiguous sequence of characters outside of an +interior-sequence. Specifying B<-expand_text> tells B<parse_text()> to +"preprocess" every such text-string it sees by invoking the referenced +function (or named method of the parser object) and using the return value +as the preprocessed (or "expanded") result. [Note that if the result is +an interior-sequence, then it will I<not> be expanded as specified by the +B<-expand_seq> option; Any such recursive expansion needs to be handled by +the specified callback routine.] + +If a subroutine reference was given, it is invoked as: + + &$code_ref( $parser, $text, $ptree_node ) + +and if a method-name was given, it is invoked as: + + $parser->method_name( $text, $ptree_node ) + +where C<$parser> is a reference to the parser object, C<$text> is the +text-string encountered, and C<$ptree_node> is a reference to the current +node in the parse-tree (usually an interior-sequence object or else the +top-level node of the parse-tree). + =item B<-expand_ptree> =E<gt> I<code-ref>|I<method-name> Rather than returning a C<Pod::ParseTree>, pass the parse-tree as an @@ -652,10 +719,10 @@ is a reference to the parse-tree object. ## This global regex is used to see if the text before a '>' inside ## an interior sequence looks like '-' or '=', but not '--', '==', -## '$-', or '$=' +## '!=', '$-', '$=' or <<op>>= use vars qw( $ARROW_RE ); -$ARROW_RE = join('', qw{ (?: [^-+*/=!&|%^x.<>$]= | [^$-]- )$ }); -#$ARROW_RE = qr/(?:[^=]+=|[^-]+-)$/; ## 5.005+ only! +$ARROW_RE = join('', qw{ (?: [^-+*/=!&|%^x.<>$]= | [^-$]- )$ }); +#$ARROW_RE = qr/(?:[^-+*/=!&|%^x.<>$]+=|[^-$]+-)$/; ## 5.005+ only! sub parse_text { my $self = shift; @@ -664,6 +731,7 @@ sub parse_text { ## Get options and set any defaults my %opts = (ref $_[0]) ? %{ shift() } : (); my $expand_seq = $opts{'-expand_seq'} || undef; + my $expand_text = $opts{'-expand_text'} || undef; my $expand_ptree = $opts{'-expand_ptree'} || undef; my $text = shift; @@ -673,6 +741,7 @@ sub parse_text { ## Convert method calls into closures, for our convenience my $xseq_sub = $expand_seq; + my $xtext_sub = $expand_text; my $xptree_sub = $expand_ptree; if (defined $expand_seq and $expand_seq eq 'interior_sequence') { ## If 'interior_sequence' is the method to use, we have to pass @@ -685,6 +754,7 @@ sub parse_text { }; } ref $xseq_sub or $xseq_sub = sub { shift()->$expand_seq(@_) }; + ref $xtext_sub or $xtext_sub = sub { shift()->$expand_text(@_) }; ref $xptree_sub or $xptree_sub = sub { shift()->$expand_ptree(@_) }; ## Keep track of the "current" interior sequence, and maintain a stack @@ -729,19 +799,24 @@ sub parse_text { ## Remember the current cmd-name $cmd = (@seq_stack > 1) ? $seq_stack[-1]->name : ''; } - else { - ## In the middle of a sequence, append this text to it - $seq->append($_) if length; + elsif (length) { + ## In the middle of a sequence, append this text to it, and + ## dont forget to "expand" it if that's what the caller wanted + $seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_); } ## Remember the "current" sequence and the previously seen token ($seq, $prev) = ( $seq_stack[-1], $_ ); } ## Handle unterminated sequences + my $errorsub = (@seq_stack > 1) ? $self->errorsub() : undef; while (@seq_stack > 1) { ($cmd, $file, $line) = ($seq->name, $seq->file_line); pop @seq_stack; - warn "** Unterminated $cmd<...> at $file line $line\n"; + my $errmsg = "** Unterminated $cmd<...> at $file line $line\n"; + (ref $errorsub) and &{$errorsub}($errmsg) + or (defined $errmsg) and $self->$errorsub($errmsg) + or warn($errmsg); $seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq) : $seq); $seq = $seq_stack[-1]; } @@ -788,7 +863,8 @@ This method takes the text of a POD paragraph to be processed, along with its corresponding line number, and invokes the appropriate method (one of B<command()>, B<verbatim()>, or B<textblock()>). -This method does I<not> usually need to be overridden by subclasses. +For performance reasons, this method is invoked directly without any +dynamic lookup; Hence subclasses may I<not> override it! =end __PRIVATE__ @@ -796,9 +872,16 @@ This method does I<not> usually need to be overridden by subclasses. sub parse_paragraph { my ($self, $text, $line_num) = @_; - local *myData = $self; ## an alias to avoid deref-ing overhead + local *myData = $self; ## alias to avoid deref-ing overhead + local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options local $_; + ## See if we want to preprocess nonPOD paragraphs as well as POD ones. + my $wantNonPods = $myOpts{'-want_nonPODs'} || 0; + + ## Perform any desired preprocessing if we wanted it this early + $wantNonPods and $text = $self->preprocess_paragraph($text, $line_num); + ## This is the end of a non-empty paragraph ## Ignore up until next POD directive if we are cutting if ($myData{_CUTTING}) { @@ -822,10 +905,13 @@ sub parse_paragraph { $self->is_selected($text) or return ($myData{_CUTTING} = 1); } - ## Perform any desired preprocessing and re-check the "cutting" state - $text = $self->preprocess_paragraph($text, $line_num); - return 1 unless ((defined $text) and (length $text)); - return 1 if ($myData{_CUTTING}); + ## If we havent already, perform any desired preprocessing and + ## then re-check the "cutting" state + unless ($wantNonPods) { + $text = $self->preprocess_paragraph($text, $line_num); + return 1 unless ((defined $text) and (length $text)); + return 1 if ($myData{_CUTTING}); + } ## Look for one of the three types of paragraphs my ($pfx, $cmd, $arg, $sep) = ('', '', '', ''); @@ -842,7 +928,7 @@ sub parse_paragraph { ## except return to "cutting" mode. if ($cmd eq 'cut') { $myData{_CUTTING} = 1; - return; + return unless $myOpts{'-process_cut_cmd'}; } } ## Save the attributes indicating how the command was specified. @@ -1097,6 +1183,35 @@ instance data fields: ##--------------------------------------------------------------------------- +=head1 B<errorsub()> + + $parser->errorsub("method_name"); + $parser->errorsub(\&warn_user); + $parser->errorsub(sub { print STDERR, @_ }); + +Specifies the method or subroutine to use when printing error messages +about POD syntax. The supplied method/subroutine I<must> return TRUE upon +successful printing of the message. If C<undef> is given, then the B<warn> +builtin is used to issue error messages (this is the default behavior). + + my $errorsub = $parser->errorsub() + my $errmsg = "This is an error message!\n" + (ref $errorsub) and &{$errorsub}($errmsg) + or (defined $errmsg) and $parser->$errorsub($errmsg) + or warn($errmsg); + +Returns a method name, or else a reference to the user-supplied subroutine +used to print error messages. Returns C<undef> if the B<warn> builtin +is used to issue error messages (this is the default behavior). + +=cut + +sub errorsub { + return (@_ > 1) ? ($_[0]->{_ERRORSUB} = $_[1]) : $_[0]->{_ERRORSUB}; +} + +##--------------------------------------------------------------------------- + =head1 B<cutting()> $boolean = $parser->cutting(); @@ -1118,6 +1233,58 @@ sub cutting { ##--------------------------------------------------------------------------- +##--------------------------------------------------------------------------- + +=head1 B<parseopts()> + +When invoked with no additional arguments, B<parseopts> returns a hashtable +of all the current parsing options. + + ## See if we are parsing non-POD sections as well as POD ones + my %opts = $parser->parseopts(); + $opts{'-want_nonPODs}' and print "-want_nonPODs\n"; + +When invoked using a single string, B<parseopts> treats the string as the +name of a parse-option and returns its corresponding value if it exists +(returns C<undef> if it doesn't). + + ## Did we ask to see '=cut' paragraphs? + my $want_cut = $parser->parseopts('-process_cut_cmd'); + $want_cut and print "-process_cut_cmd\n"; + +When invoked with multiple arguments, B<parseopts> treats them as +key/value pairs and the specified parse-option names are set to the +given values. Any unspecified parse-options are unaffected. + + ## Set them back to the default + $parser->parseopts(-process_cut_cmd => 0); + +When passed a single hash-ref, B<parseopts> uses that hash to completely +reset the existing parse-options, all previous parse-option values +are lost. + + ## Reset all options to default + $parser->parseopts( { } ); + +See L<"PARSING OPTIONS"> for more for the name and meaning of each +parse-option currently recognized. + +=cut + +sub parseopts { + local *myData = shift; + local *myOpts = ($myData{_PARSEOPTS} ||= {}); + return %myOpts if (@_ == 0); + if (@_ == 1) { + local $_ = shift; + return ref($_) ? $myData{_PARSEOPTS} = $_ : $myOpts{$_}; + } + my @newOpts = (%myOpts, @_); + $myData{_PARSEOPTS} = { @newOpts }; +} + +##--------------------------------------------------------------------------- + =head1 B<output_file()> $fname = $parser->output_file(); @@ -1361,6 +1528,159 @@ sub _pop_input_stream { ############################################################################# +=head1 TREE-BASED PARSING + +If straightforward stream-based parsing wont meet your needs (as is +likely the case for tasks such as translating PODs into structured +markup languages like HTML and XML) then you may need to take the +tree-based approach. Rather than doing everything in one pass and +calling the B<interpolate()> method to expand sequences into text, it +may be desirable to instead create a parse-tree using the B<parse_text()> +method to return a tree-like structure which may contain an ordered list +list of children (each of which may be a text-string, or a similar +tree-like structure). + +Pay special attention to L<"METHODS FOR PARSING AND PROCESSING"> and +to the objects described in L<Pod::InputObjects>. The former describes +the gory details and parameters for how to customize and extend the +parsing behavior of B<Pod::Parser>. B<Pod::InputObjects> provides +several objects that may all be used interchangeably as parse-trees. The +most obvious one is the B<Pod::ParseTree> object. It defines the basic +interface and functionality that all things trying to be a POD parse-tree +should do. A B<Pod::ParseTree> is defined such that each "node" may be a +text-string, or a reference to another parse-tree. Each B<Pod::Paragraph> +object and each B<Pod::InteriorSequence> object also supports the basic +parse-tree interface. + +The B<parse_text()> method takes a given paragraph of text, and +returns a parse-tree that contains one or more children, each of which +may be a text-string, or an InteriorSequence object. There are also +callback-options that may be passed to B<parse_text()> to customize +the way it expands or transforms interior-sequences, as well as the +returned result. These callbacks can be used to create a parse-tree +with custom-made objects (which may or may not support the parse-tree +interface, depending on how you choose to do it). + +If you wish to turn an entire POD document into a parse-tree, that process +is fairly straightforward. The B<parse_text()> method is the key to doing +this successfully. Every paragraph-callback (i.e. the polymorphic methods +for B<command()>, B<verbatim()>, and B<textblock()> paragraphs) takes +a B<Pod::Paragraph> object as an argument. Each paragraph object has a +B<parse_tree()> method that can be used to get or set a corresponding +parse-tree. So for each of those paragraph-callback methods, simply call +B<parse_text()> with the options you desire, and then use the returned +parse-tree to assign to the given paragraph object. + +That gives you a parse-tree for each paragraph - so now all you need is +an ordered list of paragraphs. You can maintain that yourself as a data +element in the object/hash. The most straightforward way would be simply +to use an array-ref, with the desired set of custom "options" for each +invocation of B<parse_text>. Let's assume the desired option-set is +given by the hash C<%options>. Then we might do something like the +following: + + package MyPodParserTree; + + @ISA = qw( Pod::Parser ); + + ... + + sub begin_pod { + my $self = shift; + $self->{'-paragraphs'} = []; ## initialize paragraph list + } + + sub command { + my ($parser, $command, $paragraph, $line_num, $pod_para) = @_; + my $ptree = $parser->parse_text({%options}, $paragraph, ...); + $pod_para->parse_tree( $ptree ); + push @{ $self->{'-paragraphs'} }, $pod_para; + } + + sub verbatim { + my ($parser, $paragraph, $line_num, $pod_para) = @_; + push @{ $self->{'-paragraphs'} }, $pod_para; + } + + sub textblock { + my ($parser, $paragraph, $line_num, $pod_para) = @_; + my $ptree = $parser->parse_text({%options}, $paragraph, ...); + $pod_para->parse_tree( $ptree ); + push @{ $self->{'-paragraphs'} }, $pod_para; + } + + ... + + package main; + ... + my $parser = new MyPodParserTree(...); + $parser->parse_from_file(...); + my $paragraphs_ref = $parser->{'-paragraphs'}; + +Of course, in this module-author's humble opinion, I'd be more inclined to +use the existing B<Pod::ParseTree> object than a simple array. That way +everything in it, paragraphs and sequences, all respond to the same core +interface for all parse-tree nodes. The result would look something like: + + package MyPodParserTree2; + + ... + + sub begin_pod { + my $self = shift; + $self->{'-ptree'} = new Pod::ParseTree; ## initialize parse-tree + } + + sub parse_tree { + ## convenience method to get/set the parse-tree for the entire POD + (@_ > 1) and $_[0]->{'-ptree'} = $_[1]; + return $_[0]->{'-ptree'}; + } + + sub command { + my ($parser, $command, $paragraph, $line_num, $pod_para) = @_; + my $ptree = $parser->parse_text({<<options>>}, $paragraph, ...); + $pod_para->parse_tree( $ptree ); + $parser->parse_tree()->append( $pod_para ); + } + + sub verbatim { + my ($parser, $paragraph, $line_num, $pod_para) = @_; + $parser->parse_tree()->append( $pod_para ); + } + + sub textblock { + my ($parser, $paragraph, $line_num, $pod_para) = @_; + my $ptree = $parser->parse_text({<<options>>}, $paragraph, ...); + $pod_para->parse_tree( $ptree ); + $parser->parse_tree()->append( $pod_para ); + } + + ... + + package main; + ... + my $parser = new MyPodParserTree2(...); + $parser->parse_from_file(...); + my $ptree = $parser->parse_tree; + ... + +Now you have the entire POD document as one great big parse-tree. You +can even use the B<-expand_seq> option to B<parse_text> to insert +whole different kinds of objects. Just don't expect B<Pod::Parser> +to know what to do with them after that. That will need to be in your +code. Or, alternatively, you can insert any object you like so long as +it conforms to the B<Pod::ParseTree> interface. + +One could use this to create subclasses of B<Pod::Paragraphs> and +B<Pod::InteriorSequences> for specific commands (or to create your own +custom node-types in the parse-tree) and add some kind of B<emit()> +method to each custom node/subclass object in the tree. Then all you'd +need to do is recursively walk the tree in the desired order, processing +the children (most likely from left to right) by formatting them if +they are text-strings, or by calling their B<emit()> method if they +are objects/references. + =head1 SEE ALSO L<Pod::InputObjects>, L<Pod::Select> diff --git a/lib/Pod/PlainText.pm b/lib/Pod/PlainText.pm deleted file mode 100644 index 3816badb7f..0000000000 --- a/lib/Pod/PlainText.pm +++ /dev/null @@ -1,650 +0,0 @@ -############################################################################# -# Pod/PlainText.pm -- convert POD data to formatted ASCII text -# -# Derived from Tom Christiansen's Pod::PlainText module -# (with extensive modifications). -# -# Copyright (C) 1994-1999 Tom Christiansen. All rights reserved. -# This file is part of "PodParser". PodParser is free software; -# you can redistribute it and/or modify it under the same terms -# as Perl itself. -############################################################################# - -package Pod::PlainText; - -use vars qw($VERSION); -$VERSION = 1.081; ## Current version of this package -require 5.004; ## requires this Perl version or later - -=head1 NAME - -pod2plaintext - function to convert POD data to formatted ASCII text - -Pod::PlainText - a class for converting POD data to formatted ASCII text - -=head1 SYNOPSIS - - use Pod::PlainText; - pod2plaintext("perlfunc.pod"); - -or - - use Pod::PlainText; - package MyParser; - @ISA = qw(Pod::PlainText); - - sub new { - ## constructor code ... - } - - ## implementation of appropriate subclass methods ... - - package main; - $parser = new MyParser; - @ARGV = ('-') unless (@ARGV > 0); - for (@ARGV) { - $parser->parse_from_file($_); - } - -=head1 REQUIRES - -perl5.004, Pod::Select, Term::Cap, Exporter, Carp - -=head1 EXPORTS - -pod2plaintext() - -=head1 DESCRIPTION - -Pod::PlainText is a module that can convert documentation in the POD -format (such as can be found throughout the Perl distribution) into -formatted ASCII. Termcap is optionally supported for -boldface/underline, and can be enabled via C<$Pod::PlainText::termcap=1>. -If termcap has not been enabled, then backspaces will be used to -simulate bold and underlined text. - -A separate F<pod2plaintext> program is included that is primarily a wrapper -for C<Pod::PlainText::pod2plaintext()>. - -The single function C<pod2plaintext()> can take one or two arguments. The first -should be the name of a file to read the pod from, or "<&STDIN" to read from -STDIN. A second argument, if provided, should be a filehandle glob where -output should be sent. - -=head1 SEE ALSO - -L<Pod::Parser>. - -=head1 AUTHOR - -Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> - -Modified to derive from B<Pod::Parser> by -Brad Appleton E<lt>bradapp@enteract.comE<gt> - -=cut - -############################################################################# - -use strict; -#use diagnostics; -use Carp; -use Exporter; -use Pod::Select; -use Term::Cap; -use vars qw(@ISA @EXPORT %HTML_Escapes); - -@ISA = qw(Exporter Pod::Select); -@EXPORT = qw(&pod2plaintext); - -%HTML_Escapes = ( - 'amp' => '&', # ampersand - 'lt' => '<', # left chevron, less-than - 'gt' => '>', # right chevron, greater-than - 'quot' => '"', # double quote - - "Aacute" => "\xC1", # capital A, acute accent - "aacute" => "\xE1", # small a, acute accent - "Acirc" => "\xC2", # capital A, circumflex accent - "acirc" => "\xE2", # small a, circumflex accent - "AElig" => "\xC6", # capital AE diphthong (ligature) - "aelig" => "\xE6", # small ae diphthong (ligature) - "Agrave" => "\xC0", # capital A, grave accent - "agrave" => "\xE0", # small a, grave accent - "Aring" => "\xC5", # capital A, ring - "aring" => "\xE5", # small a, ring - "Atilde" => "\xC3", # capital A, tilde - "atilde" => "\xE3", # small a, tilde - "Auml" => "\xC4", # capital A, dieresis or umlaut mark - "auml" => "\xE4", # small a, dieresis or umlaut mark - "Ccedil" => "\xC7", # capital C, cedilla - "ccedil" => "\xE7", # small c, cedilla - "Eacute" => "\xC9", # capital E, acute accent - "eacute" => "\xE9", # small e, acute accent - "Ecirc" => "\xCA", # capital E, circumflex accent - "ecirc" => "\xEA", # small e, circumflex accent - "Egrave" => "\xC8", # capital E, grave accent - "egrave" => "\xE8", # small e, grave accent - "ETH" => "\xD0", # capital Eth, Icelandic - "eth" => "\xF0", # small eth, Icelandic - "Euml" => "\xCB", # capital E, dieresis or umlaut mark - "euml" => "\xEB", # small e, dieresis or umlaut mark - "Iacute" => "\xCD", # capital I, acute accent - "iacute" => "\xED", # small i, acute accent - "Icirc" => "\xCE", # capital I, circumflex accent - "icirc" => "\xEE", # small i, circumflex accent - "Igrave" => "\xCD", # capital I, grave accent - "igrave" => "\xED", # small i, grave accent - "Iuml" => "\xCF", # capital I, dieresis or umlaut mark - "iuml" => "\xEF", # small i, dieresis or umlaut mark - "Ntilde" => "\xD1", # capital N, tilde - "ntilde" => "\xF1", # small n, tilde - "Oacute" => "\xD3", # capital O, acute accent - "oacute" => "\xF3", # small o, acute accent - "Ocirc" => "\xD4", # capital O, circumflex accent - "ocirc" => "\xF4", # small o, circumflex accent - "Ograve" => "\xD2", # capital O, grave accent - "ograve" => "\xF2", # small o, grave accent - "Oslash" => "\xD8", # capital O, slash - "oslash" => "\xF8", # small o, slash - "Otilde" => "\xD5", # capital O, tilde - "otilde" => "\xF5", # small o, tilde - "Ouml" => "\xD6", # capital O, dieresis or umlaut mark - "ouml" => "\xF6", # small o, dieresis or umlaut mark - "szlig" => "\xDF", # small sharp s, German (sz ligature) - "THORN" => "\xDE", # capital THORN, Icelandic - "thorn" => "\xFE", # small thorn, Icelandic - "Uacute" => "\xDA", # capital U, acute accent - "uacute" => "\xFA", # small u, acute accent - "Ucirc" => "\xDB", # capital U, circumflex accent - "ucirc" => "\xFB", # small u, circumflex accent - "Ugrave" => "\xD9", # capital U, grave accent - "ugrave" => "\xF9", # small u, grave accent - "Uuml" => "\xDC", # capital U, dieresis or umlaut mark - "uuml" => "\xFC", # small u, dieresis or umlaut mark - "Yacute" => "\xDD", # capital Y, acute accent - "yacute" => "\xFD", # small y, acute accent - "yuml" => "\xFF", # small y, dieresis or umlaut mark - - "lchevron" => "\xAB", # left chevron (double less than) - "rchevron" => "\xBB", # right chevron (double greater than) -); - -##--------------------------------- -## Function definitions begin here -##--------------------------------- - - ## Try to find #columns for the tty -my %NotUnix = map {($_ => 1)} qw(MacOS MSWin32 VMS MVS); -sub get_screen { - ((defined $ENV{TERMCAP}) && ($ENV{TERMCAP} =~ /co#(\d+)/)[0]) - or ((defined $ENV{COLUMNS}) && $ENV{COLUMNS}) - or (!$NotUnix{$^O} && (`stty -a 2>/dev/null` =~ /(\d+) columns/)[0]) - or 72; - -} - -sub pod2plaintext { - my ($infile, $outfile) = @_; - local $_; - my $text_parser = new Pod::PlainText; - $text_parser->parse_from_file($infile, $outfile); -} - -##------------------------------- -## Method definitions begin here -##------------------------------- - -sub new { - my $this = shift; - my $class = ref($this) || $this; - my %params = @_; - my $self = {%params}; - bless $self, $class; - $self->initialize(); - return $self; -} - -sub initialize { - my $self = shift; - $self->SUPER::initialize(); - return; -} - -sub makespace { - my $self = shift; - my $out_fh = $self->output_handle(); - if ($self->{NEEDSPACE}) { - print $out_fh "\n"; - $self->{NEEDSPACE} = 0; - } -} - -sub bold { - my $self = shift; - my $line = shift; - my $map = $self->{FONTMAP}; - return $line if $self->{USE_FORMAT}; - if ($self->{TERMCAP}) { - $line = "$map->{BOLD}$line$map->{NORM}"; - } - else { - $line =~ s/(.)/$1\b$1/g; - } -# $line = "$map->{BOLD}$line$map->{NORM}" if $self->{ANSIFY}; - return $line; -} - -sub italic { - my $self = shift; - my $line = shift; - my $map = $self->{FONTMAP}; - return $line if $self->{USE_FORMAT}; - if ($self->{TERMCAP}) { - $line = "$map->{UNDL}$line$map->{NORM}"; - } - else { - $line =~ s/(.)/$1\b_/g; - } -# $line = "$map->{UNDL}$line$map->{NORM}" if $self->{ANSIFY}; - return $line; -} - -# Fill a paragraph including underlined and overstricken chars. -# It's not perfect for words longer than the margin, and it's probably -# slow, but it works. -sub fill { - my $self = shift; - local $_ = shift; - my $par = ""; - my $indent_space = " " x $self->{INDENT}; - my $marg = $self->{SCREEN} - $self->{INDENT}; - my $line = $indent_space; - my $line_length; - foreach (split) { - my $word_length = length; - $word_length -= 2 while /\010/g; # Subtract backspaces - - if ($line_length + $word_length > $marg) { - $par .= $line . "\n"; - $line= $indent_space . $_; - $line_length = $word_length; - } - else { - if ($line_length) { - $line_length++; - $line .= " "; - } - $line_length += $word_length; - $line .= $_; - } - } - $par .= "$line\n" if length $line; - $par .= "\n"; - return $par; -} - -## Handle a pending "item" paragraph. The paragraph (if given) is the -## corresponding item text. (the item tag should be in $self->{ITEM}). -sub item { - my $self = shift; - my $cmd = shift; - local $_ = shift; - my $line = shift; - $cmd = '' unless (defined $cmd); - $_ = '' unless (defined $_); - my $out_fh = $self->output_handle(); - return unless (defined $self->{ITEM}); - my $paratag = $self->{ITEM}; - my $prev_indent = $self->{INDENTS}->[-1] || $self->{DEF_INDENT}; - ## reset state - undef $self->{ITEM}; - #$self->rm_callbacks('*'); - - my $over = $self->{INDENT}; - $over -= $prev_indent if ($prev_indent < $over); - if (length $cmd) { # tricked - this is another command - $self->output($paratag, INDENT => $prev_indent); - $self->command($cmd, $_); - } - elsif (/^\s+/o) { # verbatim - $self->output($paratag, INDENT => $prev_indent); - s/\s+\Z//; - $self->verbatim($_); - } - else { # plain textblock - $_ = $self->interpolate($_, $line); - s/\s+\Z//; - if ((length $_) && (length($paratag) <= $over)) { - $self->IP_output($paratag, $_); - } - else { - $self->output($paratag, INDENT => $prev_indent); - $self->output($_, REFORMAT => 1); - } - } -} - -sub remap_whitespace { - my $self = shift; - local($_) = shift; - tr/\000-\177/\200-\377/; - return $_; -} - -sub unmap_whitespace { - my $self = shift; - local($_) = shift; - tr/\200-\377/\000-\177/; - return $_; -} - -sub IP_output { - my $self = shift; - my $tag = shift; - local($_) = @_; - my $out_fh = $self->output_handle(); - my $tag_indent = $self->{INDENTS}->[-1] || $self->{DEF_INDENT}; - my $tag_cols = $self->{SCREEN} - $tag_indent; - my $cols = $self->{SCREEN} - $self->{INDENT}; - $tag =~ s/\s*$//; - s/\s+/ /g; - s/^ //; - my $fmt_name = '_Pod_Text_IP_output_format_'; - my $str = "format $fmt_name = \n" - . (" " x ($tag_indent)) - . '@' . ('<' x ($self->{INDENT} - $tag_indent - 1)) - . "^" . ("<" x ($cols - 1)) . "\n" - . '$tag, $_' - . "\n~~" - . (" " x ($self->{INDENT} - 2)) - . "^" . ("<" x ($cols - 5)) . "\n" - . '$_' . "\n\n.\n1"; - #warn $str; warn "tag is $tag, _ is $_"; - { - ## reset format (turn off warning about redefining a format) - local($^W) = 0; - eval $str; - croak if ($@); - } - select((select($out_fh), $~ = $fmt_name)[0]); - local($:) = ($self->curr_headings(1) eq 'SYNOPSIS') ? "\n " : $: ; - write $out_fh; -} - -sub output { - my $self = shift; - local $_ = shift; - $_ = '' unless (defined $_); - return unless (length $_); - my $out_fh = $self->output_handle(); - my %options; - if (@_ > 1) { - ## usage was $self->output($text, NAME=>VALUE, ...); - %options = @_; - } - elsif (@_ == 1) { - if (ref $_[0]) { - ## usage was $self->output($text, { NAME=>VALUE, ... } ); - %options = %{$_[0]}; - } - else { - ## usage was $self->output($text, $number); - $options{"REFORMAT"} = shift; - } - } - $options{"INDENT"} = $self->{INDENT} unless (defined $options{"INDENT"}); - if ((defined $options{"REFORMAT"}) && $options{"REFORMAT"}) { - my $cols = $self->{SCREEN} - $options{"INDENT"}; - s/\s+/ /g; - s/^ //; - my $fmt_name = '_Pod_Text_output_format_'; - my $str = "format $fmt_name = \n~~" - . (" " x ($options{"INDENT"} - 2)) - . "^" . ("<" x ($cols - 5)) . "\n" - . '$_' . "\n\n.\n1"; - { - ## reset format (turn off warning about redefining a format) - local($^W) = 0; - eval $str; - croak if ($@); - } - select((select($out_fh), $~ = $fmt_name)[0]); - local($:) = ($self->curr_headings(1) eq 'SYNOPSIS') ? "\n " : $: ; - write $out_fh; - } - else { - s/^/' ' x $options{"INDENT"}/gem; - s/^\s+\n$/\n/gm; - print $out_fh $_; - } -} - -sub internal_lrefs { - my $self = shift; - local $_ = shift; - s{L</([^>]+)>}{$1}g; - my(@items) = split( /(?:,?\s+(?:and\s+)?)/ ); - my $retstr = "the "; - my $i; - for ($i = 0; $i <= $#items; $i++) { - $retstr .= "C<$items[$i]>"; - $retstr .= ", " if @items > 2 && $i != $#items; - $retstr .= " and " if $i+2 == @items; - } - - $retstr .= " entr" . ( @items > 1 ? "ies" : "y" ) - . " elsewhere in this document "; - - return $retstr; -} - -sub begin_pod { - my $self = shift; - - $self->{BEGUN} = []; - $self->{TERMCAP} = 0; - #$self->{USE_FORMAT} = 1; - - $self->{FONTMAP} = { - UNDL => "\x1b[4m", - INV => "\x1b[7m", - BOLD => "\x1b[1m", - NORM => "\x1b[0m", - }; - if ($self->{TERMCAP} and (! defined $self->{SETUPTERMCAP})) { - $self->{SETUPTERMCAP} = 1; - my ($term) = Tgetent Term::Cap { TERM => undef, OSPEED => 9600 }; - $self->{FONTMAP}->{UNDL} = $term->{'_us'}; - $self->{FONTMAP}->{INV} = $term->{'_mr'}; - $self->{FONTMAP}->{BOLD} = $term->{'_md'}; - $self->{FONTMAP}->{NORM} = $term->{'_me'}; - } - - $self->{SCREEN} = &get_screen; - $self->{FANCY} = 0; - $self->{DEF_INDENT} = 4; - $self->{INDENTS} = []; - $self->{INDENT} = $self->{DEF_INDENT}; - $self->{NEEDSPACE} = 0; -} - -sub end_pod { - my $self = shift; - $self->item('', '', '', 0) if (defined $self->{ITEM}); -} - -sub begun_excluded { - my $self = shift; - my @begun = @{ $self->{BEGUN} }; - return (@begun > 0) ? ($begun[-1] ne 'text') : 0; -} - -sub command { - my $self = shift; - my $cmd = shift; - local $_ = shift; - my $line = shift; - $cmd = '' unless (defined $cmd); - $_ = '' unless (defined $_); - my $out_fh = $self->output_handle(); - - return if (($cmd ne 'end') and $self->begun_excluded()); - return $self->item($cmd, $_, $line) if (defined $self->{ITEM}); - $_ = $self->interpolate($_, $line); - s/\s+\Z/\n/; - - return if ($cmd eq 'pod'); - if ($cmd eq 'head1') { - $self->makespace(); - print $out_fh $_; - # print $out_fh uc($_); - } - elsif ($cmd eq 'head2') { - $self->makespace(); - # s/(\w+)/\u\L$1/g; - #print ' ' x $self->{DEF_INDENT}, $_; - # print "\xA7"; - s/(\w)/\xA7 $1/ if $self->{FANCY}; - print $out_fh ' ' x ($self->{DEF_INDENT}/2), $_, "\n"; - } - elsif ($cmd eq 'over') { - /^[-+]?\d+$/ or $_ = $self->{DEF_INDENT}; - push(@{$self->{INDENTS}}, $self->{INDENT}); - $self->{INDENT} += ($_ + 0); - } - elsif ($cmd eq 'back') { - $self->{INDENT} = pop(@{$self->{INDENTS}}); - unless (defined $self->{INDENT}) { - carp "Unmatched =back\n"; - $self->{INDENT} = $self->{DEF_INDENT}; - } - } - elsif ($cmd eq 'begin') { - my ($kind) = /^(\S*)/; - push( @{ $self->{BEGUN} }, $kind ); - } - elsif ($cmd eq 'end') { - pop( @{ $self->{BEGUN} } ); - } - elsif ($cmd eq 'for') { - $self->textblock($1) if /^text\b\s*(.*)$/s; - } - elsif ($cmd eq 'item') { - $self->makespace(); - # s/\A(\s*)\*/$1\xb7/ if $self->{FANCY}; - # s/^(\s*\*\s+)/$1 /; - $self->{ITEM} = $_; - #$self->add_callbacks('*', SUB => \&item); - } - else { - carp "Unrecognized directive: $cmd\n"; - } -} - -sub verbatim { - my $self = shift; - local $_ = shift; - my $line = shift; - return if $self->begun_excluded(); - return $self->item('', $_, $line) if (defined $self->{ITEM}); - $self->output($_); - #$self->{NEEDSPACE} = 1; -} - -sub textblock { - my $self = shift; - my $text = shift; - my $line = shift; - return if $self->begun_excluded(); - return $self->item('', $text, $line) if (defined $self->{ITEM}); - local($_) = $self->interpolate($text, $line); - s/\s*\Z/\n/; - $self->makespace(); - $self->output($_, REFORMAT => 1); -} - -sub interior_sequence { - my $self = shift; - my $cmd = shift; - my $arg = shift; - local($_) = $arg; - if ($cmd eq 'C') { - my ($pre, $post) = ("`", "'"); - ($pre, $post) = ($HTML_Escapes{"lchevron"}, $HTML_Escapes{"rchevron"}) - if ((defined $self->{FANCY}) && $self->{FANCY}); - $_ = $pre . $_ . $post; - } - elsif ($cmd eq 'E') { - if (defined $HTML_Escapes{$_}) { - $_ = $HTML_Escapes{$_}; - } - else { - carp "Unknown escape: E<$_>"; - $_ = "E<$_>"; - } - # } - # elsif ($cmd eq 'B') { - # $_ = $self->bold($_); - } - elsif ($cmd eq 'I') { - # $_ = $self->italic($_); - $_ = "*" . $_ . "*"; - } - elsif (($cmd eq 'X') || ($cmd eq 'Z')) { - $_ = ''; - } - elsif ($cmd eq 'S') { - # Escape whitespace until we are ready to print - #$_ = $self->remap_whitespace($_); - } - elsif ($cmd eq 'L') { - s/\s+/ /g; - my ($text, $manpage, $sec, $ref) = ('', $_, '', ''); - if (/\A(.*?)\|(.*)\Z/) { - $text = $1; - $manpage = $_ = $2; - } - if (/^\s*"\s*(.*)\s*"\s*$/o) { - ($manpage, $sec) = ('', "\"$1\""); - } - elsif (m|\s*/\s*|s) { - ($manpage, $sec) = split(/\s*\/\s*/, $_, 2); - } - if (! length $sec) { - $ref .= "the $manpage manpage" if (length $manpage); - } - elsif ($sec =~ /^\s*"\s*(.*)\s*"\s*$/o) { - $ref .= "the section on \"$1\""; - $ref .= " in the $manpage manpage" if (length $manpage); - } - else { - $ref .= "the \"$sec\" entry"; - $ref .= (length $manpage) ? " in the $manpage manpage" - : " in this manpage" - } - $_ = $text || $ref; - #if ( m{^ ([a-zA-Z][^\s\/]+) (\([^\)]+\))? $}x ) { - # ## LREF: a manpage(3f) - # $_ = "the $1$2 manpage"; - #} - #elsif ( m{^ ([^/]+) / ([:\w]+(\(\))?) $}x ) { - # ## LREF: an =item on another manpage - # $_ = "the \"$2\" entry in the $1 manpage"; - #} - #elsif ( m{^ / ([:\w]+(\(\))?) $}x ) { - # ## LREF: an =item on this manpage - # $_ = $self->internal_lrefs($1); - #} - #elsif ( m{^ (?: ([a-zA-Z]\S+?) / )? "?(.*?)"? $}x ) { - # ## LREF: a =head2 (head1?), maybe on a manpage, maybe right here - # ## the "func" can disambiguate - # $_ = ((defined $1) && $1) - # ? "the section on \"$2\" in the $1 manpage" - # : "the section on \"$2\""; - #} - } - return $_; -} - -1; diff --git a/lib/Pod/Select.pm b/lib/Pod/Select.pm index 26cbe021ed..b933cc2cdf 100644 --- a/lib/Pod/Select.pm +++ b/lib/Pod/Select.pm @@ -1,10 +1,7 @@ ############################################################################# # Pod/Select.pm -- function to select portions of POD docs # -# Based on Tom Christiansen's pod2text() function -# (with extensive modifications). -# -# Copyright (C) 1996-1999 Tom Christiansen. All rights reserved. +# Copyright (C) 1996-1999 by Bradford Appleton. All rights reserved. # This file is part of "PodParser". PodParser is free software; # you can redistribute it and/or modify it under the same terms # as Perl itself. @@ -13,7 +10,7 @@ package Pod::Select; use vars qw($VERSION); -$VERSION = 1.081; ## Current version of this package +$VERSION = 1.085; ## Current version of this package require 5.004; ## requires this Perl version or later ############################################################################# diff --git a/lib/Pod/Text.pm b/lib/Pod/Text.pm index 88c594fdd4..165dd5db16 100644 --- a/lib/Pod/Text.pm +++ b/lib/Pod/Text.pm @@ -1,16 +1,15 @@ # Pod::Text -- Convert POD data to formatted ASCII text. -# $Id: Text.pm,v 0.2 1999/06/13 02:44:01 eagle Exp $ +# $Id: Text.pm,v 2.1 1999/09/20 11:53:33 eagle Exp $ # # Copyright 1999 by Russ Allbery <rra@stanford.edu> # # This program is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # -# This module may potentially be a replacement for Pod::Text, although it -# does not (at the current time) attempt to match the output of Pod::Text -# and makes several different formatting choices (mostly in the direction of -# less markup). It uses Pod::Parser and is designed to be very easy to -# subclass. +# This module is intended to be a replacement for Pod::Text, and attempts to +# match its output except for some specific circumstances where other +# decisions seemed to produce better output. It uses Pod::Parser and is +# designed to be very easy to subclass. ############################################################################ # Modules and declarations @@ -20,15 +19,17 @@ package Pod::Text; require 5.004; -use Carp qw(carp); -use Pod::Parser (); +use Carp qw(carp croak); +use Pod::Select (); use strict; use vars qw(@ISA %ESCAPES $VERSION); -@ISA = qw(Pod::Parser); +# We inherit from Pod::Select instead of Pod::Parser so that we can be used +# by Pod::Usage. +@ISA = qw(Pod::Select); -$VERSION = '0.01'; +($VERSION = (split (' ', q$Revision: 2.1 $ ))[1]) =~ s/\.(\d)$/.0$1/; ############################################################################ @@ -36,8 +37,8 @@ $VERSION = '0.01'; ############################################################################ # This table is taken near verbatim from Pod::PlainText in Pod::Parser, -# which got it near verbatim from Pod::Text. It is therefore credited to -# Tom Christiansen, and I'm glad I didn't have to write it. :) +# which got it near verbatim from the original Pod::Text. It is therefore +# credited to Tom Christiansen, and I'm glad I didn't have to write it. :) %ESCAPES = ( 'amp' => '&', # ampersand 'lt' => '<', # left chevron, less-than @@ -126,7 +127,6 @@ sub initialize { $$self{sentence} = 0 unless defined $$self{sentence}; $$self{width} = 76 unless defined $$self{width}; - $$self{BEGUN} = []; # Stack of =begin blocks. $$self{INDENTS} = []; # Stack of indentations. $$self{MARGIN} = $$self{indent}; # Current left margin in spaces. @@ -168,14 +168,16 @@ sub verbatim { # Called for a regular text block. Gets the paragraph, the line number, and # a Pod::Paragraph object. Perform interpolation and output the results. sub textblock { - my ($self, $text, $line) = @_; + my $self = shift; return if $$self{EXCLUDE}; - local $_ = $text; + $self->output ($_[0]), return if $$self{VERBATIM}; + local $_ = shift; + my $line = shift; # Perform a little magic to collapse multiple L<> references. This is - # here mostly for backwards-compatibility with Pod::Text. We'll just - # rewrite the whole thing into actual text at this part, bypassing the - # whole internal sequence parsing thing. + # here mostly for backwards-compatibility. We'll just rewrite the whole + # thing into actual text at this part, bypassing the whole internal + # sequence parsing thing. s{ ( L< # A link of the form L</something>. @@ -239,7 +241,7 @@ sub interior_sequence { } # For all the other sequences, empty content produces no output. - return unless $_; + return if $_ eq ''; # For S<>, compress all internal whitespace and then map spaces to \01. # When we output the text, we'll map this back. @@ -279,6 +281,7 @@ sub cmd_head1 { my $self = shift; local $_ = shift; s/\s+$//; + $_ = $self->interpolate ($_, shift); if ($$self{alt}) { $self->output ("\n==== $_ ====\n\n"); } else { @@ -292,6 +295,7 @@ sub cmd_head2 { my $self = shift; local $_ = shift; s/\s+$//; + $_ = $self->interpolate ($_, shift); if ($$self{alt}) { $self->output ("\n== $_ ==\n\n"); } else { @@ -327,38 +331,35 @@ sub cmd_item { $$self{ITEM} = $self->interpolate ($_); } -# Begin a block for a particular translator. To allow for weird nested -# =begin blocks, keep track of how many blocks we were excluded from and -# only unwind one level with each =end. +# Begin a block for a particular translator. Setting VERBATIM triggers +# special handling in textblock(). sub cmd_begin { my $self = shift; local $_ = shift; my ($kind) = /^(\S+)/ or return; - push (@{ $$self{BEGUN} }, $kind); - $$self{EXCLUDE}++ unless $kind eq 'text'; + if ($kind eq 'text') { + $$self{VERBATIM} = 1; + } else { + $$self{EXCLUDE} = 1; + } } # End a block for a particular translator. We assume that all =begin/=end -# pairs are properly nested and just pop the previous one. +# pairs are properly closed. sub cmd_end { my $self = shift; - my $kind = pop @{ $$self{BEGUN} }; - $$self{EXCLUDE}-- if $$self{EXCLUDE}; + $$self{EXCLUDE} = 0; + $$self{VERBATIM} = 0; } # One paragraph for a particular translator. Ignore it unless it's intended -# for text, in which case we treat it as either a normal text block or a -# verbatim text block, depending on whether it's indented. +# for text, in which case we treat it as a verbatim text block. sub cmd_for { my $self = shift; local $_ = shift; my $line = shift; - return unless s/^text\b[ \t]*//; - if (/^\n\s+/) { - $self->verbatim ($_, $line); - } else { - $self->textblock ($_, $line); - } + return unless s/^text\b[ \t]*\n?//; + $self->verbatim ($_, $line); } @@ -368,9 +369,9 @@ sub cmd_for { # The simple formatting ones. These are here mostly so that subclasses can # override them and do more complicated things. -sub seq_b { my $self = shift; return $$self{alt} ? "``$_[0]''" : $_[0] } -sub seq_c { my $self = shift; return $$self{alt} ? "``$_[0]''" : "`$_[0]'" } -sub seq_f { my $self = shift; return $$self{alt} ? "\"$_[0]\"" : $_[0] } +sub seq_b { return $_[0]{alt} ? "``$_[1]''" : $_[1] } +sub seq_c { return $_[0]{alt} ? "``$_[1]''" : "`$_[1]'" } +sub seq_f { return $_[0]{alt} ? "\"$_[1]\"" : $_[1] } sub seq_i { return '*' . $_[1] . '*' } # The complicated one. Handle links. Since this is plain text, we can't @@ -389,7 +390,6 @@ sub seq_l { # Okay, leading and trailing whitespace isn't important; get rid of it. s/^\s+//; s/\s+$//; - chomp; # Default to using the whole content of the link entry as a section # name. Note that L<manpage/> forces a manpage interpretation, as does @@ -447,7 +447,12 @@ sub item { my $space = ' ' x $indent; $space =~ s/^ /:/ if $$self{alt}; if (!$_ || /^\s+$/ || ($$self{MARGIN} - $indent < length ($tag) + 1)) { - $self->output ($space . $tag . "\n"); + my $margin = $$self{MARGIN}; + $$self{MARGIN} = $indent; + my $output = $self->reformat ($tag); + $output =~ s/\n*$/\n/; + $self->output ($output); + $$self{MARGIN} = $margin; $self->output ($self->reformat ($_)) if /\S/; } else { $_ = $self->reformat ($_); @@ -509,6 +514,49 @@ sub output { $_[1] =~ tr/\01/ /; print { $_[0]->output_handle } $_[1] } ############################################################################ +# Backwards compatibility +############################################################################ + +# The old Pod::Text module did everything in a pod2text() function. This +# tries to provide the same interface for legacy applications. +sub pod2text { + my @args; + + # This is really ugly; I hate doing option parsing in the middle of a + # module. But the old Pod::Text module supported passing flags to its + # entry function, so handle -a and -<number>. + while ($_[0] =~ /^-/) { + my $flag = shift; + if ($flag eq '-a') { push (@args, alt => 1) } + elsif ($flag =~ /^-(\d+)$/) { push (@args, width => $1) } + else { + unshift (@_, $flag); + last; + } + } + + # Now that we know what arguments we're using, create the parser. + my $parser = Pod::Text->new (@args); + + # If two arguments were given, the second argument is going to be a file + # handle. That means we want to call parse_from_filehandle(), which + # means we need to turn the first argument into a file handle. Magic + # open will handle the <&STDIN case automagically. + if (defined $_[1]) { + local *IN; + unless (open (IN, $_[0])) { + croak ("Can't open $_[0] for reading: $!\n"); + return; + } + $_[0] = \*IN; + return $parser->parse_from_filehandle (@_); + } else { + return $parser->parse_from_file (@_); + } +} + + +############################################################################ # Module return value and documentation ############################################################################ @@ -532,17 +580,17 @@ Pod::Text - Convert POD data to formatted ASCII text =head1 DESCRIPTION -Pod::Text is a module that can convert documentation in the POD format -(such as can be found throughout the Perl distribution) into formatted -ASCII. It uses no special formatting controls or codes whatsoever, and its -output is therefore suitable for nearly any device. +Pod::Text is a module that can convert documentation in the POD format (the +preferred language for documenting Perl) into formatted ASCII. It uses no +special formatting controls or codes whatsoever, and its output is therefore +suitable for nearly any device. -As a derived class from Pod::Parser, Pod::Text supports the same -methods and interfaces. See L<Pod::Parser> for all the details; briefly, -one creates a new parser with C<Pod::Text-E<gt>new()> and then calls -either C<parse_from_filehandle()> or C<parse_from_file()>. +As a derived class from Pod::Parser, Pod::Text supports the same methods and +interfaces. See L<Pod::Parser> for all the details; briefly, one creates a +new parser with C<Pod::Text-E<gt>new()> and then calls either +parse_from_filehandle() or parse_from_file(). -C<new()> can take options, in the form of key/value pairs, that control the +new() can take options, in the form of key/value pairs, that control the behavior of the parser. The currently recognized options are: =over 4 @@ -569,8 +617,8 @@ output. =item sentence -If set to a true value, Pod::Text will assume that each sentence ends -in two spaces, and will try to preserve that spacing. If set to false, all +If set to a true value, Pod::Text will assume that each sentence ends in two +spaces, and will try to preserve that spacing. If set to false, all consecutive whitespace in non-verbatim paragraphs is compressed into a single space. Defaults to true. @@ -580,49 +628,67 @@ The column at which to wrap text on the right-hand side. Defaults to 76. =back -The standard Pod::Parser method C<parse_from_filehandle()> takes up to two +The standard Pod::Parser method parse_from_filehandle() takes up to two arguments, the first being the file handle to read POD from and the second being the file handle to write the formatted output to. The first defaults to STDIN if not given, and the second defaults to STDOUT. The method -C<parse_from_file()> is almost identical, except that its two arguments are -the input and output disk files instead. See L<Pod::Parser> for the -specific details. +parse_from_file() is almost identical, except that its two arguments are the +input and output disk files instead. See L<Pod::Parser> for the specific +details. =head1 DIAGNOSTICS =over 4 +=item Bizarre space in item + +(W) Something has gone wrong in internal C<=item> processing. This message +indicates a bug in Pod::Text; you should never see it. + +=item Can't open %s for reading: %s + +(F) Pod::Text was invoked via the compatibility mode pod2text() interface +and the input file it was given could not be opened. + =item Unknown escape: %s -The POD source contained an C<EE<lt>E<gt>> escape that Pod::Text -didn't know about. +(W) The POD source contained an C<EE<lt>E<gt>> escape that Pod::Text didn't +know about. =item Unknown sequence: %s -The POD source contained a non-standard internal sequence (something of the -form C<XE<lt>E<gt>>) that Pod::Text didn't know about. +(W) The POD source contained a non-standard internal sequence (something of +the form C<XE<lt>E<gt>>) that Pod::Text didn't know about. =item Unmatched =back -Pod::Text encountered a C<=back> command that didn't correspond to an +(W) Pod::Text encountered a C<=back> command that didn't correspond to an C<=over> command. =back +=head1 RESTRICTIONS + +Embedded Ctrl-As (octal 001) in the input will be mapped to spaces on +output, due to an internal implementation detail. + =head1 NOTES -I'm hoping this module will eventually replace Pod::Text in Perl core once -Pod::Parser has been added to Perl core. Accordingly, don't be surprised if -the name of this module changes to Pod::Text down the road. +This is a replacement for an earlier Pod::Text module written by Tom +Christiansen. It has a revamped interface, since it now uses Pod::Parser, +but an interface roughly compatible with the old Pod::Text::pod2text() +function is still available. Please change to the new calling convention, +though. The original Pod::Text contained code to do formatting via termcap sequences, although it wasn't turned on by default and it was problematic to -get it to work at all. This module doesn't even try to do that, but a -subclass of it does. Look for Pod::Text::Termcap. +get it to work at all. This rewrite doesn't even try to do that, but a +subclass of it does. Look for L<Pod::Text::Termcap|Pod::Text::Termcap>. =head1 SEE ALSO -L<Pod::Parser|Pod::Parser>, L<Pod::Text::Termcap|Pod::Text::Termcap> +L<Pod::Parser|Pod::Parser>, L<Pod::Text::Termcap|Pod::Text::Termcap>, +pod2text(1) =head1 AUTHOR diff --git a/lib/Pod/Text/Color.pm b/lib/Pod/Text/Color.pm index 5eac57ca9f..10e1d9fa30 100644 --- a/lib/Pod/Text/Color.pm +++ b/lib/Pod/Text/Color.pm @@ -1,5 +1,5 @@ # Pod::Text::Color -- Convert POD data to formatted color ASCII text -# $Id: Color.pm,v 0.1 1999/06/13 02:41:06 eagle Exp $ +# $Id: Color.pm,v 0.5 1999/09/20 10:15:16 eagle Exp $ # # Copyright 1999 by Russ Allbery <rra@stanford.edu> # @@ -27,7 +27,7 @@ use vars qw(@ISA $VERSION); @ISA = qw(Pod::Text); # Use the CVS revision of this file as its version number. -($VERSION = (split (' ', q$Revision: 0.1 $ ))[1]) =~ s/\.(\d)$/.0$1/; +($VERSION = (split (' ', q$Revision: 0.5 $ ))[1]) =~ s/\.(\d)$/.0$1/; ############################################################################ @@ -100,10 +100,19 @@ Pod::Text::Color - Convert POD data to formatted color ASCII text =head1 DESCRIPTION -Pod::Text::Color is a simple subclass of Pod::Text that highlights -output text using ANSI color escape sequences. Apart from the color, it in -all ways functions like Pod::Text. See L<Pod::Text> for details -and available options. +Pod::Text::Color is a simple subclass of Pod::Text that highlights output +text using ANSI color escape sequences. Apart from the color, it in all +ways functions like Pod::Text. See L<Pod::Text> for details and available +options. + +Term::ANSIColor is used to get colors and therefore must be installed to use +this module. + +=head1 BUGS + +This is just a basic proof of concept. It should be seriously expanded to +support configurable coloration via options passed to the constructor, and +B<pod2text> should be taught about those. =head1 SEE ALSO diff --git a/lib/Pod/Text/Termcap.pm b/lib/Pod/Text/Termcap.pm index efb71a69ba..7e89ec61be 100644 --- a/lib/Pod/Text/Termcap.pm +++ b/lib/Pod/Text/Termcap.pm @@ -1,14 +1,14 @@ # Pod::Text::Termcap -- Convert POD data to ASCII text with format escapes. -# $Id: Termcap.pm,v 0.1 1999/06/13 02:41:06 eagle Exp $ +# $Id: Termcap.pm,v 0.4 1999/09/20 10:17:45 eagle Exp $ # # Copyright 1999 by Russ Allbery <rra@stanford.edu> # # This program is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # -# This is a simple subclass of Pod::Text that overrides a few key -# methods to output the right termcap escape sequences for formatted text -# on the current terminal type. +# This is a simple subclass of Pod::Text that overrides a few key methods to +# output the right termcap escape sequences for formatted text on the +# current terminal type. ############################################################################ # Modules and declarations @@ -21,13 +21,14 @@ require 5.004; use Pod::Text (); use POSIX (); use Term::Cap; + use strict; use vars qw(@ISA $VERSION); @ISA = qw(Pod::Text); # Use the CVS revision of this file as its version number. -($VERSION = (split (' ', q$Revision: 0.1 $ ))[1]) =~ s/\.(\d)$/.0$1/; +($VERSION = (split (' ', q$Revision: 0.4 $ ))[1]) =~ s/\.(\d)$/.0$1/; ############################################################################ @@ -125,10 +126,10 @@ Pod::Text::Color - Convert POD data to ASCII text with format escapes =head1 DESCRIPTION -Pod::Text::Termcap is a simple subclass of Pod::Text that highlights -output text using the correct termcap escape sequences for the current -terminal. Apart from the format codes, it in all ways functions like -Pod::Text. See L<Pod::Text> for details and available options. +Pod::Text::Termcap is a simple subclass of Pod::Text that highlights output +text using the correct termcap escape sequences for the current terminal. +Apart from the format codes, it in all ways functions like Pod::Text. See +L<Pod::Text> for details and available options. =head1 SEE ALSO diff --git a/lib/Pod/Usage.pm b/lib/Pod/Usage.pm index 9cb71e0afa..18fa22598f 100644 --- a/lib/Pod/Usage.pm +++ b/lib/Pod/Usage.pm @@ -1,10 +1,7 @@ ############################################################################# # Pod/Usage.pm -- print usage messages for the running script. # -# Based on Tom Christiansen's Pod::Text::pod2text() function -# (with modifications). -# -# Copyright (C) 1994-1999 Tom Christiansen. All rights reserved. +# Copyright (C) 1996-1999 by Bradford Appleton. All rights reserved. # This file is part of "PodParser". PodParser is free software; # you can redistribute it and/or modify it under the same terms # as Perl itself. @@ -13,7 +10,7 @@ package Pod::Usage; use vars qw($VERSION); -$VERSION = 1.081; ## Current version of this package +$VERSION = 1.085; ## Current version of this package require 5.004; ## requires this Perl version or later =head1 NAME @@ -363,12 +360,21 @@ use strict; #use diagnostics; use Carp; use Exporter; -use Pod::PlainText; use File::Spec; use vars qw(@ISA @EXPORT); -@ISA = qw(Pod::PlainText); @EXPORT = qw(&pod2usage); +BEGIN { + if ( $] >= 5.005_58 ) { + require Pod::Text; + @ISA = qw( Pod::Text ); + } + else { + require Pod::PlainText; + @ISA = qw( Pod::PlainText ); + } +} + ##--------------------------------------------------------------------------- diff --git a/lib/Shell.pm b/lib/Shell.pm index f4ef431cc5..0177479de5 100644 --- a/lib/Shell.pm +++ b/lib/Shell.pm @@ -1,6 +1,7 @@ package Shell; +use vars qw($capture_stderr $VERSION); -use Config; +$VERSION = '0.2'; sub import { my $self = shift; @@ -20,12 +21,12 @@ sub import { AUTOLOAD { my $cmd = $AUTOLOAD; $cmd =~ s/^.*:://; - eval qq { - *$AUTOLOAD = sub { + eval <<"*END*"; + sub $AUTOLOAD { if (\@_ < 1) { - `$cmd`; + \$Shell::capture_stderr ? `$cmd 2>&1` : `$cmd`; } - elsif (\$Config{'archname'} eq 'os2') { + elsif ('$^O' eq 'os2') { local(\*SAVEOUT, \*READ, \*WRITE); open SAVEOUT, '>&STDOUT' or die; @@ -33,8 +34,8 @@ AUTOLOAD { open STDOUT, '>&WRITE' or die; close WRITE; - my \$pid = system(1, \$cmd, \@_); - die "Can't execute $cmd: \$!\n" if \$pid < 0; + my \$pid = system(1, '$cmd', \@_); + die "Can't execute $cmd: \$!\\n" if \$pid < 0; open STDOUT, '>&SAVEOUT' or die; close SAVEOUT; @@ -54,9 +55,34 @@ AUTOLOAD { } } else { - open(SUBPROC, "-|") - or exec '$cmd', \@_ - or die "Can't exec $cmd: \$!\n"; + my \$a; + my \@arr = \@_; + if ('$^O' eq 'MSWin32') { + # XXX this special-casing should not be needed + # if we do quoting right on Windows. :-( + # + # First, escape all quotes. Cover the case where we + # want to pass along a quote preceded by a backslash + # (i.e., C<"param \\""" end">). + # Ugly, yup? You know, windoze. + # Enclose in quotes only the parameters that need it: + # try this: c:\> dir "/w" + # and this: c:\> dir /w + for (\@arr) { + s/"/\\\\"/g; + s/\\\\\\\\"/\\\\\\\\"""/g; + \$_ = qq["\$_"] if /\s/; + } + } + else { + for (\@arr) { + s/(['\\\\])/\\\\\$1/g; + \$_ = "'\$_'"; + } + } + push \@arr, '2>&1' if \$Shell::capture_stderr; + open(SUBPROC, join(' ', '$cmd', \@arr, '|')) + or die "Can't exec $cmd: \$!\\n"; if (wantarray) { my \@ret = <SUBPROC>; close SUBPROC; # XXX Oughta use a destructor. @@ -70,7 +96,9 @@ AUTOLOAD { } } } - }; +*END* + + die "$@\n" if $@; goto &$AUTOLOAD; } @@ -119,8 +147,17 @@ usage should be Larry +If you set $Shell::capture_stderr to 1, the module will attempt to +capture the STDERR of the process as well. + +The module now should work on Win32. + + Jenda + =head1 AUTHOR Larry Wall +Changes by Jenda@Krynicky.cz and Dave Cottle <d.cottle@csc.canterbury.ac.nz> + =cut diff --git a/lib/Time/Local.pm b/lib/Time/Local.pm index 60f42e8756..75bcc38eea 100644 --- a/lib/Time/Local.pm +++ b/lib/Time/Local.pm @@ -74,8 +74,7 @@ sub cheat { $year = $_[5]; $month = $_[4]; croak "Month '$month' out of range 0..11" if $month > 11 || $month < 0; -# Allow "julian" conversions. --jhi 1999-09-09 -# croak "Day '$_[3]' out of range 1..31" if $_[3] > 31 || $_[3] < 1; + croak "Day '$_[3]' out of range 1..31" if $_[3] > 31 || $_[3] < 1; croak "Hour '$_[2]' out of range 0..23" if $_[2] > 23 || $_[2] < 0; croak "Minute '$_[1]' out of range 0..59" if $_[1] > 59 || $_[1] < 0; croak "Second '$_[0]' out of range 0..59" if $_[0] > 59 || $_[0] < 0; diff --git a/lib/unicode/Eq/Latin1 b/lib/unicode/Eq/Latin1 index b85bb3b61b..89ecd763ad 100644 --- a/lib/unicode/Eq/Latin1 +++ b/lib/unicode/Eq/Latin1 @@ -3,7 +3,7 @@ 0045 00C8 00C9 00CA 00CB 0049 00CC 00CD 00CE 00CF 004E 00D1 -004F 00D2 00D3 00D4 00D5 00D6 +004F 00D2 00D3 00D4 00D5 00D6 00D8 0055 00D9 00DA 00DB 00DC 0059 00DD 0061 00AA 00E0 00E1 00E2 00E3 00E4 00E5 @@ -11,6 +11,6 @@ 0065 00E8 00E9 00EA 00EB 0069 00EC 00ED 00EE 00EF 006E 00F1 -006F 00BA 00F2 00F3 00F4 00F5 00F6 +006F 00BA 00F2 00F3 00F4 00F5 00F6 00F8 0075 00F9 00FA 00FB 00FC 0079 00FD 00FF diff --git a/lib/unicode/Eq/Unicode b/lib/unicode/Eq/Unicode index a7d8feaa5b..29b2a1c044 100644 --- a/lib/unicode/Eq/Unicode +++ b/lib/unicode/Eq/Unicode @@ -1,56 +1,55 @@ -0020 037A FC5E FC5F FC60 FC61 FC62 FC63 FE70 FE72 FE74 FE76 FE78 FE7A FE7C FE7E 0041 00C0 00C1 00C2 00C3 00C4 00C5 0100 0102 0104 01CD 0200 0202 0226 1E00 1EA0 1EA2 FF21 -0042 1E02 1E04 1E06 212C FF22 -0043 00C7 0106 0108 010A 010C 2102 212D FF23 -0044 010E 01C4 01C5 01F1 01F2 1E0A 1E0C 1E0E 1E10 1E12 FF24 +0042 0181 0182 1E02 1E04 1E06 212C FF22 +0043 00C7 0106 0108 010A 010C 0187 2102 212D FF23 +0044 010E 0110 018A 018B 01C4 01C5 01F1 01F2 1E0A 1E0C 1E0E 1E10 1E12 FF24 0045 00C8 00C9 00CA 00CB 0112 0114 0116 0118 011A 0204 0206 0228 1E18 1E1A 1EB8 1EBA 1EBC 2130 FF25 -0046 1E1E 2131 FF26 -0047 011C 011E 0120 0122 01E6 01F4 1E20 FF27 -0048 0124 021E 1E22 1E24 1E26 1E28 1E2A 210B 210C 210D FF28 -0049 00CC 00CD 00CE 00CF 0128 012A 012C 012E 0130 0132 01CF 0208 020A 1E2C 1EC8 1ECA 2110 2111 FF29 +0046 0191 1E1E 2131 FF26 +0047 011C 011E 0120 0122 0193 01E4 01E6 01F4 1E20 FF27 +0048 0124 0126 021E 1E22 1E24 1E26 1E28 1E2A 210B 210C 210D FF28 +0049 00CC 00CD 00CE 00CF 0128 012A 012C 012E 0130 0132 0197 01CF 0208 020A 1E2C 1EC8 1ECA 2110 2111 FF29 004A 0134 FF2A -004B 0136 01E8 1E30 1E32 1E34 212A FF2B -004C 0139 013B 013D 013F 01C7 01C8 1E36 1E3A 1E3C 2112 FF2C +004B 0136 0198 01E8 1E30 1E32 1E34 212A FF2B +004C 0139 013B 013D 013F 0141 01C7 01C8 1E36 1E3A 1E3C 2112 FF2C 004D 1E3E 1E40 1E42 2133 FF2D -004E 00D1 0143 0145 0147 01CA 01CB 01F8 1E44 1E46 1E48 1E4A 2115 FF2E -004F 00D2 00D3 00D4 00D5 00D6 014C 014E 0150 01A0 01D1 01EA 020C 020E 022E 1ECC 1ECE FF2F -0050 1E54 1E56 2119 FF30 +004E 00D1 0143 0145 0147 019D 01CA 01CB 01F8 1E44 1E46 1E48 1E4A 2115 FF2E +004F 00D2 00D3 00D4 00D5 00D6 00D8 014C 014E 0150 019F 01A0 01D1 01EA 020C 020E 022E 1ECC 1ECE FF2F +0050 01A4 1E54 1E56 2119 FF30 0051 211A FF31 0052 0154 0156 0158 0210 0212 1E58 1E5A 1E5E 211B 211C 211D FF32 0053 015A 015C 015E 0160 0218 1E60 1E62 FF33 -0054 0162 0164 021A 1E6A 1E6C 1E6E 1E70 FF34 +0054 0162 0164 0166 01AC 01AE 021A 1E6A 1E6C 1E6E 1E70 FF34 0055 00D9 00DA 00DB 00DC 0168 016A 016C 016E 0170 0172 01AF 01D3 0214 0216 1E72 1E74 1E76 1EE4 1EE6 FF35 -0056 1E7C 1E7E FF36 +0056 01B2 1E7C 1E7E FF36 0057 0174 1E80 1E82 1E84 1E86 1E88 FF37 0058 1E8A 1E8C FF38 -0059 00DD 0176 0178 0232 1E8E 1EF2 1EF4 1EF6 1EF8 FF39 -005A 0179 017B 017D 1E90 1E92 1E94 2124 2128 FF3A +0059 00DD 0176 0178 01B3 0232 1E8E 1EF2 1EF4 1EF6 1EF8 FF39 +005A 0179 017B 017D 01B5 0224 1E90 1E92 1E94 2124 2128 FF3A 0061 00AA 00E0 00E1 00E2 00E3 00E4 00E5 0101 0103 0105 01CE 0201 0203 0227 1E01 1E9A 1EA1 1EA3 FF41 -0062 1E03 1E05 1E07 FF42 -0063 00E7 0107 0109 010B 010D FF43 -0064 010F 01C6 01F3 1E0B 1E0D 1E0F 1E11 1E13 FF44 +0062 0180 0183 0253 1E03 1E05 1E07 FF42 +0063 00E7 0107 0109 010B 010D 0188 0255 FF43 +0064 010F 0111 018C 01C6 01F3 0256 0257 1E0B 1E0D 1E0F 1E11 1E13 FF44 0065 00E8 00E9 00EA 00EB 0113 0115 0117 0119 011B 0205 0207 0229 1E19 1E1B 1EB9 1EBB 1EBD 212F FF45 -0066 1E1F FB00 FB01 FB02 FB03 FB04 FF46 -0067 011D 011F 0121 0123 01E7 01F5 1E21 210A FF47 -0068 0125 021F 02B0 1E23 1E25 1E27 1E29 1E2B 1E96 210E FF48 -0069 00EC 00ED 00EE 00EF 0129 012B 012D 012F 0133 01D0 0209 020B 1E2D 1EC9 1ECB 2139 FF49 -006A 0135 01F0 02B2 FF4A -006B 0137 01E9 1E31 1E33 1E35 FF4B -006C 013A 013C 013E 0140 01C9 02E1 1E37 1E3B 1E3D 2113 FF4C -006D 1E3F 1E41 1E43 FF4D -006E 00F1 0144 0146 0148 01CC 01F9 1E45 1E47 1E49 1E4B 207F FF4E -006F 00BA 00F2 00F3 00F4 00F5 00F6 014D 014F 0151 01A1 01D2 01EB 020D 020F 022F 1ECD 1ECF 2134 FF4F -0070 1E55 1E57 FF50 -0071 FF51 -0072 0155 0157 0159 0211 0213 02B3 1E59 1E5B 1E5F FF52 -0073 015B 015D 015F 0161 017F 0219 02E2 1E61 1E63 FB06 FF53 -0074 0163 0165 021B 1E6B 1E6D 1E6F 1E71 1E97 FF54 +0066 0192 1E1F FB00 FB01 FB02 FB03 FB04 FF46 +0067 011D 011F 0121 0123 01E5 01E7 01F5 0260 1E21 210A FF47 +0068 0125 0127 021F 0266 02B0 1E23 1E25 1E27 1E29 1E2B 1E96 210E FF48 +0069 00EC 00ED 00EE 00EF 0129 012B 012D 012F 0133 01D0 0209 020B 0268 1E2D 1EC9 1ECB 2139 FF49 +006A 0135 01F0 029D 02B2 FF4A +006B 0137 0199 01E9 1E31 1E33 1E35 FF4B +006C 013A 013C 013E 0140 0142 019A 01C9 026B 026C 026D 02E1 1E37 1E3B 1E3D 2113 FF4C +006D 0271 1E3F 1E41 1E43 FF4D +006E 00F1 0144 0146 0148 019E 01CC 01F9 0272 0273 1E45 1E47 1E49 1E4B 207F FF4E +006F 00BA 00F2 00F3 00F4 00F5 00F6 00F8 014D 014F 0151 01A1 01D2 01EB 020D 020F 022F 1ECD 1ECF 2134 FF4F +0070 01A5 1E55 1E57 FF50 +0071 02A0 FF51 +0072 0155 0157 0159 0211 0213 027C 027D 027E 02B3 1E59 1E5B 1E5F FF52 +0073 015B 015D 015F 0161 017F 0219 0282 02E2 1E61 1E63 FB06 FF53 +0074 0163 0165 0167 01AB 01AD 021B 0288 1E6B 1E6D 1E6F 1E71 1E97 FF54 0075 00F9 00FA 00FB 00FC 0169 016B 016D 016F 0171 0173 01B0 01D4 0215 0217 1E73 1E75 1E77 1EE5 1EE7 FF55 -0076 1E7D 1E7F FF56 +0076 028B 1E7D 1E7F FF56 0077 0175 02B7 1E81 1E83 1E85 1E87 1E89 1E98 FF57 0078 02E3 1E8B 1E8D FF58 -0079 00FD 00FF 0177 0233 02B8 1E8F 1E99 1EF3 1EF5 1EF7 1EF9 FF59 -007A 017A 017C 017E 1E91 1E93 1E95 FF5A +0079 00FD 00FF 0177 01B4 0233 02B8 1E8F 1E99 1EF3 1EF5 1EF7 1EF9 FF59 +007A 017A 017C 017E 01B6 0225 0290 0291 1E91 1E93 1E95 FF5A 00C2 1EA4 1EA6 1EA8 1EAA 00C4 01DE 00C5 01FA 212B @@ -105,13 +104,21 @@ 0229 1E1D 022E 0230 022F 0231 +0259 025A +025C 025D +0262 029B 0263 02E0 0266 02B1 -0279 02B4 +026F 0270 +0279 027A 027B 02B4 027B 02B5 0281 02B6 -0292 01EF +0283 0286 +0292 01BA 01EF 0293 +0294 02A1 0295 02E4 +0296 01BE +02A3 02A5 02BC 0149 0386 1FBB 0388 1FC9 @@ -157,32 +164,50 @@ 03D2 03D3 03D4 0406 0407 0410 04D0 04D2 -0413 0403 +0413 0403 0490 0492 0494 0415 0400 0401 04D6 -0416 04C1 04DC -0417 04DE +0416 0496 04C1 04DC +0417 0498 04DE 0418 040D 0419 04E2 04E4 -041A 040C +041A 040C 049A 049C 049E 04C3 +041D 04A2 04C7 041E 04E6 +041F 04A6 +0420 048E +0421 04AA +0422 04AC 0423 040E 04EE 04F0 04F2 -0427 04F4 +0425 04B2 +0427 04B6 04B8 04F4 042B 04F8 042D 04EC 0430 04D1 04D3 -0433 0453 +0433 0453 0491 0493 0495 0435 0450 0451 04D7 -0436 04C2 04DD -0437 04DF +0436 0497 04C2 04DD +0437 0499 04DF 0438 0439 045D 04E3 04E5 -043A 045C +043A 045C 049B 049D 049F 04C4 +043D 04A3 04C8 043E 04E7 +043F 04A7 +0440 048F +0441 04AB +0442 04AD 0443 045E 04EF 04F1 04F3 -0447 04F5 +0445 04B3 +0447 04B7 04B9 04F5 044B 04F9 044D 04ED 0456 0457 +0460 047C +0461 047D 0474 0476 0475 0477 +04AE 04B0 +04AF 04B1 +04BC 04BE +04BD 04BF 04D8 04DA 04D9 04DB 04E8 04EA @@ -221,37 +246,37 @@ 0624 FE85 FE86 0625 FE87 FE88 0626 FBEA FBEB FBEC FBED FBEE FBEF FBF0 FBF1 FBF2 FBF3 FBF4 FBF5 FBF6 FBF7 FBF8 FBF9 FBFA FBFB FC00 FC01 FC02 FC03 FC04 FC64 FC65 FC66 FC67 FC68 FC69 FC97 FC98 FC99 FC9A FC9B FCDF FCE0 FE89 FE8A FE8B FE8C -0627 0622 0623 0625 0675 FD3C FD3D FDF2 FDF3 FE8D FE8E +0627 0622 0623 0625 0672 0673 0675 FD3C FD3D FDF2 FDF3 FE8D FE8E 0628 FC05 FC06 FC07 FC08 FC09 FC0A FC6A FC6B FC6C FC6D FC6E FC6F FC9C FC9D FC9E FC9F FCA0 FCE1 FCE2 FD9E FDC2 FE8F FE90 FE91 FE92 0629 FE93 FE94 -062A FC0B FC0C FC0D FC0E FC0F FC10 FC70 FC71 FC72 FC73 FC74 FC75 FCA1 FCA2 FCA3 FCA4 FCA5 FCE3 FCE4 FD50 FD51 FD52 FD53 FD54 FD55 FD56 FD57 FD9F FDA0 FDA1 FDA2 FDA3 FDA4 FE95 FE96 FE97 FE98 +062A 067C 067D FC0B FC0C FC0D FC0E FC0F FC10 FC70 FC71 FC72 FC73 FC74 FC75 FCA1 FCA2 FCA3 FCA4 FCA5 FCE3 FCE4 FD50 FD51 FD52 FD53 FD54 FD55 FD56 FD57 FD9F FDA0 FDA1 FDA2 FDA3 FDA4 FE95 FE96 FE97 FE98 062B FC11 FC12 FC13 FC14 FC76 FC77 FC78 FC79 FC7A FC7B FCA6 FCE5 FCE6 FE99 FE9A FE9B FE9C 062C FC15 FC16 FCA7 FCA8 FD01 FD02 FD1D FD1E FD58 FD59 FDA5 FDA6 FDA7 FDBE FDFB FE9D FE9E FE9F FEA0 -062D FC17 FC18 FCA9 FCAA FCFF FD00 FD1B FD1C FD5A FD5B FDBF FEA1 FEA2 FEA3 FEA4 +062D 0681 0682 0685 FC17 FC18 FCA9 FCAA FCFF FD00 FD1B FD1C FD5A FD5B FDBF FEA1 FEA2 FEA3 FEA4 062E FC19 FC1A FC1B FCAB FCAC FD03 FD04 FD1F FD20 FEA5 FEA6 FEA7 FEA8 -062F FEA9 FEAA +062F 0689 068A 068B 068F 0690 FEA9 FEAA 0630 FC5B FEAB FEAC -0631 FC5C FDF6 FEAD FEAE +0631 0692 0693 0694 0695 0696 0697 0699 FC5C FDF6 FEAD FEAE 0632 FEAF FEB0 -0633 FC1C FC1D FC1E FC1F FCAD FCAE FCAF FCB0 FCE7 FCE8 FCFB FCFC FD0E FD17 FD18 FD2A FD31 FD34 FD35 FD36 FD5C FD5D FD5E FD5F FD60 FD61 FD62 FD63 FDA8 FDC6 FEB1 FEB2 FEB3 FEB4 -0634 FCE9 FCEA FCFD FCFE FD09 FD0A FD0B FD0C FD0D FD19 FD1A FD25 FD26 FD27 FD28 FD29 FD2D FD2E FD2F FD30 FD32 FD37 FD38 FD39 FD67 FD68 FD69 FD6A FD6B FD6C FD6D FDAA FEB5 FEB6 FEB7 FEB8 -0635 FC20 FC21 FCB1 FCB2 FCB3 FD05 FD06 FD0F FD21 FD22 FD2B FD64 FD65 FD66 FDA9 FDC5 FDF0 FDF5 FDF9 FDFA FEB9 FEBA FEBB FEBC -0636 FC22 FC23 FC24 FC25 FCB4 FCB5 FCB6 FCB7 FD07 FD08 FD10 FD23 FD24 FD2C FD6E FD6F FD70 FDAB FEBD FEBE FEBF FEC0 -0637 FC26 FC27 FCB8 FCF5 FCF6 FD11 FD12 FD33 FD3A FD71 FD72 FD73 FD74 FEC1 FEC2 FEC3 FEC4 +0633 069A 069B 069C FC1C FC1D FC1E FC1F FCAD FCAE FCAF FCB0 FCE7 FCE8 FCFB FCFC FD0E FD17 FD18 FD2A FD31 FD34 FD35 FD36 FD5C FD5D FD5E FD5F FD60 FD61 FD62 FD63 FDA8 FDC6 FEB1 FEB2 FEB3 FEB4 +0634 06FA FCE9 FCEA FCFD FCFE FD09 FD0A FD0B FD0C FD0D FD19 FD1A FD25 FD26 FD27 FD28 FD29 FD2D FD2E FD2F FD30 FD32 FD37 FD38 FD39 FD67 FD68 FD69 FD6A FD6B FD6C FD6D FDAA FEB5 FEB6 FEB7 FEB8 +0635 069D 069E FC20 FC21 FCB1 FCB2 FCB3 FD05 FD06 FD0F FD21 FD22 FD2B FD64 FD65 FD66 FDA9 FDC5 FDF0 FDF5 FDF9 FDFA FEB9 FEBA FEBB FEBC +0636 06FB FC22 FC23 FC24 FC25 FCB4 FCB5 FCB6 FCB7 FD07 FD08 FD10 FD23 FD24 FD2C FD6E FD6F FD70 FDAB FEBD FEBE FEBF FEC0 +0637 069F FC26 FC27 FCB8 FCF5 FCF6 FD11 FD12 FD33 FD3A FD71 FD72 FD73 FD74 FEC1 FEC2 FEC3 FEC4 0638 FC28 FCB9 FD3B FEC5 FEC6 FEC7 FEC8 -0639 FC29 FC2A FCBA FCBB FCF7 FCF8 FD13 FD14 FD75 FD76 FD77 FD78 FDB6 FDC4 FDF7 FEC9 FECA FECB FECC -063A FC2B FC2C FCBC FCBD FCF9 FCFA FD15 FD16 FD79 FD7A FD7B FECD FECE FECF FED0 +0639 06A0 FC29 FC2A FCBA FCBB FCF7 FCF8 FD13 FD14 FD75 FD76 FD77 FD78 FDB6 FDC4 FDF7 FEC9 FECA FECB FECC +063A 06FC FC2B FC2C FCBC FCBD FCF9 FCFA FD15 FD16 FD79 FD7A FD7B FECD FECE FECF FED0 0640 FCF2 FCF3 FCF4 FE71 FE77 FE79 FE7B FE7D FE7F -0641 FC2D FC2E FC2F FC30 FC31 FC32 FC7C FC7D FCBE FCBF FCC0 FCC1 FD7C FD7D FDC1 FED1 FED2 FED3 FED4 -0642 FC33 FC34 FC35 FC36 FC7E FC7F FCC2 FCC3 FD7E FD7F FDB2 FDB4 FDF1 FED5 FED6 FED7 FED8 -0643 FC37 FC38 FC39 FC3A FC3B FC3C FC3D FC3E FC80 FC81 FC82 FC83 FC84 FCC4 FCC5 FCC6 FCC7 FCC8 FCEB FCEC FDB7 FDBB FDC3 FED9 FEDA FEDB FEDC -0644 FC3F FC40 FC41 FC42 FC43 FC44 FC85 FC86 FC87 FCC9 FCCA FCCB FCCC FCCD FCED FD80 FD81 FD82 FD83 FD84 FD85 FD86 FD87 FD88 FDAC FDAD FDB5 FDBA FDBC FEDD FEDE FEDF FEE0 FEF5 FEF6 FEF7 FEF8 FEF9 FEFA FEFB FEFC +0641 06A2 06A3 06A5 FC2D FC2E FC2F FC30 FC31 FC32 FC7C FC7D FCBE FCBF FCC0 FCC1 FD7C FD7D FDC1 FED1 FED2 FED3 FED4 +0642 06A7 06A8 FC33 FC34 FC35 FC36 FC7E FC7F FCC2 FCC3 FD7E FD7F FDB2 FDB4 FDF1 FED5 FED6 FED7 FED8 +0643 06AB 06AC 06AE FC37 FC38 FC39 FC3A FC3B FC3C FC3D FC3E FC80 FC81 FC82 FC83 FC84 FCC4 FCC5 FCC6 FCC7 FCC8 FCEB FCEC FDB7 FDBB FDC3 FED9 FEDA FEDB FEDC +0644 06B5 06B6 06B7 06B8 FC3F FC40 FC41 FC42 FC43 FC44 FC85 FC86 FC87 FCC9 FCCA FCCB FCCC FCCD FCED FD80 FD81 FD82 FD83 FD84 FD85 FD86 FD87 FD88 FDAC FDAD FDB5 FDBA FDBC FEDD FEDE FEDF FEE0 FEF5 FEF6 FEF7 FEF8 FEF9 FEFA FEFB FEFC 0645 FC45 FC46 FC47 FC48 FC49 FC4A FC88 FC89 FCCE FCCF FCD0 FCD1 FD89 FD8A FD8B FD8C FD8D FD8E FD8F FD92 FDB1 FDB9 FDC0 FDF4 FEE1 FEE2 FEE3 FEE4 -0646 FC4B FC4C FC4D FC4E FC4F FC50 FC8A FC8B FC8C FC8D FC8E FC8F FCD2 FCD3 FCD4 FCD5 FCD6 FCEE FCEF FD95 FD96 FD97 FD98 FD99 FD9A FD9B FDB3 FDB8 FDBD FDC7 FEE5 FEE6 FEE7 FEE8 +0646 06B9 06BC 06BD FC4B FC4C FC4D FC4E FC4F FC50 FC8A FC8B FC8C FC8D FC8E FC8F FCD2 FCD3 FCD4 FCD5 FCD6 FCEE FCEF FD95 FD96 FD97 FD98 FD99 FD9A FD9B FDB3 FDB8 FDBD FDC7 FEE5 FEE6 FEE7 FEE8 0647 FC51 FC52 FC53 FC54 FCD7 FCD8 FCD9 FD93 FD94 FEE9 FEEA FEEB FEEC -0648 0624 0676 FDF8 FEED FEEE +0648 0624 0676 06C4 06CA 06CF FDF8 FEED FEEE 0649 FBE8 FBE9 FC5D FC90 FEEF FEF0 -064A 0626 0678 FC55 FC56 FC57 FC58 FC59 FC5A FC91 FC92 FC93 FC94 FC95 FC96 FCDA FCDB FCDC FCDD FCDE FCF0 FCF1 FD9C FD9D FDAE FDAF FDB0 FEF1 FEF2 FEF3 FEF4 +064A 0626 0678 06CD 06CE 06D1 FC55 FC56 FC57 FC58 FC59 FC5A FC91 FC92 FC93 FC94 FC95 FC96 FCDA FCDB FCDC FCDD FCDE FCF0 FCF1 FD9C FD9D FDAE FDAF FDB0 FEF1 FEF2 FEF3 FEF4 0671 FB50 FB51 0677 FBDD 0679 FB66 FB67 FB68 FB69 @@ -262,7 +287,7 @@ 0680 FB5A FB5B FB5C FB5D 0683 FB76 FB77 FB78 FB79 0684 FB72 FB73 FB74 FB75 -0686 FB7A FB7B FB7C FB7D +0686 06BF FB7A FB7B FB7C FB7D 0687 FB7E FB7F FB80 FB81 0688 FB88 FB89 068C FB84 FB85 @@ -274,7 +299,7 @@ 06A6 FB6E FB6F FB70 FB71 06A9 FB8E FB8F FB90 FB91 06AD FBD3 FBD4 FBD5 FBD6 -06AF FB92 FB93 FB94 FB95 +06AF 06B0 06B2 06B4 FB92 FB93 FB94 FB95 06B1 FB9A FB9B FB9C FB9D 06B3 FB96 FB97 FB98 FB99 06BA FB9E FB9F @@ -307,6 +332,7 @@ 09A1 09DC 09A2 09DD 09AF 09DF +09B0 09F0 09F1 0A16 0A59 0A17 0A5A 0A1C 0A5B @@ -316,9 +342,7 @@ 0B21 0B5C 0B22 0B5D 0B92 0B94 -0E4D 0E33 0EAB 0EDC 0EDD -0ECD 0EB3 0F40 0F69 0F42 0F43 0F4C 0F4D @@ -522,8 +546,6 @@ 3075 3076 3077 3078 3079 307A 307B 307C 307D -3099 FF9E -309A FF9F 309D 309E 30A1 FF67 30A2 FF71 diff --git a/lib/unicode/Unicode.html b/lib/unicode/Unicode.html new file mode 100644 index 0000000000..113d311f01 --- /dev/null +++ b/lib/unicode/Unicode.html @@ -0,0 +1,345 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" + + "http://www.w3.org/TR/REC-html40/loose.dtd"> + +<html> + + + +<head> + +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> + +<meta http-equiv="Content-Language" content="en-us"> + +<meta name="GENERATOR" content="Microsoft FrontPage 4.0"> + +<meta name="ProgId" content="FrontPage.Editor.Document"> + +<link rel="stylesheet" href="http://www.unicode.org/unicode.css" type="text/css"> + +<title>Unicode Character Database</title> + +</head> + + + +<body> + + + +<h1>UNICODE CHARACTER DATABASE<br> +Version 3.0.0</h1> + +<table border="1" cellspacing="2" cellpadding="0" height="87" width="100%"> + + <tr> + + <td valign="TOP" width="144">Revision</td> + + <td valign="TOP">3.0.0</td> + + </tr> + + <tr> + + <td valign="TOP" width="144">Authors</td> + + <td valign="TOP">Mark Davis and Ken Whistler</td> + + </tr> + + <tr> + + <td valign="TOP" width="144">Date</td> + + <td valign="TOP">1999-09-11</td> + + </tr> + + <tr> + + <td valign="TOP" width="144">This Version</td> + + <td valign="TOP"><a href="ftp://ftp.unicode.org/Public/3.0-Update/UnicodeCharacterDatabase-3.0.0.html">ftp://ftp.unicode.org/Public/3.0-Update/UnicodeCharacterDatabase-3.0.0.html</a></td> + + </tr> + + <tr> + + <td valign="TOP" width="144">Previous Version</td> + + <td valign="TOP">n/a</td> + + </tr> + + <tr> + + <td valign="TOP" width="144">Latest Version</td> + + <td valign="TOP"><a href="ftp://ftp.unicode.org/Public/3.0-Update/UnicodeCharacterDatabase-3.0.0.html">ftp://ftp.unicode.org/Public/3.0-Update/UnicodeCharacterDatabase-3.0.0.html</a></td> + + </tr> + +</table> + +<p align="center">Copyright © 1995-1999 Unicode, Inc. All Rights reserved.</p> + +<h2>Disclaimer</h2> + +<p>The Unicode Character Database is provided as is by Unicode, Inc. No claims + +are made as to fitness for any particular purpose. No warranties of any kind are + +expressed or implied. The recipient agrees to determine applicability of + +information provided. If this file has been purchased on magnetic or optical + +media from Unicode, Inc., the sole remedy for any claim will be exchange of + +defective media within 90 days of receipt.</p> + +<p>This disclaimer is applicable for all other data files accompanying the + +Unicode Character Database, some of which have been compiled by the Unicode + +Consortium, and some of which have been supplied by other sources.</p> + +<h2>Limitations on Rights to Redistribute This Data</h2> + +<p>Recipient is granted the right to make copies in any form for internal + +distribution and to freely use the information supplied in the creation of + +products supporting the Unicode<sup>TM</sup> Standard. The files in the Unicode + +Character Database can be redistributed to third parties or other organizations + +(whether for profit or not) as long as this notice and the disclaimer notice are + +retained. Information can be extracted from these files and used in + +documentation or programs, as long as there is an accompanying notice indicating + +the source.</p> + +<h2>Introduction</h2> + +<p>The Unicode Character Database is a set of files that define the Unicode + +character properties and internal mappings. For more information about character + +properties and mappings, see <i><a href="http://www.unicode.org/unicode/uni2book/u2.html">The + +Unicode Standard</a></i>.</p> + +<p>The Unicode Character Database has been updated to reflect Version 3.0 of the + +Unicode Standard, with many characters added to those published in Version 2.0. + +A number of corrections have also been made to case mappings or other errors in + +the database noted since the publication of Version 2.0. Normative bidirectional + +properties have also been modified to reflect decisions of the Unicode Technical + +Committee.</p> + +<p>For more information on versions of the Unicode Standard and how to reference + +them, see <a href="http://www.unicode.org/unicode/standard/versions/">http://www.unicode.org/unicode/standard/versions/</a>.</p> + +<h2>Conformance</h2> + +<p>Character properties may be either normative or informative. <i>Normative</i> + +means that implementations that claim conformance to the Unicode Standard (at a + +particular version) and which make use of a particular property or field must + +follow the specifications of the standard for that property or field in order to + +be conformant. The term <i>normative</i> when applied to a property or field of + +the Unicode Character Database, does <i>not</i> mean that the value of that + +field will never change. Corrections and extensions to the standard in the + +future may require minor changes to normative values, even though the Unicode + +Technical Committee strives to minimize such changes. An<i> informative </i>property + +or field is strongly recommended, but a conformant implementation is free to use + +or change such values as it may require while still being conformant to the + +standard. Particular implementations may choose to override the properties and + +mappings that are not normative. In that case, it is up to the implementer to + +establish a protocol to convey that information.</p> + +<h2>Files</h2> + +<p>The following summarizes the files in the Unicode Character Database. For + +more information about these files, see the referenced technical report or + +section of Unicode Standard, Version 3.0.</p> + +<p><b>UnicodeData.txt (Chapter 4)</b> + +<ul> + + <li>The main file in the Unicode Character Database.</li> + + <li>For detailed information on the format, see <a href="UnicodeData.html">UnicodeData.html</a>. + + This file also characterizes which properties are normative and which are + + informative.</li> + +</ul> + +<p><b>PropList.txt (Chapter 4)</b> + +<ul> + + <li>Additional informative properties list: <i>Alphabetic, Ideographic,</i> + + and <i>Mathematical</i>, among others.</li> + +</ul> + +<p><b>SpecialCasing.txt (Chapter 4)</b> + +<ul> + + <li>List of informative special casing properties, including one-to-many + + mappings such as SHARP S => "SS", and locale-specific mappings, + + such as for Turkish <i>dotless i</i>.</li> + +</ul> + +<p><b>Blocks.txt (Chapter 14)</b> + +<ul> + + <li>List of normative block names.</li> + +</ul> + +<p><b>Jamo.txt (Chapter 4)</b> + +<ul> + + <li>List of normative Jamo short names, used in deriving HANGUL SYLLABLE names + + algorithmically.</li> + +</ul> + +<p><b>ArabicShaping.txt (Section 8.2)</b> + +<ul> + + <li>Basic Arabic and Syriac character shaping properties, such as initial, + + medial and final shapes. These properties are normative for minimal shaping + + of Arabic and Syriac. </li> + +</ul> + +<p><b>NamesList.txt (Chapter 14)</b> + +<ul> + + <li>This file duplicates some of the material in the UnicodeData file, and + + adds informative annotations uses in the character charts, as printed in the + + Unicode Standard. </li> + + <li><b>Note: </b>The information in NamesList.txt and Index.txt files matches + + the appropriate version of the book. Changes in the Unicode Character + + Database since then may not be reflected in these files, since they are + + primarily of archival interest.</li> + +</ul> + +<p><b>Index.txt (Chapter 14)</b> + +<ul> + + <li>Informative index to Unicode characters, as printed in the Unicode + + Standard</li> + + <li><b>Note: </b>The information in NamesList.txt and Index.txt files matches + + the appropriate version of the book. Changes in the Unicode Character + + Database since then may not be reflected in these files, since they are + + primarily of archival interest.</li> + +</ul> + +<p><b>CompositionExclusions.txt (<a href="http://www.unicode.org/unicode/reports/tr15/">UTR#15 + +Unicode Normalization Forms</a>)</b> + +<ul> + + <li>Normative properties for normalization.</li> + +</ul> + +<p><b>LineBreak.txt (<a href="http://www.unicode.org/unicode/reports/tr14/">UTR + +#14: Line Breaking Properties</a>)</b> + +<ul> + + <li>Normative and informative properties for line breaking. To see which + + properties are informative and which are normative, consult UTR#14.</li> + +</ul> + +<p><b>EastAsianWidth.txt (<a href="http://www.unicode.org/unicode/reports/tr11/">UTR + +#11: East Asian Character Width</a>)</b> + +<ul> + + <li>Informative properties for determining the choice of wide vs. narrow + + glyphs in East Asian contexts.</li> + +</ul> + +<p><b>diffXvY.txt</b> + +<ul> + + <li>Mechanically-generated informative files containing accumulated + + differences between successive versions of UnicodeData.txt</li> + +</ul> + + + +</body> + + + +</html> + diff --git a/lib/unicode/mktables.PL b/lib/unicode/mktables.PL index 9458a95838..7d70b18469 100755 --- a/lib/unicode/mktables.PL +++ b/lib/unicode/mktables.PL @@ -331,20 +331,58 @@ while (<UNICODEDATA>) { $code{$name} = $code; $name{$code} = $name; + $category{$code} = $category; + + next unless $category =~ /^L/; + + # The definition of "equivalence" is twofold. + if ($decomposition ne '') { + # (1) If there's an official Unicode decomposition + # and the base is a Unicode letter. + $decomposition =~ s/^<\w+> //; + @decomposition = split(' ', $decomposition); + # Some Arabic ligatures like + # FC5E;ARABIC LIGATURE SHADDA WITH DAMMATAN ISOLATED FORM;Lo;... + # are problematic because their decomposition begins with + # a space (0020) -- which could be just skipped -- but then + # their base glyph is not a letter, for example + # the above decomposes as <isolated> 0020 064C 0651, + # but 064C is 064C;ARABIC DAMMATAN;Mn;... + # (the 0651 being ARABIC SHADDA;Mn) + ($basecode) = shift @decomposition; + push @base, [ $code, $basecode ]; + } elsif ($name =~ /^(.+?) WITH /) { + # (2) If there's a "FOO WITH ..." Unicode name and FOO + # happens to be valid Unicode letter. This is + # a debatable definition and all fault is by me (jhi). + # For example this definition adds + # LATIN SMALL LETTER O WITH STROKE + # as a derivative of + # LATIN SMALL LETTER O + # which some might rightfully contest, especially + # the speakers of languages who have the former + # phonetically as very distinct from the latter. + push @with, [ $code, $1 ]; + } +} - next unless $category =~ /^L/ && $decomposition ne ''; - $decomposition =~ s/^<\w+> //; - @decomposition = split(' ', $decomposition); - - push @base, [ $code, $decomposition[0] ]; +foreach my $w (@with) { + ($code, $basename) = @$w; + next if not exists $code{$basename} or + not $category{$code{$basename}} =~ /^L/; + push @base, [ $code, $code{$basename} ]; } +@base = sort { $a->[0] cmp $b->[0] } @base; + foreach my $b (@base) { ($code, $basecode) = @$b; - $base = $name{$basecode}; - next unless exists $code{$base}; - push @{$unicode{$code{$base}}}, $code; -# print "$code: $name{$code} -> $base\n", + $basename = $name{$basecode}; + next if not defined $basename or + not exists $code{$basename} or + not $category{$code{$basename}} =~ /^L/; + push @{$unicode{$code{$basename}}}, $code; +# print "$code: $name{$code} -> $basename\n", } @unicode = sort keys %unicode; @@ -363,7 +401,7 @@ print "EqLatin1\n"; if (open(EQ_LATIN1, ">Eq/Latin1")) { foreach my $c (@unicode) { last if hex($c) > 255; - my @c = grep { hex($_) <= 255 } @{$unicode{$c}}; + my @c = grep { hex($_) < 256 } @{$unicode{$c}}; next unless @c; print EQ_LATIN1 "$c @c\n"; } @@ -373,4 +411,3 @@ if (open(EQ_LATIN1, ">Eq/Latin1")) { } # eof - @@ -227,7 +227,7 @@ #ifdef PERL_CORE # include "EXTERN.h" -#define PERL_IN_MALLOC_C +# define PERL_IN_MALLOC_C # include "perl.h" # if defined(PERL_IMPLICIT_CONTEXT) # define croak Perl_croak_nocontext @@ -287,6 +287,21 @@ # ifndef PERL_GET_INTERP # define PERL_GET_INTERP PL_curinterp # endif +# ifndef Perl_malloc +# define Perl_malloc malloc +# endif +# ifndef Perl_mfree +# define Perl_mfree free +# endif +# ifndef Perl_realloc +# define Perl_realloc realloc +# endif +# ifndef Perl_calloc +# define Perl_calloc calloc +# endif +# ifndef Perl_strdup +# define Perl_strdup strdup +# endif #endif #ifndef MUTEX_LOCK @@ -325,7 +340,7 @@ * of such *unused* blocks are kept in nextf[i] with big enough i. (nextf * is an array of linked lists.) (Addresses of used blocks are not known.) * - * Moreover, since the algorithm may try to "bite" smaller blocks of out + * Moreover, since the algorithm may try to "bite" smaller blocks out * of unused bigger ones, there are also regions of "irregular" size, * managed separately, by a linked list chunk_chain. * @@ -487,29 +502,121 @@ static u_short buck_size[MAX_BUCKET_BY_TABLE + 1] = #ifdef PACK_MALLOC -/* In this case it is assumed that if we do sbrk() in 2K units, we - * will get 2K aligned arenas (at least after some initial - * alignment). The bucket number of the given subblock is on the start - * of 2K arena which contains the subblock. Several following bytes - * contain the magic numbers for the subblocks in the block. +/* In this case there are several possible layout of arenas depending + * on the size. Arenas are of sizes multiple to 2K, 2K-aligned, and + * have a size close to a power of 2. + * + * Arenas of the size >= 4K keep one chunk only. Arenas of size 2K + * may keep one chunk or multiple chunks. Here are the possible + * layouts of arenas: + * + * # One chunk only, chunksize 2^k + SOMETHING - ALIGN, k >= 11 + * + * INDEX MAGIC1 UNUSED CHUNK1 + * + * # Multichunk with sanity checking and chunksize 2^k-ALIGN, k>7 + * + * INDEX MAGIC1 MAGIC2 MAGIC3 UNUSED CHUNK1 CHUNK2 CHUNK3 ... + * + * # Multichunk with sanity checking and size 2^k-ALIGN, k=7 + * + * INDEX MAGIC1 MAGIC2 MAGIC3 UNUSED CHUNK1 UNUSED CHUNK2 CHUNK3 ... + * + * # Multichunk with sanity checking and size up to 80 + * + * INDEX UNUSED MAGIC1 UNUSED MAGIC2 UNUSED ... CHUNK1 CHUNK2 CHUNK3 ... + * + * # No sanity check (usually up to 48=byte-long buckets) + * INDEX UNUSED CHUNK1 CHUNK2 ... + * + * Above INDEX and MAGIC are one-byte-long. Sizes of UNUSED are + * appropriate to keep algorithms simple and memory aligned. INDEX + * encodes the size of the chunk, while MAGICn encodes state (used, + * free or non-managed-by-us-so-it-indicates-a-bug) of CHUNKn. MAGIC + * is used for sanity checking purposes only. SOMETHING is 0 or 4K + * (to make size of big CHUNK accomodate allocations for powers of two + * better). + * + * [There is no need to alignment between chunks, since C rules ensure + * that structs which need 2^k alignment have sizeof which is + * divisible by 2^k. Thus as far as the last chunk is aligned at the + * end of the arena, and 2K-alignment does not contradict things, + * everything is going to be OK for sizes of chunks 2^n and 2^n + + * 2^k. Say, 80-bit buckets will be 16-bit aligned, and as far as we + * put allocations for requests in 65..80 range, all is fine. + * + * Note, however, that standard malloc() puts more strict + * requirements than the above C rules. Moreover, our algorithms of + * realloc() may break this idyll, but we suppose that realloc() does + * need not change alignment.] + * + * Is very important to make calculation of the offset of MAGICm as + * quick as possible, since it is done on each malloc()/free(). In + * fact it is so quick that it has quite little effect on the speed of + * doing malloc()/free(). [By default] We forego such calculations + * for small chunks, but only to save extra 3% of memory, not because + * of speed considerations. + * + * Here is the algorithm [which is the same for all the allocations + * schemes above], see OV_MAGIC(block,bucket). Let OFFSETm be the + * offset of the CHUNKm from the start of ARENA. Then offset of + * MAGICm is (OFFSET1 >> SHIFT) + ADDOFFSET. Here SHIFT and ADDOFFSET + * are numbers which depend on the size of the chunks only. + * + * Let as check some sanity conditions. Numbers OFFSETm>>SHIFT are + * different for all the chunks in the arena if 2^SHIFT is not greater + * than size of the chunks in the arena. MAGIC1 will not overwrite + * INDEX provided ADDOFFSET is >0 if OFFSET1 < 2^SHIFT. MAGIClast + * will not overwrite CHUNK1 if OFFSET1 > (OFFSETlast >> SHIFT) + + * ADDOFFSET. + * + * Make SHIFT the maximal possible (there is no point in making it + * smaller). Since OFFSETlast is 2K - CHUNKSIZE, above restrictions + * give restrictions on OFFSET1 and on ADDOFFSET. + * + * In particular, for chunks of size 2^k with k>=6 we can put + * ADDOFFSET to be from 0 to 2^k - 2^(11-k), and have + * OFFSET1==chunksize. For chunks of size 80 OFFSET1 of 2K%80=48 is + * large enough to have ADDOFFSET between 1 and 16 (similarly for 96, + * when ADDOFFSET should be 1). In particular, keeping MAGICs for + * these sizes gives no additional size penalty. + * + * However, for chunks of size 2^k with k<=5 this gives OFFSET1 >= + * ADDOFSET + 2^(11-k). Keeping ADDOFFSET 0 allows for 2^(11-k)-2^(11-2k) + * chunks per arena. This is smaller than 2^(11-k) - 1 which are + * needed if no MAGIC is kept. [In fact, having a negative ADDOFFSET + * would allow for slightly more buckets per arena for k=2,3.] + * + * Similarly, for chunks of size 3/2*2^k with k<=5 MAGICs would span + * the area up to 2^(11-k)+ADDOFFSET. For k=4 this give optimal + * ADDOFFSET as -7..0. For k=3 ADDOFFSET can go up to 4 (with tiny + * savings for negative ADDOFFSET). For k=5 ADDOFFSET can go -1..16 + * (with no savings for negative values). * - * Sizes of chunks are powers of 2 for chunks in buckets <= - * MAX_PACKED, after this they are (2^n - sizeof(union overhead)) (to - * get alignment right). + * In particular, keeping ADDOFFSET 0 for sizes of chunks up to 2^6 + * leads to tiny pessimizations in case of sizes 4, 8, 12, 24, and + * leads to no contradictions except for size=80 (or 96.) * - * Consider an arena for 2^n with n>MAX_PACKED. We suppose that - * starts of all the chunks in a 2K arena are in different - * 2^n-byte-long chunks. If the top of the last chunk is aligned on a - * boundary of 2K block, this means that sizeof(union - * overhead)*"number of chunks" < 2^n, or sizeof(union overhead)*2K < - * 4^n, or n > 6 + log2(sizeof()/2)/2, since a chunk of size 2^n - - * overhead is used. Since this rules out n = 7 for 8 byte alignment, - * we specialcase allocation of the first of 16 128-byte-long chunks. + * However, it also makes sense to keep no magic for sizes 48 or less. + * This is what we do. In this case one needs ADDOFFSET>=1 also for + * chunksizes 12, 24, and 48, unless one gets one less chunk per + * arena. + * + * The algo of OV_MAGIC(block,bucket) keeps ADDOFFSET 0 until + * chunksize of 64, then makes it 1. * - * Note that with the above assumption we automatically have enough - * place for MAGIC at the start of 2K block. Note also that we - * overlay union overhead over the chunk, thus the start of small chunks - * is immediately overwritten after freeing. */ + * This allows for an additional optimization: the above scheme leads + * to giant overheads for sizes 128 or more (one whole chunk needs to + * be sacrifised to keep INDEX). Instead we use chunks not of size + * 2^k, but of size 2^k-ALIGN. If we pack these chunks at the end of + * the arena, then the beginnings are still in different 2^k-long + * sections of the arena if k>=7 for ALIGN==4, and k>=8 if ALIGN=8. + * Thus for k>7 the above algo of calculating the offset of the magic + * will still give different answers for different chunks. And to + * avoid the overrun of MAGIC1 into INDEX, one needs ADDOFFSET of >=1. + * In the case k=7 we just move the first chunk an extra ALIGN + * backward inside the ARENA (this is done once per arena lifetime, + * thus is not a big overhead). */ # define MAX_PACKED_POW2 6 # define MAX_PACKED (MAX_PACKED_POW2 * BUCKETS_PER_POW2 + BUCKET_POW2_SHIFT) # define MAX_POW2_ALGO ((1<<(MAX_PACKED_POW2 + 1)) - M_OVERHEAD) @@ -862,7 +969,6 @@ Perl_malloc(register size_t nbytes) croak("%s", "panic: malloc"); #endif - MALLOC_LOCK; /* * Convert amount of memory requested into * closest block size stored in hash buckets @@ -894,6 +1000,7 @@ Perl_malloc(register size_t nbytes) while (shiftr >>= 1) bucket += BUCKETS_PER_POW2; } + MALLOC_LOCK; /* * If nothing in hash bucket right now, * request more memory from the system. @@ -910,9 +1017,8 @@ Perl_malloc(register size_t nbytes) my_exit(1); } } -#else - return (NULL); #endif + return (NULL); } DEBUG_m(PerlIO_printf(Perl_debug_log, @@ -927,6 +1033,9 @@ Perl_malloc(register size_t nbytes) (unsigned long)*((int*)p),(unsigned long)p); #endif nextf[bucket] = p->ov_next; + + MALLOC_UNLOCK; + #ifdef IGNORE_SMALL_BAD_FREE if (bucket >= FIRST_BUCKET_WITH_CHECK) #endif @@ -954,7 +1063,6 @@ Perl_malloc(register size_t nbytes) *((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC; } #endif - MALLOC_UNLOCK; return ((Malloc_t)(p + CHUNK_SHIFT)); } @@ -1394,7 +1502,6 @@ Perl_mfree(void *mp) #endif return; /* sanity */ } - MALLOC_LOCK; #ifdef RCHECK ASSERT(ovp->ov_rmagic == RMAGIC, "chunk's head overwrite"); if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) { @@ -1415,23 +1522,17 @@ Perl_mfree(void *mp) #endif ASSERT(OV_INDEX(ovp) < NBUCKETS, "chunk's head overwrite"); size = OV_INDEX(ovp); + + MALLOC_LOCK; ovp->ov_next = nextf[size]; nextf[size] = ovp; MALLOC_UNLOCK; } -/* - * When a program attempts "storage compaction" as mentioned in the - * old malloc man page, it realloc's an already freed block. Usually - * this is the last block it freed; occasionally it might be farther - * back. We have to search all the free lists for the block in order - * to determine its bucket: 1st we make one pass thru the lists - * checking only the first block in each; if that fails we search - * ``reall_srchlen'' blocks in each list for a match (the variable - * 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. - */ -#define reall_srchlen 4 /* 4 should be plenty, -1 =>'s whole list */ +/* There is no need to do any locking in realloc (with an exception of + trying to grow in place if we are at the end of the chain). + If somebody calls us from a different thread with the same address, + we are sole anyway. */ Malloc_t Perl_realloc(void *mp, size_t nbytes) @@ -1441,7 +1542,8 @@ Perl_realloc(void *mp, size_t nbytes) char *res; int prev_bucket; register int bucket; - int was_alloced = 0, incr; + int incr; /* 1 if does not fit, -1 if "easily" fits in a + smaller bucket, otherwise 0. */ char *cp = (char*)mp; #if defined(DEBUGGING) || !defined(PERL_CORE) @@ -1455,34 +1557,34 @@ Perl_realloc(void *mp, size_t nbytes) if (!cp) return Perl_malloc(nbytes); - MALLOC_LOCK; ovp = (union overhead *)((caddr_t)cp - sizeof (union overhead) * CHUNK_SHIFT); bucket = OV_INDEX(ovp); + #ifdef IGNORE_SMALL_BAD_FREE - if ((bucket < FIRST_BUCKET_WITH_CHECK) - || (OV_MAGIC(ovp, bucket) == MAGIC)) + if ((bucket >= FIRST_BUCKET_WITH_CHECK) + && (OV_MAGIC(ovp, bucket) != MAGIC)) #else - if (OV_MAGIC(ovp, bucket) == MAGIC) + if (OV_MAGIC(ovp, bucket) != MAGIC) #endif - { - was_alloced = 1; - } else { - /* - * Already free, doing "compaction". - * - * Search for the old block of memory on the - * free list. First, check the most common - * case (last element free'd), then (this failing) - * the last ``reall_srchlen'' items free'd. - * If all lookups fail, then assume the size of - * the memory block being realloc'd is the - * smallest possible. - */ - if ((bucket = findbucket(ovp, 1)) < 0 && - (bucket = findbucket(ovp, reall_srchlen)) < 0) - bucket = 0; - } + { + static int bad_free_warn = -1; + if (bad_free_warn == -1) { + char *pbf = PerlEnv_getenv("PERL_BADFREE"); + bad_free_warn = (pbf) ? atoi(pbf) : 1; + } + if (!bad_free_warn) + return; +#ifdef RCHECK + warn("%srealloc() %signored", + (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "), + ovp->ov_rmagic == RMAGIC - 1 ? "of freed memory " : ""); +#else + warn("%s", "Bad realloc() ignored"); +#endif + return; /* sanity */ + } + onb = BUCKET_SIZE_REAL(bucket); /* * avoid the copy if same size block. @@ -1511,12 +1613,10 @@ Perl_realloc(void *mp, size_t nbytes) incr = 0; else incr = -1; } - if (!was_alloced #ifdef STRESS_REALLOC - || 1 /* always do it the hard way */ + goto hard_way; #endif - ) goto hard_way; - else if (incr == 0) { + if (incr == 0) { inplace_label: #ifdef RCHECK /* @@ -1553,7 +1653,6 @@ Perl_realloc(void *mp, size_t nbytes) } #endif res = cp; - MALLOC_UNLOCK; DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05lu) realloc %ld bytes inplace\n", (unsigned long)res,(unsigned long)(PL_an++), @@ -1574,18 +1673,22 @@ Perl_realloc(void *mp, size_t nbytes) newarena = (1 << pow) + POW2_OPTIMIZE_SURPLUS(pow * BUCKETS_PER_POW2); require = newarena - onb - M_OVERHEAD; - if (getpages_adjacent(require)) { + MALLOC_LOCK; + if (cp - M_OVERHEAD == last_op /* We *still* are the last chunk */ + && getpages_adjacent(require)) { #ifdef DEBUGGING_MSTATS nmalloc[bucket]--; nmalloc[pow * BUCKETS_PER_POW2]++; #endif *(cp - M_OVERHEAD) = pow * BUCKETS_PER_POW2; /* Fill index. */ + MALLOC_UNLOCK; goto inplace_label; - } else + } else { + MALLOC_UNLOCK; goto hard_way; + } } else { hard_way: - MALLOC_UNLOCK; DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05lu) realloc %ld bytes the hard way\n", (unsigned long)cp,(unsigned long)(PL_an++), @@ -1594,8 +1697,7 @@ Perl_realloc(void *mp, size_t nbytes) return (NULL); if (cp != res) /* common optimization */ Copy(cp, res, (MEM_SIZE)(nbytes<onb?nbytes:onb), char); - if (was_alloced) - Perl_mfree(cp); + Perl_mfree(cp); } return ((Malloc_t)res); } @@ -1634,6 +1736,46 @@ Perl_calloc(register size_t elements, register size_t size) return p; } +char * +Perl_strdup(const char *s) +{ + MEM_SIZE l = strlen(s); + char *s1 = (char *)Perl_malloc(l); + + Copy(s, s1, (MEM_SIZE)l, char); + return s1; +} + +#ifdef PERL_CORE +int +Perl_putenv(char *a) +{ + /* Sometimes system's putenv conflicts with my_setenv() - this is system + malloc vs Perl's free(). */ + dTHX; + char *var; + char *val = a; + MEM_SIZE l; + char buf[80]; + + while (*val && *val != '=') + val++; + if (!*val) + return -1; + l = val - a; + if (l < sizeof(buf)) + var = buf; + else + var = Perl_malloc(l + 1); + Copy(a, var, l, char); + val++; + my_setenv(var,val); + if (var != buf) + Perl_mfree(var); + return 0; +} +# endif + MEM_SIZE Perl_malloced_size(void *p) { @@ -1673,8 +1815,9 @@ Perl_dump_mstats(pTHX_ char *s) int topbucket=0, topbucket_ev=0, topbucket_odd=0, totfree=0, total=0; u_int nfree[NBUCKETS]; int total_chain = 0; - struct chunk_chain_s* nextchain = chunk_chain; + struct chunk_chain_s* nextchain; + MALLOC_LOCK; for (i = MIN_BUCKET ; i < NBUCKETS; i++) { for (j = 0, p = nextf[i]; p; p = p->ov_next, j++) ; @@ -1686,6 +1829,12 @@ Perl_dump_mstats(pTHX_ char *s) topbucket = i; } } + nextchain = chunk_chain; + while (nextchain) { + total_chain += nextchain->size; + nextchain = nextchain->next; + } + MALLOC_UNLOCK; if (s) PerlIO_printf(PerlIO_stderr(), "Memory allocation statistics %s (buckets %ld(%ld)..%ld(%ld)\n", @@ -1729,10 +1878,6 @@ Perl_dump_mstats(pTHX_ char *s) nmalloc[i] - nfree[i]); } #endif - while (nextchain) { - total_chain += nextchain->size; - nextchain = nextchain->next; - } PerlIO_printf(PerlIO_stderr(), "\nTotal sbrk(): %d/%d:%d. Odd ends: pad+heads+chain+tail: %d+%d+%d+%d.\n", goodsbrk + sbrk_slack, sbrks, sbrk_good, sbrk_slack, start_slack, total_chain, sbrked_remains); @@ -905,8 +905,6 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) svp = &PL_diehook; else if (strEQ(s,"__WARN__")) svp = &PL_warnhook; - else if (strEQ(s,"__PARSE__")) - svp = &PL_parsehook; else Perl_croak(aTHX_ "No such hook: %s", s); i = 0; @@ -372,8 +372,6 @@ #define PL_padix (*Perl_Ipadix_ptr(aTHXo)) #undef PL_padix_floor #define PL_padix_floor (*Perl_Ipadix_floor_ptr(aTHXo)) -#undef PL_parsehook -#define PL_parsehook (*Perl_Iparsehook_ptr(aTHXo)) #undef PL_patchlevel #define PL_patchlevel (*Perl_Ipatchlevel_ptr(aTHXo)) #undef PL_pending_ident @@ -524,6 +522,22 @@ #define PL_xnv_root (*Perl_Ixnv_root_ptr(aTHXo)) #undef PL_xpv_root #define PL_xpv_root (*Perl_Ixpv_root_ptr(aTHXo)) +#undef PL_xpvav_root +#define PL_xpvav_root (*Perl_Ixpvav_root_ptr(aTHXo)) +#undef PL_xpvbm_root +#define PL_xpvbm_root (*Perl_Ixpvbm_root_ptr(aTHXo)) +#undef PL_xpvcv_root +#define PL_xpvcv_root (*Perl_Ixpvcv_root_ptr(aTHXo)) +#undef PL_xpvhv_root +#define PL_xpvhv_root (*Perl_Ixpvhv_root_ptr(aTHXo)) +#undef PL_xpviv_root +#define PL_xpviv_root (*Perl_Ixpviv_root_ptr(aTHXo)) +#undef PL_xpvlv_root +#define PL_xpvlv_root (*Perl_Ixpvlv_root_ptr(aTHXo)) +#undef PL_xpvmg_root +#define PL_xpvmg_root (*Perl_Ixpvmg_root_ptr(aTHXo)) +#undef PL_xpvnv_root +#define PL_xpvnv_root (*Perl_Ixpvnv_root_ptr(aTHXo)) #undef PL_xrv_root #define PL_xrv_root (*Perl_Ixrv_root_ptr(aTHXo)) #undef PL_yychar @@ -580,6 +594,8 @@ #define PL_efloatbuf (*Perl_Tefloatbuf_ptr(aTHXo)) #undef PL_efloatsize #define PL_efloatsize (*Perl_Tefloatsize_ptr(aTHXo)) +#undef PL_errors +#define PL_errors (*Perl_Terrors_ptr(aTHXo)) #undef PL_extralen #define PL_extralen (*Perl_Textralen_ptr(aTHXo)) #undef PL_firstgv @@ -1004,6 +1020,10 @@ #define Perl_form_nocontext pPerl->Perl_form_nocontext #undef form_nocontext #define form_nocontext Perl_form_nocontext +#undef Perl_mess_nocontext +#define Perl_mess_nocontext pPerl->Perl_mess_nocontext +#undef mess_nocontext +#define mess_nocontext Perl_mess_nocontext #undef Perl_warn_nocontext #define Perl_warn_nocontext pPerl->Perl_warn_nocontext #undef warn_nocontext @@ -2015,6 +2035,14 @@ #define Perl_mess pPerl->Perl_mess #undef mess #define mess Perl_mess +#undef Perl_vmess +#define Perl_vmess pPerl->Perl_vmess +#undef vmess +#define vmess Perl_vmess +#undef Perl_qerror +#define Perl_qerror pPerl->Perl_qerror +#undef qerror +#define qerror Perl_qerror #undef Perl_mg_clear #define Perl_mg_clear pPerl->Perl_mg_clear #undef mg_clear @@ -18,6 +18,7 @@ #include "EXTERN.h" #define PERL_IN_OP_C #include "perl.h" +#include "keywords.h" /* #define PL_OP_SLAB_ALLOC */ @@ -96,9 +97,9 @@ S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid) STATIC void S_no_bareword_allowed(pTHX_ OP *o) { - Perl_warn(aTHX_ "Bareword \"%s\" not allowed while \"strict subs\" in use", - SvPV_nolen(cSVOPo->op_sv)); - ++PL_error_count; + qerror(Perl_mess(aTHX_ + "Bareword \"%s\" not allowed while \"strict subs\" in use", + SvPV_nolen(cSVOPo->op_sv))); } /* "register" allocation */ @@ -111,9 +112,10 @@ Perl_pad_allocmy(pTHX_ char *name) SV *sv; if (!( + PL_in_my == KEY_our || isALPHA(name[1]) || (PL_hints & HINT_UTF8 && (name[1] & 0xc0) == 0xc0) || - name[1] == '_' && (int)strlen(name) > 2)) + name[1] == '_' && (int)strlen(name) > 2 )) { if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { /* 1999-02-27 mjd@plover.com */ @@ -145,8 +147,10 @@ Perl_pad_allocmy(pTHX_ char *name) && strEQ(name, SvPVX(sv))) { Perl_warner(aTHX_ WARN_UNSAFE, - "\"my\" variable %s masks earlier declaration in same %s", - name, (SvIVX(sv) == PAD_MAX ? "scope" : "statement")); + "\"%s\" variable %s masks earlier declaration in same %s", + (PL_in_my == KEY_our ? "our" : "my"), + name, + (SvIVX(sv) == PAD_MAX ? "scope" : "statement")); break; } } @@ -164,6 +168,8 @@ Perl_pad_allocmy(pTHX_ char *name) SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash); PL_sv_objcount++; } + if (PL_in_my == KEY_our) + SvFLAGS(sv) |= SVpad_OUR; av_store(PL_comppad_name, off, sv); SvNVX(sv) = (NV)PAD_MAX; SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */ @@ -231,6 +237,8 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, SvNVX(namesv) = (NV)PL_curcop->cop_seq; SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */ SvFAKE_on(namesv); /* A ref, not a real var */ + if (SvFLAGS(sv) & SVpad_OUR)/* An "our" variable */ + SvFLAGS(namesv) |= SVpad_OUR; if (SvOBJECT(sv)) { /* A typed var */ SvOBJECT_on(namesv); (void)SvUPGRADE(namesv, SVt_PVMG); @@ -355,7 +363,7 @@ Perl_pad_findmy(pTHX_ char *name) seq > I_32(SvNVX(sv)))) && strEQ(SvPVX(sv), name)) { - if (SvIVX(sv)) + if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR) return (PADOFFSET)off; pendoff = off; /* this pending def. will override import */ } @@ -1731,6 +1739,10 @@ S_my_kid(pTHX_ OP *o, OP *attrs) my_kid(kid, attrs); } else if (type == OP_UNDEF) { return o; + } else if (type == OP_RV2SV || /* "our" declaration */ + type == OP_RV2AV || + type == OP_RV2HV) { /* XXX does this let anything illegal in? */ + return o; } else if (type != OP_PADSV && type != OP_PADAV && type != OP_PADHV && @@ -397,7 +397,7 @@ EXT char *PL_op_desc[] = { "single ref constructor", "reference-type operator", "bless", - "backticks (``, qx)", + "quoted execution (``, qx)", "glob", "<HANDLE>", "append I/O operator", @@ -683,9 +683,9 @@ EXT char *PL_op_desc[] = { "semctl", "semop", "require", - "do 'file'", - "eval 'string'", - "eval 'string' exit", + "do \"file\"", + "eval \"string\"", + "eval \"string\" exit", "eval {block}", "eval {block} exit", "gethostbyname", @@ -296,6 +296,8 @@ sub tab { # ucfirst etc not OK: TMP arg processed inplace # each repeat not OK too due to array context # pack split - unknown whether they are safe +# sprintf: is calling do_sprintf(TARG,...) which can act on TARG +# before other args are processed. # pp_hot.c # readline - unknown whether it is safe @@ -357,7 +359,7 @@ bless bless ck_fun s@ S S? # Pushy I/O. -backtick backticks (``, qx) ck_null t% +backtick quoted execution (``, qx) ck_null t% # glob defaults its first arg to $_ glob glob ck_glob t@ S? S? readline <HANDLE> ck_null t% @@ -479,7 +481,7 @@ vec vec ck_fun ist@ S S S index index ck_index isT@ S S S? rindex rindex ck_index isT@ S S S? -sprintf sprintf ck_fun_locale mfsT@ S L +sprintf sprintf ck_fun_locale mfst@ S L formline formline ck_fun ms@ S L ord ord ck_fun ifsTu% S? chr chr ck_fun fsTu% S? @@ -747,9 +749,9 @@ semop semop ck_fun imst@ S S # Eval. require require ck_require du% S? -dofile do 'file' ck_fun d1 S -entereval eval 'string' ck_eval d% S -leaveeval eval 'string' exit ck_null 1 S +dofile do "file" ck_fun d1 S +entereval eval "string" ck_eval d% S +leaveeval eval "string" exit ck_null 1 S #evalonce eval constant string ck_null d1 S entertry eval {block} ck_null | leavetry eval {block} exit ck_null @ @@ -328,8 +328,6 @@ perl_destruct(pTHXx) PL_warnhook = Nullsv; SvREFCNT_dec(PL_diehook); PL_diehook = Nullsv; - SvREFCNT_dec(PL_parsehook); - PL_parsehook = Nullsv; /* call exit list functions */ while (PL_exitlistlen-- > 0) @@ -443,6 +441,10 @@ perl_destruct(pTHXx) PL_defstash = 0; SvREFCNT_dec(hv); + /* clear queued errors */ + SvREFCNT_dec(PL_errors); + PL_errors = Nullsv; + FREETMPS; if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) { if (PL_scopestack_ix != 0) @@ -1422,17 +1422,13 @@ typedef union any ANY; #include "handy.h" -#ifdef USE_64_BITS -# define USE_64_BIT_FILES -#endif - -#if defined(USE_64_BIT_FILES) || defined(USE_LARGE_FILES) -# define USE_64_BIT_OFFSETS /* Explicit */ +#if defined(USE_LARGE_FILES) +# define USE_64_BIT_RAWIO /* Explicit */ # define USE_64_BIT_STDIO #endif -#if LSEEKSIZE == 8 && !defined(USE_64_BIT_OFFSETS) -# define USE_64_BIT_OFFSETS /* Implicit */ +#if LSEEKSIZE == 8 && !defined(USE_64_BIT_RAWIO) +# define USE_64_BIT_RAWIO /* Implicit */ #endif /* Do we need FSEEKSIZE? */ @@ -1449,7 +1445,7 @@ typedef union any ANY; #define USE_FREOPEN64 #endif -#ifdef USE_64_BIT_OFFSETS +#ifdef USE_64_BIT_RAWIO # ifdef HAS_OFF64_T # undef Off_t # define Off_t off64_t @@ -1458,7 +1454,7 @@ typedef union any ANY; # endif /* Most 64-bit environments have defines like _LARGEFILE_SOURCE that * will trigger defines like the ones below. Some 64-bit environments, - * however, do not. */ + * however, do not. Therefore we have to explicitly mix and match. */ # if defined(USE_OPEN64) # define open open64 # endif @@ -1730,22 +1726,6 @@ typedef pthread_key_t perl_key; # endif #endif -#if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_GET_THX) -# ifdef USE_THREADS -# define PERL_GET_THX THR -# else -# ifdef MULTIPLICITY -# define PERL_GET_THX PERL_GET_INTERP -# else -# ifdef PERL_OBJECT -# define PERL_GET_THX ((CPerlObj*)PERL_GET_INTERP) -# else -# define PERL_GET_THX ((void*)0) -# endif -# endif -# endif -#endif - /* Some unistd.h's give a prototype for pause() even though HAS_PAUSE ends up undefined. This causes the #define below to be rejected by the compmiler. Sigh. @@ -314,7 +314,7 @@ Perl_convert(pTHXo_ I32 optype, I32 flags, OP* o) #undef Perl_croak void -Perl_croak(pTHXo_ const char* pat) +Perl_croak(pTHXo_ const char* pat, ...) { va_list args; va_start(args, pat); @@ -332,7 +332,7 @@ Perl_vcroak(pTHXo_ const char* pat, va_list* args) #undef Perl_croak_nocontext void -Perl_croak_nocontext(const char* pat) +Perl_croak_nocontext(const char* pat, ...) { dTHXo; va_list args; @@ -343,7 +343,7 @@ Perl_croak_nocontext(const char* pat) #undef Perl_die_nocontext OP* -Perl_die_nocontext(const char* pat) +Perl_die_nocontext(const char* pat, ...) { dTHXo; OP* retval; @@ -357,7 +357,7 @@ Perl_die_nocontext(const char* pat) #undef Perl_deb_nocontext void -Perl_deb_nocontext(const char* pat) +Perl_deb_nocontext(const char* pat, ...) { dTHXo; va_list args; @@ -368,7 +368,7 @@ Perl_deb_nocontext(const char* pat) #undef Perl_form_nocontext char* -Perl_form_nocontext(const char* pat) +Perl_form_nocontext(const char* pat, ...) { dTHXo; char* retval; @@ -380,9 +380,23 @@ Perl_form_nocontext(const char* pat) } +#undef Perl_mess_nocontext +SV* +Perl_mess_nocontext(const char* pat, ...) +{ + dTHXo; + SV* retval; + va_list args; + va_start(args, pat); + retval = ((CPerlObj*)pPerl)->Perl_vmess(pat, &args); + va_end(args); + return retval; + +} + #undef Perl_warn_nocontext void -Perl_warn_nocontext(const char* pat) +Perl_warn_nocontext(const char* pat, ...) { dTHXo; va_list args; @@ -393,7 +407,7 @@ Perl_warn_nocontext(const char* pat) #undef Perl_warner_nocontext void -Perl_warner_nocontext(U32 err, const char* pat) +Perl_warner_nocontext(U32 err, const char* pat, ...) { dTHXo; va_list args; @@ -404,7 +418,7 @@ Perl_warner_nocontext(U32 err, const char* pat) #undef Perl_newSVpvf_nocontext SV* -Perl_newSVpvf_nocontext(const char* pat) +Perl_newSVpvf_nocontext(const char* pat, ...) { dTHXo; SV* retval; @@ -418,7 +432,7 @@ Perl_newSVpvf_nocontext(const char* pat) #undef Perl_sv_catpvf_nocontext void -Perl_sv_catpvf_nocontext(SV* sv, const char* pat) +Perl_sv_catpvf_nocontext(SV* sv, const char* pat, ...) { dTHXo; va_list args; @@ -429,7 +443,7 @@ Perl_sv_catpvf_nocontext(SV* sv, const char* pat) #undef Perl_sv_setpvf_nocontext void -Perl_sv_setpvf_nocontext(SV* sv, const char* pat) +Perl_sv_setpvf_nocontext(SV* sv, const char* pat, ...) { dTHXo; va_list args; @@ -440,7 +454,7 @@ Perl_sv_setpvf_nocontext(SV* sv, const char* pat) #undef Perl_sv_catpvf_mg_nocontext void -Perl_sv_catpvf_mg_nocontext(SV* sv, const char* pat) +Perl_sv_catpvf_mg_nocontext(SV* sv, const char* pat, ...) { dTHXo; va_list args; @@ -451,7 +465,7 @@ Perl_sv_catpvf_mg_nocontext(SV* sv, const char* pat) #undef Perl_sv_setpvf_mg_nocontext void -Perl_sv_setpvf_mg_nocontext(SV* sv, const char* pat) +Perl_sv_setpvf_mg_nocontext(SV* sv, const char* pat, ...) { dTHXo; va_list args; @@ -570,7 +584,7 @@ Perl_cxinc(pTHXo) #undef Perl_deb void -Perl_deb(pTHXo_ const char* pat) +Perl_deb(pTHXo_ const char* pat, ...) { va_list args; va_start(args, pat); @@ -636,7 +650,7 @@ Perl_deprecate(pTHXo_ char* s) #undef Perl_die OP* -Perl_die(pTHXo_ const char* pat) +Perl_die(pTHXo_ const char* pat, ...) { OP* retval; va_list args; @@ -1014,7 +1028,7 @@ Perl_fold_constants(pTHXo_ OP* arg) #undef Perl_form char* -Perl_form(pTHXo_ const char* pat) +Perl_form(pTHXo_ const char* pat, ...) { char* retval; va_list args; @@ -2172,9 +2186,29 @@ Perl_mem_collxfrm(pTHXo_ const char* s, STRLEN len, STRLEN* xlen) #undef Perl_mess SV* -Perl_mess(pTHXo_ const char* pat, va_list* args) +Perl_mess(pTHXo_ const char* pat, ...) +{ + SV* retval; + va_list args; + va_start(args, pat); + retval = ((CPerlObj*)pPerl)->Perl_vmess(pat, &args); + va_end(args); + return retval; + +} + +#undef Perl_vmess +SV* +Perl_vmess(pTHXo_ const char* pat, va_list* args) +{ + return ((CPerlObj*)pPerl)->Perl_vmess(pat, args); +} + +#undef Perl_qerror +void +Perl_qerror(pTHXo_ SV* err) { - return ((CPerlObj*)pPerl)->Perl_mess(pat, args); + ((CPerlObj*)pPerl)->Perl_qerror(err); } #undef Perl_mg_clear @@ -2688,7 +2722,7 @@ Perl_newSVpvn(pTHXo_ const char* s, STRLEN len) #undef Perl_newSVpvf SV* -Perl_newSVpvf(pTHXo_ const char* pat) +Perl_newSVpvf(pTHXo_ const char* pat, ...) { SV* retval; va_list args; @@ -3741,7 +3775,7 @@ Perl_sv_bless(pTHXo_ SV* sv, HV* stash) #undef Perl_sv_catpvf void -Perl_sv_catpvf(pTHXo_ SV* sv, const char* pat) +Perl_sv_catpvf(pTHXo_ SV* sv, const char* pat, ...) { va_list args; va_start(args, pat); @@ -4033,7 +4067,7 @@ Perl_sv_reset(pTHXo_ char* s, HV* stash) #undef Perl_sv_setpvf void -Perl_sv_setpvf(pTHXo_ SV* sv, const char* pat) +Perl_sv_setpvf(pTHXo_ SV* sv, const char* pat, ...) { va_list args; va_start(args, pat); @@ -4341,7 +4375,7 @@ Perl_wait4pid(pTHXo_ Pid_t pid, int* statusp, int flags) #undef Perl_warn void -Perl_warn(pTHXo_ const char* pat) +Perl_warn(pTHXo_ const char* pat, ...) { va_list args; va_start(args, pat); @@ -4358,7 +4392,7 @@ Perl_vwarn(pTHXo_ const char* pat, va_list* args) #undef Perl_warner void -Perl_warner(pTHXo_ U32 err, const char* pat) +Perl_warner(pTHXo_ U32 err, const char* pat, ...) { va_list args; va_start(args, pat); @@ -4557,7 +4591,7 @@ Perl_runops_debug(pTHXo) #undef Perl_sv_catpvf_mg void -Perl_sv_catpvf_mg(pTHXo_ SV *sv, const char* pat) +Perl_sv_catpvf_mg(pTHXo_ SV *sv, const char* pat, ...) { va_list args; va_start(args, pat); @@ -4595,7 +4629,7 @@ Perl_sv_catsv_mg(pTHXo_ SV *dstr, SV *sstr) #undef Perl_sv_setpvf_mg void -Perl_sv_setpvf_mg(pTHXo_ SV *sv, const char* pat) +Perl_sv_setpvf_mg(pTHXo_ SV *sv, const char* pat, ...) { va_list args; va_start(args, pat); @@ -4682,7 +4716,7 @@ Perl_pv_display(pTHXo_ SV *sv, char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) #undef Perl_dump_indent void -Perl_dump_indent(pTHXo_ I32 level, PerlIO *file, const char* pat) +Perl_dump_indent(pTHXo_ I32 level, PerlIO *file, const char* pat, ...) { va_list args; va_start(args, pat); @@ -4755,7 +4789,7 @@ Perl_magic_dump(pTHXo_ MAGIC *mg) #undef Perl_default_protect void* -Perl_default_protect(pTHXo_ int *excpt, protect_body_t body) +Perl_default_protect(pTHXo_ int *excpt, protect_body_t body, ...) { void* retval; va_list args; diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 772a464293..9489c58acb 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -17,6 +17,18 @@ This document describes differences between the 5.005 release and this one. TODO +=over 4 + +=item Possibly changed pseudo-random number generator + +In 5.005_0x and earlier, perl's rand() function used the C library +rand(3) function. As of 5.005_52, Configure tests for drand48(), +random(), and rand() (in that order) and picks the first one it finds. +Perl programs that depend on reproducing a specific set of pseudo-random +numbers will now likely produce different output. + +=back + =head2 C Source Incompatibilities =over 4 @@ -183,7 +195,9 @@ start losing precision (their lower digits). =head2 Large file support If you have filesystems that support "large files" (files larger than -2 gigabytes), you may now also be able to create and access them from Perl. +2 gigabytes), you may now also be able to create and access them from +Perl. You have to use Configure -Duselargefiles. Turning on the +large file support turns on also the 64-bit support, for obvious reasons. Note that in addition to requiring a proper file system to do large files you may also need to adjust your per-process (or your @@ -203,7 +217,17 @@ included with the standard Perl distribution) may also be of use, it offers the getrlimit/setrlimit interface that can be used to adjust process resource usage limits, including the maximum filesize limit. -(Large file support is related to 64-bit support, for obvious reasons.) +=head2 Long doubles + +In some systems you may be able to use long doubles to enhance the +range of precision of your double precision floating point numbers +(that is, Perl's numbers). Use Configure -Duselongdouble to enable +this support (if it is available). + +=head2 "more bits" + +You can Configure -Dusemorebits to turn on both the 64-bit support +and the long double support. =head2 Better syntax checks on parenthesized unary operators @@ -722,11 +746,6 @@ too soon. (W) You are concatenating the number 19 with another number, which could be a potential Year 2000 problem. -=item Possible Y2K bug: %s - -(W) You are concatenating the number 19 with another number, which -could be a potential Year 2000 problem. - =item Unterminated attribute parameter in subroutine attribute list (F) The lexer saw an opening (left) parenthesis character while parsing a @@ -748,13 +767,6 @@ like in the first argument to C<join>. Perl will treat the true or false result of matching the pattern against $_ as the string, which is probably not what you had in mind. -=item /%s/ should probably be written as "%s" - -(W) You have used a pattern where Perl expected to find a string, -like in the first argument to C<join>. Perl will treat the true -or false result of matching the pattern against $_ as the string, -which is probably not what you had in mind. - =head1 Obsolete Diagnostics Todo. diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 607a410e38..d224a54bd7 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -65,26 +65,26 @@ no useful value. See L<perlmod>. (F) The '!' is allowed in pack() and unpack() only after certain types. See L<perlfunc/pack>. -=item # cannot take a count +=item / cannot take a count (F) You had an unpack template indicating a counted-length string, but you have also specified an explicit size for the string. See L<perlfunc/pack>. -=item # must be followed by a, A or Z +=item / must be followed by a, A or Z (F) You had an unpack template indicating a counted-length string, which must be followed by one of the letters a, A or Z to indicate what sort of string is to be unpacked. See L<perlfunc/pack>. -=item # must be followed by a*, A* or Z* +=item / must be followed by a*, A* or Z* (F) You had an pack template indicating a counted-length string, Currently the only things that can have their length counted are a*, A* or Z*. See L<perlfunc/pack>. -=item # must follow a numeric type +=item / must follow a numeric type (F) You had an unpack template that contained a '#', but this did not follow some numeric unpack specification. @@ -455,6 +455,12 @@ is not the same as $var = 'myvar'; $sym = "mypack::$var"; +=item Bad realloc() ignored + +(S) An internal routine called realloc() on something that had never been +malloc()ed in the first place. Mandatory, but can be disabled by +setting environment variable C<PERL_BADFREE> to 1. + =item Bad symbol for array (P) An internal request asked to add an array entry to something that @@ -1840,8 +1846,8 @@ have a name with which they can be found. (W) Typographical errors often show up as unique variable names. If you had a good reason for having a unique name, then just mention -it again somehow to suppress the message. The C<use vars> pragma is -provided for just this purpose. +it again somehow to suppress the message. The C<our> declaration is +provided for this purpose. =item Negative length @@ -2135,6 +2141,12 @@ to use an operator, but this is highly likely to be incorrect. For example, if you say "*foo *foo" it will be interpreted as if you said "*foo * 'foo'". +=item Out of memory! + +(X) The malloc() function returned 0, indicating there was insufficient +remaining memory (or virtual memory) to satisfy the request. Perl +has no option but to exit immediately. + =item Out of memory for yacc stack (F) The yacc parser wanted to grow its stack so it could continue parsing, @@ -2471,6 +2483,11 @@ increment by prepending "0" to your numbers. (W) The filehandle you're reading from got itself closed sometime before now. Check your logic flow. +=item realloc() of freed memory ignored + +(S) An internal routine called realloc() on something that had already +been freed. + =item Reallocation too large: %lx (F) You can't allocate more than 64K on an MS-DOS machine. diff --git a/pod/perlembed.pod b/pod/perlembed.pod index db5aab0052..3ea173688f 100644 --- a/pod/perlembed.pod +++ b/pod/perlembed.pod @@ -656,7 +656,7 @@ with L<perlfunc/my> whenever possible. #persistent.pl use strict; - use vars '%Cache'; + our %Cache; use Symbol qw(delete_package); sub valid_package_name { diff --git a/pod/perlfaq3.pod b/pod/perlfaq3.pod index d2e83be460..26f7a693f3 100644 --- a/pod/perlfaq3.pod +++ b/pod/perlfaq3.pod @@ -53,7 +53,7 @@ Have you used C<-w>? It enables warnings for dubious practices. Have you tried C<use strict>? It prevents you from using symbolic references, makes you predeclare any subroutines that you call as bare words, and (probably most importantly) forces you to predeclare your -variables with C<my> or C<use vars>. +variables with C<my> or C<our> or C<use vars>. Did you check the returns of each and every system call? The operating system (and thus Perl) tells you whether they worked or not, and if not diff --git a/pod/perlfaq7.pod b/pod/perlfaq7.pod index 070d9653d4..72f4bb74ab 100644 --- a/pod/perlfaq7.pod +++ b/pod/perlfaq7.pod @@ -171,7 +171,7 @@ own module. Make sure to change the names appropriately. BEGIN { use Exporter (); - use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); ## set the version for version checking; uncomment to use ## $VERSION = 1.00; @@ -188,10 +188,11 @@ own module. Make sure to change the names appropriately. # as well as any optionally exported functions @EXPORT_OK = qw($Var1 %Hashit); } - use vars @EXPORT_OK; + our @EXPORT_OK; # non-exported package globals go here - use vars qw( @more $stuff ); + our @more; + our $stuff; # initialize package globals, first exported ones $Var1 = ''; diff --git a/pod/perlfaq9.pod b/pod/perlfaq9.pod index 2443fc9cdb..3da9bc1e4d 100644 --- a/pod/perlfaq9.pod +++ b/pod/perlfaq9.pod @@ -399,7 +399,7 @@ Sys::Hostname module (which is part of the standard perl distribution), you can probably try using something like this: use Sys::Hostname; - $address = sprintf('%s@%s', getpwuid($<), hostname); + $address = sprintf('%s@%s', scalar getpwuid($<), hostname); Company policies on mail address can mean that this generates addresses that the company's mail system will not accept, so you should ask for diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 995a671110..a09c6e5d46 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -2149,6 +2149,10 @@ 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. +Note that a block by itself is semantically identical to a loop +that executes once. Thus C<last> can be used to effect an early +exit out of such a block. + See also L</continue> for an illustration of how C<last>, C<next>, and C<redo> work. @@ -2394,6 +2398,9 @@ 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. +Note that a block by itself is semantically identical to a loop +that executes once. Thus C<next> will exit such a block early. + See also L</continue> for an illustration of how C<last>, C<next>, and C<redo> work. @@ -2700,6 +2707,18 @@ Returns the numeric (ASCII or Unicode) value of the first character of EXPR. If EXPR is omitted, uses C<$_>. For the reverse, see L</chr>. See L<utf8> for more about Unicode. +=item our EXPR + +An C<our> declares the listed variables to be valid globals within +the enclosing block, file, or C<eval>. That is, it has the same +scoping rules as a "my" declaration, but does not create a local +variable. If more than one value is listed, the list must be placed +in parentheses. The C<our> declaration has no semantic effect unless +"use strict vars" is in effect, in which case it lets you use the +declared global variable without qualifying it with a package name. +(But only within the lexical scope of the C<our> declaration. In this +it differs from "use vars", which is package scoped.) + =item pack TEMPLATE,LIST Takes a list of values and packs it into a binary structure, @@ -2809,9 +2828,9 @@ C<"P"> is C<undef>. =item * -The C<"#"> character allows packing and unpacking of strings where the +The C<"/"> character allows packing and unpacking of strings where the packed structure contains a byte count followed by the string itself. -You write I<length-item>C<#>I<string-item>. +You write I<length-item>C</>I<string-item>. The I<length-item> can be any C<pack> template letter, and describes how the length value is packed. @@ -2823,9 +2842,9 @@ The I<string-item> must, at present, be C<"A*">, C<"a*"> or C<"Z*">. For C<unpack> the length of the string is obtained from the I<length-item>, but if you put in the '*' it will be ignored. - unpack 'C#a', "\04Gurusamy"; gives 'Guru' - unpack 'a3#A* A*', '007 Bond J '; gives (' Bond','J') - pack 'n#a* w#a*','hello,','world'; gives "\000\006hello,\005world" + unpack 'C/a', "\04Gurusamy"; gives 'Guru' + unpack 'a3/A* A*', '007 Bond J '; gives (' Bond','J') + pack 'n/a* w/a*','hello,','world'; gives "\000\006hello,\005world" The I<length-item> is not returned explicitly from C<unpack>. @@ -2861,7 +2880,7 @@ L<Config>: print $Config{longsize}, "\n"; print $Config{longlongsize}, "\n"; -(The C<$Config{longlongsize}> will be empty if your system does +(The C<$Config{longlongsize}> will be undefine if your system does not support long longs.) =item * @@ -2869,7 +2888,7 @@ not support long longs.) 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 +4-byte integer 0x12345678 (305419896 decimal) be ordered natively (arranged in and handled by the CPU registers) into bytes as 0x12 0x34 0x56 0x78 # little-endian @@ -2885,7 +2904,7 @@ 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 Lilliputians. -Some systems may even have weird byte orders such as +Some systems may have even weirder byte orders such as 0x56 0x78 0x12 0x34 0x34 0x12 0x78 0x56 @@ -2931,6 +2950,10 @@ could know where the bytes are going to or coming from. Therefore C<pack> (and C<unpack>) handle their output and input as flat sequences of bytes. +=item * + +A comment in a TEMPLATE starts with C<#> and goes to the end of line. + =back Examples: @@ -3269,6 +3292,10 @@ 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. +Note that a block by itself is semantically identical to a loop +that executes once. Thus C<redo> inside such a block will effectively +turn it into a looping construct. + See also L</continue> for an illustration of how C<last>, C<next>, and C<redo> work. diff --git a/pod/perlguts.pod b/pod/perlguts.pod index af12297ec3..d0f916786c 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -107,9 +107,10 @@ 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: + SV *s; STRLEN len; char * ptr; - ptr = SvPV(len); + ptr = SvPV(s, len); foo(ptr, len); If you want to know if the scalar value is TRUE, you can use: @@ -2907,15 +2908,17 @@ Test two strings to see if they are different. Returns true or false. Test two strings to see if they are equal. The C<len> parameter indicates the number of bytes to compare. Returns true or false. +(A wrapper for C<strncmp>). - int strnEQ( char *s1, char *s2 ) + int strnEQ( const char *s1, const char *s2, size_t len ) =item strnNE Test two strings to see if they are different. The C<len> parameter indicates the number of bytes to compare. Returns true or false. +(A wrapper for C<strncmp>). - int strnNE( char *s1, char *s2, int len ) + int strnNE( const char *s1, const char *s2, size_t len ) =item sv_2mortal diff --git a/pod/perlmod.pod b/pod/perlmod.pod index 0031d6e0e6..fc81fdfaae 100644 --- a/pod/perlmod.pod +++ b/pod/perlmod.pod @@ -279,7 +279,7 @@ create a file called F<Some/Module.pm> and start with this template: BEGIN { use Exporter (); - use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); # set the version for version checking $VERSION = 1.00; @@ -294,10 +294,11 @@ create a file called F<Some/Module.pm> and start with this template: # as well as any optionally exported functions @EXPORT_OK = qw($Var1 %Hashit &func3); } - use vars @EXPORT_OK; + our @EXPORT_OK; # non-exported package globals go here - use vars qw(@more $stuff); + our @more; + our $stuff; # initialize package globals, first exported ones $Var1 = ''; diff --git a/pod/perlmodlib.pod b/pod/perlmodlib.pod index bfc5223819..99d31bd6e1 100644 --- a/pod/perlmodlib.pod +++ b/pod/perlmodlib.pod @@ -36,7 +36,7 @@ which lasts until the end of that BLOCK. Some pragmas are lexically scoped--typically those that affect the C<$^H> hints variable. Others affect the current package instead, -like C<use vars> and C<use subs>, whic allow you to predeclare a +like C<use vars> and C<use subs>, which allow you to predeclare a variables or subroutines within a particular I<file> rather than just a block. Such declarations are effective for the entire file for which they were declared. You cannot rescind them with C<no diff --git a/pod/perlsub.pod b/pod/perlsub.pod index 2beb3dea55..4abdc39529 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -353,7 +353,7 @@ which are always global, if you say then any variable mentioned from there to the end of the enclosing block must either refer to a lexical variable, be predeclared via -C<use vars>, or else must be fully qualified with the package name. +C<our> or C<use vars>, or else must be fully qualified with the package name. A compilation error results otherwise. An inner block may countermand this with C<no strict 'vars'>. diff --git a/pod/perltoot.pod b/pod/perltoot.pod index 89e5cbe993..3062f5924d 100644 --- a/pod/perltoot.pod +++ b/pod/perltoot.pod @@ -1124,8 +1124,7 @@ it happens when you say If you wanted to add version checking to your Person class explained above, just add this to Person.pm: - use vars qw($VERSION); - $VERSION = '1.1'; + our $VERSION = '1.1'; and then in Employee.pm could you can say @@ -1363,7 +1362,7 @@ constructor will look like when taking this approach: package Person; use Carp; - use vars qw($AUTOLOAD); # it's a package global + our $AUTOLOAD; # it's a package global my %fields = ( name => undef, @@ -1433,8 +1432,7 @@ Here's how to be careful: package Employee; use Person; use strict; - use vars qw(@ISA); - @ISA = qw(Person); + our @ISA = qw(Person); my %fields = ( id => undef, @@ -1560,16 +1558,15 @@ Here's the whole implementation: BEGIN { use Exporter (); - use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); - @EXPORT = qw(gethostbyname gethostbyaddr gethost); - @EXPORT_OK = qw( - $h_name @h_aliases - $h_addrtype $h_length - @h_addr_list $h_addr - ); - %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); + our @EXPORT = qw(gethostbyname gethostbyaddr gethost); + our @EXPORT_OK = qw( + $h_name @h_aliases + $h_addrtype $h_length + @h_addr_list $h_addr + ); + our %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); } - use vars @EXPORT_OK; + our @EXPORT_OK; # Class::Struct forbids use of @ISA sub import { goto &Exporter::import } @@ -1661,7 +1658,7 @@ update value fields in the hash. Convenient, eh? } use Alias qw(attr); - use vars qw($NAME $AGE $PEERS); + our ($NAME, $AGE, $PEERS); sub name { my $self = attr shift; @@ -1692,7 +1689,7 @@ update value fields in the hash. Convenient, eh? return ++$AGE; } -The need for the C<use vars> declaration is because what Alias does +The need for the C<our> declaration is because what Alias does is play with package globals with the same name as the fields. To use globals while C<use strict> is in effect, you have to predeclare them. These package variables are localized to the block enclosing the attr() diff --git a/pod/perlxstut.pod b/pod/perlxstut.pod index 4200140833..632f417496 100644 --- a/pod/perlxstut.pod +++ b/pod/perlxstut.pod @@ -92,19 +92,18 @@ The file Mytest.pm should start with something like this: package Mytest; use strict; - use vars qw($VERSION @ISA @EXPORT); require Exporter; require DynaLoader; - @ISA = qw(Exporter DynaLoader); + our @ISA = qw(Exporter DynaLoader); # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. - @EXPORT = qw( + our @EXPORT = qw( ); - $VERSION = '0.01'; + our $VERSION = '0.01'; bootstrap Mytest $VERSION; @@ -563,8 +562,7 @@ the following three lines: mylib/mylib.h To keep our namespace nice and unpolluted, edit the .pm file and change -the variable C<@EXPORT> to C<@EXPORT_OK> (there are two: one in the line -beginning "use vars" and one setting the array itself). Finally, in the +the variable C<@EXPORT> to C<@EXPORT_OK>. Finally, in the .xs file, edit the #include line to read: #include "mylib/mylib.h" diff --git a/pod/pod2man.PL b/pod/pod2man.PL index 20610a84c3..68d0c42b1e 100644 --- a/pod/pod2man.PL +++ b/pod/pod2man.PL @@ -9,7 +9,6 @@ use Cwd; # have to mention them as if they were shell variables, not # %Config entries. Thus you write # $startperl -# $man3ext # to ensure Configure will look for $Config{startperl}. # This forces PL files to create target in same directory as PL file. @@ -29,1206 +28,440 @@ print "Extracting $file (with variable substitutions)\n"; print OUT <<"!GROK!THIS!"; $Config{startperl} eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' - if \$running_under_some_shell; - -\$DEF_PM_SECTION = '$Config{man3ext}' || '3'; + if \$running_under_some_shell; !GROK!THIS! # In the following, perl variables are not expanded during extraction. print OUT <<'!NO!SUBS!'; -=head1 NAME - -pod2man - translate embedded Perl pod directives into man pages - -=head1 SYNOPSIS - -B<pod2man> -[ B<--section=>I<manext> ] -[ B<--release=>I<relpatch> ] -[ B<--center=>I<string> ] -[ B<--date=>I<string> ] -[ B<--fixed=>I<font> ] -[ B<--official> ] -[ B<--lax> ] -I<inputfile> - -=head1 DESCRIPTION - -B<pod2man> converts its input file containing embedded pod directives (see -L<perlpod>) into nroff source suitable for viewing with nroff(1) or -troff(1) using the man(7) macro set. - -Besides the obvious pod conversions, B<pod2man> also takes care of -func(), func(n), and simple variable references like $foo or @bar so -you don't have to use code escapes for them; complex expressions like -C<$fred{'stuff'}> will still need to be escaped, though. Other nagging -little roffish things that it catches include translating the minus in -something like foo-bar, making a long dash--like this--into a real em -dash, fixing up "paired quotes", putting a little space after the -parens in something like func(), making C++ and PI look right, making -double underbars have a little tiny space between them, making ALLCAPS -a teeny bit smaller in troff(1), and escaping backslashes so you don't -have to. - -=head1 OPTIONS - -=over 8 - -=item center - -Set the centered header to a specific string. The default is -"User Contributed Perl Documentation", unless the C<--official> flag is -given, in which case the default is "Perl Programmers Reference Guide". - -=item date - -Set the left-hand footer string to this value. By default, -the modification date of the input file will be used. - -=item fixed - -The fixed font to use for code refs. Defaults to CW. - -=item official - -Set the default header to indicate that this page is of -the standard release in case C<--center> is not given. - -=item release - -Set the centered footer. By default, this is the current -perl release. - -=item section - -Set the section for the C<.TH> macro. The standard conventions on -sections are to use 1 for user commands, 2 for system calls, 3 for -functions, 4 for devices, 5 for file formats, 6 for games, 7 for -miscellaneous information, and 8 for administrator commands. This works -best if you put your Perl man pages in a separate tree, like -F</usr/local/perl/man/>. By default, section 1 will be used -unless the file ends in F<.pm> in which case section 3 will be selected. - -=item lax - -Don't complain when required sections aren't present. - -=back - -=head1 Anatomy of a Proper Man Page - -For those not sure of the proper layout of a man page, here's -an example of the skeleton of a proper man page. Head of the -major headers should be setout as a C<=head1> directive, and -are historically written in the rather startling ALL UPPER CASE -format, although this is not mandatory. -Minor headers may be included using C<=head2>, and are -typically in mixed case. - -=over 10 - -=item NAME +# pod2man -- Convert POD data to formatted *roff input. +# +# Copyright 1999 by Russ Allbery <rra@stanford.edu> +# +# This program is free software; you can redistribute it and/or modify it +# under the same terms as Perl itself. +# +# The driver script for Pod::Man. This script is expected to eventually +# replace pod2man in the standard Perl distribution. + +require 5.004; + +use Getopt::Long qw(GetOptions); +use Pod::Man (); +use Pod::Usage qw(pod2usage); + +use strict; +use vars; + +# Parse our options, trying to retain backwards compatibility with pod2man +# but allowing short forms as well. --lax is currently ignored. +my %options; +Getopt::Long::config ('bundling'); +GetOptions (\%options, 'section|s=s', 'release|r=s', 'center|c=s', + 'date|d=s', 'fixed=s', 'fixedbold=s', 'fixeditalic=s', + 'fixedbolditalic=s', 'official|o', 'lax|l', 'help|h') or exit 1; +pod2usage (0) if $options{help}; + +# Official sets --center, but don't override things explicitly set. +if ($options{official} && !defined $options{center}) { + $options{center} = 'Perl Programmers Reference Guide'; +} -Mandatory section; should be a comma-separated list of programs or -functions documented by this podpage, such as: +# Initialize and run the formatter. +my $parser = Pod::Man->new (\%options); +$parser->parse_from_file (@ARGV); - foo, bar - programs to do something +__END__ -=item SYNOPSIS +=head1 NAME -A short usage summary for programs and functions, which -may someday be deemed mandatory. +pod2man - Convert POD data to formatted *roff input -=item DESCRIPTION +=head1 SYNOPSIS -Long drawn out discussion of the program. It's a good idea to break this -up into subsections using the C<=head2> directives, like +pod2txt [B<--section>=I<manext>] [B<--release>=I<version>] +[B<--center>=I<string>] [B<--date>=I<string>] [B<--fixed>=I<font>] +[B<--fixedbold>=I<font>] [B<--fixeditalic>=I<font>] +[B<--fixedbolditalic>=I<font>] [B<--official>] [B<--lax>] [I<input> +[I<output>]] - =head2 A Sample Subection +pod2txt B<--help> - =head2 Yet Another Sample Subection +=head1 DESCRIPTION -=item OPTIONS +B<pod2man> is a front-end for Pod::Man, using it to generate *roff input +from POD source. The resulting *roff code is suitable for display on a +terminal using nroff(1), normally via man(1), or printing using troff(1). + +I<input> is the file to read for POD source (the POD can be embedded in +code). If I<input> isn't given, it defaults to STDIN. I<output>, if given, +is the file to which to write the formatted output. If I<output> isn't +given, the formatted output is written to STDOUT. + +B<--section>, B<--release>, B<--center>, B<--date>, and B<--official> can be +used to set the headers and footers to use; if not given, Pod::Man will +assume various defaults. See below or L<Pod::Man> for details. + +B<pod2man> assumes that your *roff formatters have a fixed-width font named +CW. If yours is called something else (like CR), use B<--fixed> to specify +it. This generally only matters for troff output for printing. Similarly, +you can set the fonts used for bold, italic, and bold italic fixed-width +output. + +Besides the obvious pod conversions, Pod::Man, and therefore pod2man also +takes care of formatting func(), func(n), and simple variable references +like $foo or @bar so you don't have to use code escapes for them; complex +expressions like C<$fred{'stuff'}> will still need to be escaped, though. +It also translates dashes that aren't used as hyphens into en dashes, makes +long dashes--like this--into proper em dashes, fixes "paired quotes," and +takes care of several other troff-specific tweaks. See L<Pod::Man> for +complete information. -Some people make this separate from the description. +=head1 OPTIONS -=item RETURN VALUE +=over 4 -What the program or function returns if successful. +=item B<-c> I<string>, B<--center>=I<string> -=item ERRORS +Sets the centered page header to I<string>. The default is "User +Contributed Perl Documentation", but also see B<--official> below. -Exceptions, return codes, exit stati, and errno settings. +=item B<-d> I<string>, B<--date>=I<string> -=item EXAMPLES +Set the left-hand footer string to this value. By default, the modification +date of the input file will be used, or the current date if input comes from +STDIN. -Give some example uses of the program. +=item B<--fixed>=I<font> -=item ENVIRONMENT +The fixed-width font to use for vertabim text and code. Defaults to CW. +Some systems may want CR instead. Only matters for troff(1) output. -Envariables this program might care about. +=item B<--fixedbold>=I<font> -=item FILES +Bold version of the fixed-width font. Defaults to CB. Only matters for +troff(1) output. -All files used by the program. You should probably use the FE<lt>E<gt> -for these. +=item B<--fixeditalic>=I<font> -=item SEE ALSO +Italic version of the fixed-width font (actually, something of a misnomer, +since most fixed-width fonts only have an oblique version, not an italic +version). Defaults to CI. Only matters for troff(1) output. -Other man pages to check out, like man(1), man(7), makewhatis(8), or catman(8). +=item B<--fixedbolditalic>=I<font> -=item NOTES +Bold italic (probably actually oblique) version of the fixed-width font. +Pod::Man doesn't assume you have this, and defaults to CB. Some systems +(such as Solaris) have this font available as CX. Only matters for troff(1) +output. -Miscellaneous commentary. +=item B<-h>, B<--help> -=item CAVEATS +Print out usage information. -Things to take special care with; sometimes called WARNINGS. +=item B<-l>, B<--lax> -=item DIAGNOSTICS +Don't complain when required sections are missing. Not currently used, as +POD checking functionality is not yet implemented in Pod::Man. -All possible messages the program can print out--and -what they mean. +=item B<-o>, B<--official> -=item BUGS +Set the default header to indicate that this page is part of the standard +Perl release, if B<--center> is not also given. -Things that are broken or just don't work quite right. +=item B<-r>, B<--release> -=item RESTRICTIONS +Set the centered footer. By default, this is the version of Perl you run +B<pod2man> under. Note that some system an macro sets assume that the +centered footer will be a modification date and will prepend something like +"Last modified: "; if this is the case, you may want to set B<--release> to +the last modified date and B<--date> to the version number. -Bugs you don't plan to fix :-) +=item B<-s>, B<--section> -=item AUTHOR +Set the section for the C<.TH> macro. The standard section numbering +convention is to use 1 for user commands, 2 for system calls, 3 for +functions, 4 for devices, 5 for file formats, 6 for games, 7 for +miscellaneous information, and 8 for administrator commands. There is a lot +of variation here, however; some systems (like Solaris) use 4 for file +formats, 5 for miscellaneous information, and 7 for devices. Still others +use 1m instead of 8, or some mix of both. About the only section numbers +that are reliably consistent are 1, 2, and 3. -Who wrote it (or AUTHORS if multiple). +By default, section 1 will be used unless the file ends in .pm in which case +section 3 will be selected. -=item HISTORY +=back -Programs derived from other sources sometimes have this, or -you might keep a modification log here. +=head1 DIAGNOSTICS -=back +If B<pod2man> fails with errors, see L<Pod::Man> and L<Pod::Parser> for +information about what those errors might mean. =head1 EXAMPLES pod2man program > program.1 - pod2man some_module.pm > /usr/perl/man/man3/some_module.3 + pod2man SomeModule.pm /usr/perl/man/man3/SomeModule.3 pod2man --section=7 note.pod > note.7 -=head1 DIAGNOSTICS +If you would like to print out a lot of man page continuously, you probably +want to set the C and D registers to set contiguous page numbering and +even/odd paging, at least on some versions of man(7). -The following diagnostics are generated by B<pod2man>. Items -marked "(W)" are non-fatal, whereas the "(F)" errors will cause -B<pod2man> to immediately exit with a non-zero status. + troff -man -rC1 -rD1 perl.1 perldata.1 perlsyn.1 ... -=over 4 +To get index entries on stderr, turn on the F register, as in: -=item bad option in paragraph %d of %s: ``%s'' should be [%s]<%s> + troff -man -rF1 perl.1 -(W) If you start include an option, you should set it off -as bold, italic, or code. +The indexing merely outputs messages via C<.tm> for each major page, +section, subsection, item, and any C<XE<lt>E<gt>> directives. See +L<Pod::Man> for more details. -=item can't open %s: %s +=head1 BUGS -(F) The input file wasn't available for the given reason. +Lots of this documentation is duplicated from L<Pod::Man>. -=item Improper man page - no dash in NAME header in paragraph %d of %s +POD checking and the corresponding B<--lax> option don't work yet. -(W) The NAME header did not have an isolated dash in it. This is -considered important. +=head1 NOTES -=item Invalid man page - no NAME line in %s +For those not sure of the proper layout of a man page, here are some notes +on writing a proper man page. -(F) You did not include a NAME header, which is essential. +The name of the program being documented is conventionally written in bold +(using BE<lt>E<gt>) wherever it occurs, as are all program options. +Arguments should be written in italics (IE<lt>E<gt>). Functions are +traditionally written in italics; if you write a function as function(), +Pod::Man will take care of this for you. Literal code or commands should +be in CE<lt>E<gt>. References to other man pages should be in the form +C<manpage(section)>, and Pod::Man will automatically format those +appropriately. As an exception, it's traditional not to use this form when +referring to module documentation; use C<LE<lt>Module::NameE<gt>> instead. -=item roff font should be 1 or 2 chars, not `%s' (F) +References to other programs or functions are normally in the form of man +page references so that cross-referencing tools can provide the user with +links and the like. It's possible to overdo this, though, so be careful not +to clutter your documentation with too much markup. -(F) The font specified with the C<--fixed> option was not -a one- or two-digit roff font. +The major headers should be set out using a C<=head1> directive, and are +historically written in the rather startling ALL UPPER CASE format, although +this is not mandatory. Minor headers may be included using C<=head2>, and +are typically in mixed case. -=item %s is missing required section: %s +The standard sections of a manual page are: -(W) Required sections include NAME, DESCRIPTION, and if you're -using a section starting with a 3, also a SYNOPSIS. Actually, -not having a NAME is a fatal. +=over 4 -=item Unknown escape: %s in %s +=item NAME -(W) An unknown HTML entity (probably for an 8-bit character) was given via -a C<EE<lt>E<gt>> directive. Besides amp, lt, gt, and quot, recognized -entities are Aacute, aacute, Acirc, acirc, AElig, aelig, Agrave, agrave, -Aring, aring, Atilde, atilde, Auml, auml, Ccedil, ccedil, Eacute, eacute, -Ecirc, ecirc, Egrave, egrave, ETH, eth, Euml, euml, Iacute, iacute, Icirc, -icirc, Igrave, igrave, Iuml, iuml, Ntilde, ntilde, Oacute, oacute, Ocirc, -ocirc, Ograve, ograve, Oslash, oslash, Otilde, otilde, Ouml, ouml, szlig, -THORN, thorn, Uacute, uacute, Ucirc, ucirc, Ugrave, ugrave, Uuml, uuml, -Yacute, yacute, and yuml. +Mandatory section; should be a comma-separated list of programs or functions +documented by this podpage, such as: -=item Unmatched =back + foo, bar - programs to do something -(W) You have a C<=back> without a corresponding C<=over>. +Manual page indexers are often extremely picky about the format of this +section, so don't put anything in it except this line. A single dash, and +only a single dash, should separate the list of programs or functions from +the description. Functions should not be qualified with C<()> or the like. +The description should ideally fit on a single line, even if a man program +replaces the dash with a few tabs. -=item Unrecognized pod directive: %s +=item SYNOPSIS -(W) You specified a pod directive that isn't in the known list of -C<=head1>, C<=head2>, C<=item>, C<=over>, C<=back>, or C<=cut>. +A short usage summary for programs and functions. This section is mandatory +for section 3 pages. +=item DESCRIPTION -=back +Extended description and discussion of the program or functions, or the body +of the documentation for man pages that document something else. If +particularly long, it's a good idea to break this up into subsections +C<=head2> directives like: -=head1 NOTES + =head2 Normal Usage -If you would like to print out a lot of man page continuously, you -probably want to set the C and D registers to set contiguous page -numbering and even/odd paging, at least on some versions of man(7). -Settting the F register will get you some additional experimental -indexing: + =head2 Advanced Features - troff -man -rC1 -rD1 -rF1 perl.1 perldata.1 perlsyn.1 ... + =head2 Writing Configuration Files -The indexing merely outputs messages via C<.tm> for each -major page, section, subsection, item, and any C<XE<lt>E<gt>> -directives. +or whatever is appropriate for your documentation. +=item OPTIONS -=head1 RESTRICTIONS +Detailed description of each of the command-line options taken by the +program. This should be separate from the description for the use of things +like L<Pod::Usage|Pod::Usage>. This is normally presented as a list, with +each option as a separate C<=item>. The specific option string should be +enclosed in BE<lt>E<gt>. Any values that the option takes should be +enclosed in IE<lt>E<gt>. For example, the section for the option +B<--section>=I<manext> would be introduced with: -None at this time. + =item B<--section>=I<manext> -=head1 BUGS +Synonymous options (like both the short and long forms) are separated by a +comma and a space on the same C<=item> line, or optionally listed as their +own item with a reference to the canonical name. For example, since +B<--section> can also be written as B<-s>, the above would be: -The =over and =back directives don't really work right. They -take absolute positions instead of offsets, don't nest well, and -making people count is suboptimal in any event. + =item B<-s> I<manext>, B<--section>=I<manext> -=head1 AUTHORS +(Writing the short option first is arguably easier to read, since the long +option is long enough to draw the eye to it anyway and the short option can +otherwise get lost in visual noise.) -Original prototype by Larry Wall, but so massively hacked over by -Tom Christiansen such that Larry probably doesn't recognize it anymore. +=item RETURN VALUE -=cut +What the program or function returns, if successful. This section can be +omitted for programs whose precise exit codes aren't important, provided +they return 0 on success as is standard. It should always be present for +functions. -$/ = ""; -$cutting = 1; -@Indices = (); - -# We try first to get the version number from a local binary, in case we're -# 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') { - 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; -$DEF_RELEASE = "perl $version"; -$DEF_RELEASE .= ", patch $patch" if $patch; - - -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"; -} +=item ERRORS -use Getopt::Long; - -$DEF_SECTION = 1; -$DEF_CENTER = "User Contributed Perl Documentation"; -$STD_CENTER = "Perl Programmers Reference Guide"; -$DEF_FIXED = 'CW'; -$DEF_LAX = 0; - -sub usage { - warn "$0: @_\n" if @_; - die <<EOF; -usage: $0 [options] podpage -Options are: - --section=manext (default "$DEF_SECTION") - --release=relpatch (default "$DEF_RELEASE") - --center=string (default "$DEF_CENTER") - --date=string (default "$DEF_DATE") - --fixed=font (default "$DEF_FIXED") - --official (default NOT) - --lax (default NOT) -EOF -} +Exceptions, error return codes, exit stati, and errno settings. Typically +used for function documentation; program documentation uses DIAGNOSTICS +instead. The general rule of thumb is that errors printed to STDOUT or +STDERR and intended for the end user are documented in DIAGNOSTICS while +errors passed internal to the calling program and intended for other +programmers are documented in ERRORS. When documenting a function that sets +errno, a full list of the possible errno values should be given here. -$uok = GetOptions( qw( - section=s - release=s - center=s - date=s - fixed=s - official - lax - help)); +=item DIAGNOSTICS -$DEF_DATE = makedate((stat($ARGV[0]))[9] || time()); +All possible messages the program can print out--and what they mean. You +may wish to follow the same documentation style as the Perl documentation; +see perldiag(1) for more details (and look at the POD source as well). -usage("Usage error!") unless $uok; -usage() if $opt_help; -usage("Need one and only one podpage argument") unless @ARGV == 1; +If applicable, please include details on what the user should do to correct +the error; documenting an error as indicating "the input buffer is too +small" without telling the user how to increase the size of the input buffer +(or at least telling them that it isn't possible) aren't very useful. -$section = $opt_section || ($ARGV[0] =~ /\.pm$/ - ? $DEF_PM_SECTION : $DEF_SECTION); -$RP = $opt_release || $DEF_RELEASE; -$center = $opt_center || ($opt_official ? $STD_CENTER : $DEF_CENTER); -$lax = $opt_lax || $DEF_LAX; +=item EXAMPLES -$CFont = $opt_fixed || $DEF_FIXED; +Give some example uses of the program or function. Don't skimp; users often +find this the most useful part of the documentation. The examples are +generally given as verbatim paragraphs. -if (length($CFont) == 2) { - $CFont_embed = "\\f($CFont"; -} -elsif (length($CFont) == 1) { - $CFont_embed = "\\f$CFont"; -} -else { - die "roff font should be 1 or 2 chars, not `$CFont_embed'"; -} +Don't just present an example without explaining what it does. Adding a +short paragraph saying what the example will do can increase the value of +the example immensely. -$date = $opt_date || $DEF_DATE; +=item ENVIRONMENT -for (qw{NAME DESCRIPTION}) { -# for (qw{NAME DESCRIPTION AUTHOR}) { - $wanna_see{$_}++; -} -$wanna_see{SYNOPSIS}++ if $section =~ /^3/; +Environment variables that the program cares about, normally presented as a +list using C<=over>, C<=item>, and C<=back>. For example: + =over 6 -$name = @ARGV ? $ARGV[0] : "<STDIN>"; -$Filename = $name; -if ($section =~ /^1/) { - require File::Basename; - $name = uc File::Basename::basename($name); -} -$name =~ s/\.(pod|p[lm])$//i; - -# Lose everything up to the first of -# */lib/*perl* standard or site_perl module -# */*perl*/lib from -D prefix=/opt/perl -# */*perl*/ random module hierarchy -# which works. -$name =~ s-//+-/-g; -if ($name =~ s-^.*?/lib/[^/]*perl[^/]*/--i - or $name =~ s-^.*?/[^/]*perl[^/]*/lib/--i - or $name =~ s-^.*?/[^/]*perl[^/]*/--i) { - # Lose ^site(_perl)?/. - $name =~ s-^site(_perl)?/--; - # Lose ^arch/. (XXX should we use Config? Just for archname?) - $name =~ s~^(.*-$^O|$^O-.*)/~~o; - # Lose ^version/. - $name =~ s-^\d+\.\d+/--; -} + =item HOME -# Translate Getopt/Long to Getopt::Long, etc. -$name =~ s(/)(::)g; - -if ($name ne 'something') { - FCHECK: { - open(F, "< $ARGV[0]") || die "can't open $ARGV[0]: $!"; - while (<F>) { - next unless /^=\b/; - if (/^=head1\s+NAME\s*$/) { # an /m would forgive mistakes - $_ = <F>; - unless (/\s*-+\s+/) { - $oops++; - warn "$0: Improper man page - no dash in NAME header in paragraph $. of $ARGV[0]\n" - } else { - my @n = split /\s+-+\s+/; - if (@n != 2) { - $oops++; - warn "$0: Improper man page - malformed NAME header in paragraph $. of $ARGV[0]\n" - } - else { - %namedesc = @n; - } - } - last FCHECK; - } - next if /^=cut\b/; # DB_File and Net::Ping have =cut before NAME - next if /^=pod\b/; # It is OK to have =pod before NAME - die "$0: Invalid man page - 1st pod line is not NAME in $ARGV[0]\n" unless $lax; - } - die "$0: Invalid man page - no documentation in $ARGV[0]\n" unless $lax; - } - close F; -} + Used to determine the user's home directory. F<.foorc> in this + directory is read for configuration details, if it exists. -print <<"END"; -.rn '' }` -''' \$RCSfile\$\$Revision\$\$Date\$ -''' -''' \$Log\$ -''' -.de Sh -.br -.if t .Sp -.ne 5 -.PP -\\fB\\\\\$1\\fR -.PP -.. -.de Sp -.if t .sp .5v -.if n .sp -.. -.de Ip -.br -.ie \\\\n(.\$>=3 .ne \\\\\$3 -.el .ne 3 -.IP "\\\\\$1" \\\\\$2 -.. -.de Vb -.ft $CFont -.nf -.ne \\\\\$1 -.. -.de Ve -.ft R - -.fi -.. -''' -''' -''' Set up \\*(-- to give an unbreakable dash; -''' string Tr holds user defined translation string. -''' Bell System Logo is used as a dummy character. -''' -.tr \\(*W-|\\(bv\\*(Tr -.ie n \\{\\ -.ds -- \\(*W- -.ds PI pi -.if (\\n(.H=4u)&(1m=24u) .ds -- \\(*W\\h'-12u'\\(*W\\h'-12u'-\\" diablo 10 pitch -.if (\\n(.H=4u)&(1m=20u) .ds -- \\(*W\\h'-12u'\\(*W\\h'-8u'-\\" diablo 12 pitch -.ds L" "" -.ds R" "" -''' \\*(M", \\*(S", \\*(N" and \\*(T" are the equivalent of -''' \\*(L" and \\*(R", except that they are used on ".xx" lines, -''' such as .IP and .SH, which do another additional levels of -''' double-quote interpretation -.ds M" """ -.ds S" """ -.ds N" """"" -.ds T" """"" -.ds L' ' -.ds R' ' -.ds M' ' -.ds S' ' -.ds N' ' -.ds T' ' -'br\\} -.el\\{\\ -.ds -- \\(em\\| -.tr \\*(Tr -.ds L" `` -.ds R" '' -.ds M" `` -.ds S" '' -.ds N" `` -.ds T" '' -.ds L' ` -.ds R' ' -.ds M' ` -.ds S' ' -.ds N' ` -.ds T' ' -.ds PI \\(*p -'br\\} -END - -print <<'END'; -.\" If the F register is turned on, we'll generate -.\" index entries out stderr for the following things: -.\" TH Title -.\" SH Header -.\" Sh Subsection -.\" Ip Item -.\" X<> Xref (embedded -.\" Of course, you have to process the output yourself -.\" in some meaninful fashion. -.if \nF \{ -.de IX -.tm Index:\\$1\t\\n%\t"\\$2" -.. -.nr % 0 -.rr F -.\} -END - -print <<"END"; -.TH $name $section "$date" "$RP" "$center" -.UC -END - -push(@Indices, qq{.IX Title "$name $section"}); - -while (($name, $desc) = each %namedesc) { - for ($name, $desc) { s/^\s+//; s/\s+$//; } - push(@Indices, qq(.IX Name "$name - $desc"\n)); -} + =back -print <<'END'; -.if n .hy 0 -.if n .na -.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p' -.de CQ \" put $1 in typewriter font -END -print ".ft $CFont\n"; -print <<'END'; -'if n "\c -'if t \\&\\$1\c -'if n \\&\\$1\c -'if n \&" -\\&\\$2 \\$3 \\$4 \\$5 \\$6 \\$7 -'.ft R -.. -.\" @(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2 -. \" AM - accent mark definitions -.bd B 3 -. \" fudge factors for nroff and troff -.if n \{\ -. ds #H 0 -. ds #V .8m -. ds #F .3m -. ds #[ \f1 -. ds #] \fP -.\} -.if t \{\ -. ds #H ((1u-(\\\\n(.fu%2u))*.13m) -. ds #V .6m -. ds #F 0 -. ds #[ \& -. ds #] \& -.\} -. \" simple accents for nroff and troff -.if n \{\ -. ds ' \& -. ds ` \& -. ds ^ \& -. ds , \& -. ds ~ ~ -. ds ? ? -. ds ! ! -. ds / -. ds q -.\} -.if t \{\ -. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u" -. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u' -. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u' -. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u' -. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u' -. ds ? \s-2c\h'-\w'c'u*7/10'\u\h'\*(#H'\zi\d\s+2\h'\w'c'u*8/10' -. ds ! \s-2\(or\s+2\h'-\w'\(or'u'\v'-.8m'.\v'.8m' -. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u' -. ds q o\h'-\w'o'u*8/10'\s-4\v'.4m'\z\(*i\v'-.4m'\s+4\h'\w'o'u*8/10' -.\} -. \" troff and (daisy-wheel) nroff accents -.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V' -.ds 8 \h'\*(#H'\(*b\h'-\*(#H' -.ds v \\k:\h'-(\\n(.wu*9/10-\*(#H)'\v'-\*(#V'\*(#[\s-4v\s0\v'\*(#V'\h'|\\n:u'\*(#] -.ds _ \\k:\h'-(\\n(.wu*9/10-\*(#H+(\*(#F*2/3))'\v'-.4m'\z\(hy\v'.4m'\h'|\\n:u' -.ds . \\k:\h'-(\\n(.wu*8/10)'\v'\*(#V*4/10'\z.\v'-\*(#V*4/10'\h'|\\n:u' -.ds 3 \*(#[\v'.2m'\s-2\&3\s0\v'-.2m'\*(#] -.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#] -.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H' -.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u' -.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#] -.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#] -.ds ae a\h'-(\w'a'u*4/10)'e -.ds Ae A\h'-(\w'A'u*4/10)'E -.ds oe o\h'-(\w'o'u*4/10)'e -.ds Oe O\h'-(\w'O'u*4/10)'E -. \" corrections for vroff -.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u' -.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u' -. \" for low resolution devices (crt and lpr) -.if \n(.H>23 .if \n(.V>19 \ -\{\ -. ds : e -. ds 8 ss -. ds v \h'-1'\o'\(aa\(ga' -. ds _ \h'-1'^ -. ds . \h'-1'. -. ds 3 3 -. ds o a -. ds d- d\h'-1'\(ga -. ds D- D\h'-1'\(hy -. ds th \o'bp' -. ds Th \o'LP' -. ds ae ae -. ds Ae AE -. ds oe oe -. ds Oe OE -.\} -.rm #[ #] #H #V #F C -END - -$indent = 0; - -$begun = ""; - -# Unrolling [^-=A-Z>]|[A-Z](?!<)|[-=](?![A-Z]<)[\x00-\xFF] gives: // MRE pp 165. -my $nonest = q{(?x) # Turn on /x mode. - (?: # Group - [^-=A-Z>]* # Anything that isn't a dash, equal sign or - # closing hook isn't special. Eat as much as - # we can. - (?: # Group. - (?: # Group. - [-=] # We want to recognize -> and =>. - (?![A-Z]<) # So, as long as it isn't followed by markup - [\x00-\xFF] # anything may follow - and = - | - [A-Z] # Capitals are fine too, - (?!<) # But not if they start markup. - ) # End of special sequences. - [^-=A-Z>]* # Followed by zero or more non-special chars. - )* # And we can repeat this as often as we can. - )}; # That's all folks. - -while (<>) { - if ($cutting) { - next unless /^=/; - $cutting = 0; - } - if ($begun) { - if (/^=end\s+$begun/) { - $begun = ""; - } - elsif ($begun =~ /^(roff|man)$/) { - print STDOUT $_; - } - next; - } - chomp; - - # Translate verbatim paragraph - - if (/^\s/) { - @lines = split(/\n/); - for (@lines) { - 1 while s - {^( [^\t]* ) \t ( \t* ) } - { $1 . ' ' x (8 - (length($1)%8) + 8 * (length($2))) }ex; - s/\\/\\e/g; - s/\A/\\&/s; - } - $lines = @lines; - makespace() unless $verbatim++; - print ".Vb $lines\n"; - print join("\n", @lines), "\n"; - print ".Ve\n"; - $needspace = 0; - next; - } - - $verbatim = 0; - - if (/^=for\s+(\S+)\s*/s) { - if ($1 eq "man" or $1 eq "roff") { - print STDOUT $',"\n\n"; - } else { - # ignore unknown for - } - next; - } - elsif (/^=begin\s+(\S+)\s*/s) { - $begun = $1; - if ($1 eq "man" or $1 eq "roff") { - print STDOUT $'."\n\n"; - } - next; - } - - # check for things that'll hosed our noremap scheme; affects $_ - init_noremap(); - - if (!/^=item/) { - - # trofficate backslashes; must do it before what happens below - s/\\/noremap('\\e')/ge; - - # protect leading periods and quotes against *roff - # mistaking them for directives - s/^(?:[A-Z]<)?[.']/\\&$&/gm; - - # first hide the escapes in case we need to - # intuit something and get it wrong due to fmting - - 1 while s/([A-Z]<$nonest>)/noremap($1)/ge; - - # func() is a reference to a perl function - s{ - \b - ( - [:\w]+ \(\) - ) - } {I<$1>}gx; - - # func(n) is a reference to a perl function or a man page - s{ - ([:\w]+) - ( - \( [^\051]+ \) - ) - } {I<$1>\\|$2}gx; - - # convert simple variable references - s/(\s+)([\$\@%&*][\w:]+)(?!\()/${1}C<$2>/g; - - if (m{ ( - [\-\w]+ - \( - [^\051]*? - [\@\$,] - [^\051]*? - \) - ) - }x && $` !~ /([LCI]<[^<>]*|-)$/ && !/^=\w/) - { - warn "$0: bad option in paragraph $. of $ARGV: ``$1'' should be [LCI]<$1>\n"; - $oops++; - } - - while (/(-[a-zA-Z])\b/g && $` !~ /[\w\-]$/) { - warn "$0: bad option in paragraph $. of $ARGV: ``$1'' should be [CB]<$1>\n"; - $oops++; - } - - # put it back so we get the <> processed again; - clear_noremap(0); # 0 means leave the E's - - } else { - # trofficate backslashes - s/\\/noremap('\\e')/ge; - - } - - # need to hide E<> first; they're processed in clear_noremap - s/(E<[^<>]+>)/noremap($1)/ge; - - - $maxnest = 10; - while ($maxnest-- && /[A-Z]</) { - - # can't do C font here - s/([BI])<($nonest)>/font($1) . $2 . font('R')/eg; - - # files and filelike refs in italics - s/F<($nonest)>/I<$1>/g; - - # no break -- usually we want C<> for this - s/S<($nonest)>/nobreak($1)/eg; - - # LREF: a la HREF L<show this text|man/section> - s:L<([^|>]+)\|[^>]+>:$1:g; - - # LREF: a manpage(3f) - s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))?>:the I<$1>$2 manpage:g; - - # LREF: an =item on another manpage - s{ - L< - ([^/]+) - / - ( - [:\w]+ - (\(\))? - ) - > - } {the C<$2> entry in the I<$1> manpage}gx; - - # LREF: an =item on this manpage - s{ - ((?: - L< - / - ( - [:\w]+ - (\(\))? - ) - > - (,?\s+(and\s+)?)? - )+) - } { internal_lrefs($1) }gex; - - # LREF: a =head2 (head1?), maybe on a manpage, maybe right here - # the "func" can disambiguate - s{ - L< - (?: - ([a-zA-Z]\S+?) / - )? - "?(.*?)"? - > - }{ - do { - $1 # if no $1, assume it means on this page. - ? "the section on I<$2> in the I<$1> manpage" - : "the section on I<$2>" - } - }gesx; # s in case it goes over multiple lines, so . matches \n - - s/Z<>/\\&/g; - - # comes last because not subject to reprocessing - s/C<($nonest)>/noremap("${CFont_embed}${1}\\fR")/eg; - } - - if (s/^=//) { - $needspace = 0; # Assume this. - - s/\n/ /g; - - ($Cmd, $_) = split(' ', $_, 2); - - $dotlevel = 1; - if ($Cmd eq 'head1') { - $dotlevel = 1; - } - elsif ($Cmd eq 'head2') { - $dotlevel = 1; - } - elsif ($Cmd eq 'item') { - $dotlevel = 2; - } - - if (defined $_) { - &escapes($dotlevel); - s/"/""/g; - } - - clear_noremap(1); - - if ($Cmd eq 'cut') { - $cutting = 1; - } - elsif ($Cmd eq 'head1') { - s/\s+$//; - delete $wanna_see{$_} if exists $wanna_see{$_}; - print qq{.SH "$_"\n}; - push(@Indices, qq{.IX Header "$_"\n}); - } - elsif ($Cmd eq 'head2') { - print qq{.Sh "$_"\n}; - push(@Indices, qq{.IX Subsection "$_"\n}); - } - elsif ($Cmd eq 'over') { - push(@indent,$indent); - $indent += ($_ + 0) || 5; - } - elsif ($Cmd eq 'back') { - $indent = pop(@indent); - warn "$0: Unmatched =back in paragraph $. of $ARGV\n" unless defined $indent; - $needspace = 1; - } - elsif ($Cmd eq 'item') { - s/^\*( |$)/\\(bu$1/g; - # if you know how to get ":s please do - s/\\\*\(L"([^"]+?)\\\*\(R"/'$1'/g; - s/\\\*\(L"([^"]+?)""/'$1'/g; - s/[^"]""([^"]+?)""[^"]/'$1'/g; - # here do something about the $" in perlvar? - print STDOUT qq{.Ip "$_" $indent\n}; - push(@Indices, qq{.IX Item "$_"\n}); - } - elsif ($Cmd eq 'pod') { - # this is just a comment - } - else { - warn "$0: Unrecognized pod directive in paragraph $. of $ARGV: $Cmd\n"; - } - } - else { - if ($needspace) { - &makespace; - } - &escapes(0); - clear_noremap(1); - print $_, "\n"; - $needspace = 1; - } -} +Since environment variables are normally in all uppercase, no additional +special formatting is generally needed; they're glaring enough as it is. -print <<"END"; +=item FILES -.rn }` '' -END +All files used by the program or function, normally presented as a list, and +what it uses them for. File names should be enclosed in FE<lt>E<gt>. It's +particularly important to document files that will be potentially modified. -if (%wanna_see && !$lax) { - @missing = keys %wanna_see; - warn "$0: $Filename is missing required section" - . (@missing > 1 && "s") - . ": @missing\n"; - $oops++; -} +=item CAVEATS -foreach (@Indices) { print "$_\n"; } +Things to take special care with, sometimes called WARNINGS. -exit; -#exit ($oops != 0); +=item BUGS -######################################################################### +Things that are broken or just don't work quite right. -sub nobreak { - my $string = shift; - $string =~ s/ /\\ /g; - $string; -} +=item RESTRICTIONS -sub escapes { - my $indot = shift; - - s/X<(.*?)>/mkindex($1)/ge; - - # translate the minus in foo-bar into foo\-bar for roff - s/([^0-9a-z-])-([^-])/$1\\-$2/g; - - # make -- into the string version \*(-- (defined above) - s/\b--\b/\\*(--/g; - s/"--([^"])/"\\*(--$1/g; # should be a better way - s/([^"])--"/$1\\*(--"/g; - - # fix up quotes; this is somewhat tricky - my $dotmacroL = 'L'; - my $dotmacroR = 'R'; - if ( $indot == 1 ) { - $dotmacroL = 'M'; - $dotmacroR = 'S'; - } - elsif ( $indot >= 2 ) { - $dotmacroL = 'N'; - $dotmacroR = 'T'; - } - if (!/""/) { - s/(^|\s)(['"])/noremap("$1\\*($dotmacroL$2")/ge; - s/(['"])($|[\-\s,;\\!?.])/noremap("\\*($dotmacroR$1$2")/ge; - } - - #s/(?!")(?:.)--(?!")(?:.)/\\*(--/g; - #s/(?:(?!")(?:.)--(?:"))|(?:(?:")--(?!")(?:.))/\\*(--/g; - - - # make sure that func() keeps a bit a space tween the parens - ### s/\b\(\)/\\|()/g; - ### s/\b\(\)/(\\|)/g; - - # make C++ into \*C+, which is a squinched version (defined above) - s/\bC\+\+/\\*(C+/g; - - # make double underbars have a little tiny space between them - s/__/_\\|_/g; - - # PI goes to \*(PI (defined above) - s/\bPI\b/noremap('\\*(PI')/ge; - - # make all caps a teeny bit smaller, but don't muck with embedded code literals - my $hidCFont = font('C'); - if ($Cmd !~ /^head1/) { # SH already makes smaller - # /g isn't enough; 1 while or we'll be off - -# 1 while s{ -# (?!$hidCFont)(..|^.|^) -# \b -# ( -# [A-Z][\/A-Z+:\-\d_$.]+ -# ) -# (s?) -# \b -# } {$1\\s-1$2\\s0}gmox; - - 1 while s{ - (?!$hidCFont)(..|^.|^) - ( - \b[A-Z]{2,}[\/A-Z+:\-\d_\$]*\b - ) - } { - $1 . noremap( '\\s-1' . $2 . '\\s0' ) - }egmox; - - } -} +Bugs you don't plan to fix. :-) -# make troff just be normal, but make small nroff get quoted -# decided to just put the quotes in the text; sigh; -sub ccvt { - local($_,$prev) = @_; - noremap(qq{.CQ "$_" \n\\&}); -} +=item NOTES -sub makespace { - if ($indent) { - print ".Sp\n"; - } - else { - print ".PP\n"; - } -} +Miscellaneous commentary. -sub mkindex { - my ($entry) = @_; - my @entries = split m:\s*/\s*:, $entry; - push @Indices, ".IX Xref " . join ' ', map {qq("$_")} @entries; - return ''; -} +=item SEE ALSO -sub font { - local($font) = shift; - return '\\f' . noremap($font); -} +Other man pages to check out, like man(1), man(7), makewhatis(8), or +catman(8). Normally a simple list of man pages separated by commas, or a +paragraph giving the name of a reference work. Man page references, if they +use the standard C<name(section)> form, don't have to be enclosed in +LE<lt>E<gt>, but other things in this section probably should be when +appropriate. You may need to use the C<LE<lt>...|...E<gt>> syntax to keep +B<pod2man> and B<pod2text> from being too verbose; see perlpod(1). -sub noremap { - local($thing_to_hide) = shift; - $thing_to_hide =~ tr/\000-\177/\200-\377/; - return $thing_to_hide; -} +If the package has a web site, include a URL here. -sub init_noremap { - # escape high bit characters in input stream - s/([\200-\377])/"E<".ord($1).">"/ge; -} +=item AUTHOR -sub clear_noremap { - my $ready_to_print = $_[0]; - - tr/\200-\377/\000-\177/; - - # trofficate backslashes - # s/(?!\\e)(?:..|^.|^)\\/\\e/g; - - # now for the E<>s, which have been hidden until now - # otherwise the interative \w<> processing would have - # been hosed by the E<gt> - s { - E< - ( - ( \d + ) - | ( [A-Za-z]+ ) - ) - > - } { - do { - defined $2 - ? chr($2) - : - exists $HTML_Escapes{$3} - ? do { $HTML_Escapes{$3} } - : do { - warn "$0: Unknown escape in paragraph $. of $ARGV: ``$&''\n"; - "E<$1>"; - } - } - }egx if $ready_to_print; -} +Who wrote it (use AUTHORS for multiple people). Including your current +e-mail address (or some e-mail address to which bug reports should be sent) +so that users have a way of contacting you is a good idea. Remember that +program documentation tends to roam the wild for far longer than you expect +and pick an e-mail address that's likely to last if possible. -sub internal_lrefs { - local($_) = shift; - local $trailing_and = s/and\s+$// ? "and " : ""; - - s{L</([^>]+)>}{$1}g; - my(@items) = split( /(?:,?\s+(?:and\s+)?)/ ); - my $retstr = "the "; - my $i; - for ($i = 0; $i <= $#items; $i++) { - $retstr .= "C<$items[$i]>"; - $retstr .= ", " if @items > 2 && $i != $#items; - $retstr .= " and " if $i+2 == @items; - } - - $retstr .= " entr" . ( @items > 1 ? "ies" : "y" ) - . " elsewhere in this document"; - # terminal space to avoid words running together (pattern used - # strips terminal spaces) - $retstr .= " " if length $trailing_and; - $retstr .= $trailing_and; - - return $retstr; +=item HISTORY -} +Programs derived from other sources sometimes have this, or you might keep a +modification log here. -BEGIN { -%HTML_Escapes = ( - 'amp' => '&', # ampersand - 'lt' => '<', # left chevron, less-than - 'gt' => '>', # right chevron, greater-than - 'quot' => '"', # double quote - - "Aacute" => "A\\*'", # capital A, acute accent - "aacute" => "a\\*'", # small a, acute accent - "Acirc" => "A\\*^", # capital A, circumflex accent - "acirc" => "a\\*^", # small a, circumflex accent - "AElig" => '\*(AE', # capital AE diphthong (ligature) - "aelig" => '\*(ae', # small ae diphthong (ligature) - "Agrave" => "A\\*`", # capital A, grave accent - "agrave" => "A\\*`", # small a, grave accent - "Aring" => 'A\\*o', # capital A, ring - "aring" => 'a\\*o', # small a, ring - "Atilde" => 'A\\*~', # capital A, tilde - "atilde" => 'a\\*~', # small a, tilde - "Auml" => 'A\\*:', # capital A, dieresis or umlaut mark - "auml" => 'a\\*:', # small a, dieresis or umlaut mark - "Ccedil" => 'C\\*,', # capital C, cedilla - "ccedil" => 'c\\*,', # small c, cedilla - "Eacute" => "E\\*'", # capital E, acute accent - "eacute" => "e\\*'", # small e, acute accent - "Ecirc" => "E\\*^", # capital E, circumflex accent - "ecirc" => "e\\*^", # small e, circumflex accent - "Egrave" => "E\\*`", # capital E, grave accent - "egrave" => "e\\*`", # small e, grave accent - "ETH" => '\\*(D-', # capital Eth, Icelandic - "eth" => '\\*(d-', # small eth, Icelandic - "Euml" => "E\\*:", # capital E, dieresis or umlaut mark - "euml" => "e\\*:", # small e, dieresis or umlaut mark - "Iacute" => "I\\*'", # capital I, acute accent - "iacute" => "i\\*'", # small i, acute accent - "Icirc" => "I\\*^", # capital I, circumflex accent - "icirc" => "i\\*^", # small i, circumflex accent - "Igrave" => "I\\*`", # capital I, grave accent - "igrave" => "i\\*`", # small i, grave accent - "Iuml" => "I\\*:", # capital I, dieresis or umlaut mark - "iuml" => "i\\*:", # small i, dieresis or umlaut mark - "Ntilde" => 'N\*~', # capital N, tilde - "ntilde" => 'n\*~', # small n, tilde - "Oacute" => "O\\*'", # capital O, acute accent - "oacute" => "o\\*'", # small o, acute accent - "Ocirc" => "O\\*^", # capital O, circumflex accent - "ocirc" => "o\\*^", # small o, circumflex accent - "Ograve" => "O\\*`", # capital O, grave accent - "ograve" => "o\\*`", # small o, grave accent - "Oslash" => "O\\*/", # capital O, slash - "oslash" => "o\\*/", # small o, slash - "Otilde" => "O\\*~", # capital O, tilde - "otilde" => "o\\*~", # small o, tilde - "Ouml" => "O\\*:", # capital O, dieresis or umlaut mark - "ouml" => "o\\*:", # small o, dieresis or umlaut mark - "szlig" => '\*8', # small sharp s, German (sz ligature) - "THORN" => '\\*(Th', # capital THORN, Icelandic - "thorn" => '\\*(th',, # small thorn, Icelandic - "Uacute" => "U\\*'", # capital U, acute accent - "uacute" => "u\\*'", # small u, acute accent - "Ucirc" => "U\\*^", # capital U, circumflex accent - "ucirc" => "u\\*^", # small u, circumflex accent - "Ugrave" => "U\\*`", # capital U, grave accent - "ugrave" => "u\\*`", # small u, grave accent - "Uuml" => "U\\*:", # capital U, dieresis or umlaut mark - "uuml" => "u\\*:", # small u, dieresis or umlaut mark - "Yacute" => "Y\\*'", # capital Y, acute accent - "yacute" => "y\\*'", # small y, acute accent - "yuml" => "y\\*:", # small y, dieresis or umlaut mark -); -} +=back + +In addition, some systems use CONFORMING TO to note conformance to relevant +standards and MT-LEVEL to note safeness for use in threaded programs or +signal handlers. These headings are primarily useful when documenting parts +of a C library. Documentation of object-oriented libraries or modules may +use CONSTRUCTORS and METHODS sections for detailed documentation of the +parts of the library and save the DESCRIPTION section for an overview; other +large modules may use FUNCTIONS for similar reasons. Some people use +OVERVIEW to summarize the description if it's quite long. Sometimes there's +an additional COPYRIGHT section at the bottom, for licensing terms. +AVAILABILITY is sometimes added, giving the canonical download site for the +software or a URL for updates. + +Section ordering varies, although NAME should I<always> be the first section +(you'll break some man page systems otherwise), and NAME, SYNOPSIS, +DESCRIPTION, and OPTIONS generally always occur first and in that order if +present. In general, SEE ALSO, AUTHOR, and similar material should be left +for last. Some systems also move WARNINGS and NOTES to last. The order +given above should be reasonable for most purposes. + +Finally, as a general note, try not to use an excessive amount of markup. +As documented here and in L<Pod::Man>, you can safely leave Perl variables, +function names, man page references, and the like unadorned by markup and +the POD translators will figure it out for you. This makes it much easier +to later edit the documentation. Note that many existing translators +(including this one currently) will do the wrong thing with e-mail addresses +or URLs when wrapped in LE<lt>E<gt>, so don't do that. + +For additional information that may be more accurate for your specific +system, see either man(5) or man(7) depending on your system manual section +numbering conventions. + +=head1 SEE ALSO + +L<Pod::Man|Pod::Man>, L<Pod::Parser|Pod::Parser>, man(1), nroff(1), +troff(1), man(7) + +The man page documenting the an macro set may be man(5) instead of man(7) on +your system. + +=head1 AUTHOR + +Russ Allbery E<lt>rra@stanford.eduE<gt>, based I<very> heavily on the +original B<pod2man> by Larry Wall and Tom Christiansen. Large portions of +this documentation, particularly the sections on the anatomy of a proper man +page, are taken from the B<pod2man> documentation by Tom. +=cut !NO!SUBS! close OUT or die "Can't close $file: $!"; diff --git a/pod/pod2text.PL b/pod/pod2text.PL index 92b26feceb..79cf8b219b 100644 --- a/pod/pod2text.PL +++ b/pod/pod2text.PL @@ -28,23 +28,22 @@ print "Extracting $file (with variable substitutions)\n"; print OUT <<"!GROK!THIS!"; $Config{startperl} eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' - if \$running_under_some_shell; + if \$running_under_some_shell; !GROK!THIS! # In the following, perl variables are not expanded during extraction. print OUT <<'!NO!SUBS!'; -$ID = q$Id: pod2text,v 0.1 1999/06/13 02:42:18 eagle Exp $; - # pod2text -- Convert POD data to formatted ASCII text. -# Copyright 1999 by Russ Allbery <rra@stanford.edu> +# +# Copyright 1999 by Russ Allbery <rra@stanford.edu> # # This program is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # -# The driver script for Pod::Text, Pod::Text::Termcap, and -# Pod::Text::Color, invoked by perldoc -t among other things. +# The driver script for Pod::Text, Pod::Text::Termcap, and Pod::Text::Color, +# invoked by perldoc -t among other things. require 5.004; @@ -65,8 +64,8 @@ for (my $i = 0; $i < @ARGV; $i++) { } } -# Parse our options. Use the same names as Pod::Text for simplicity, -# and default to sentence boundaries turned off for compatibility. +# Parse our options. Use the same names as Pod::Text for simplicity, and +# default to sentence boundaries turned off for compatibility. my %options; $options{termcap} = -t STDOUT; $options{sentence} = 0; @@ -79,6 +78,8 @@ pod2usage (1) if $options{help}; my $formatter = 'Pod::Text'; if ($options{color}) { $formatter = 'Pod::Text::Color'; + eval { require Term::ANSIColor }; + if ($@) { die "-c (--color) requires Term::ANSIColor be installed\n" } require Pod::Text::Color; } elsif ($options{termcap}) { $formatter = 'Pod::Text::Termcap'; @@ -104,16 +105,19 @@ pod2text B<-h> =head1 DESCRIPTION -B<pod2text> is a front-end for Pod::Text and its subclasses. It uses -them to generate formatted ASCII text from POD source. It can optionally -use either termcap sequences or ANSI color escape sequences to format the -text. +B<pod2text> is a front-end for Pod::Text and its subclasses. It uses them +to generate formatted ASCII text from POD source. It can optionally use +either termcap sequences or ANSI color escape sequences to format the text. I<input> is the file to read for POD source (the POD can be embedded in code). If I<input> isn't given, it defaults to STDIN. I<output>, if given, is the file to which to write the formatted output. If I<output> isn't given, the formatted output is written to STDOUT. +B<pod2text> defaults to trying to use Pod::Text::Termcap if STDOUT is a tty. +To explicitly say not to attempt termcap escape sequences, use +B<--notermcap>. + =head1 OPTIONS =over 4 @@ -133,17 +137,20 @@ requires that Term::ANSIColor be installed on your system. Set the number of spaces to indent regular text, and the default indentation for C<=over> blocks. Defaults to 4 spaces if this option isn't given. +=item B<-h>, B<--help> + +Print out usage information and exit. + =item B<-l>, B<--loose> Print a blank line after a C<=head1> heading. Normally, no blank line is -printed after C<=head1>, although one is still printed after C<=head2>. -This is the default because it's the expected formatting for manual pages; -if you're formatting arbitrary text documents, using this option is -recommended. +printed after C<=head1>, although one is still printed after C<=head2>, +because this is the expected formatting for manual pages; if you're +formatting arbitrary text documents, using this option is recommended. =item B<-s>, B<--sentence> -Assume each sentence ends in two spaces and try to preserve that spacing. +Assume each sentence ends with two spaces and try to preserve that spacing. Without this option, all consecutive whitespace in non-verbatim paragraphs is compressed into a single space. @@ -154,8 +161,8 @@ sequences for the terminal from termcap, and use that information in formatting the output. Output will be wrapped at two columns less than the width of your terminal device. Using this option requires that your system have a termcap file somewhere where Term::Cap can find it. With this -option, the output of B<pod2text> will contain terminal control sequences for -your current terminal type. +option, the output of B<pod2text> will contain terminal control sequences +for your current terminal type. =item B<-w>, B<--width=>I<width>, B<->I<width> @@ -165,6 +172,28 @@ your terminal device. =back +=head1 DIAGNOSTICS + +If B<pod2text> fails with errors, see L<Pod::Text> and L<Pod::Parser> for +information about what those errors might mean. Internally, it can also +produce the following diagnostics: + +=over 4 + +=item -c (--color) requires Term::ANSIColor be installed + +(F) B<-c> or B<--color> were given, but Term::ANSIColor could not be +loaded. + +=item Unknown option: %s + +(F) An unknown command line option was given. + +=back + +In addition, other L<Getopt::Long|Getopt::Long> error messages may result +from invalid command-line options. + =head1 ENVIRONMENT =over 4 @@ -183,11 +212,6 @@ current terminal device. =back -=head1 DIAGNOSTICS - -If B<pod2text> fails with POD errors, see L<Pod::Text> and -L<Pod::Parser> for information about what those errors might mean. - =head1 SEE ALSO L<Pod::Text|Pod::Text>, L<Pod::Text::Color|Pod::Text::Color>, diff --git a/pod/pod2usage.PL b/pod/pod2usage.PL index adf49bd69d..24e93fa350 100644 --- a/pod/pod2usage.PL +++ b/pod/pod2usage.PL @@ -39,10 +39,7 @@ print OUT <<'!NO!SUBS!'; ############################################################################# # pod2usage -- command to print usage messages from embedded pod docs # -# Derived from Tom Christiansen's pod2text script. -# (with extensive modifications) -# -# Copyright (c) 1996 Bradford Appleton. All rights reserved. +# Copyright (c) 1996-1999 by Bradford Appleton. All rights reserved. # This file is part of "PodParser". PodParser is free software; # you can redistribute it and/or modify it under the same terms # as Perl itself. diff --git a/pod/podchecker.PL b/pod/podchecker.PL index 0d31763879..89c2899248 100644 --- a/pod/podchecker.PL +++ b/pod/podchecker.PL @@ -38,10 +38,7 @@ print OUT <<'!NO!SUBS!'; ############################################################################# # podchecker -- command to invoke the podchecker function in Pod::Checker # -# Derived from Tom Christiansen's pod2text script. -# (with extensive modifications) -# -# Copyright (c) 1998 Bradford Appleton. All rights reserved. +# Copyright (c) 1998-1999 by Bradford Appleton. All rights reserved. # This file is part of "PodParser". PodParser is free software; # you can redistribute it and/or modify it under the same terms # as Perl itself. diff --git a/pod/podselect.PL b/pod/podselect.PL index a76f6a045f..3fa411846b 100644 --- a/pod/podselect.PL +++ b/pod/podselect.PL @@ -39,10 +39,7 @@ print OUT <<'!NO!SUBS!'; ############################################################################# # podselect -- command to invoke the podselect function in Pod::Select # -# Derived from Tom Christiansen's pod2text script. -# (with extensive modifications) -# -# Copyright (c) 1996 Bradford Appleton. All rights reserved. +# Copyright (c) 1996-1999 by Bradford Appleton. All rights reserved. # This file is part of "PodParser". PodParser is free software; # you can redistribute it and/or modify it under the same terms # as Perl itself. @@ -407,7 +407,7 @@ PP(pp_rv2cv) if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv)) - Perl_croak(aTHX_ "Can't modify non-lvalue subroutine call"); + DIE(aTHX_ "Can't modify non-lvalue subroutine call"); } else cv = (CV*)&PL_sv_undef; @@ -469,7 +469,7 @@ PP(pp_prototype) goto set; else { /* None such */ nonesuch: - Perl_croak(aTHX_ "Can't find an opnumber for \"%s\"", s+6); + DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6); } } } @@ -530,6 +530,12 @@ S_refto(pTHX_ SV *sv) else (void)SvREFCNT_inc(sv); } + else if (SvTYPE(sv) == SVt_PVAV) { + if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv)) + av_reify((AV*)sv); + SvTEMP_off(sv); + (void)SvREFCNT_inc(sv); + } else if (SvPADTMP(sv)) sv = newSVsv(sv); else { @@ -865,7 +871,7 @@ PP(pp_predec) { djSP; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - Perl_croak(aTHX_ PL_no_modify); + DIE(aTHX_ PL_no_modify); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) { @@ -882,7 +888,7 @@ PP(pp_postinc) { djSP; dTARGET; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - Perl_croak(aTHX_ PL_no_modify); + DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) @@ -903,7 +909,7 @@ PP(pp_postdec) { djSP; dTARGET; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - Perl_croak(aTHX_ PL_no_modify); + DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) @@ -3282,6 +3288,11 @@ PP(pp_unpack) #endif if (isSPACE(datumtype)) continue; + if (datumtype == '#') { + while (pat < patend && *pat != '\n') + pat++; + continue; + } if (*pat == '!') { char *natstr = "sSiIlL"; @@ -3292,7 +3303,7 @@ PP(pp_unpack) pat++; } else - Perl_croak(aTHX_ "'!' allowed only after types %s", natstr); + DIE(aTHX_ "'!' allowed only after types %s", natstr); } if (pat >= patend) len = 1; @@ -3305,17 +3316,18 @@ PP(pp_unpack) while (isDIGIT(*pat)) { len = (len * 10) + (*pat++ - '0'); if (len < 0) - Perl_croak(aTHX_ "Repeat count in unpack overflows"); + DIE(aTHX_ "Repeat count in unpack overflows"); } } else len = (datumtype != '@'); switch(datumtype) { default: - Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype); + DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ if (commas++ == 0 && ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype); + Perl_warner(aTHX_ WARN_UNSAFE, + "Invalid type in unpack: '%c'", (int)datumtype); break; case '%': if (len == 1 && pat[-1] != '1') @@ -3341,16 +3353,16 @@ PP(pp_unpack) DIE(aTHX_ "x outside of string"); s += len; break; - case '#': + case '/': if (oldsp >= SP) - DIE(aTHX_ "# must follow a numeric type"); + DIE(aTHX_ "/ must follow a numeric type"); if (*pat != 'a' && *pat != 'A' && *pat != 'Z') - DIE(aTHX_ "# must be followed by a, A or Z"); + DIE(aTHX_ "/ must be followed by a, A or Z"); datumtype = *pat++; if (*pat == '*') pat++; /* ignore '*' for compatibility with pack */ if (isDIGIT(*pat)) - DIE(aTHX_ "# cannot take a count" ); + DIE(aTHX_ "/ cannot take a count" ); len = POPi; /* drop through */ case 'A': @@ -3981,7 +3993,7 @@ PP(pp_unpack) } } if ((s >= strend) && bytes) - Perl_croak(aTHX_ "Unterminated compressed integer"); + DIE(aTHX_ "Unterminated compressed integer"); } break; case 'P': @@ -4339,6 +4351,11 @@ PP(pp_pack) #endif if (isSPACE(datumtype)) continue; + if (datumtype == '#') { + while (pat < patend && *pat != '\n') + pat++; + continue; + } if (*pat == '!') { char *natstr = "sSiIlL"; @@ -4349,7 +4366,7 @@ PP(pp_pack) pat++; } else - Perl_croak(aTHX_ "'!' allowed only after types %s", natstr); + DIE(aTHX_ "'!' allowed only after types %s", natstr); } if (*pat == '*') { len = strchr("@Xxu", datumtype) ? 0 : items; @@ -4360,21 +4377,21 @@ PP(pp_pack) while (isDIGIT(*pat)) { len = (len * 10) + (*pat++ - '0'); if (len < 0) - Perl_croak(aTHX_ "Repeat count in pack overflows"); + DIE(aTHX_ "Repeat count in pack overflows"); } } else len = 1; - if (*pat == '#') { + if (*pat == '/') { ++pat; if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*') - DIE(aTHX_ "# must be followed by a*, A* or Z*"); + DIE(aTHX_ "/ must be followed by a*, A* or Z*"); lengthcode = sv_2mortal(newSViv(sv_len(items > 0 ? *MARK : &PL_sv_no))); } switch(datumtype) { default: - Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype); + DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ if (commas++ == 0 && ckWARN(WARN_UNSAFE)) Perl_warner(aTHX_ WARN_UNSAFE, @@ -4663,7 +4680,7 @@ PP(pp_pack) adouble = Perl_floor(SvNV(fromstr)); if (adouble < 0) - Perl_croak(aTHX_ "Cannot compress negative numbers"); + DIE(aTHX_ "Cannot compress negative numbers"); if ( #ifdef BW_BITS @@ -4697,7 +4714,7 @@ PP(pp_pack) /* Copy string and check for compliance */ from = SvPV(fromstr, len); if ((norm = is_an_int(from, len)) == NULL) - Perl_croak(aTHX_ "can compress only unsigned integer"); + DIE(aTHX_ "can compress only unsigned integer"); New('w', result, len, char); in = result + len; @@ -4717,14 +4734,14 @@ PP(pp_pack) double next = floor(adouble / 128); *--in = (unsigned char)(adouble - (next * 128)) | 0x80; if (--in < buf) /* this cannot happen ;-) */ - Perl_croak(aTHX_ "Cannot compress integer"); + DIE(aTHX_ "Cannot compress integer"); adouble = next; } while (adouble > 0); buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ sv_catpvn(cat, in, (buf + sizeof(buf)) - in); } else - Perl_croak(aTHX_ "Cannot compress non integer"); + DIE(aTHX_ "Cannot compress non integer"); } break; case 'i': @@ -971,7 +971,7 @@ PP(pp_flop) (looks_like_number(left) && *SvPVX(left) != '0') ) { if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX) - Perl_croak(aTHX_ "Range iterator outside integer range"); + DIE(aTHX_ "Range iterator outside integer range"); i = SvIV(left); max = SvIV(right); if (max >= i) { @@ -1247,6 +1247,18 @@ S_free_closures(pTHX) } } +void +Perl_qerror(pTHX_ SV *err) +{ + if (PL_in_eval) + sv_catsv(ERRSV, err); + else if (PL_errors) + sv_catsv(PL_errors, err); + else + Perl_warn(aTHX_ "%_", err); + ++PL_error_count; +} + OP * Perl_die_where(pTHX_ char *message, STRLEN msglen) { @@ -1288,7 +1300,9 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) else message = SvPVx(ERRSV, msglen); - while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) { + while ((cxix = dopoptoeval(cxstack_ix)) < 0 + && PL_curstackinfo->si_prev) + { dounwind(-1); POPSTACK; } @@ -1315,7 +1329,8 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) if (optype == OP_REQUIRE) { char* msg = SvPVx(ERRSV, n_a); - DIE(aTHX_ "%s", *msg ? msg : "Compilation failed in require"); + DIE(aTHX_ "%sCompilation failed in require", + *msg ? msg : "Unknown error\n"); } return pop_return(); } @@ -1601,7 +1616,7 @@ PP(pp_enteriter) (looks_like_number(sv) && *SvPVX(sv) != '0')) { if (SvNV(sv) < IV_MIN || SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX) - Perl_croak(aTHX_ "Range iterator outside integer range"); + DIE(aTHX_ "Range iterator outside integer range"); cx->blk_loop.iterix = SvIV(sv); cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary); } @@ -1972,7 +1987,6 @@ PP(pp_goto) SV** mark; I32 items = 0; I32 oldsave; - int arg_was_real = 0; retry: if (!CvROOT(cv) && !CvXSUB(cv)) { @@ -2004,8 +2018,8 @@ PP(pp_goto) if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) DIE(aTHX_ "Can't goto subroutine from an eval-string"); mark = PL_stack_sp; - if (CxTYPE(cx) == CXt_SUB && - cx->blk_sub.hasargs) { /* put @_ back onto stack */ + if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) { + /* put @_ back onto stack */ AV* av = cx->blk_sub.argarray; items = AvFILLp(av) + 1; @@ -2017,11 +2031,14 @@ PP(pp_goto) SvREFCNT_dec(GvAV(PL_defgv)); GvAV(PL_defgv) = cx->blk_sub.savearray; #endif /* USE_THREADS */ + /* abandon @_ if it got reified */ if (AvREAL(av)) { - arg_was_real = 1; - AvREAL_off(av); /* so av_clear() won't clobber elts */ + (void)sv_2mortal((SV*)av); /* delay until return */ + av = newAV(); + av_extend(av, items-1); + AvFLAGS(av) = AVf_REIFY; + PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av); } - av_clear(av); } else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */ AV* av; @@ -2179,11 +2196,7 @@ 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); - } + assert(!AvREAL(av)); while (items--) { if (*mark) SvTEMP_off(*mark); @@ -2627,13 +2640,16 @@ S_doeval(pTHX_ int gimme, OP** startop) LEAVE; if (optype == OP_REQUIRE) { char* msg = SvPVx(ERRSV, n_a); - DIE(aTHX_ "%s", *msg ? msg : "Compilation failed in require"); - } else if (startop) { + DIE(aTHX_ "%sCompilation failed in require", + *msg ? msg : "Unknown error\n"); + } + else if (startop) { char* msg = SvPVx(ERRSV, n_a); POPBLOCK(cx,PL_curpm); POPEVAL(cx); - Perl_croak(aTHX_ "%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n")); + Perl_croak(aTHX_ "%sCompilation failed in regexp", + (*msg ? msg : "Unknown error\n")); } SvREFCNT_dec(PL_rs); PL_rs = SvREFCNT_inc(PL_nrs); @@ -233,7 +233,7 @@ PP(pp_preinc) { djSP; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - Perl_croak(aTHX_ PL_no_modify); + DIE(aTHX_ PL_no_modify); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) { @@ -1644,7 +1644,7 @@ PP(pp_subst) if (SvREADONLY(TARG) || (SvTYPE(TARG) > SVt_PVLV && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))) - Perl_croak(aTHX_ PL_no_modify); + DIE(aTHX_ PL_no_modify); PUTBACK; s = SvPV(TARG, len); @@ -2013,36 +2013,49 @@ PP(pp_leavesublv) /* Here we go for robustness, not for speed, so we change all * the refcounts so the caller gets a live guy. Cannot set * TEMP, so sv_2mortal is out of question. */ - if (!CvLVALUE(cxsub.cv)) - Perl_croak(aTHX_ "Can't modify non-lvalue subroutine call"); + if (!CvLVALUE(cxsub.cv)) { + POPSUB2(); + PL_curpm = newpm; + DIE(aTHX_ "Can't modify non-lvalue subroutine call"); + } if (gimme == G_SCALAR) { MARK = newsp + 1; EXTEND_MORTAL(1); if (MARK == SP) { - if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) - Perl_croak(aTHX_ "Can't return a %s from lvalue subroutine", + if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { + POPSUB2(); + PL_curpm = newpm; + DIE(aTHX_ "Can't return a %s from lvalue subroutine", SvREADONLY(TOPs) ? "readonly value" : "temporary"); + } else { /* Can be a localized value * subject to deletion. */ PL_tmps_stack[++PL_tmps_ix] = *mark; SvREFCNT_inc(*mark); } } - else /* Should not happen? */ - Perl_croak(aTHX_ "%s returned from lvalue subroutine in scalar context", + else { /* Should not happen? */ + POPSUB2(); + PL_curpm = newpm; + DIE(aTHX_ "%s returned from lvalue subroutine in scalar context", (MARK > SP ? "Empty array" : "Array")); + } SP = MARK; } else if (gimme == G_ARRAY) { EXTEND_MORTAL(SP - newsp); for (mark = newsp + 1; mark <= SP; mark++) { - if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) - /* Might be flattened array after $#array = */ - Perl_croak(aTHX_ "Can't return %s from lvalue subroutine", + if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { + /* Might be flattened array after $#array = */ + PUTBACK; + POPSUB2(); + PL_curpm = newpm; + DIE(aTHX_ "Can't return %s from lvalue subroutine", (*mark != &PL_sv_undef) ? (SvREADONLY(TOPs) ? "a readonly value" : "a temporary") : "an uninitialized value"); + } else { mortalize: /* Can be a localized value subject to deletion. */ @@ -2257,7 +2270,7 @@ try_autoload: || !(sv = AvARRAY(av)[0])) { MUTEX_UNLOCK(CvMUTEXP(cv)); - Perl_croak(aTHX_ "no argument for locked method call"); + DIE(aTHX_ "no argument for locked method call"); } } if (SvROK(sv)) @@ -2521,11 +2534,7 @@ try_autoload: "%p entersub preparing @_\n", thr)); #endif av = (AV*)PL_curpad[0]; - if (AvREAL(av)) { - av_clear(av); - AvREAL_off(av); - AvREIFY_on(av); - } + assert(!AvREAL(av)); #ifndef USE_THREADS cx->blk_sub.savearray = GvAV(PL_defgv); GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); @@ -3657,7 +3657,7 @@ PP(pp_system) PerlLIO_close(pp[0]); if (n) { /* Error */ if (n != sizeof(int)) - Perl_croak(aTHX_ "panic: kid popen errno read"); + DIE(aTHX_ "panic: kid popen errno read"); errno = errkid; /* Propagate errno from kid */ STATUS_CURRENT = -1; } @@ -56,6 +56,7 @@ VIRTUAL void Perl_croak_nocontext(const char* pat, ...) __attribute__((noreturn) VIRTUAL OP* Perl_die_nocontext(const char* pat, ...); VIRTUAL void Perl_deb_nocontext(const char* pat, ...); VIRTUAL char* Perl_form_nocontext(const char* pat, ...); +VIRTUAL SV* Perl_mess_nocontext(const char* pat, ...); VIRTUAL void Perl_warn_nocontext(const char* pat, ...); VIRTUAL void Perl_warner_nocontext(U32 err, const char* pat, ...); VIRTUAL SV* Perl_newSVpvf_nocontext(const char* pat, ...); @@ -322,7 +323,9 @@ VIRTUAL void Perl_markstack_grow(pTHX); #if defined(USE_LOCALE_COLLATE) VIRTUAL char* Perl_mem_collxfrm(pTHX_ const char* s, STRLEN len, STRLEN* xlen); #endif -VIRTUAL SV* Perl_mess(pTHX_ const char* pat, va_list* args); +VIRTUAL SV* Perl_mess(pTHX_ const char* pat, ...); +VIRTUAL SV* Perl_vmess(pTHX_ const char* pat, va_list* args); +VIRTUAL void Perl_qerror(pTHX_ SV* err); VIRTUAL int Perl_mg_clear(pTHX_ SV* sv); VIRTUAL int Perl_mg_copy(pTHX_ SV* sv, SV* nsv, const char* key, I32 klen); VIRTUAL MAGIC* Perl_mg_find(pTHX_ SV* sv, int type); @@ -920,14 +923,38 @@ STATIC SV* S_more_sv(pTHX); STATIC void S_more_xiv(pTHX); STATIC void S_more_xnv(pTHX); STATIC void S_more_xpv(pTHX); +STATIC void S_more_xpviv(pTHX); +STATIC void S_more_xpvnv(pTHX); +STATIC void S_more_xpvcv(pTHX); +STATIC void S_more_xpvav(pTHX); +STATIC void S_more_xpvhv(pTHX); +STATIC void S_more_xpvmg(pTHX); +STATIC void S_more_xpvlv(pTHX); +STATIC void S_more_xpvbm(pTHX); STATIC void S_more_xrv(pTHX); STATIC XPVIV* S_new_xiv(pTHX); STATIC XPVNV* S_new_xnv(pTHX); STATIC XPV* S_new_xpv(pTHX); +STATIC XPVIV* S_new_xpviv(pTHX); +STATIC XPVNV* S_new_xpvnv(pTHX); +STATIC XPVCV* S_new_xpvcv(pTHX); +STATIC XPVAV* S_new_xpvav(pTHX); +STATIC XPVHV* S_new_xpvhv(pTHX); +STATIC XPVMG* S_new_xpvmg(pTHX); +STATIC XPVLV* S_new_xpvlv(pTHX); +STATIC XPVBM* S_new_xpvbm(pTHX); STATIC XRV* S_new_xrv(pTHX); STATIC void S_del_xiv(pTHX_ XPVIV* p); STATIC void S_del_xnv(pTHX_ XPVNV* p); STATIC void S_del_xpv(pTHX_ XPV* p); +STATIC void S_del_xpviv(pTHX_ XPVIV* p); +STATIC void S_del_xpvnv(pTHX_ XPVNV* p); +STATIC void S_del_xpvcv(pTHX_ XPVCV* p); +STATIC void S_del_xpvav(pTHX_ XPVAV* p); +STATIC void S_del_xpvhv(pTHX_ XPVHV* p); +STATIC void S_del_xpvmg(pTHX_ XPVMG* p); +STATIC void S_del_xpvlv(pTHX_ XPVLV* p); +STATIC void S_del_xpvbm(pTHX_ XPVBM* p); STATIC void S_del_xrv(pTHX_ XRV* p); STATIC void S_sv_unglob(pTHX_ SV* sv); STATIC void S_not_a_number(pTHX_ SV *sv); @@ -3245,7 +3245,7 @@ Perl_regprop(pTHX_ SV *sv, regnode *o) k = PL_regkind[(U8)OP(o)]; if (k == EXACT) - Perl_sv_catpvf(aTHX_ sv, " <%s%*s%s>", PL_colors[0], + Perl_sv_catpvf(aTHX_ sv, " <%s%.*s%s>", PL_colors[0], STR_LEN(o), STRING(o), PL_colors[1]); else if (k == CURLY) { if (OP(o) == CURLYM || OP(o) == CURLYN) @@ -3287,6 +3287,9 @@ Perl_pregfree(pTHX_ struct regexp *r) { dTHR; DEBUG_r(if (!PL_colorset) reginitcolors()); + + if (!r || (--r->refcnt > 0)) + return; DEBUG_r(PerlIO_printf(Perl_debug_log, "%sFreeing REx:%s `%s%.60s%s%s'\n", PL_colors[4],PL_colors[5],PL_colors[0], @@ -3294,9 +3297,6 @@ Perl_pregfree(pTHX_ struct regexp *r) PL_colors[1], (strlen(r->precomp) > 60 ? "..." : ""))); - - if (!r || (--r->refcnt > 0)) - return; if (r->precomp) Safefree(r->precomp); if (RX_MATCH_COPIED(r)) @@ -3395,7 +3395,7 @@ S_re_croak2(pTHX_ const char* pat1,const char* pat2,...) #else va_start(args); #endif - msv = mess(buf, &args); + msv = vmess(buf, &args); va_end(args); message = SvPV(msv,l1); if (l1 > 512) @@ -1602,11 +1602,19 @@ S_regmatch(pTHX_ regnode *prog) #ifdef DEBUGGING # define sayYES goto yes # define sayNO goto no +# define sayYES_FINAL goto yes_final +# define sayYES_LOUD goto yes_loud +# define sayNO_FINAL goto no_final +# define sayNO_SILENT goto do_no # define saySAME(x) if (x) goto yes; else goto no # define REPORT_CODE_OFF 24 #else # define sayYES return 1 # define sayNO return 0 +# define sayYES_FINAL return 1 +# define sayYES_LOUD return 1 +# define sayNO_FINAL return 0 +# define sayNO_SILENT return 0 # define saySAME(x) return x #endif DEBUG_r( { @@ -2220,11 +2228,6 @@ S_regmatch(pTHX_ regnode *prog) regcpblow(cp); sayYES; } - DEBUG_r( - PerlIO_printf(Perl_debug_log, - "%*s failed...\n", - REPORT_CODE_OFF+PL_regindent*2, "") - ); ReREFCNT_dec(re); REGCP_UNWIND; regcppop(); @@ -2411,11 +2414,6 @@ S_regmatch(pTHX_ regnode *prog) ); if (regmatch(cc->next)) sayYES; - DEBUG_r( - PerlIO_printf(Perl_debug_log, - "%*s failed...\n", - REPORT_CODE_OFF+PL_regindent*2, "") - ); if (PL_regcc) PL_regcc->cur = ln; PL_regcc = cc; @@ -2431,11 +2429,6 @@ S_regmatch(pTHX_ regnode *prog) sayYES; cc->cur = n - 1; cc->lastloc = lastloc; - DEBUG_r( - PerlIO_printf(Perl_debug_log, - "%*s failed...\n", - REPORT_CODE_OFF+PL_regindent*2, "") - ); sayNO; } @@ -2478,7 +2471,7 @@ S_regmatch(pTHX_ regnode *prog) "%*s already tried at this position...\n", REPORT_CODE_OFF+PL_regindent*2, "") ); - sayNO; + sayNO_SILENT; } PL_reg_poscache[o] |= (1<<b); } @@ -2528,11 +2521,6 @@ S_regmatch(pTHX_ regnode *prog) regcpblow(cp); sayYES; } - DEBUG_r( - PerlIO_printf(Perl_debug_log, - "%*s failed...\n", - REPORT_CODE_OFF+PL_regindent*2, "") - ); REGCP_UNWIND; regcppop(); cc->cur = n - 1; @@ -2574,10 +2562,6 @@ S_regmatch(pTHX_ regnode *prog) ln = PL_regcc->cur; if (regmatch(cc->next)) sayYES; - DEBUG_r( - PerlIO_printf(Perl_debug_log, "%*s failed...\n", - REPORT_CODE_OFF+PL_regindent*2, "") - ); if (PL_regcc) PL_regcc->cur = ln; PL_regcc = cc; @@ -2972,14 +2956,22 @@ S_regmatch(pTHX_ regnode *prog) "%*s continuation failed...\n", REPORT_CODE_OFF+PL_regindent*2, "") ); - sayNO; + sayNO_SILENT; } - if (locinput < PL_regtill) - sayNO; /* Cannot match: too short. */ - /* Fall through */ + if (locinput < PL_regtill) { + DEBUG_r(PerlIO_printf(Perl_debug_log, + "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n", + PL_colors[4], + (long)(locinput - PL_reg_starttry), + (long)(PL_regtill - PL_reg_starttry), + PL_colors[5])); + sayNO_FINAL; /* Cannot match: too short. */ + } + PL_reginput = locinput; /* put where regtry can find it */ + sayYES_FINAL; /* Success! */ case SUCCEED: PL_reginput = locinput; /* put where regtry can find it */ - sayYES; /* Success! */ + sayYES_LOUD; /* Success! */ case SUSPEND: n = 1; PL_reginput = locinput; @@ -3070,6 +3062,16 @@ S_regmatch(pTHX_ regnode *prog) /*NOTREACHED*/ sayNO; +yes_loud: + DEBUG_r( + PerlIO_printf(Perl_debug_log, + "%*s %scould match...%s\n", + REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],PL_colors[5]) + ); + goto yes; +yes_final: + DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n", + PL_colors[4],PL_colors[5])); yes: #ifdef DEBUGGING PL_regindent--; @@ -3077,6 +3079,14 @@ yes: return 1; no: + DEBUG_r( + PerlIO_printf(Perl_debug_log, + "%*s %sfailed...%s\n", + REPORT_CODE_OFF+PL_regindent*2, "",PL_colors[4],PL_colors[5]) + ); + goto do_no; +no_final: +do_no: #ifdef DEBUGGING PL_regindent--; #endif @@ -475,6 +475,321 @@ S_more_xpv(pTHX) xpv->xpv_pv = 0; } +STATIC XPVIV* +S_new_xpviv(pTHX) +{ + XPVIV* xpviv; + LOCK_SV_MUTEX; + if (!PL_xpviv_root) + more_xpviv(); + xpviv = PL_xpviv_root; + PL_xpviv_root = (XPVIV*)xpviv->xpv_pv; + UNLOCK_SV_MUTEX; + return xpviv; +} + +STATIC void +S_del_xpviv(pTHX_ XPVIV *p) +{ + LOCK_SV_MUTEX; + p->xpv_pv = (char*)PL_xpviv_root; + PL_xpviv_root = p; + UNLOCK_SV_MUTEX; +} + + +STATIC void +S_more_xpviv(pTHX) +{ + register XPVIV* xpviv; + register XPVIV* xpvivend; + New(714, PL_xpviv_root, 1008/sizeof(XPVIV), XPVIV); + xpviv = PL_xpviv_root; + xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1]; + while (xpviv < xpvivend) { + xpviv->xpv_pv = (char*)(xpviv + 1); + xpviv++; + } + xpviv->xpv_pv = 0; +} + + +STATIC XPVNV* +S_new_xpvnv(pTHX) +{ + XPVNV* xpvnv; + LOCK_SV_MUTEX; + if (!PL_xpvnv_root) + more_xpvnv(); + xpvnv = PL_xpvnv_root; + PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv; + UNLOCK_SV_MUTEX; + return xpvnv; +} + +STATIC void +S_del_xpvnv(pTHX_ XPVNV *p) +{ + LOCK_SV_MUTEX; + p->xpv_pv = (char*)PL_xpvnv_root; + PL_xpvnv_root = p; + UNLOCK_SV_MUTEX; +} + + +STATIC void +S_more_xpvnv(pTHX) +{ + register XPVNV* xpvnv; + register XPVNV* xpvnvend; + New(715, PL_xpvnv_root, 1008/sizeof(XPVNV), XPVNV); + xpvnv = PL_xpvnv_root; + xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1]; + while (xpvnv < xpvnvend) { + xpvnv->xpv_pv = (char*)(xpvnv + 1); + xpvnv++; + } + xpvnv->xpv_pv = 0; +} + + + +STATIC XPVCV* +S_new_xpvcv(pTHX) +{ + XPVCV* xpvcv; + LOCK_SV_MUTEX; + if (!PL_xpvcv_root) + more_xpvcv(); + xpvcv = PL_xpvcv_root; + PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv; + UNLOCK_SV_MUTEX; + return xpvcv; +} + +STATIC void +S_del_xpvcv(pTHX_ XPVCV *p) +{ + LOCK_SV_MUTEX; + p->xpv_pv = (char*)PL_xpvcv_root; + PL_xpvcv_root = p; + UNLOCK_SV_MUTEX; +} + + +STATIC void +S_more_xpvcv(pTHX) +{ + register XPVCV* xpvcv; + register XPVCV* xpvcvend; + New(716, PL_xpvcv_root, 1008/sizeof(XPVCV), XPVCV); + xpvcv = PL_xpvcv_root; + xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1]; + while (xpvcv < xpvcvend) { + xpvcv->xpv_pv = (char*)(xpvcv + 1); + xpvcv++; + } + xpvcv->xpv_pv = 0; +} + + + +STATIC XPVAV* +S_new_xpvav(pTHX) +{ + XPVAV* xpvav; + LOCK_SV_MUTEX; + if (!PL_xpvav_root) + more_xpvav(); + xpvav = PL_xpvav_root; + PL_xpvav_root = (XPVAV*)xpvav->xav_array; + UNLOCK_SV_MUTEX; + return xpvav; +} + +STATIC void +S_del_xpvav(pTHX_ XPVAV *p) +{ + LOCK_SV_MUTEX; + p->xav_array = (char*)PL_xpvav_root; + PL_xpvav_root = p; + UNLOCK_SV_MUTEX; +} + + +STATIC void +S_more_xpvav(pTHX) +{ + register XPVAV* xpvav; + register XPVAV* xpvavend; + New(717, PL_xpvav_root, 1008/sizeof(XPVAV), XPVAV); + xpvav = PL_xpvav_root; + xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1]; + while (xpvav < xpvavend) { + xpvav->xav_array = (char*)(xpvav + 1); + xpvav++; + } + xpvav->xav_array = 0; +} + + + +STATIC XPVHV* +S_new_xpvhv(pTHX) +{ + XPVHV* xpvhv; + LOCK_SV_MUTEX; + if (!PL_xpvhv_root) + more_xpvhv(); + xpvhv = PL_xpvhv_root; + PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array; + UNLOCK_SV_MUTEX; + return xpvhv; +} + +STATIC void +S_del_xpvhv(pTHX_ XPVHV *p) +{ + LOCK_SV_MUTEX; + p->xhv_array = (char*)PL_xpvhv_root; + PL_xpvhv_root = p; + UNLOCK_SV_MUTEX; +} + + +STATIC void +S_more_xpvhv(pTHX) +{ + register XPVHV* xpvhv; + register XPVHV* xpvhvend; + New(718, PL_xpvhv_root, 1008/sizeof(XPVHV), XPVHV); + xpvhv = PL_xpvhv_root; + xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1]; + while (xpvhv < xpvhvend) { + xpvhv->xhv_array = (char*)(xpvhv + 1); + xpvhv++; + } + xpvhv->xhv_array = 0; +} + + +STATIC XPVMG* +S_new_xpvmg(pTHX) +{ + XPVMG* xpvmg; + LOCK_SV_MUTEX; + if (!PL_xpvmg_root) + more_xpvmg(); + xpvmg = PL_xpvmg_root; + PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv; + UNLOCK_SV_MUTEX; + return xpvmg; +} + +STATIC void +S_del_xpvmg(pTHX_ XPVMG *p) +{ + LOCK_SV_MUTEX; + p->xpv_pv = (char*)PL_xpvmg_root; + PL_xpvmg_root = p; + UNLOCK_SV_MUTEX; +} + + +STATIC void +S_more_xpvmg(pTHX) +{ + register XPVMG* xpvmg; + register XPVMG* xpvmgend; + New(719, PL_xpvmg_root, 1008/sizeof(XPVMG), XPVMG); + xpvmg = PL_xpvmg_root; + xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1]; + while (xpvmg < xpvmgend) { + xpvmg->xpv_pv = (char*)(xpvmg + 1); + xpvmg++; + } + xpvmg->xpv_pv = 0; +} + + + +STATIC XPVLV* +S_new_xpvlv(pTHX) +{ + XPVLV* xpvlv; + LOCK_SV_MUTEX; + if (!PL_xpvlv_root) + more_xpvlv(); + xpvlv = PL_xpvlv_root; + PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv; + UNLOCK_SV_MUTEX; + return xpvlv; +} + +STATIC void +S_del_xpvlv(pTHX_ XPVLV *p) +{ + LOCK_SV_MUTEX; + p->xpv_pv = (char*)PL_xpvlv_root; + PL_xpvlv_root = p; + UNLOCK_SV_MUTEX; +} + + +STATIC void +S_more_xpvlv(pTHX) +{ + register XPVLV* xpvlv; + register XPVLV* xpvlvend; + New(720, PL_xpvlv_root, 1008/sizeof(XPVLV), XPVLV); + xpvlv = PL_xpvlv_root; + xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1]; + while (xpvlv < xpvlvend) { + xpvlv->xpv_pv = (char*)(xpvlv + 1); + xpvlv++; + } + xpvlv->xpv_pv = 0; +} + + +STATIC XPVBM* +S_new_xpvbm(pTHX) +{ + XPVBM* xpvbm; + LOCK_SV_MUTEX; + if (!PL_xpvbm_root) + more_xpvbm(); + xpvbm = PL_xpvbm_root; + PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv; + UNLOCK_SV_MUTEX; + return xpvbm; +} + +STATIC void +S_del_xpvbm(pTHX_ XPVBM *p) +{ + LOCK_SV_MUTEX; + p->xpv_pv = (char*)PL_xpvbm_root; + PL_xpvbm_root = p; + UNLOCK_SV_MUTEX; +} + + +STATIC void +S_more_xpvbm(pTHX) +{ + register XPVBM* xpvbm; + register XPVBM* xpvbmend; + New(721, PL_xpvbm_root, 1008/sizeof(XPVBM), XPVBM); + xpvbm = PL_xpvbm_root; + xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1]; + while (xpvbm < xpvbmend) { + xpvbm->xpv_pv = (char*)(xpvbm + 1); + xpvbm++; + } + xpvbm->xpv_pv = 0; +} + #ifdef PURIFY #define new_XIV() (void*)safemalloc(sizeof(XPVIV)) #define del_XIV(p) Safefree((char*)p) @@ -521,32 +836,73 @@ S_my_safemalloc(MEM_SIZE size) # define my_safefree(s) Safefree(s) #endif -#define new_XPVIV() (void*)my_safemalloc(sizeof(XPVIV)) -#define del_XPVIV(p) my_safefree((char*)p) - -#define new_XPVNV() (void*)my_safemalloc(sizeof(XPVNV)) -#define del_XPVNV(p) my_safefree((char*)p) - -#define new_XPVMG() (void*)my_safemalloc(sizeof(XPVMG)) -#define del_XPVMG(p) my_safefree((char*)p) - -#define new_XPVLV() (void*)my_safemalloc(sizeof(XPVLV)) -#define del_XPVLV(p) my_safefree((char*)p) +#ifdef PURIFY +#define new_XPVIV() (void*)safemalloc(sizeof(XPVIV)) +#define del_XPVIV(p) Safefree((char*)p) +#else +#define new_XPVIV() (void*)new_xpviv() +#define del_XPVIV(p) del_xpviv((XPVIV *)p) +#endif -#define new_XPVAV() (void*)my_safemalloc(sizeof(XPVAV)) -#define del_XPVAV(p) my_safefree((char*)p) +#ifdef PURIFY +#define new_XPVNV() (void*)safemalloc(sizeof(XPVNV)) +#define del_XPVNV(p) Safefree((char*)p) +#else +#define new_XPVNV() (void*)new_xpvnv() +#define del_XPVNV(p) del_xpvnv((XPVNV *)p) +#endif + + +#ifdef PURIFY +#define new_XPVCV() (void*)safemalloc(sizeof(XPVCV)) +#define del_XPVCV(p) Safefree((char*)p) +#else +#define new_XPVCV() (void*)new_xpvcv() +#define del_XPVCV(p) del_xpvcv((XPVCV *)p) +#endif + +#ifdef PURIFY +#define new_XPVAV() (void*)safemalloc(sizeof(XPVAV)) +#define del_XPVAV(p) Safefree((char*)p) +#else +#define new_XPVAV() (void*)new_xpvav() +#define del_XPVAV(p) del_xpvav((XPVAV *)p) +#endif + +#ifdef PURIFY +#define new_XPVHV() (void*)safemalloc(sizeof(XPVHV)) +#define del_XPVHV(p) Safefree((char*)p) +#else +#define new_XPVHV() (void*)new_xpvhv() +#define del_XPVHV(p) del_xpvhv((XPVHV *)p) +#endif -#define new_XPVHV() (void*)my_safemalloc(sizeof(XPVHV)) -#define del_XPVHV(p) my_safefree((char*)p) +#ifdef PURIFY +#define new_XPVMG() (void*)safemalloc(sizeof(XPVMG)) +#define del_XPVMG(p) Safefree((char*)p) +#else +#define new_XPVMG() (void*)new_xpvmg() +#define del_XPVMG(p) del_xpvmg((XPVMG *)p) +#endif -#define new_XPVCV() (void*)my_safemalloc(sizeof(XPVCV)) -#define del_XPVCV(p) my_safefree((char*)p) +#ifdef PURIFY +#define new_XPVLV() (void*)safemalloc(sizeof(XPVLV)) +#define del_XPVLV(p) Safefree((char*)p) +#else +#define new_XPVLV() (void*)new_xpvlv() +#define del_XPVLV(p) del_xpvlv((XPVLV *)p) +#endif #define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV)) #define del_XPVGV(p) my_safefree((char*)p) -#define new_XPVBM() (void*)my_safemalloc(sizeof(XPVBM)) -#define del_XPVBM(p) my_safefree((char*)p) +#ifdef PURIFY +#define new_XPVBM() (void*)safemalloc(sizeof(XPVBM)) +#define del_XPVBM(p) Safefree((char*)p) +#else +#define new_XPVBM() (void*)new_xpvbm() +#define del_XPVBM(p) del_xpvbm((XPVBM *)p) +#endif #define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM)) #define del_XPVFM(p) my_safefree((char*)p) @@ -156,6 +156,8 @@ struct io { /* Some private flags. */ +#define SVpad_OUR 0x80000000 /* pad name is "our" instead of "my" */ + #define SVf_IVisUV 0x80000000 /* use XPVUV instead of XPVIV */ #define SVpfm_COMPILED 0x80000000 /* FORMLINE is compiled */ diff --git a/t/lib/filecopy.t b/t/lib/filecopy.t index e461595d9b..7ef68eb02b 100755 --- a/t/lib/filecopy.t +++ b/t/lib/filecopy.t @@ -88,3 +88,7 @@ print "not " unless $foo eq "ok 3\n" and not -e "file-$$";; print "ok 11\n"; unlink "lib/file-$$" or die "unlink: $!"; +END { + 1 while unlink "file-$$"; + 1 while unlink "lib/file-$$"; +} diff --git a/t/lib/posix.t b/t/lib/posix.t index 4c6aa49a05..7fb5f62177 100755 --- a/t/lib/posix.t +++ b/t/lib/posix.t @@ -14,7 +14,7 @@ use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read strftime write); use strict subs; $| = 1; -print "1..18\n"; +print "1..26\n"; $Is_W32 = $^O eq 'MSWin32'; @@ -95,6 +95,31 @@ print &POSIX::acos(1.0) == 0.0 ? "ok 17\n" : "not ok 17\n"; # See ext/POSIX/hints/sunos_4.pl and ext/POSIX/hints/linux.pl print POSIX::strftime("ok 18 # %H:%M, on %D\n", localtime()); +# If that worked, validate the mini_mktime() routine's normalisation of +# input fields to strftime(). +sub try_strftime { + my $num = shift; + my $expect = shift; + my $got = POSIX::strftime("%a %b %d %H:%M:%S %Y %j", @_); + if ($got eq $expect) { + print "ok $num\n"; + } + else { + print "# expected: $expect\n# got: $got\nnot ok $num\n"; + } +} + +$lc = &POSIX::setlocale(&POSIX::LC_TIME, 'C') if $Config{d_setlocale}; +try_strftime(19, "Wed Feb 28 00:00:00 1996 059", 0,0,0, 28,1,96); +try_strftime(20, "Thu Feb 29 00:00:60 1996 060", 60,0,-24, 30,1,96); +try_strftime(21, "Fri Mar 01 00:00:00 1996 061", 0,0,-24, 31,1,96); +try_strftime(22, "Sun Feb 28 00:00:00 1999 059", 0,0,0, 28,1,99); +try_strftime(23, "Mon Mar 01 00:00:00 1999 060", 0,0,24, 28,1,99); +try_strftime(24, "Mon Feb 28 00:00:00 2000 059", 0,0,0, 28,1,100); +try_strftime(25, "Tue Feb 29 00:00:00 2000 060", 0,0,0, 0,2,100); +try_strftime(26, "Wed Mar 01 00:00:00 2000 061", 0,0,0, 1,2,100); +&POSIX::setlocale(&POSIX::LC_TIME, $lc) if $Config{d_setlocale}; + $| = 0; # The following line assumes buffered output, which may be not true with EMX: print '@#!*$@(!@#$' unless ($^O eq 'os2' || $^O eq 'uwin' || $^O eq 'os390'); diff --git a/t/lib/syslfs.t b/t/lib/syslfs.t index 4619e111dc..a8a7a0cde2 100644 --- a/t/lib/syslfs.t +++ b/t/lib/syslfs.t @@ -187,4 +187,8 @@ explain if $fail; bye(); # does the necessary cleanup +END { + unlink "big"; # be paranoid about leaving 5 gig files lying around +} + # eof diff --git a/t/lib/thread.t b/t/lib/thread.t index 3bca8ba726..6c25407853 100755 --- a/t/lib/thread.t +++ b/t/lib/thread.t @@ -55,9 +55,7 @@ sleep 6; print "ok 12\n"; $t->join; -sub islocked -{ - use attrs 'locked'; +sub islocked : locked { my $val = shift; my $ret; print $val; @@ -74,8 +72,7 @@ $t->join->join; { package Loch::Ness; sub new { bless [], shift } - sub monster { - use attrs qw(locked method); + sub monster : locked, method { my($s, $m) = @_; print "ok $m\n"; } diff --git a/t/op/args.t b/t/op/args.t new file mode 100755 index 0000000000..48bf5afec0 --- /dev/null +++ b/t/op/args.t @@ -0,0 +1,54 @@ +#!./perl + +print "1..8\n"; + +# test various operations on @_ + +my $ord = 0; +sub new1 { bless \@_ } +{ + my $x = new1("x"); + my $y = new1("y"); + ++$ord; + print "# got [@$y], expected [y]\nnot " unless "@$y" eq "y"; + print "ok $ord\n"; + ++$ord; + print "# got [@$x], expected [x]\nnot " unless "@$x" eq "x"; + print "ok $ord\n"; +} + +sub new2 { splice @_, 0, 0, "a", "b", "c"; return \@_ } +{ + my $x = new2("x"); + my $y = new2("y"); + ++$ord; + print "# got [@$x], expected [a b c x]\nnot " unless "@$x" eq "a b c x"; + print "ok $ord\n"; + ++$ord; + print "# got [@$y], expected [a b c y]\nnot " unless "@$y" eq "a b c y"; + print "ok $ord\n"; +} + +sub new3 { goto &new1 } +{ + my $x = new3("x"); + my $y = new3("y"); + ++$ord; + print "# got [@$y], expected [y]\nnot " unless "@$y" eq "y"; + print "ok $ord\n"; + ++$ord; + print "# got [@$x], expected [x]\nnot " unless "@$x" eq "x"; + print "ok $ord\n"; +} + +sub new4 { goto &new2 } +{ + my $x = new4("x"); + my $y = new4("y"); + ++$ord; + print "# got [@$x], expected [a b c x]\nnot " unless "@$x" eq "a b c x"; + print "ok $ord\n"; + ++$ord; + print "# got [@$y], expected [a b c y]\nnot " unless "@$y" eq "a b c y"; + print "ok $ord\n"; +} diff --git a/t/op/avhv.t b/t/op/avhv.t index 6837127d52..92afa37d37 100755 --- a/t/op/avhv.t +++ b/t/op/avhv.t @@ -17,7 +17,7 @@ sub STORESIZE { $#{$_[0]} = $_[1]+1 } package main; -print "1..12\n"; +print "1..15\n"; $sch = { 'abc' => 1, @@ -108,3 +108,13 @@ f($a->{key}); print "not " unless $a->[1] eq 'b'; print "ok 12\n"; +# check if exists() is behaving properly +$avhv = [{foo=>1,bar=>2,pants=>3}]; +print "not " if exists $avhv->{bar}; +print "ok 13\n"; + +$avhv->{pants} = undef; +print "not " unless exists $avhv->{pants}; +print "ok 14\n"; +print "not " if exists $avhv->{bar}; +print "ok 15\n"; diff --git a/t/op/lfs.t b/t/op/lfs.t index 129752b6b1..6f252312ab 100644 --- a/t/op/lfs.t +++ b/t/op/lfs.t @@ -192,4 +192,8 @@ explain if $fail; bye(); # does the necessary cleanup +END { + unlink "big"; # be paranoid about leaving 5 gig files lying around +} + # eof diff --git a/t/op/pack.t b/t/op/pack.t index 082b954756..092e8109cc 100755 --- a/t/op/pack.t +++ b/t/op/pack.t @@ -6,7 +6,7 @@ BEGIN { require Config; import Config; } -print "1..148\n"; +print "1..152\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 @@ -354,18 +354,34 @@ print "ok ", $test++, "\n"; print "not " unless pack("V", 0xdeadbeef) eq "\xef\xbe\xad\xde"; print "ok ", $test++, "\n"; -# 143..148: # +# 143..148: / my $z; -eval { ($x) = unpack '#a*','hello' }; +eval { ($x) = unpack '/a*','hello' }; print 'not ' unless $@; print "ok $test\n"; $test++; -eval { ($z,$x,$y) = unpack 'a3#A C#a* C#Z', "003ok \003yes\004z\000abc" }; +eval { ($z,$x,$y) = unpack 'a3/A C/a* C/Z', "003ok \003yes\004z\000abc" }; print $@ eq '' && $z eq 'ok' ? "ok $test\n" : "not ok $test\n"; $test++; print $@ eq '' && $x eq 'yes' ? "ok $test\n" : "not ok $test\n"; $test++; print $@ eq '' && $y eq 'z' ? "ok $test\n" : "not ok $test\n"; $test++; -eval { ($x) = pack '#a*','hello' }; +eval { ($x) = pack '/a*','hello' }; print 'not ' unless $@; print "ok $test\n"; $test++; -$z = pack 'n#a* w#A*','string','etc'; +$z = pack 'n/a* w/A*','string','etc'; print 'not ' unless $z eq "\000\006string\003etc"; print "ok $test\n"; $test++; +# 149..152: / with # + +eval { ($z,$x,$y) = unpack <<EOU, "003ok \003yes\004z\000abc" }; + a3/A # Count in ASCII + C/a* # Count in a C char + C/Z # Count in a C char but skip after \0 +EOU +print $@ eq '' && $z eq 'ok' ? "ok $test\n" : "not ok $test\n"; $test++; +print $@ eq '' && $x eq 'yes' ? "ok $test\n" : "not ok $test\n"; $test++; +print $@ eq '' && $y eq 'z' ? "ok $test\n" : "not ok $test\n"; $test++; + +$z = pack <<EOP,'string','etc'; + n/a* # Count as network short + w/A* # Count a BER integer +EOP +print 'not ' unless $z eq "\000\006string\003etc"; print "ok $test\n"; $test++; diff --git a/t/op/time.t b/t/op/time.t index 658f9f35b9..caf2c14a6c 100755 --- a/t/op/time.t +++ b/t/op/time.t @@ -47,7 +47,7 @@ else {print "not ok 5\n";} # This could be stricter. -if (gmtime() =~ /^(Sun|Mon|Tue|Wed|Thu|Fri|Sat) (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Nov|Dec) ([ \d]\d) (\d\d):(\d\d):(\d\d) (\d\d\d\d)$/) +if (gmtime() =~ /^(Sun|Mon|Tue|Wed|Thu|Fri|Sat) (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) ([ \d]\d) (\d\d):(\d\d):(\d\d) (\d\d\d\d)$/) {print "ok 6\n";} else {print "not ok 6\n";} diff --git a/t/pod/emptycmd.t b/t/pod/emptycmd.t index 59e395ea04..d348a9d278 100755 --- a/t/pod/emptycmd.t +++ b/t/pod/emptycmd.t @@ -1,7 +1,7 @@ +#!./perl BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/t/pod/for.t b/t/pod/for.t index 44af44f17d..b8a6ec5c73 100755 --- a/t/pod/for.t +++ b/t/pod/for.t @@ -1,7 +1,7 @@ +#!./perl BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/t/pod/for.xr b/t/pod/for.xr index 25794ab0fe..5f6b8b2ce8 100644 --- a/t/pod/for.xr +++ b/t/pod/for.xr @@ -1,19 +1,21 @@ This is a test - pod2text should see this and this and this + pod2text should see this + and this + and this and everything should see this! - Similarly, this line ... +Similarly, this line ... - and this one ... +and this one ... - as well this one, +as well this one, - should all be in pod2text output +should all be in pod2text output - Tweedley-deedley-dee, Im as happy as can be! Tweedley-deedley- - dum, cuz youre my honey sugar plum! + Tweedley-deedley-dee, Im as happy as can be! Tweedley-deedley-dum, cuz + youre my honey sugar plum! The rest of this should show up in everything. diff --git a/t/pod/headings.t b/t/pod/headings.t index 78608d0fd9..fc7b4b265b 100755 --- a/t/pod/headings.t +++ b/t/pod/headings.t @@ -1,7 +1,7 @@ +#!./perl BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/t/pod/headings.xr b/t/pod/headings.xr index e1277b7e37..fb37a2b0cf 100644 --- a/t/pod/headings.xr +++ b/t/pod/headings.xr @@ -5,25 +5,22 @@ SYNOPSIS rdb2pg [*param*=*value* ...] PARAMETERS - rdb2pg uses an IRAF-compatible parameter interface. A template - parameter file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. + rdb2pg uses an IRAF-compatible parameter interface. A template parameter + file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. input *file* - The RDB file to insert into the database. If the given name - is the string `stdin', it reads from the UNIX standard input - stream. - + The RDB file to insert into the database. If the given name is the + string `stdin', it reads from the UNIX standard input stream. DESCRIPTION - rdb2pg will enter the data from an RDB database into a - PostgreSQL database table, optionally creating the database and - the table if they do not exist. It automatically determines the - PostgreSQL data type from the column definition in the RDB file, - but may be overriden via a series of definition files or - directly via one of its parameters. + rdb2pg will enter the data from an RDB database into a PostgreSQL + database table, optionally creating the database and the table if they + do not exist. It automatically determines the PostgreSQL data type from + the column definition in the RDB file, but may be overriden via a series + of definition files or directly via one of its parameters. - The target database and table are specified by the `db' and - `table' parameters. If they do not exist, and the `createdb' - parameter is set, they will be created. Table field definitions - are determined in the following order: + The target database and table are specified by the `db' and `table' + parameters. If they do not exist, and the `createdb' parameter is set, + they will be created. Table field definitions are determined in the + following order: diff --git a/t/pod/include.t b/t/pod/include.t index 4e73b78356..6d0b7e34e5 100755 --- a/t/pod/include.t +++ b/t/pod/include.t @@ -1,7 +1,7 @@ +#!./perl BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/t/pod/include.xr b/t/pod/include.xr index 1bac06adb1..624ee44447 100644 --- a/t/pod/include.xr +++ b/t/pod/include.xr @@ -1,20 +1,19 @@ - This file tries to demonstrate a simple =include directive for - pods. It is used as follows: + This file tries to demonstrate a simple =include directive for pods. It + is used as follows: =include filename - where "filename" is expected to be an absolute pathname, or else - reside be relative to the directory in which the current - processed podfile resides, or be relative to the current - directory. + where "filename" is expected to be an absolute pathname, or else reside + be relative to the directory in which the current processed podfile + resides, or be relative to the current directory. Lets try it out with the file "included.t" shall we. ***THIS TEXT IS IMMEDIATELY BEFORE THE INCLUDE*** ###### begin =include included.t ##### - This is the text of the included file named "included.t". It - should appear in the final pod document from pod2xxx + This is the text of the included file named "included.t". It should + appear in the final pod document from pod2xxx ###### end =include included.t ##### ***THIS TEXT IS IMMEDIATELY AFTER THE INCLUDE*** diff --git a/t/pod/included.t b/t/pod/included.t index 4f171c454b..0e31a090fc 100755 --- a/t/pod/included.t +++ b/t/pod/included.t @@ -1,7 +1,7 @@ +#!./perl BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/t/pod/included.xr b/t/pod/included.xr index f0bc03bf09..54142fa0d3 100644 --- a/t/pod/included.xr +++ b/t/pod/included.xr @@ -1,3 +1,3 @@ - This is the text of the included file named "included.t". It - should appear in the final pod document from pod2xxx + This is the text of the included file named "included.t". It should + appear in the final pod document from pod2xxx diff --git a/t/pod/lref.t b/t/pod/lref.t index 02e2c9e307..e367d6dd66 100755 --- a/t/pod/lref.t +++ b/t/pod/lref.t @@ -1,7 +1,7 @@ +#!./perl BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/t/pod/lref.xr b/t/pod/lref.xr index d8455e3874..297053b1ac 100644 --- a/t/pod/lref.xr +++ b/t/pod/lref.xr @@ -1,22 +1,22 @@ Try out *LOTS* of different ways of specifying references: - Reference the the "section" entry in the manpage manpage + Reference the the section entry in the manpage manpage - Reference the the "section" entry in the manpage manpage + Reference the the section entry in the manpage manpage - Reference the the "section" entry in the manpage manpage + Reference the the section entry in the manpage manpage - Reference the the "section" entry in the manpage manpage + Reference the the section entry in the manpage manpage Reference the the section on "manpage/section" - Reference the the "section" entry in the "manpage" manpage + Reference the the section entry in the "manpage" manpage Reference the the section on "section" in the manpage manpage - Reference the the "section" entry in the manpage manpage + Reference the the section entry in the manpage manpage - Reference the the "section" entry in the manpage manpage + Reference the the section entry in the manpage manpage Now try it using the new "|" stuff ... diff --git a/t/pod/multiline_items.t b/t/pod/multiline_items.t new file mode 100755 index 0000000000..37e8d53069 --- /dev/null +++ b/t/pod/multiline_items.t @@ -0,0 +1,31 @@ +#!./perl +BEGIN { + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +=head1 Test multiline item lists + +This is a test to ensure that multiline =item paragraphs +get indented appropriately. + +=over 4 + +=item This +is +a +test. + +=back + +=cut diff --git a/t/pod/multiline_items.xr b/t/pod/multiline_items.xr new file mode 100644 index 0000000000..dddf05fe34 --- /dev/null +++ b/t/pod/multiline_items.xr @@ -0,0 +1,5 @@ +Test multiline item lists + This is a test to ensure that multiline =item paragraphs get indented + appropriately. + + This is a test. diff --git a/t/pod/nested_items.t b/t/pod/nested_items.t index c8e9b22427..9c098018d1 100755 --- a/t/pod/nested_items.t +++ b/t/pod/nested_items.t @@ -1,7 +1,7 @@ +#!./perl BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/t/pod/nested_items.xr b/t/pod/nested_items.xr index 7d72bbe890..dd1adac127 100644 --- a/t/pod/nested_items.xr +++ b/t/pod/nested_items.xr @@ -1,6 +1,6 @@ Test nested item lists - This is a test to ensure the nested =item paragraphs get - indented appropriately. + This is a test to ensure the nested =item paragraphs get indented + appropriately. 1 First section. diff --git a/t/pod/nested_seqs.t b/t/pod/nested_seqs.t index 8559f1f25f..6a5405bf47 100755 --- a/t/pod/nested_seqs.t +++ b/t/pod/nested_seqs.t @@ -1,7 +1,7 @@ +#!./perl BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/t/pod/nested_seqs.xr b/t/pod/nested_seqs.xr index 5a008c17e9..f981061f94 100644 --- a/t/pod/nested_seqs.xr +++ b/t/pod/nested_seqs.xr @@ -1,3 +1,3 @@ - The statement: `This is dog kind's *finest* hour!' is a parody - of a quotation from Winston Churchill. + The statement: `This is dog kind's *finest* hour!' is a parody of a + quotation from Winston Churchill. diff --git a/t/pod/oneline_cmds.t b/t/pod/oneline_cmds.t index 28bd1d09e5..3081ef4dc3 100755 --- a/t/pod/oneline_cmds.t +++ b/t/pod/oneline_cmds.t @@ -1,7 +1,7 @@ +#!./perl BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/t/pod/oneline_cmds.xr b/t/pod/oneline_cmds.xr index e1277b7e37..fb37a2b0cf 100644 --- a/t/pod/oneline_cmds.xr +++ b/t/pod/oneline_cmds.xr @@ -5,25 +5,22 @@ SYNOPSIS rdb2pg [*param*=*value* ...] PARAMETERS - rdb2pg uses an IRAF-compatible parameter interface. A template - parameter file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. + rdb2pg uses an IRAF-compatible parameter interface. A template parameter + file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. input *file* - The RDB file to insert into the database. If the given name - is the string `stdin', it reads from the UNIX standard input - stream. - + The RDB file to insert into the database. If the given name is the + string `stdin', it reads from the UNIX standard input stream. DESCRIPTION - rdb2pg will enter the data from an RDB database into a - PostgreSQL database table, optionally creating the database and - the table if they do not exist. It automatically determines the - PostgreSQL data type from the column definition in the RDB file, - but may be overriden via a series of definition files or - directly via one of its parameters. + rdb2pg will enter the data from an RDB database into a PostgreSQL + database table, optionally creating the database and the table if they + do not exist. It automatically determines the PostgreSQL data type from + the column definition in the RDB file, but may be overriden via a series + of definition files or directly via one of its parameters. - The target database and table are specified by the `db' and - `table' parameters. If they do not exist, and the `createdb' - parameter is set, they will be created. Table field definitions - are determined in the following order: + The target database and table are specified by the `db' and `table' + parameters. If they do not exist, and the `createdb' parameter is set, + they will be created. Table field definitions are determined in the + following order: diff --git a/t/pod/pod2usage.t b/t/pod/pod2usage.t new file mode 100755 index 0000000000..bceeeefce8 --- /dev/null +++ b/t/pod/pod2usage.t @@ -0,0 +1,18 @@ +#!./perl +BEGIN { + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + +=include pod2usage.PL + + diff --git a/t/pod/pod2usage.xr b/t/pod/pod2usage.xr new file mode 100644 index 0000000000..7315d4025a --- /dev/null +++ b/t/pod/pod2usage.xr @@ -0,0 +1,55 @@ +###### begin =include pod2usage.PL ##### +NAME + pod2usage - print usage messages from embedded pod docs in files + +SYNOPSIS + pod2usage [-help] [-man] [-exit *exitval*] [-output *outfile*] + [-verbose *level*] [-pathlist *dirlist*] *file* + +OPTIONS AND ARGUMENTS + -help Print a brief help message and exit. + + -man Print this command's manual page and exit. + + -exit *exitval* + The exit status value to return. + + -output *outfile* + The output file to print to. If the special names "-" or ">&1" + or ">&STDOUT" are used then standard output is used. If ">&2" or + ">&STDERR" is used then standard error is used. + + -verbose *level* + The desired level of verbosity to use: + + 1 : print SYNOPSIS only + 2 : print SYNOPSIS sections and any OPTIONS/ARGUMENTS sections + 3 : print the entire manpage (similar to running pod2text) + + -pathlist *dirlist* + Specifies one or more directories to search for the input file + if it was not supplied with an absolute path. Each directory + path in the given list should be separated by a ':' on Unix (';' + on MSWin32 and DOS). + + *file* The pathname of a file containing pod documentation to be output + in usage mesage format (defaults to standard input). + +DESCRIPTION + pod2usage will read the given input file looking for pod documentation + and will print the corresponding usage message. If no input file is + specifed than standard input is read. + + pod2usage invokes the pod2usage() function in the Pod::Usage module. + Please see the pod2usage() entry in the Pod::Usage manpage. + +SEE ALSO + the Pod::Usage manpage, the pod2text(1) manpage + +AUTHOR + Brad Appleton <bradapp@enteract.com> + + Based on code for pod2text(1) written by Tom Christiansen + <tchrist@mox.perl.com> + +###### end =include pod2usage.PL ##### diff --git a/t/pod/poderrs.t b/t/pod/poderrs.t index 591bd2a86d..9cbbeeeb91 100755 --- a/t/pod/poderrs.t +++ b/t/pod/poderrs.t @@ -1,7 +1,7 @@ +#!./perl BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; require "testpchk.pl"; import TestPodChecker; } diff --git a/t/pod/poderrs.xr b/t/pod/poderrs.xr index a7bc42d956..82d402d8b2 100644 --- a/t/pod/poderrs.xr +++ b/t/pod/poderrs.xr @@ -1,11 +1,11 @@ -*** ERROR: Unknown command "unknown1" at line 21 of file t/poderrs.t -*** ERROR: Unknown interior-sequence "N" at line 21 of file t/poderrs.t -*** ERROR: Unknown interior-sequence "D" at line 22 of file t/poderrs.t -*** ERROR: Unknown interior-sequence "Q" at line 25 of file t/poderrs.t -*** ERROR: Unknown interior-sequence "A" at line 26 of file t/poderrs.t -*** ERROR: Unknown interior-sequence "V" at line 27 of file t/poderrs.t -*** ERROR: Unknown interior-sequence "Y" at line 27 of file t/poderrs.t -** Unterminated B<...> at t/poderrs.t line 31 -** Unterminated I<...> at t/poderrs.t line 30 -** Unterminated C<...> at t/poderrs.t line 33 -t/poderrs.t has 10 pod syntax errors. +*** ERROR: Unknown command "unknown1" at line 21 in file pod/poderrs.t +*** ERROR: Unknown interior-sequence "N" at line 21 in file pod/poderrs.t +*** ERROR: Unknown interior-sequence "D" at line 22 in file pod/poderrs.t +*** ERROR: Unknown interior-sequence "Q" at line 25 in file pod/poderrs.t +*** ERROR: Unknown interior-sequence "A" at line 26 in file pod/poderrs.t +*** ERROR: Unknown interior-sequence "V" at line 27 in file pod/poderrs.t +*** ERROR: Unknown interior-sequence "Y" at line 27 in file pod/poderrs.t +** Unterminated B<...> at pod/poderrs.t line 31 +** Unterminated I<...> at pod/poderrs.t line 30 +** Unterminated C<...> at pod/poderrs.t line 33 +pod/poderrs.t has 10 pod syntax errors. diff --git a/t/pod/podselect.t b/t/pod/podselect.t new file mode 100755 index 0000000000..30eb30c9b0 --- /dev/null +++ b/t/pod/podselect.t @@ -0,0 +1,18 @@ +#!./perl +BEGIN { + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + +=include podselect.PL + + diff --git a/t/pod/podselect.xr b/t/pod/podselect.xr new file mode 100644 index 0000000000..7d1188d84c --- /dev/null +++ b/t/pod/podselect.xr @@ -0,0 +1,42 @@ +###### begin =include podselect.PL ##### +NAME + podselect - print selected sections of pod documentation on standard + output + +SYNOPSIS + podselect [-help] [-man] [-section *section-spec*] [*file* ...] + +OPTIONS AND ARGUMENTS + -help Print a brief help message and exit. + + -man Print the manual page and exit. + + -section *section-spec* + Specify a section to include in the output. See the section on + "SECTION SPECIFICATIONS" in the Pod::Parser manpage for the + format to use for *section-spec*. This option may be given + multiple times on the command line. + + *file* The pathname of a file from which to select sections of pod + documentation (defaults to standard input). + +DESCRIPTION + podselect will read the given input files looking for pod documentation + and will print out (in raw pod format) all sections that match one ore + more of the given section specifications. If no section specifications + are given than all pod sections encountered are output. + + podselect invokes the podselect() function exported by Pod::Select + Please see the podselect() entry in the Pod::Select manpage for more + details. + +SEE ALSO + the Pod::Parser manpage and the Pod::Select manpage + +AUTHOR + Brad Appleton <bradapp@enteract.com> + + Based on code for Pod::Text::pod2text(1) written by Tom Christiansen + <tchrist@mox.perl.com> + +###### end =include podselect.PL ##### diff --git a/t/pod/special_seqs.t b/t/pod/special_seqs.t index 1b31387dd3..572fb8c061 100755 --- a/t/pod/special_seqs.t +++ b/t/pod/special_seqs.t @@ -1,7 +1,7 @@ +#!./perl BEGIN { - use File::Basename; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/t/pod/special_seqs.xr b/t/pod/special_seqs.xr index 6795de0490..fc06593d9d 100644 --- a/t/pod/special_seqs.xr +++ b/t/pod/special_seqs.xr @@ -1,13 +1,11 @@ - This is a test to see if I can do not only `$self' and - `method()', but also `$self->method()' and `$self->{FIELDNAME}' - and `{FOO=>BAR}' without resorting to escape sequences. + This is a test to see if I can do not only `$self' and `method()', but + also `$self->method()' and `$self->{FIELDNAME}' and `{FOO=>BAR}' without + resorting to escape sequences. - Now for the grand finale of `$self->method()->{FIELDNAME} = - {FOO=>BAR}'. + Now for the grand finale of `$self->method()->{FIELDNAME} = {FOO=>BAR}'. - Of course I should still be able to do all this *with* escape - sequences too: `$self->method()' and `$self->{FIELDNAME}' and - `{FOO=>BAR}'. + Of course I should still be able to do all this *with* escape sequences + too: `$self->method()' and `$self->{FIELDNAME}' and `{FOO=>BAR}'. Dont forget `$self->method()->{FIELDNAME} = {FOO=>BAR}'. diff --git a/t/pod/testp2pt.pl b/t/pod/testp2pt.pl index 9df5b9f2ed..234a5271c4 100644 --- a/t/pod/testp2pt.pl +++ b/t/pod/testp2pt.pl @@ -13,8 +13,6 @@ BEGIN { push @INC, map { File::Spec->catfile($_, 'lib') } ($PARENTDIR, $THISDIR); } -use Pod::PlainText; -use vars qw(@ISA @EXPORT $MYPKG); #use strict; #use diagnostics; use Carp; @@ -22,13 +20,23 @@ use Exporter; #use File::Compare; #use Cwd qw(abs_path); -@ISA = qw(Pod::PlainText); -@EXPORT = qw(&testpodplaintext); +use vars qw($MYPKG @EXPORT @ISA); $MYPKG = eval { (caller)[0] }; +@EXPORT = qw(&testpodplaintext); +BEGIN { + if ( $] >= 5.005_58 ) { + require Pod::Text; + @ISA = qw( Pod::Text ); + } + else { + require Pod::PlainText; + @ISA = qw( Pod::PlainText ); + } +} ## Hardcode settings for TERMCAP and COLUMNS so we can try to get ## reproducible results between environments -@ENV{qw(TERMCAP COLUMNS)} = ('co=72:do=^J', 72); +@ENV{qw(TERMCAP COLUMNS)} = ('co=76:do=^J', 76); sub catfile(@) { File::Spec->catfile(@_); } @@ -37,7 +45,7 @@ $INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 'xtra'); $INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 'pod'); $INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 't'); my @PODINCDIRS = ( catfile($INSTDIR, 'lib', 'Pod'), - catfile($INSTDIR, 'scripts'), + catfile($INSTDIR, 'pod'), catfile($INSTDIR, 't', 'pod'), catfile($INSTDIR, 't', 'pod', 'xtra') ); @@ -111,7 +119,7 @@ sub testpodinc2plaintext( @ ) { return $msg; } - print "+ Running testpodinc2plaintext for '$testname'...\n"; + print "# Running testpodinc2plaintext for '$testname'...\n"; ## Compare the output against the expected result podinc2plaintext($infile, $outfile); if ( testcmp($outfile, $cmpfile) ) { @@ -145,12 +153,12 @@ sub testpodplaintext( @ ) { if ($opts{'-xrgen'}) { if ($opts{'-force'} or ! -e $cmpfile) { ## Create the comparison file - print "+ Creating expected result for \"$testname\"" . + print "# Creating expected result for \"$testname\"" . " pod2plaintext test ...\n"; podinc2plaintext($podfile, $cmpfile); } else { - print "+ File $cmpfile already exists" . + print "# File $cmpfile already exists" . " (use '-force' to regenerate it).\n"; } next; @@ -162,13 +170,13 @@ sub testpodplaintext( @ ) { -Cmp => $cmpfile; if ($failmsg) { ++$failed; - print "+\tFAILED. ($failmsg)\n"; + print "#\tFAILED. ($failmsg)\n"; print "not ok ", $failed+$passes, "\n"; } else { ++$passes; unlink($outfile); - print "+\tPASSED.\n"; + print "#\tPASSED.\n"; print "ok ", $failed+$passes, "\n"; } } diff --git a/t/pod/testpchk.pl b/t/pod/testpchk.pl index cd3c13816d..07236e69e7 100644 --- a/t/pod/testpchk.pl +++ b/t/pod/testpchk.pl @@ -62,7 +62,7 @@ sub testpodcheck( @ ) { return $msg; } - print "+ Running podchecker for '$testname'...\n"; + print "# Running podchecker for '$testname'...\n"; ## Compare the output against the expected result podchecker($infile, $outfile); if ( testcmp({'-cmplines' => \&msgcmp}, $outfile, $cmpfile) ) { @@ -96,12 +96,12 @@ sub testpodchecker( @ ) { if ($opts{'-xrgen'}) { if ($opts{'-force'} or ! -e $cmpfile) { ## Create the comparison file - print "+ Creating expected result for \"$testname\"" . + print "# Creating expected result for \"$testname\"" . " podchecker test ...\n"; podchecker($podfile, $cmpfile); } else { - print "+ File $cmpfile already exists" . + print "# File $cmpfile already exists" . " (use '-force' to regenerate it).\n"; } next; @@ -113,13 +113,13 @@ sub testpodchecker( @ ) { -Cmp => $cmpfile; if ($failmsg) { ++$failed; - print "+\tFAILED. ($failmsg)\n"; + print "#\tFAILED. ($failmsg)\n"; print "not ok ", $failed+$passes, "\n"; } else { ++$passes; unlink($outfile); - print "+\tPASSED.\n"; + print "#\tPASSED.\n"; print "ok ", $failed+$passes, "\n"; } } diff --git a/t/pragma/strict-refs b/t/pragma/strict-refs index 7bf1556e10..10599b0bb2 100644 --- a/t/pragma/strict-refs +++ b/t/pragma/strict-refs @@ -196,6 +196,7 @@ ${"Fred"} ; require "./abc"; EXPECT Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at ./abc line 2. +Compilation failed in require at - line 2. ######## --FILE-- abc.pm @@ -207,6 +208,7 @@ my $a = ${"Fred"} ; use abc; EXPECT Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at abc.pm line 2. +Compilation failed in require at - line 2. BEGIN failed--compilation aborted at - line 2. ######## diff --git a/t/pragma/strict-vars b/t/pragma/strict-vars index 42107fa8e1..b8108d278c 100644 --- a/t/pragma/strict-vars +++ b/t/pragma/strict-vars @@ -165,6 +165,7 @@ print STDERR $@; $joe = 1 ; EXPECT Global symbol "$joe" requires explicit package name at - line 5. +Global symbol "$joe" requires explicit package name at - line 8. Execution of - aborted due to compilation errors. ######## @@ -221,3 +222,88 @@ $joe = 1 ; EXPECT Global symbol "$joe" requires explicit package name at - line 8. Execution of - aborted due to compilation errors. +######## + +# Check if multiple evals produce same errors +use strict 'vars'; +my $ret = eval q{ print $x; }; +print $@; +print "ok 1\n" unless defined $ret; +$ret = eval q{ print $x; }; +print $@; +print "ok 2\n" unless defined $ret; +EXPECT +Global symbol "$x" requires explicit package name at (eval 1) line 1. +ok 1 +Global symbol "$x" requires explicit package name at (eval 2) line 1. +ok 2 +######## + +# strict vars with outer our - no error +use strict 'vars' ; +our $freddy; +local $abc::joe ; +my $fred ; +my $b = \$fred ; +$Fred::ABC = 1 ; +$freddy = 2 ; +EXPECT + +######## + +# strict vars with inner our - no error +use strict 'vars' ; +sub foo { + our $fred; + $fred; +} +EXPECT + +######## + +# strict vars with outer our, inner use - no error +use strict 'vars' ; +our $fred; +sub foo { + $fred; +} +EXPECT + +######## + +# strict vars with nested our - no error +use strict 'vars' ; +our $fred; +sub foo { + our $fred; + $fred; +} +$fred ; +EXPECT + +######## + +# strict vars with elapsed our - error +use strict 'vars' ; +sub foo { + our $fred; + $fred; +} +$fred ; +EXPECT +Variable "$fred" is not imported at - line 8. +Global symbol "$fred" requires explicit package name at - line 8. +Execution of - aborted due to compilation errors. +######## + +# nested our with local - no error +$fred = 1; +use strict 'vars'; +{ + local our $fred = 2; + print $fred,"\n"; +} +print our $fred,"\n"; +EXPECT +2 +1 diff --git a/t/pragma/sub_lval.t b/t/pragma/sub_lval.t index c382ad52ae..e96c329d8e 100755 --- a/t/pragma/sub_lval.t +++ b/t/pragma/sub_lval.t @@ -5,8 +5,8 @@ BEGIN { unshift @INC, '../lib'; } -sub a {use attrs 'lvalue'; my $a = 34; bless \$a} # Return a temporary -sub b {use attrs 'lvalue'; shift} +sub a : lvalue { my $a = 34; bless \$a } # Return a temporary +sub b : lvalue { shift } my $out = a(b()); # Check that temporaries are allowed. print "# `$out'\nnot " unless ref $out eq 'main'; # Not reached if error. @@ -20,8 +20,8 @@ my $in; # Check that we can return localized values from subroutines: -sub in {use attrs 'lvalue'; $in = shift;} -sub neg {use attrs 'lvalue'; #(num_str) return num_str +sub in : lvalue { $in = shift; } +sub neg : lvalue { #(num_str) return num_str local $_ = shift; s/^\+/-/; $_; @@ -32,11 +32,11 @@ in(neg("+2")); print "# `$in'\nnot " unless $in eq '-2'; print "ok 3\n"; -sub get_lex {use attrs 'lvalue'; $in} -sub get_st {use attrs 'lvalue'; $blah} -sub id {use attrs 'lvalue'; shift} -sub id1 {use attrs 'lvalue'; $_[0]} -sub inc {use attrs 'lvalue'; ++$_[0]} +sub get_lex : lvalue { $in } +sub get_st : lvalue { $blah } +sub id : lvalue { shift } +sub id1 : lvalue { $_[0] } +sub inc : lvalue { ++$_[0] } $in = 5; $blah = 3; @@ -139,9 +139,9 @@ $#c = 3; # These slots are not fillable. =for disabled constructs -sub a3 {use attrs 'lvalue'; @a} -sub b2 {use attrs 'lvalue'; @b} -sub c4 {use attrs 'lvalue'; @c} +sub a3 :lvalue {@a} +sub b2 : lvalue {@b} +sub c4: lvalue {@c} $_ = ''; @@ -162,7 +162,7 @@ print "ok 22\n"; my $var; -sub a::var {use attrs 'lvalue'; $var} +sub a::var : lvalue { $var } "a"->var = 45; @@ -177,7 +177,7 @@ $o->var = 47; print "# `$var' ne 47\nnot " unless $var eq 47; print "ok 24\n"; -sub o {use attrs 'lvalue'; $o} +sub o : lvalue { $o } o->var = 49; @@ -242,7 +242,7 @@ print "# '$_', '$x0', '$x1'.\nnot " unless /Can\'t modify non-lvalue subroutine call/; print "ok 30\n"; -sub lv0 {use attrs 'lvalue';} # Converted to lv10 in scalar context +sub lv0 : lvalue { } # Converted to lv10 in scalar context $_ = undef; eval <<'EOE' or $_ = $@; @@ -254,7 +254,7 @@ print "# '$_'.\nnot " unless /Can\'t return a readonly value from lvalue subroutine/; print "ok 31\n"; -sub lv10 {use attrs 'lvalue';} +sub lv10 : lvalue {} $_ = undef; eval <<'EOE' or $_ = $@; @@ -265,7 +265,7 @@ EOE print "# '$_'.\nnot " if defined $_; print "ok 32\n"; -sub lv1u {use attrs 'lvalue'; undef } +sub lv1u :lvalue { undef } $_ = undef; eval <<'EOE' or $_ = $@; @@ -288,7 +288,7 @@ print "# '$_'.\nnot " print "ok 34\n"; $x = '1234567'; -sub lv1t {use attrs 'lvalue'; index $x, 2 } +sub lv1t : lvalue { index $x, 2 } $_ = undef; eval <<'EOE' or $_ = $@; @@ -312,7 +312,7 @@ print "ok 36\n"; $xxx = 'xxx'; sub xxx () { $xxx } # Not lvalue -sub lv1tmp {use attrs 'lvalue'; xxx } # is it a TEMP? +sub lv1tmp : lvalue { xxx } # is it a TEMP? $_ = undef; eval <<'EOE' or $_ = $@; @@ -335,7 +335,7 @@ print "# '$_'.\nnot " print "ok 38\n"; sub xxx () { 'xxx' } # Not lvalue -sub lv1tmpr {use attrs 'lvalue'; xxx } # is it a TEMP? +sub lv1tmpr : lvalue { xxx } # is it a TEMP? $_ = undef; eval <<'EOE' or $_ = $@; @@ -359,7 +359,7 @@ print "ok 40\n"; =for disabled constructs -sub lva {use attrs 'lvalue';@a} +sub lva : lvalue {@a} $_ = undef; @a = (); @@ -401,7 +401,7 @@ print "ok 43\n"; print "ok $_\n" for 41..43; -sub lv1n {use attrs 'lvalue'; $newvar } +sub lv1n : lvalue { $newvar } $_ = undef; eval <<'EOE' or $_ = $@; @@ -412,7 +412,7 @@ EOE print "# '$_', '$newvar'.\nnot " unless "'$newvar' $_" eq "'4' "; print "ok 44\n"; -sub lv1nn {use attrs 'lvalue'; $nnewvar } +sub lv1nn : lvalue { $nnewvar } $_ = undef; eval <<'EOE' or $_ = $@; @@ -101,6 +101,7 @@ PERLVAR(Tmainstack, AV *) /* the stack when nothing funny is happening */ PERLVAR(Ttop_env, JMPENV *) /* ptr. to current sigjmp() environment */ PERLVAR(Tstart_env, JMPENV) /* empty startup sigjmp() environment */ PERLVARI(Tprotect, protect_proc_t, MEMBER_TO_FPTR(Perl_default_protect)) +PERLVARI(Terrors, SV *, Nullsv) /* outstanding queued errors */ /* statics "owned" by various functions */ PERLVAR(Tav_fetch_sv, SV *) /* owned by av_fetch() */ @@ -1971,12 +1971,17 @@ Perl_yylex(pTHX) if it's a legal name, the OP is a PADANY. */ if (PL_in_my) { - if (strchr(PL_tokenbuf,':')) - yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf)); + if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */ + tmp = pad_allocmy(PL_tokenbuf); + } + else { + if (strchr(PL_tokenbuf,':')) + yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf)); - yylval.opval = newOP(OP_PADANY, 0); - yylval.opval->op_targ = pad_allocmy(PL_tokenbuf); - return PRIVATEREF; + yylval.opval = newOP(OP_PADANY, 0); + yylval.opval->op_targ = pad_allocmy(PL_tokenbuf); + return PRIVATEREF; + } } /* @@ -2004,6 +2009,22 @@ Perl_yylex(pTHX) } #endif /* USE_THREADS */ if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) { + /* might be an "our" variable" */ + if (SvFLAGS(AvARRAY(PL_comppad_name)[tmp]) & SVpad_OUR) { + /* build ops for a bareword */ + yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0)); + yylval.opval->op_private = OPpCONST_ENTERED; + gv_fetchpv(PL_tokenbuf+1, + (PL_in_eval + ? (GV_ADDMULTI | GV_ADDINEVAL | GV_ADDOUR) + : GV_ADDOUR + ), + ((PL_tokenbuf[0] == '$') ? SVt_PV + : (PL_tokenbuf[0] == '@') ? SVt_PVAV + : SVt_PVHV)); + return WORD; + } + /* if it's a sort block and they're naming $a or $b */ if (PL_last_lop_op == OP_SORT && PL_tokenbuf[0] == '$' && @@ -2425,8 +2446,24 @@ Perl_yylex(pTHX) * Look for options. */ d = instr(s,"perl -"); - if (!d) + if (!d) { d = instr(s,"perl"); +#if defined(DOSISH) + /* avoid getting into infinite loops when shebang + * line contains "Perl" rather than "perl" */ + if (!d) { + for (d = ipathend-4; d >= ipath; --d) { + if ((*d == 'p' || *d == 'P') + && !ibcmp(d, "perl", 4)) + { + break; + } + } + if (d < ipath) + d = Nullch; + } +#endif + } #ifdef ALTERNATE_SHEBANG /* * If the ALTERNATE_SHEBANG on this system starts with a @@ -3943,8 +3980,16 @@ Perl_yylex(pTHX) if ((PL_bufend - p) >= 3 && strnEQ(p, "my", 2) && isSPACE(*(p + 2))) p += 2; + else if ((PL_bufend - p) >= 4 && + strnEQ(p, "our", 3) && isSPACE(*(p + 3))) + p += 3; p = skipspace(p); - if (isIDFIRST_lazy(p)) + if (isIDFIRST_lazy(p)) { + p = scan_ident(p, PL_bufend, + PL_tokenbuf, sizeof PL_tokenbuf, TRUE); + p = skipspace(p); + } + if (*p != '$') Perl_croak(aTHX_ "Missing $ on loop variable"); } OPERATOR(FOR); @@ -4150,8 +4195,9 @@ Perl_yylex(pTHX) case KEY_msgsnd: LOP(OP_MSGSND,XTERM); + case KEY_our: case KEY_my: - PL_in_my = TRUE; + PL_in_my = tmp; s = skipspace(s); if (isIDFIRST_lazy(s)) { s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len); @@ -5104,8 +5150,7 @@ Perl_keyword(pTHX_ register char *d, I32 len) case 3: if (strEQ(d,"ord")) return -KEY_ord; if (strEQ(d,"oct")) return -KEY_oct; - if (strEQ(d,"our")) { deprecate("reserved word \"our\""); - return 0;} + if (strEQ(d,"our")) return KEY_our; break; case 4: if (strEQ(d,"open")) return -KEY_open; @@ -6897,7 +6942,6 @@ int Perl_yywarn(pTHX_ char *s) { dTHR; - --PL_error_count; PL_in_eval |= EVAL_WARNONLY; yyerror(s); PL_in_eval &= ~EVAL_WARNONLY; @@ -6977,11 +7021,9 @@ PRId64 ")\n", } if (PL_in_eval & EVAL_WARNONLY) Perl_warn(aTHX_ "%_", msg); - else if (PL_in_eval) - sv_catsv(ERRSV, msg); else - PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg)); - if (++PL_error_count >= 10) + qerror(msg); + if (PL_error_count >= 10) Perl_croak(aTHX_ "%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv)); PL_in_my = 0; PL_in_my_stash = Nullhv; @@ -912,7 +912,7 @@ Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen) If FBMcf_TAIL, the table is created as if the string has a trailing \n. */ void -Perl_fbm_compile(pTHX_ SV *sv, U32 flags /* not used yet */) +Perl_fbm_compile(pTHX_ SV *sv, U32 flags) { register U8 *s; register U8 *table; @@ -928,23 +928,23 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags /* not used yet */) if (len == 0) /* TAIL might be on on a zero-length string. */ return; if (len > 2) { - I32 mlen = len; + U8 mlen; unsigned char *sb; - if (mlen > 255) + if (len > 255) mlen = 255; - Sv_Grow(sv,len + 256 + FBM_TABLE_OFFSET); + else + mlen = (U8)len; + Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET); table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET); - s = table - 1 - FBM_TABLE_OFFSET; /* Last char */ - for (i = 0; i < 256; i++) { - table[i] = mlen; - } - table[-1] = flags; /* Not used yet */ + s = table - 1 - FBM_TABLE_OFFSET; /* last char */ + memset((void*)table, mlen, 256); + table[-1] = (U8)flags; i = 0; - sb = s - mlen; + sb = s - mlen + 1; /* first char (maybe) */ while (s >= sb) { if (table[*s] == mlen) - table[*s] = i; + table[*s] = (U8)i; s--, i++; } } @@ -963,7 +963,8 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags /* not used yet */) BmUSEFUL(sv) = 100; /* Initial value */ if (flags & FBMcf_TAIL) SvTAIL_on(sv); - DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv))); + DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n", + BmRARE(sv),BmPREVIOUS(sv))); } /* If SvTAIL(littlestr), it has a fake '\n' at end. */ @@ -1075,15 +1076,17 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit } if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */ s = bigend - littlelen; - if (s >= big - && bigend[-1] == '\n' - && *s == *little + if (s >= big && bigend[-1] == '\n' && *s == *little /* Automatically of length > 2 */ && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2)) + { return (char*)s; /* how sweet it is */ - if (s[1] == *little && memEQ((char*)s + 2,(char*)little + 1, - littlelen - 2)) + } + if (s[1] == *little + && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2)) + { return (char*)s + 1; /* how sweet it is */ + } return Nullch; } if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) { @@ -1093,9 +1096,11 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */ /* Chop \n from littlestr: */ s = bigend - littlelen + 1; - if (*s == *little && memEQ((char*)s + 1, (char*)little + 1, - littlelen - 2)) + if (*s == *little + && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2)) + { return (char*)s; + } return Nullch; } return b; @@ -1117,7 +1122,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit top2: /*SUPPRESS 560*/ - if (tmp = table[*s]) { + if ((tmp = table[*s])) { #ifdef POINTERRIGOR if (bigend - s > tmp) { s += tmp; @@ -1379,8 +1384,33 @@ Perl_vform(pTHX_ const char *pat, va_list *args) return SvPVX(sv); } +#if defined(PERL_IMPLICIT_CONTEXT) SV * -Perl_mess(pTHX_ const char *pat, va_list *args) +Perl_mess_nocontext(const char *pat, ...) +{ + dTHX; + SV *retval; + va_list args; + va_start(args, pat); + retval = vmess(pat, &args); + va_end(args); + return retval; +} +#endif /* PERL_IMPLICIT_CONTEXT */ + +SV * +Perl_mess(pTHX_ const char *pat, ...) +{ + SV *retval; + va_list args; + va_start(args, pat); + retval = vmess(pat, &args); + va_end(args); + return retval; +} + +SV * +Perl_vmess(pTHX_ const char *pat, va_list *args) { SV *sv = mess_alloc(); static char dgd[] = " during global destruction.\n"; @@ -1438,8 +1468,14 @@ Perl_vdie(pTHX_ const char* pat, va_list *args) thr, PL_curstack, PL_mainstack)); if (pat) { - msv = mess(pat, args); - message = SvPV(msv,msglen); + msv = vmess(pat, args); + if (PL_errors && SvCUR(PL_errors)) { + sv_catsv(PL_errors, msv); + message = SvPV(PL_errors, msglen); + SvCUR_set(PL_errors, 0); + } + else + message = SvPV(msv,msglen); } else { message = Nullch; @@ -1529,9 +1565,18 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) SV *msv; STRLEN msglen; - msv = mess(pat, args); - message = SvPV(msv,msglen); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message)); + msv = vmess(pat, args); + if (PL_errors && SvCUR(PL_errors)) { + sv_catsv(PL_errors, msv); + message = SvPV(PL_errors, msglen); + SvCUR_set(PL_errors, 0); + } + else + message = SvPV(msv,msglen); + + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", + (unsigned long) thr, message)); + if (PL_diehook) { /* sv_2cv might call Perl_croak() */ SV *olddiehook = PL_diehook; @@ -1609,7 +1654,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) SV *msv; STRLEN msglen; - msv = mess(pat, args); + msv = vmess(pat, args); message = SvPV(msv, msglen); if (PL_warnhook) { @@ -1705,7 +1750,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) SV *msv; STRLEN msglen; - msv = mess(pat, args); + msv = vmess(pat, args); message = SvPV(msv, msglen); if (ckDEAD(err)) { @@ -3370,6 +3415,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) PL_restartop = 0; PL_statname = NEWSV(66,0); + PL_errors = newSVpvn("", 0); PL_maxscream = -1; PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp); PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags); diff --git a/utils/h2xs.PL b/utils/h2xs.PL index bd0ba16f46..7d72e8a1a8 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -81,7 +81,11 @@ the POD template. =item B<-F> Additional flags to specify to C preprocessor when scanning header for -function declarations. Should not be used without B<-x>. +function declarations. Should not be used without B<-x>. + +=item B<-M> I<regular expression> + +selects functions/macros to process. =item B<-O> @@ -108,7 +112,7 @@ Turn on debugging messages. =item B<-f> Allows an extension to be created for a header even if that header is -not found in /usr/include. +not found in standard include directories. =item B<-h> @@ -118,6 +122,21 @@ Print the usage, help and version for this h2xs and exit. Specifies a name to be used for the extension, e.g., S<-n RPC::DCE> +=item B<-o> I<regular expression> + +Use "opaque" data type for the C types matched by the regular +expression, even if these types are C<typedef>-equivalent to types +from typemaps. Should not be used without B<-x>. + +This may be useful since, say, types which are C<typedef>-equivalent +to integers may represent OS-related handles, and one may want to work +with these handles in OO-way, as in C<$handle-E<gt>do_something()>. +Use C<-o .> if you want to handle all the C<typedef>ed types as opaque types. + +The type-to-match is whitewashed (except for commas, which have no +whitespace before them, and multiple C<*> which have no whitespace +between them). + =item B<-p> I<prefix> Specify a prefix which should be removed from the Perl function names, e.g., S<-p sec_rgy_> @@ -145,7 +164,8 @@ but XSUBs are emitted only for the declarations included from file NAME2. Note that some types of arguments/return-values for functions may result in XSUB-declarations/typemap-entries which need hand-editing. Such may be objects which cannot be converted from/to a -pointer (like C<long long>), pointers to functions, or arrays. +pointer (like C<long long>), pointers to functions, or arrays. See +also the section on L<LIMITATIONS of B<-x>>. =back @@ -198,6 +218,12 @@ pointer (like C<long long>), pointers to functions, or arrays. # Same with function declaration in proto.h as visible from perl.h. h2xs -xAn perl2 perl.h,proto.h + # Same but select only functions which match /^av_/ + h2xs -M '^av_' -xAn perl2 perl.h,proto.h + + # Same but treat SV* etc as "opaque" types + h2xs -o '^[S]V \*$' -M '^av_' -xAn perl2 perl.h,proto.h + =head1 ENVIRONMENT No environment variables are used. @@ -214,10 +240,74 @@ L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>. The usual warnings if it cannot read or write the files involved. +=head1 LIMITATIONS of B<-x> + +F<h2xs> would not distinguish whether an argument to a C function +which is of the form, say, C<int *>, is an input, output, or +input/output parameter. In particular, argument declarations of the +form + + int + foo(n) + int *n + +should be better rewritten as + + int + foo(n) + int &n + +if C<n> is an input parameter. + +Additionally, F<h2xs> has no facilities to intuit that a function + + int + foo(addr,l) + char *addr + int l + +takes a pair of address and length of data at this address, so it is better +to rewrite this function as + + int + foo(sv) + SV *addr + PREINIT: + STRLEN len; + char *s; + CODE: + s = SvPV(sv,len); + RETVAL = foo(s, len); + OUTPUT: + RETVAL + +or alternately + + static int + my_foo(SV *sv) + { + STRLEN len; + char *s = SvPV(sv,len); + + return foo(s, len); + } + + MODULE = foo PACKAGE = foo PREFIX = my_ + + int + foo(sv) + SV *sv + +See L<perlxs> and L<perlxstut> for additional details. + =cut -my( $H2XS_VERSION ) = ' $Revision: 1.19 $ ' =~ /\$Revision:\s+([^\s]+)/; +use strict; + + +my( $H2XS_VERSION ) = ' $Revision: 1.20 $ ' =~ /\$Revision:\s+([^\s]+)/; my $TEMPLATE_VERSION = '0.01'; +my @ARGS = @ARGV; use Getopt::Std; @@ -228,6 +318,7 @@ version: $H2XS_VERSION -A Omit all autoloading facilities (implies -c). -C Omit creating the Changes file, add HISTORY heading to stub POD. -F Additional flags for C preprocessor (used with -x). + -M Mask to select C functions/macros (default is select all). -O Allow overwriting of a pre-existing extension directory. -P Omit the stub POD section. -X Omit the XS portion (implies both -c and -f). @@ -236,6 +327,7 @@ version: $H2XS_VERSION -f Force creation of the extension even if the C header does not exist. -h Display this help message -n Specify a name to use for the extension (recommended). + -o Regular expression for \"opaque\" types. -p Specify a prefix which should be removed from the Perl function names. -s Create subroutines for specified macros. -v Specify a version number for this extension. @@ -247,7 +339,9 @@ extra_libraries } -getopts("ACF:OPXcdfhn:p:s:v:x") || usage; +getopts("ACF:M:OPXcdfhn:o:p:s:v:x") || usage; +use vars qw($opt_A $opt_C $opt_F $opt_M $opt_O $opt_P $opt_X $opt_c + $opt_d $opt_f $opt_h $opt_n $opt_o $opt_p $opt_s $opt_v $opt_x); usage if $opt_h; @@ -261,7 +355,9 @@ $opt_c = 1 if $opt_A; # -X implies -c and -f $opt_c = $opt_f = 1 if $opt_X; -%const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s; +my %const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s; +my $extralibs; +my @path_h; while (my $arg = shift) { if ($arg =~ /^-l/i) { @@ -274,34 +370,70 @@ while (my $arg = shift) { usage "Must supply header file or module name\n" unless (@path_h or $opt_n); +my $fmask; +my $tmask; + +$fmask = qr{$opt_M} if defined $opt_M; +$tmask = qr{$opt_o} if defined $opt_o; +my $tmask_all = $tmask && $opt_o eq '.'; + +if ($opt_x) { + eval {require C::Scan; 1} + or die <<EOD; +C::Scan required if you use -x option. +To install C::Scan, execute + perl -MCPAN -e "install C::Scan" +EOD + unless ($tmask_all) { + $C::Scan::VERSION >= 0.70 + or die <<EOD; +C::Scan v. 0.70 or later required unless you use -o . option. +You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}. +To install C::Scan, execute + perl -MCPAN -e "install C::Scan" +EOD + } +} +elsif ($opt_o or $opt_F) { + warn <<EOD; +Options -o and -F do not make sense without -x. +EOD +} + +my @path_h_ini = @path_h; +my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names); if( @path_h ){ + use Config; + use File::Spec; + my @paths; + if ($^O eq 'VMS') { # Consider overrides of default location + # XXXX This is not equivalent to what the older version did: + # it was looking at $hadsys header-file per header-file... + my($hadsys) = grep s!^sys/!!i , @path_h; + @paths = qw( Sys$Library VAXC$Include ); + push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]'); + push @paths, qw( DECC$Library_Include DECC$System_Include ); + } + else { + @paths = (File::Spec->curdir(), $Config{usrinc}, + (split ' ', $Config{locincpth}), '/usr/include'); + } foreach my $path_h (@path_h) { $name ||= $path_h; if( $path_h =~ s#::#/#g && $opt_n ){ warn "Nesting of headerfile ignored with -n\n"; } $path_h .= ".h" unless $path_h =~ /\.h$/; - $fullpath = $path_h; + my $fullpath = $path_h; $path_h =~ s/,.*$// if $opt_x; - if ($^O eq 'VMS') { # Consider overrides of default location - if ($path_h !~ m![:>\[]!) { - my($hadsys) = ($path_h =~ s!^sys/!!i); - if ($ENV{'DECC$System_Include'}) { $path_h = "DECC\$System_Include:$path_h"; } - elsif ($ENV{'DECC$Library_Include'}) { $path_h = "DECC\$Library_Include:$path_h"; } - elsif ($ENV{'GNU_CC_Include'}) { $path_h = 'GNU_CC_Include:' . - ($hadsys ? '[vms]' : '[000000]') . $path_h; } - elsif ($ENV{'VAXC$Include'}) { $path_h = "VAXC\$_Include:$path_h"; } - else { $path_h = "Sys\$Library:$path_h"; } - } - } - elsif ($^O eq 'os2') { - $path_h = "/usr/include/$path_h" - if $path_h !~ m#^([a-z]:)?[./]#i and -r "/usr/include/$path_h"; - } - else { - $path_h = "/usr/include/$path_h" - if $path_h !~ m#^[./]# and -r "/usr/include/$path_h"; + $fullpath{$path_h} = $fullpath; + + if (not -f $path_h) { + my $tmp_path_h = $path_h; + for my $dir (@paths) { + last if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h)); + } } if (!$opt_c) { @@ -310,10 +442,24 @@ if( @path_h ){ # Record the names of simple #define constants into const_names # Function prototypes are processed below. open(CH, "<$path_h") || die "Can't open $path_h: $!\n"; + defines: while (<CH>) { - if (/^#[ \t]*define\s+([\$\w]+)\b\s*[^("]/) { - print "Matched $_ ($1)\n" if $opt_d; - $_ = $1; + if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^" \t])(.*)/) { + my $def = $1; + my $rest = $2; + $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments + $rest =~ s/^\s+//; + $rest =~ s/\s+$//; + # Cannot do: (-1) and ((LHANDLE)3) are OK: + #print("Skip non-wordy $def => $rest\n"), + # next defines if $rest =~ /[^\w\$]/; + if ($rest =~ /"/) { + print("Skip stringy $def => $rest\n") if $opt_d; + next defines; + } + print "Matched $_ ($def)\n" if $opt_d; + $seen_define{$def} = $rest; + $_ = $def; next if /^_.*_h_*$/i; # special case, but for what? if (defined $opt_p) { if (!/^$opt_p(\d)/) { @@ -323,17 +469,20 @@ if( @path_h ){ warn "can't remove $opt_p prefix from '$_'!\n"; } } - $const_names{$_}++; + $prefixless{$def} = $_; + if (!$fmask or /$fmask/) { + print "... Passes mask of -M.\n" if $opt_d and $fmask; + $const_names{$_}++; + } } } close(CH); } } - @const_names = sort keys %const_names; } -$module = $opt_n || do { +my $module = $opt_n || do { $name =~ s/\.h$//; if( $name !~ /::/ ){ $name =~ s#^.*/##; @@ -342,6 +491,7 @@ $module = $opt_n || do { $name; }; +my ($ext, $nested, @modparts, $modfname, $modpname); (chdir 'ext', $ext = 'ext/') if -d 'ext'; if( $module =~ /::/ ){ @@ -359,11 +509,12 @@ else { if ($opt_O) { warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname; -} else { +} +else { die "Won't overwrite existing $ext$modpname\n" if -e $modpname; } if( $nested ){ - $modpath = ""; + my $modpath = ""; foreach (@modparts){ mkdir("$modpath$_", 0777); $modpath .= "$_/"; @@ -376,19 +527,28 @@ my %types_seen; my %std_types; my $fdecls = []; my $fdecls_parsed = []; +my $typedef_rex; +my %typedefs_pre; +my %known_fnames; + +my @fnames; +my @fnames_no_prefix; if( ! $opt_X ){ # use XS, unless it was disabled open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n"; if ($opt_x) { - require C::Scan; # Run-time directive require Config; # Run-time directive warn "Scanning typemaps...\n"; get_typemap(); - my $c; - my $filter; + my @td; + my @good_td; + my $addflags = $opt_F || ''; + foreach my $filename (@path_h) { - my $addflags = $opt_F || ''; - if ($fullpath =~ /,/) { + my $c; + my $filter; + + if ($fullpath{$filename} =~ /,/) { $filename = $`; $filter = $'; } @@ -396,12 +556,71 @@ if( ! $opt_X ){ # use XS, unless it was disabled $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter, 'add_cppflags' => $addflags; $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]); - + push @$fdecls_parsed, @{ $c->get('parsed_fdecls') }; push(@$fdecls, @{$c->get('fdecls')}); + + push @td, @{$c->get('typedefs_maybe')}; + + unless ($tmask_all) { + warn "Scanning $filename for typedefs...\n"; + my $td = $c->get('typedef_hash'); + # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d; + my @f_good_td = grep $td->{$_}[1] eq '', keys %$td; + push @good_td, @f_good_td; + @typedefs_pre{@f_good_td} = map $_->[0], @$td{@f_good_td}; + } + } + { local $" = '|'; + $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b); + } + %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT + if ($fmask) { + my @good; + for my $i (0..$#$fdecls_parsed) { + next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME + push @good, $i; + print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n" + if $opt_d; + } + $fdecls = [@$fdecls[@good]]; + $fdecls_parsed = [@$fdecls_parsed[@good]]; + } + @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME + # Sort declarations: + { + my %h = map( ($_->[1], $_), @$fdecls_parsed); + $fdecls_parsed = [ @h{@fnames} ]; + } + @fnames_no_prefix = @fnames; + @fnames_no_prefix + = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix; + # Remove macros which expand to typedefs + print "Typedefs are @td.\n" if $opt_d; + my %td = map {($_, $_)} @td; + # Add some other possible but meaningless values for macros + for my $k (qw(char double float int long short unsigned signed void)) { + $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned '); + } + # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@; + my $n = 0; + my %bad_macs; + while (keys %td > $n) { + $n = keys %td; + my ($k, $v); + while (($k, $v) = each %seen_define) { + # print("found '$k'=>'$v'\n"), + $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v}; + } + } + # Now %bad_macs contains names of bad macros + for my $k (keys %bad_macs) { + delete $const_names{$prefixless{$k}}; + print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d; } } } +my @const_names = sort keys %const_names; open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n"; @@ -411,13 +630,14 @@ warn "Writing $ext$modpname/$modfname.pm\n"; print PM <<"END"; package $module; +require 5.005_62; use strict; END if( $opt_X || $opt_c || $opt_A ){ # we won't have our own AUTOLOAD(), so won't have $AUTOLOAD print PM <<'END'; -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); +our @EXPORT_OK; END } else{ @@ -425,7 +645,7 @@ else{ # will want Carp. print PM <<'END'; use Carp; -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD); +our @EXPORT_OK; END } @@ -450,19 +670,31 @@ unless ($opt_A) { # no autoloader whatsoever. } # Determine @ISA. -my $myISA = '@ISA = qw(Exporter'; # We seem to always want this. +my $myISA = 'our @ISA = qw(Exporter'; # We seem to always want this. $myISA .= ' DynaLoader' unless $opt_X; # no XS $myISA .= ');'; print PM "\n$myISA\n\n"; +my @exported_names = (@const_names, @fnames_no_prefix); + print PM<<"END"; # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. -\@EXPORT = qw( + +# This allows declaration use $module ':all'; +# If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK +# will save memory. +our %EXPORT_TAGS = ( 'all' => [ qw( + @exported_names +) ] ); + +our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } ); + +our \@EXPORT = qw( @const_names ); -\$VERSION = '$TEMPLATE_VERSION'; +our \$VERSION = '$TEMPLATE_VERSION'; END @@ -473,6 +705,7 @@ sub AUTOLOAD { # to the AUTOLOAD in AutoLoader. my \$constname; + our $AUTOLOAD; (\$constname = \$AUTOLOAD) =~ s/.*:://; croak "&$module::constant not defined" if \$constname eq 'constant'; my \$val = constant(\$constname, \@_ ? \$_[0] : 0); @@ -482,11 +715,19 @@ sub AUTOLOAD { goto &AutoLoader::AUTOLOAD; } else { - croak "Your vendor has not defined $module macro \$constname"; + croak "Your vendor has not defined $module macro \$constname"; + } + } + { + no strict 'refs'; + # Fixed between 5.005_53 and 5.005_61 + if (\$] >= 5.00561) { + *\$AUTOLOAD = sub () { \$val }; + } + else { + *\$AUTOLOAD = sub { \$val }; } } - no strict 'refs'; - *\$AUTOLOAD = sub () { \$val }; goto &\$AUTOLOAD; } @@ -498,6 +739,7 @@ bootstrap $module \$VERSION; END } +my $after; if( $opt_P ){ # if POD is disabled $after = '__END__'; } @@ -521,8 +763,8 @@ print PM <<"END"; __END__ END -$author = "A. U. Thor"; -$email = 'a.u.thor@a.galaxy.far.far.away'; +my $author = "A. U. Thor"; +my $email = 'a.u.thor@a.galaxy.far.far.away'; my $revhist = ''; $revhist = <<EOT if $opt_C; @@ -533,33 +775,46 @@ $revhist = <<EOT if $opt_C; =item $TEMPLATE_VERSION -Original version; created by h2xs $H2XS_VERSION +Original version; created by h2xs $H2XS_VERSION with options + + @ARGS =back EOT -my $const_doc = ''; -my $fdecl_doc = ''; +my $exp_doc = <<EOD; + +=head2 EXPORT + +None by default. + +EOD if (@const_names and not $opt_P) { - $const_doc = <<EOD; -\n=head2 Exported constants + $exp_doc .= <<EOD; +=head2 Exportable constants @{[join "\n ", @const_names]} EOD } if (defined $fdecls and @$fdecls and not $opt_P) { - $fdecl_doc = <<EOD; -\n=head2 Exported functions + $exp_doc .= <<EOD; +=head2 Exportable functions + +EOD + $exp_doc .= <<EOD if $opt_p; +When accessing these functions from Perl, prefix C<$opt_p> should be removed. - @{[join "\n ", @$fdecls]} +EOD + $exp_doc .= <<EOD; + @{[join "\n ", @known_fnames{@fnames}]} EOD } -$pod = <<"END" unless $opt_P; -## Below is the stub of documentation for your module. You better edit it! +my $pod = <<"END" unless $opt_P; +## Below is stub documentation for your module. You better edit it! # #=head1 NAME # @@ -572,12 +827,12 @@ $pod = <<"END" unless $opt_P; # #=head1 DESCRIPTION # -#Stub documentation for $module was created by h2xs. It looks like the +#Stub documentation for $module, created by h2xs. It looks like the #author of the extension was negligent enough to leave the stub #unedited. # #Blah blah blah. -#$const_doc$fdecl_doc$revhist +#$exp_doc$revhist #=head1 AUTHOR # #$author, $email @@ -605,7 +860,7 @@ print XS <<"END"; END if( @path_h ){ - foreach my $path_h (@path_h) { + foreach my $path_h (@path_h_ini) { my($h) = $path_h; $h =~ s#^/usr/include/##; if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; } @@ -614,54 +869,181 @@ if( @path_h ){ print XS "\n"; } -if( ! $opt_c ){ -print XS <<"END"; -static int -not_here(char *s) +my %pointer_typedefs; +my %struct_typedefs; + +sub td_is_pointer { + my $type = shift; + my $out = $pointer_typedefs{$type}; + return $out if defined $out; + my $otype = $type; + $out = ($type =~ /\*$/); + # This converts only the guys which do not have trailing part in the typedef + if (not $out + and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { + $type = normalize_type($type); + print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n" + if $opt_d; + $out = td_is_pointer($type); + } + return ($pointer_typedefs{$otype} = $out); +} + +sub td_is_struct { + my $type = shift; + my $out = $struct_typedefs{$type}; + return $out if defined $out; + my $otype = $type; + $out = ($type =~ /^struct\b/) && !td_is_pointer($type); + # This converts only the guys which do not have trailing part in the typedef + if (not $out + and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { + $type = normalize_type($type); + print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n" + if $opt_d; + $out = td_is_struct($type); + } + return ($struct_typedefs{$otype} = $out); +} + +# Some macros will bomb if you try to return them from a double-returning func. +# Say, ((char *)0), or strlen (if somebody #define STRLEN strlen). +# Fortunately, we can detect both these cases... +sub protect_convert_to_double { + my $in = shift; + my $val; + return '' unless defined ($val = $seen_define{$in}); + return '(IV)' if $known_fnames{$val}; + # OUT_t of ((OUT_t)-1): + return '' unless $val =~ /^\s*(\(\s*)?\(\s*([^()]*?)\s*\)/; + td_is_pointer($2) ? '(IV)' : ''; +} + +# For each of the generated functions, length($pref) leading +# letters are already checked. Moreover, it is recommended that +# the generated functions uses switch on letter at offset at least +# $off + length($pref). +# +# The given list has length($pref) chars removed at front, it is +# guarantied that $off leading chars in the rest are the same for all +# elts of the list. +# +# Returns: how at which offset it was decided to make a switch, or -1 if none. + +sub write_const; + +sub write_const { + my ($fh, $pref, $off, $list) = (shift,shift,shift,shift); + my %leading; + my $offarg = length $pref; + + if (@$list == 0) { # Can happen on the initial iteration only + print $fh <<"END"; +static double +constant(char *name, int len, int arg) { - croak("$module::%s not implemented on this architecture", s); + errno = EINVAL; + return 0; +} +END return -1; + } + + if (@$list == 1) { # Can happen on the initial iteration only + my $protect = protect_convert_to_double("$pref$list->[0]"); + + print $fh <<"END"; +static double +constant(char *name, int len, int arg) +{ + if (strEQ(name + $offarg, "$list->[0]")) { /* $pref removed */ +#ifdef $pref$list->[0] + return $protect$pref$list->[0]; +#else + errno = ENOENT; + return 0; +#endif + } + errno = EINVAL; + return 0; } +END + return -1; + } + + for my $n (@$list) { + my $c = substr $n, $off, 1; + $leading{$c} = [] unless exists $leading{$c}; + push @{$leading{$c}}, substr $n, $off + 1; + } + + if (keys(%leading) == 1) { + return 1 + write_const $fh, $pref, $off + 1, $list; + } + my $leader = substr $list->[0], 0, $off; + foreach my $letter (keys %leading) { + write_const $fh, "$pref$leader$letter", 0, $leading{$letter} + if @{$leading{$letter}} > 1; + } + + my $npref = "_$pref"; + $npref = '' if $pref eq ''; + + print $fh <<"END"; static double -constant(char *name, int arg) +constant$npref(char *name, int len, int arg) { errno = 0; - switch (*name) { END -my(@AZ, @az, @under); - -foreach(@const_names){ - @AZ = 'A' .. 'Z' if !@AZ && /^[A-Z]/; - @az = 'a' .. 'z' if !@az && /^[a-z]/; - @under = '_' if !@under && /^_/; -} + print $fh <<"END" if $off; + if ($offarg + $off >= len ) { + errno = EINVAL; + return 0; + } +END -foreach $letter (@AZ, @az, @under) { + print $fh <<"END"; + switch (name[$offarg + $off]) { +END - last if $letter eq 'a' && !@const_names; + foreach my $letter (sort keys %leading) { + my $let = $letter; + $let = '\0' if $letter eq ''; - print XS " case '$letter':\n"; - my($name); - while (substr($const_names[0],0,1) eq $letter) { - $name = shift(@const_names); - $macro = $prefix{$name} ? "$opt_p$name" : $name; - next if $const_xsub{$macro}; - print XS <<"END"; - if (strEQ(name, "$name")) -#ifdef $macro - return $macro; + print $fh <<EOP; + case '$let': +EOP + if (@{$leading{$letter}} > 1) { + # It makes sense to call a function + if ($off) { + print $fh <<EOP; + if (!strnEQ(name + $offarg,"$leader", $off)) + break; +EOP + } + print $fh <<EOP; + return constant_$pref$leader$letter(name, len, arg); +EOP + } + else { + # Do it ourselves + my $protect + = protect_convert_to_double("$pref$leader$letter$leading{$letter}[0]"); + + print $fh <<EOP; + if (strEQ(name + $offarg, "$leader$letter$leading{$letter}[0]")) { /* $pref removed */ +#ifdef $pref$leader$letter$leading{$letter}[0] + return $protect$pref$leader$letter$leading{$letter}[0]; #else goto not_there; #endif -END + } +EOP } - print XS <<"END"; - break; -END -} -print XS <<"END"; + } + print $fh <<"END"; } errno = EINVAL; return 0; @@ -672,9 +1054,26 @@ not_there: } END + } +if( ! $opt_c ) { + print XS <<"END"; +static int +not_here(char *s) +{ + croak("$module::%s not implemented on this architecture", s); + return -1; +} + +END + + write_const(\*XS, '', 0, \@const_names); +} + +my $prefix; $prefix = "PREFIX = $opt_p" if defined $opt_p; + # Now switch from C to XS by issuing the first MODULE declaration: print XS <<"END"; @@ -689,13 +1088,13 @@ $_() CODE: #ifdef $_ - RETVAL = $_; + RETVAL = $_; #else - croak("Your vendor has not defined the $module macro $_"); + croak("Your vendor has not defined the $module macro $_"); #endif OUTPUT: - RETVAL + RETVAL END } @@ -705,14 +1104,22 @@ END print XS <<"END" unless $opt_c; double -constant(name,arg) - char * name +constant(sv,arg) + PREINIT: + STRLEN len; + INPUT: + SV * sv + char * s = SvPV(sv, len); int arg + CODE: + RETVAL = constant(s,len,arg); + OUTPUT: + RETVAL END my %seen_decl; - +my %typemap; sub print_decl { my $fh = shift; @@ -721,7 +1128,7 @@ sub print_decl { return if $seen_decl{$name}++; # Need to do the same for docs as well? my @argnames = map {$_->[1]} @$args; - my @argtypes = map { normalize_type( $_->[0] ) } @$args; + my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args; my @argarrays = map { $_->[4] || '' } @$args; my $numargs = @$args; if ($numargs and $argtypes[-1] eq '...') { @@ -729,15 +1136,15 @@ sub print_decl { $argnames[-1] = '...'; } local $" = ', '; - $type = normalize_type($type); - + $type = normalize_type($type, 1); + print $fh <<"EOP"; $type $name(@argnames) EOP - for $arg (0 .. $numargs - 1) { + for my $arg (0 .. $numargs - 1) { print $fh <<"EOP"; $argtypes[$arg] $argnames[$arg]$argarrays[$arg] EOP @@ -751,9 +1158,11 @@ sub get_typemap { my $stdtypemap = "$Config::Config{privlib}/ExtUtils/typemap"; unshift @tm, $stdtypemap; my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ; - my $image; - - foreach $typemap (@tm) { + + # Start with useful default values + $typemap{float} = 'T_DOUBLE'; + + foreach my $typemap (@tm) { next unless -e $typemap ; # skip directories, binary files etc. warn " Scanning $typemap\n"; @@ -769,11 +1178,12 @@ sub get_typemap { elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; } elsif ($mode eq 'Typemap') { next if /^\s*($|\#)/ ; - if ( ($type, $image) = + my ($type, $image); + if ( ($type, $image) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o # This may reference undefined functions: and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) { - normalize_type($type); + $typemap{normalize_type($type)} = $image; } } } @@ -784,24 +1194,55 @@ sub get_typemap { } -sub normalize_type { - my $ignore_mods = '(?:\b(?:__const__|static|inline|__inline__)\b\s*)*'; +sub normalize_type { # Second arg: do not strip const's before \* my $type = shift; - $type =~ s/$ignore_mods//go; - $type =~ s/([\]\[()])/ \1 /g; - $type =~ s/\s+/ /g; + my $do_keep_deep_const = shift; + # If $do_keep_deep_const this is heuristical only + my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : ''); + my $ignore_mods + = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*"; + if ($do_keep_deep_const) { # Keep different compiled /RExen/o separately! + $type =~ s/$ignore_mods//go; + } + else { + $type =~ s/$ignore_mods//go; + } + $type =~ s/([^\s\w])/ \1 /g; $type =~ s/\s+$//; $type =~ s/^\s+//; - $type =~ s/\b\*/ */g; - $type =~ s/\*\b/* /g; - $type =~ s/\*\s+(?=\*)/*/g; + $type =~ s/\s+/ /g; + $type =~ s/\* (?=\*)/*/g; + $type =~ s/\. \. \./.../g; + $type =~ s/ ,/,/g; $types_seen{$type}++ unless $type eq '...' or $type eq 'void' or $std_types{$type}; $type; } +my $need_opaque; + +sub assign_typemap_entry { + my $type = shift; + my $otype = $type; + my $entry; + if ($tmask and $type =~ /$tmask/) { + print "Type $type matches -o mask\n" if $opt_d; + $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ"); + } + elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { + $type = normalize_type $type; + print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d; + $entry = assign_typemap_entry($type); + } + $entry ||= $typemap{$otype} + || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ"); + $typemap{$otype} = $entry; + $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT"; + return $entry; +} + if ($opt_x) { - for $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) } + for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) } } close XS; @@ -811,10 +1252,32 @@ if (%types_seen) { warn "Writing $ext$modpname/typemap\n"; open TM, ">typemap" or die "Cannot open typemap file for write: $!"; - for $type (keys %types_seen) { - print TM $type, "\t" x (6 - int((length $type)/8)), "T_PTROBJ\n" + for $type (sort keys %types_seen) { + my $entry = assign_typemap_entry $type; + print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n" } + print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry +############################################################################# +INPUT +T_OPAQUE_STRUCT + if (sv_derived_from($arg, \"${ntype}\")) { + STRLEN len; + char *s = SvPV((SV*)SvRV($arg), len); + + if (len != sizeof($var)) + croak(\"Size %d of packed data != expected %d\", + len, sizeof($var)); + $var = *($type *)s; + } + else + croak(\"$var is not of type ${ntype}\") +############################################################################# +OUTPUT +T_OPAQUE_STRUCT + sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var)); +EOP + close TM or die "Cannot close typemap file for write: $!"; } @@ -832,8 +1295,9 @@ print PL "WriteMakefile(\n"; print PL " 'NAME' => '$module',\n"; print PL " 'VERSION_FROM' => '$modfname.pm', # finds \$VERSION\n"; if( ! $opt_X ){ # print C stuff, unless XS is disabled + $opt_F = '' unless defined $opt_F; print PL " 'LIBS' => ['$extralibs'], # e.g., '-lm' \n"; - print PL " 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' \n"; + print PL " 'DEFINE' => '$opt_F', # e.g., '-DHAVE_SOMETHING' \n"; print PL " 'INC' => '', # e.g., '-I/usr/include/other' \n"; } print PL ");\n"; @@ -870,17 +1334,24 @@ _END_ close(EX) || die "Can't close $ext$modpname/test.pl: $!\n"; unless ($opt_C) { - warn "Writing $ext$modpname/Changes\n"; - open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n"; - print EX "Revision history for Perl extension $module.\n\n"; - print EX "$TEMPLATE_VERSION ",scalar localtime,"\n"; - print EX "\t- original version; created by h2xs $H2XS_VERSION\n\n"; - close(EX) || die "Can't close $ext$modpname/Changes: $!\n"; + warn "Writing $ext$modpname/Changes\n"; + $" = ' '; + open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n"; + @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS; + print EX <<EOP; +Revision history for Perl extension $module. + +$TEMPLATE_VERSION @{[scalar localtime]} +\t- original version; created by h2xs $H2XS_VERSION with options +\t\t@ARGS + +EOP + close(EX) || die "Can't close $ext$modpname/Changes: $!\n"; } warn "Writing $ext$modpname/MANIFEST\n"; open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!"; -@files = <*>; +my @files = <*>; if (!@files) { eval {opendir(D,'.');}; unless ($@) { @files = readdir(D); closedir(D); } diff --git a/utils/perlcc.PL b/utils/perlcc.PL index 99e9b51851..a585580be0 100644 --- a/utils/perlcc.PL +++ b/utils/perlcc.PL @@ -2,6 +2,7 @@ use Config; use File::Basename qw(&basename &dirname); +use File::Spec; use Cwd; # List explicitly here the variables you want Configure to @@ -270,13 +271,14 @@ sub _createCode if (@_ == 3) # compiling a program { chmod $generated_file, 0777 & ~umask if $backend eq "Bytecode"; - + my $null=File::Spec->devnull; _print( "$^X -I@INC -MB::Stash -c $file\n", 36); - my $stash=`$^X -I@INC -MB::Stash -c $file 2>/dev/null|tail -1`; + my @stash=`$^X -I@INC -MB::Stash -c $file 2>$null`; + my $stash=$stash[-1]; chomp $stash; _print( "$^X -I@INC -MO=$backend,$stash $file\n", 36); - $return = _run("$^X -I@INC -MO=$backend,$stash $file >> $generated_file", 9); + $return = _run("$^X -I@INC -MO=$backend,$stash,-o$generated_file $file", 9); $return; } else # compiling a shared object @@ -284,7 +286,7 @@ sub _createCode _print( "$^X -I@INC -MO=$backend,-m$final_output $file\n", 36); $return = - _run("$^X -I@INC -MO=$backend,-m$final_output $file >> $generated_file", 9); + _run("$^X -I@INC -MO=$backend,-m$final_output,-o$generated_file $file ", 9); $return; } } @@ -373,7 +375,9 @@ sub _ccharness my $libs = _getSharedObjects($sourceprog); - my $cccmd = "$Config{cc} $Config{ccflags} $optimize $incdir " + my $ccflags = $Config{ccflags}; + $ccflags .= ' -DUSEIMPORTLIB' if $Config{osname} =~ /cygwin/i; + my $cccmd = "$Config{cc} $ccflags $optimize $incdir " ."@args $dynaloader $linkargs @$libs"; _print ("$cccmd\n", 36); @@ -390,17 +394,8 @@ sub _getSharedObjects my ($tmpprog); ($tmpprog = $sourceprog) =~ s"(.*)[\\/](.*)"$2"; - my $tempdir; + my $tempdir= File::Spec->tmpdir; - if ($Config{'osname'} eq 'MSWin32') - { - $tempdir = $ENV{TEMP}; - $tempdir =~ s[\\][/]g; - } - else - { - $tempdir = "/tmp"; - } $tmpfile = "$tempdir/$tmpprog.tst"; $incfile = "$tempdir/$tmpprog.val"; @@ -474,12 +469,13 @@ sub _lookforAuto my ($relabs, $relshared); my ($prefix); my $return; - + my $sharedextension = $^O =~ /MSWin32|cygwin|os2/i + ? $Config{_a} : ".$Config{so}"; ($prefix = $file) =~ s"(.*)\.pm"$1"; my ($tmp, $modname) = ($prefix =~ m"(?:(.*)[\\/]){0,1}(.*)"s); - $relshared = "$pathsep$prefix$pathsep$modname.$Config{so}"; + $relshared = "$pathsep$prefix$pathsep$modname$sharedextension"; $relabs = "$pathsep$prefix$pathsep$modname$Config{_a}"; # HACK . WHY DOES _a HAVE A '.' # AND so HAVE NONE?? @@ -614,7 +610,7 @@ sub _checkopts one file the names clash)\n"); } - if ($options->{'e'} && ($options->{'sav'} || $options->{'gen'}) && ò0 + if ($options->{'e'} && ($options->{'sav'} || $options->{'gen'}) && !$options->{'C'}) { push(@errors, @@ -766,7 +762,7 @@ sub _run sub _interruptrun { my ($command) = @_; - my $pid = open (FD, "$command 2|"); + my $pid = open (FD, "$command |"); local($SIG{HUP}) = sub { # kill 9, $pid + 1; @@ -95,10 +95,6 @@ static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */ /* munching */ static int no_translate_barewords; -/* True if we shouldn't treat barewords as logicals during directory */ -/* munching */ -static int no_translate_barewords; - /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */ int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, diff --git a/win32/Makefile b/win32/Makefile index f700ada1b9..af3a4fbb1e 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -223,15 +223,29 @@ CFG = Optimize !ENDIF !ENDIF +ARCHDIR = ..\lib\$(ARCHNAME) COREDIR = ..\lib\CORE AUTODIR = ..\lib\auto +LIBDIR = ..\lib +EXTDIR = ..\ext +PODDIR = ..\pod +EXTUTILSDIR = $(LIBDIR)\ExtUtils + +# +INST_SCRIPT = $(INST_TOP)$(INST_VER)\bin +INST_BIN = $(INST_SCRIPT)$(INST_ARCH) +INST_LIB = $(INST_TOP)$(INST_VER)\lib +INST_ARCHLIB = $(INST_LIB)$(INST_ARCH) +INST_COREDIR = $(INST_ARCHLIB)\CORE +INST_POD = $(INST_LIB)\pod +INST_HTML = $(INST_POD)\html # # Programs to compile, build .lib files and link # -CC = cl.exe -LINK32 = link.exe +CC = cl +LINK32 = link LIB32 = $(LINK32) -lib # @@ -300,7 +314,9 @@ LIBFILES = $(LIBBASEFILES) $(LIBC) CFLAGS = -nologo -Gf -W3 $(INCLUDES) $(DEFINES) $(LOCDEFS) \ $(PCHFLAGS) $(OPTIMIZE) -LINK_FLAGS = -nologo -nodefaultlib $(LINK_DBG) -machine:$(PROCESSOR_ARCHITECTURE) +LINK_FLAGS = -nologo -nodefaultlib $(LINK_DBG) \ + -libpath:"$(INST_COREDIR)" \ + -machine:$(PROCESSOR_ARCHITECTURE) OBJOUT_FLAG = -Fo EXEOUT_FLAG = -Fe @@ -328,17 +344,6 @@ $(o).dll: -out:$@ $(LINK_FLAGS) $(LIBFILES) $< $(LIBPERL) # -INST_BIN = $(INST_TOP)$(INST_VER)\bin$(INST_ARCH) -INST_SCRIPT = $(INST_TOP)$(INST_VER)\bin -INST_LIB = $(INST_TOP)$(INST_VER)\lib -INST_POD = $(INST_LIB)\pod -INST_HTML = $(INST_POD)\html -LIBDIR = ..\lib -EXTDIR = ..\ext -PODDIR = ..\pod -EXTUTILSDIR = $(LIBDIR)\extutils - -# # various targets !IF "$(USE_OBJECT)" == "define" PERLIMPLIB = ..\perl56.lib @@ -504,7 +509,7 @@ CORE_NOCFG_H = \ ..\unixish.h \ ..\utf8.h \ ..\util.h \ - ..\warning.h \ + ..\warnings.h \ ..\XSUB.h \ ..\EXTERN.h \ ..\perlvars.h \ diff --git a/win32/makefile.mk b/win32/makefile.mk index 23dde72392..034ae3d6f7 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -229,8 +229,22 @@ DELAYLOAD *= -DELAYLOAD:wsock32.dll delayimp.lib CFG *= Optimize .ENDIF +ARCHDIR = ..\lib\$(ARCHNAME) COREDIR = ..\lib\CORE AUTODIR = ..\lib\auto +LIBDIR = ..\lib +EXTDIR = ..\ext +PODDIR = ..\pod +EXTUTILSDIR = $(LIBDIR)\ExtUtils + +# +INST_SCRIPT = $(INST_TOP)$(INST_VER)\bin +INST_BIN = $(INST_SCRIPT)$(INST_ARCH) +INST_LIB = $(INST_TOP)$(INST_VER)\lib +INST_ARCHLIB = $(INST_LIB)$(INST_ARCH) +INST_COREDIR = $(INST_ARCHLIB)\CORE +INST_POD = $(INST_LIB)\pod +INST_HTML = $(INST_POD)\html # # Programs to compile, build .lib files and link @@ -269,7 +283,7 @@ LINK_DBG = CFLAGS = -w -g0 -tWM -tWD $(INCLUDES) $(DEFINES) $(LOCDEFS) \ $(PCHFLAGS) $(OPTIMIZE) -LINK_FLAGS = $(LINK_DBG) -L"$(CCLIBDIR)" +LINK_FLAGS = $(LINK_DBG) -L"$(INST_COREDIR)" -L"$(CCLIBDIR)" OBJOUT_FLAG = -o EXEOUT_FLAG = -e LIBOUT_FLAG = @@ -307,15 +321,15 @@ LINK_DBG = .ENDIF CFLAGS = $(INCLUDES) $(DEFINES) $(LOCDEFS) $(OPTIMIZE) -LINK_FLAGS = $(LINK_DBG) -L"$(CCLIBDIR)" +LINK_FLAGS = $(LINK_DBG) -L"$(INST_COREDIR)" -L"$(CCLIBDIR)" OBJOUT_FLAG = -o EXEOUT_FLAG = -o LIBOUT_FLAG = .ELSE -CC = cl.exe -LINK32 = link.exe +CC = cl +LINK32 = link LIB32 = $(LINK32) -lib # @@ -379,7 +393,9 @@ LIBFILES = $(LIBBASEFILES) $(LIBC) CFLAGS = -nologo -Gf -W3 $(INCLUDES) $(DEFINES) $(LOCDEFS) \ $(PCHFLAGS) $(OPTIMIZE) -LINK_FLAGS = -nologo -nodefaultlib $(LINK_DBG) -machine:$(PROCESSOR_ARCHITECTURE) +LINK_FLAGS = -nologo -nodefaultlib $(LINK_DBG) \ + -libpath:"$(INST_COREDIR)" \ + -machine:$(PROCESSOR_ARCHITECTURE) OBJOUT_FLAG = -Fo EXEOUT_FLAG = -Fe LIBOUT_FLAG = /out: @@ -427,17 +443,6 @@ $(o).dll: .ENDIF # -INST_BIN = $(INST_TOP)$(INST_VER)\bin$(INST_ARCH) -INST_SCRIPT = $(INST_TOP)$(INST_VER)\bin -INST_LIB = $(INST_TOP)$(INST_VER)\lib -INST_POD = $(INST_LIB)\pod -INST_HTML = $(INST_POD)\html -LIBDIR = ..\lib -EXTDIR = ..\ext -PODDIR = ..\pod -EXTUTILSDIR = $(LIBDIR)\extutils - -# # various targets MINIPERL = ..\miniperl.exe MINIDIR = .\mini @@ -618,7 +623,7 @@ CORE_NOCFG_H = \ ..\unixish.h \ ..\utf8.h \ ..\util.h \ - ..\warning.h \ + ..\warnings.h \ ..\XSUB.h \ ..\EXTERN.h \ ..\perlvars.h \ |