From 4633a7c4bad06b471d9310620b7fe8ddd158cccd Mon Sep 17 00:00:00 2001 From: Larry Wall Date: Tue, 21 Nov 1995 10:01:00 +1200 Subject: 5.002 beta 1 If you're adventurous, have a look at ftp://ftp.sems.com/pub/outgoing/perl5.0/perl5.002beta1.tar.gz Many thanks to Andy for doing the integration. Obviously, if you consult the bugs database, you'll note there are still plenty of buglets that need fixing, and several enhancements that I've intended to put in still haven't made it in (Hi, Tim and Ilya). But I think it'll be pretty stable. And you can start to fiddle around with prototypes (which are, of course, still totally undocumented). Packrats, don't worry too much about readvertising this widely. Nowadays we're on a T1 here, so our bandwidth is okay. Have the appropriate amount of jollity. Larry --- .dotest/last | 0 Changes | 1028 +++++++++ Changes.Conf | 7 +- Configure | 4573 +++++++++++++++++++++------------------- Doc/perl5-notes | 345 --- EXTERN.h | 15 +- INSTALL | 120 +- INTERN.h | 15 +- MANIFEST | 86 +- Makefile.SH | 56 +- README.vms | 59 +- Todo | 3 +- XSUB.h | 27 +- av.c | 22 + av.h | 4 + c2ph.PL | 1184 +++++++++++ c2ph.SH | 1169 ---------- cflags.SH | 2 +- config_H | 337 +-- config_h.SH | 72 +- configure | 0 cop.h | 14 +- doio.c | 6 +- doop.c | 7 +- emacs/cperl-mode | 710 ------- emacs/cperl-mode.el | 2566 ++++++++++++++++++++++ emacs/emacs19 | 312 --- emacs/perl-mode.el | 631 ------ emacs/perldb.el | 423 ---- emacs/perldb.pl | 531 ----- emacs/tedstuff | 296 --- embed.h | 7 +- embed.pl | 0 ext/DB_File/DB_File.pm | 15 +- ext/DB_File/DB_File.xs | 71 +- ext/DB_File/Makefile.PL | 2 +- ext/Devel/DProf/DProf.pm | 106 - ext/Devel/DProf/DProf.xs | 247 --- ext/Devel/DProf/Makefile.PL | 8 - ext/Devel/DProf/README | 3 - ext/Devel/DProf/dprofpp | 394 ---- ext/Devel/DProf/test.pl | 20 - ext/DynaLoader/DynaLoader.pm | 12 +- ext/DynaLoader/dl_os2.xs | 187 ++ ext/Fcntl/Fcntl.xs | 6 + ext/GDBM_File/GDBM_File.pm | 38 + ext/GDBM_File/GDBM_File.xs | 1 + ext/NDBM_File/hints/solaris.pl | 2 +- ext/ODBM_File/hints/sco.pl | 2 +- ext/ODBM_File/hints/solaris.pl | 2 +- ext/ODBM_File/hints/svr4.pl | 2 +- ext/POSIX/POSIX.pm | 64 +- ext/POSIX/POSIX.xs | 60 +- ext/SDBM_File/Makefile.PL | 2 +- ext/SDBM_File/sdbm/Makefile.PL | 8 +- ext/SDBM_File/sdbm/sdbm.c | 3 + ext/Socket/Makefile.PL | 2 +- ext/Socket/Socket.pm | 118 +- ext/Socket/Socket.xs | 56 +- global.sym | 5 +- gv.c | 72 +- h2ph.PL | 306 +++ h2ph.SH | 295 --- h2xs.PL | 433 ++++ h2xs.SH | 413 ---- hints/aix.sh | 5 +- hints/dec_osf.sh | 2 +- hints/freebsd.sh | 11 + hints/hpux.sh | 51 +- hints/irix_6_2.sh | 25 + hints/netbsd.sh | 28 +- hints/os2.sh | 192 ++ hints/sco.sh | 45 + hints/sco_3.sh | 45 - hints/solaris_2.sh | 1 + hints/ultrix_4.sh | 6 + hv.c | 85 +- installman | 1 + installperl | 50 +- interp.sym | 1 + ioctl.pl | 169 -- lib/AutoLoader.pm | 3 +- lib/AutoSplit.pm | 14 +- lib/Cwd.pm | 142 +- lib/Exporter.pm | 4 + lib/ExtUtils/Liblist.pm | 22 +- lib/ExtUtils/MakeMaker.pm | 388 ++-- lib/ExtUtils/Manifest.pm | 30 +- lib/ExtUtils/xsubpp | 11 +- lib/File/Find.pm | 4 +- lib/File/Path.pm | 5 +- lib/IPC/Open3.pm | 39 +- lib/Shell.pm | 34 +- lib/Test/Harness.pm | 11 +- lib/Text/Tabs.pm | 54 +- lib/Text/Wrap.pm | 68 + lib/TieHash.pm | 18 +- lib/diagnostics.pm | 502 +++++ lib/dotsh.pl | 2 +- lib/lib.pm | 41 +- lib/overload.pm | 489 +++++ lib/perl5db.pl | 19 +- lib/splain | 502 +++++ makeaperl.SH | 0 mg.c | 26 +- minimod.PL | 16 +- miniperlmain.c | 34 +- op.c | 245 ++- op.h | 5 +- opcode.h | 2 +- opcode.pl | 2 +- os2/Makefile.SH | 54 + os2/POSIX.mkfifo | 16 + os2/README | 155 ++ os2/diff.Makefile | 436 ++++ os2/diff.configure | 604 ++++++ os2/diff.installperl | 248 +++ os2/diff.mkdep | 128 ++ os2/diff.x2pMakefile | 222 ++ os2/os2.c | 215 ++ os2/os2ish.h | 72 + patchlevel.h | 2 +- perl.c | 273 ++- perl.h | 96 +- perldoc.PL | 336 +++ perldoc.SH | 201 -- perly.c | 2493 +++++++++++----------- perly.c.diff | 159 +- perly.h | 99 +- perly.y | 68 +- pod/Makefile | 45 +- pod/perl.pod | 45 +- pod/perlbook.pod | 10 +- pod/perlbot.pod | 16 +- pod/perldata.pod | 116 +- pod/perldiag.pod | 58 +- pod/perldsc.pod | 348 +++ pod/perlform.pod | 3 +- pod/perlfunc.pod | 477 +++-- pod/perlipc.pod | 842 +++++++- pod/perllol.pod | 353 ++++ pod/perlmod.pod | 280 +-- pod/perlop.pod | 62 +- pod/perlpod.pod | 8 + pod/perlre.pod | 15 +- pod/perlref.pod | 3 + pod/perlsyn.pod | 250 ++- pod/perltrap.pod | 25 +- pod/perlvar.pod | 13 +- pod/perlxs.pod | 19 +- pod/perlxstut.pod | 529 +++++ pod/pod2html.PL | 550 +++++ pod/pod2html.SH | 490 ----- pod/pod2latex.PL | 673 ++++++ pod/pod2latex.SH | 660 ------ pod/pod2man.PL | 665 ++++++ pod/pod2man.SH | 652 ------ pp.c | 56 +- pp_ctl.c | 126 +- pp_hot.c | 115 +- pp_sys.c | 92 +- proto.h | 24 +- regcomp.c | 37 +- regexec.c | 146 +- run.c | 4 +- scope.c | 3 +- sv.c | 196 +- t/TEST | 5 +- t/comp/cpp.aux | 0 t/lib/socket.t | 62 - t/op/overload.t | 40 +- t/op/stat.t | 2 + toke.c | 128 +- util.c | 15 +- vms/Makefile | 129 +- vms/config.vms | 29 +- vms/descrip.mms | 154 +- vms/ext/MM_VMS.pm | 1249 ++++------- vms/gen_shrfls.pl | 97 +- vms/perlshr.c | 13 - vms/perlvms.pod | 6 +- vms/perly_c.vms | 2224 +++++++++++++++++++ vms/perly_h.vms | 68 + vms/sockadapt.c | 40 +- vms/sockadapt.h | 83 +- vms/test.com | 10 +- vms/vms.c | 202 +- vms/vms_yfix.pl | 47 + vms/vmsish.h | 17 + writemain.SH | 22 +- x2p/Makefile.SH | 13 +- x2p/a2p.h | 12 + x2p/cflags.SH | 2 +- x2p/find2perl.PL | 607 ++++++ x2p/find2perl.SH | 604 ------ x2p/s2p.PL | 782 +++++++ x2p/s2p.SH | 779 ------- 197 files changed, 26432 insertions(+), 15923 deletions(-) delete mode 100644 .dotest/last delete mode 100644 Doc/perl5-notes create mode 100644 c2ph.PL delete mode 100755 c2ph.SH mode change 100755 => 100644 config_h.SH mode change 100644 => 100755 configure delete mode 100644 emacs/cperl-mode create mode 100644 emacs/cperl-mode.el delete mode 100644 emacs/emacs19 delete mode 100644 emacs/perl-mode.el delete mode 100644 emacs/perldb.el delete mode 100644 emacs/perldb.pl delete mode 100644 emacs/tedstuff mode change 100644 => 100755 embed.pl delete mode 100644 ext/Devel/DProf/DProf.pm delete mode 100644 ext/Devel/DProf/DProf.xs delete mode 100644 ext/Devel/DProf/Makefile.PL delete mode 100644 ext/Devel/DProf/README delete mode 100644 ext/Devel/DProf/dprofpp delete mode 100644 ext/Devel/DProf/test.pl create mode 100644 ext/DynaLoader/dl_os2.xs create mode 100644 h2ph.PL delete mode 100755 h2ph.SH create mode 100644 h2xs.PL delete mode 100755 h2xs.SH create mode 100644 hints/irix_6_2.sh create mode 100644 hints/os2.sh create mode 100644 hints/sco.sh delete mode 100644 hints/sco_3.sh mode change 100644 => 100755 installman delete mode 100644 ioctl.pl create mode 100644 lib/Text/Wrap.pm create mode 100755 lib/diagnostics.pm create mode 100644 lib/overload.pm create mode 100755 lib/splain mode change 100644 => 100755 makeaperl.SH create mode 100644 os2/Makefile.SH create mode 100644 os2/POSIX.mkfifo create mode 100644 os2/README create mode 100644 os2/diff.Makefile create mode 100644 os2/diff.configure create mode 100644 os2/diff.installperl create mode 100644 os2/diff.mkdep create mode 100644 os2/diff.x2pMakefile create mode 100644 os2/os2.c create mode 100644 os2/os2ish.h create mode 100644 perldoc.PL delete mode 100644 perldoc.SH create mode 100644 pod/perldsc.pod create mode 100644 pod/perllol.pod create mode 100644 pod/perlxstut.pod create mode 100644 pod/pod2html.PL delete mode 100755 pod/pod2html.SH create mode 100644 pod/pod2latex.PL delete mode 100755 pod/pod2latex.SH create mode 100644 pod/pod2man.PL delete mode 100755 pod/pod2man.SH mode change 100644 => 100755 t/comp/cpp.aux delete mode 100644 t/lib/socket.t mode change 100755 => 100644 t/op/overload.t delete mode 100644 vms/perlshr.c create mode 100644 vms/perly_c.vms create mode 100644 vms/perly_h.vms create mode 100644 vms/vms_yfix.pl create mode 100644 x2p/find2perl.PL delete mode 100755 x2p/find2perl.SH create mode 100644 x2p/s2p.PL delete mode 100755 x2p/s2p.SH diff --git a/.dotest/last b/.dotest/last deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/Changes b/Changes index 0b8794d594..8ae36150bd 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,1031 @@ +------------- +Version 5.002 +------------- + +Nearly all the changes for 5.001 were bug fixes of one variety or another, +so here's the bug list, along with the "resolution" for each of them. If +you wish to correspond about any of them, please include the bug number. + +Added APPLLIB_EXP for embedded perl library support. +Files patched: perl.c + +Couldn't define autoloaded routine by assignment to typeglob. +Files patched: pp_hot.c sv.c + +NETaa13399: Andy patches. +From: Larry Wall +Files patched: MANIFEST + +NETaa13399: Andy's patch 1m +Files patched: Configure MANIFEST Makefile.SH embed.h embed.pl + ext/GDBM_File/GDBM_File.xs global.sym hints/freebsd.sh installman + installperl interp.sym keywords.h keywords.pl lib/Exporter.pm + lib/ExtUtils/MakeMaker.pm lib/ExtUtils/xsubpp op.c perl.c perl.h perldoc.SH + pod/perl.pod pod/pod2html.SH pp.c pp_ctl.c pp_ctl.c pp_hot.c proto.h + regcomp.c regcomp.h regexec.c toke.c x2p/util.c x2p/util.h + +NETaa13399: Andy's patch.1l +Files patched: Changes.Conf Configure Makefile.SH README README.vms c2ph.SH + config_H config_h.SH configpm configure doio.c embed.h + ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs ext/DynaLoader/DynaLoader.pm + ext/DynaLoader/Makefile.PL ext/DynaLoader/README ext/DynaLoader/dl_dlopen.xs + ext/Fcntl/Fcntl.pm ext/Fcntl/Fcntl.xs ext/GDBM_File/GDBM_File.pm + ext/GDBM_File/GDBM_File.xs ext/NDBM_File/hints/solaris.pl + ext/ODBM_File/Makefile.PL ext/ODBM_File/hints/sco.pl + ext/ODBM_File/hints/solaris.pl ext/ODBM_File/hints/svr4.pl + ext/POSIX/POSIX.pm ext/POSIX/POSIX.xs ext/SDBM_File/sdbm/sdbm.c + ext/Socket/Socket.pm global.sym h2ph.SH h2xs.SH handy.h hints/README.hints + hints/apollo.sh hints/aux.sh hints/cxux.sh hints/dynix.sh hints/epix.sh + hints/freebsd.sh hints/hpux_9.sh hints/irix_4.sh hints/irix_5.sh + hints/irix_6.sh hints/isc.sh hints/linux.sh hints/netbsd.sh hints/next_3.sh + hints/next_3_0.sh hints/powerunix.sh hints/sco_3.sh hints/titanos.sh + installman installperl lib/AnyDBM_File.pm lib/AutoLoader.pm lib/AutoSplit.pm + lib/Benchmark.pm lib/Carp.pm lib/Cwd.pm lib/English.pm lib/Exporter.pm + lib/ExtUtils/Liblist.pm lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Manifest.pm + lib/ExtUtils/Mkbootstrap.pm lib/ExtUtils/xsubpp lib/File/Basename.pm + lib/File/CheckTree.pm lib/File/Find.pm lib/FileHandle.pm lib/Getopt/Long.pm + lib/Getopt/Std.pm lib/I18N/Collate.pm lib/IPC/Open2.pm lib/IPC/Open3.pm + lib/Net/Ping.pm lib/Term/Complete.pm lib/Text/Abbrev.pm lib/Text/Tabs.pm + lib/ftp.pl lib/getcwd.pl lib/integer.pm lib/less.pm lib/sigtrap.pm + lib/strict.pm lib/subs.pm makeaperl.SH makedepend.SH myconfig perl.c perl.h + perldoc.SH pod/Makefile pod/perl.pod pod/perlbot.pod pod/perlcall.pod + pod/perlfunc.pod pod/perlguts.pod pod/perlop.pod pod/perlre.pod + pod/perlxs.pod pod/pod2html.SH pod/pod2latex.SH pod/pod2man.SH pp_ctl.c + pp_hot.c pp_sys.c proto.h scope.c sv.c sv.h t/comp/cpp.aux t/comp/cpp.t + t/op/misc.t toke.c unixish.h util.c vms/config.vms vms/ext/MM_VMS.pm + vms/ext/VMS/stdio/stdio.xs vms/perlvms.pod vms/vms.c x2p/Makefile.SH + x2p/find2perl.SH x2p/s2p.SH x2p/str.c + +NETaa13399: Jumbo Configure patch (and patch 1) +Files patched: Changes.Conf + +NETaa13399: Jumbo Configure patch (and patch 1) +Files patched: Configure INSTALL MANIFEST Makefile.SH README config_H + config_h.SH configure embed.h ext/Fcntl/Fcntl.xs ext/ODBM_File/ODBM_File.xs + h2xs.SH hints/aix.sh hints/hpux_9.sh hints/isc.sh hints/isc_2.sh + hints/solaris_2.sh hints/unicos.sh hints/utekv.sh lib/ExtUtils/MakeMaker.pm + makedepend.SH t/README x2p/a2p.h + +NETaa13399: Jumbo Configure patch (patches 2 and 3) +Files patched: Configure INSTALL config_h.SH embed.h ext/Fcntl/Fcntl.xs + ext/POSIX/POSIX.xs global.sym mg.c perl.h proto.h + +NETaa13525: doc changes +From: Larry Wall +Files patched: pod/perlop.pod pod/perltrap.pod + +NETaa13525: random cleanup +Files patched: Configure MANIFEST Makefile.SH cop.h embed.h global.sym + hints/dec_osf.sh hv.c lib/dotsh.pl mg.c op.c op.c op.h perl.c perl.c perly.c + perly.c perly.c.diff perly.c.diff perly.h perly.y pod/perl.pod + pod/perldiag.pod pod/perlfunc.pod pod/perlfunc.pod pod/perlfunc.pod + pod/perlfunc.pod pod/perlop.pod pod/perlre.pod pod/perltrap.pod + pod/perlxs.pod pod/perlxs.pod pp_ctl.c pp_ctl.c pp_hot.c pp_sys.c proto.h + regcomp.c regexec.c sv.c sv.c sv.c toke.c vms/perly_c.vms vms/perly_h.vms + +NETaa13540: VMS stuff +From: Larry Wall +Files patched: EXTERN.h INTERN.h MANIFEST Makefile.SH README.vms av.c embed.h + ext/Socket/Socket.pm ext/Socket/Socket.xs global.sym gv.c lib/AutoSplit.pm + lib/ExtUtils/MakeMaker.pm lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Manifest.pm + lib/ExtUtils/xsubpp lib/File/Find.pm lib/File/Path.pm lib/lib.pm perl.c + perl.h pp_ctl.c pp_sys.c proto.h run.c sv.c vms/Makefile vms/Makefile + vms/config.vms vms/descrip.mms vms/descrip.mms vms/ext/MM_VMS.pm + vms/gen_shrfls.pl vms/perlvms.pod vms/perly_c.vms vms/perly_h.vms + vms/sockadapt.c vms/sockadapt.h vms/test.com vms/vms.c vms/vms_yfix.pl + vms/vmsish.h + +NETaa13540: VMS uses CLK_TCK for HZ +Files patched: pp_sys.c + +NETaa13721: pad_findlex core dumps on bad CvOUTSIDE() +From: Carl Witty +Files patched: op.c sv.c toke.c + Each CV has a reference to the CV containing it lexically. Unfortunately, + it didn't reference-count this reference, so when the outer CV was freed, + we ended up with a pointer to memory that got reused later as some other kind + of SV. + +NETaa13721: warning suppression +Files patched: toke.c + (same) + +NETaa13722: walk.c had inconsistent static declarations +From: Tim Bunce +Files patched: x2p/walk.c + Consolidated the various declarations and made them consistent with + the actual definitions. + +NETaa13729: order-of-evaluation dependency in scope.c on leaving REGCONTEXT +From: "Jason Shirk" +Files patched: scope.c + Did + + I32 delta = SSPOPINT; + savestack_ix -= delta; /* regexp must have croaked */ + + instead. + +NETaa13731: couldn't assign external lexical array to itself +From: oneill@cs.sfu.ca +Files patched: op.c + The pad_findmy routine was only checking previous statements for previous + mention of external lexicals, so the fact that the current statement + already mentioned @list was not noted. It therefore allocated another + reference to the outside lexical, and this didn't compare equal when + the assigment parsing code was trying to determine whether there was a + common variable on either side of the equals. Since it didn't see the + same variable, it thought it could avoid making copies of the values on + the stack during list assignment. Unfortunately, before using those + values, the list assignment has to zero out the target array, which + destroys the values. + + The fix was to make pad_findmy search the current statement as well. This + was actually a holdover from some old code that was trying to delay + introduction of "my" variables until the next statement. This is now + done with a different mechanism, so the fix should not adversely affect + that. + +NETaa13733: s/// doesn't free old string when using copy mode +From: Larry Wall +Files patched: pp_ctl.c pp_hot.c + When I removed the use of sv_replace(), I simply forgot to free the old char*. + +NETaa13736: closures leaked memory +From: Carl Witty +Files patched: op.c pp.c + This is a specific example of a more general bug, fixed as NETaa13760, having + to do with reference counts on comppads. + +NETaa13739: XSUB interface caches gimme in case XSUB clobbers it +From: Dean Roehrich +Files patched: pp_hot.c + Applied suggest patch. Also deleted second gimme declaration as redundant. + +NETaa13760: comppad reference counts were inconsistent +From: Larry Wall +Files patched: op.c perl.c pp_ctl.c toke.c + All official references to comppads are supposed to be through compcv now, + but the transformation was not complete, resulting in memory leakage. + +NETaa13761: sv_2pv() wrongly preferred IV to NV when SV was readonly +From: "Jack R. Lawler" +Files patched: sv.c + Okay, I understand how this one happened. This is a case where a + beneficial fix uncovered a bug elsewhere. I changed the constant + folder to prefer integer results over double if the numbers are the + same. In this case, they aren't, but it leaves the integer value there + anyway because the storage is already allocated for it, and it *might* + be used in an integer context. And since it's producing a constant, it + sets READONLY. Unfortunately, sv_2pv() bogusly preferred the integer + value to the double when READONLY was set. This never showed up if you + just said + + print 1.4142135623731; + + because in that case, there was already a string value. + + +NETaa13772: shmwrite core dumps consistently +From: Gabe Schaffer +Files patched: opcode.h opcode.pl + The shmwrite operator is a list operator but neglected to push a stack + mark beforehand, because an 'm' was missing from opcode.pl. + +NETaa13773: $. was misdocumented as read-only. +From: Inaba Hiroto +Files patched: pod/perlvar.pod + <1.array-element-read-only> + % perl -le '$,=", "; $#w=5; for (@w) { $_=1; } print @w' + Modification of a read-only value attempted at -e line 1. + % perl4 -le '$,=", "; $#w=5; for (@w) { $_=1; } print @w' + 1, 1, 1, 1, 1, 1 + + This one may stay the way it is for performance reasons. + + <2.begin-local-RS> + % cat abc + a + b + c + % perl -e 'BEGIN { local $/ = ""; } print "$.:$_" while <>;' abc + 1:a + b + c + % perl -e '{ local $/ = ""; } print "$.:$_" while <>;' abc + 1:a + 2:b + 3:c + + $/ wasn't initialized early enough, so local set it back to permanently + undefined on exit from the block. + + <3.grep-x0-bug> + % perl -le 'print grep(/^-/ ? ($x=$_) x 0 : 1, "a", "-b", "c");' + a + + % perl4 -le 'print grep(/^-/ ? ($x=$_) x 0 : 1, "a", "-b", "c");' + ac + + An extra mark was left on the stack if (('x') x $repeat) was used in a scalar + context. + + <4.input-lineno-assign> + # perl -w does not complain about assignment to $. (Is this just a feature?) + # perlvar.pod says "This variable should be considered read-only." + % cat abc + a + b + c + % perl -wnle '$. = 10 if $. == 2; print "$.:$_"' abc + 1:a + 10:b + 11:c + + Fixed doc. + + <5.local-soft-ref.bug> + % perl -e 'local ${"a"}=1;' + zsh: 529 segmentation fault perl -e 'local ${"a"}=1;' + + Now says + Can't localize a reference at -e line 1. + + <6.package-readline> + % perl -e 'package foo; sub foo { 1; } package main; $_ = foo::foo(); print' + 1 + % perl -e ' + package readline; sub foo { 1; } package main; $_ = readline::foo(); print' + Undefined subroutine &main::foo called at -e line 1. + % perl -e ' + package readline; sub foo { 1; } package main; $_ = &readline::foo(); print' + 1 + + Now treats foo::bar correctly even if foo is a keyword. + + <7.page-head-set-to-null-string> + % cat page-head + #From: russell@ccu1.auckland.ac.nz (Russell Fulton) + #Newsgroups: comp.lang.perl + #Subject: This script causes Perl 5.00 to sementation fault + #Date: 15 Nov 1994 00:11:37 GMT + #Message-ID: <3a8ubp$jrj@net.auckland.ac.nz> + + select((select(STDOUT), $^='')[0]); #this is the critical line + $a = 'a'; + write ; + exit; + + format STDOUT = + @<<<<<< + $a + . + + % perl page-head + zsh: 1799 segmentation fault perl /tmp/page-head + + Now says + Undefined top format "main::" called at ./try line 11. + + <8.sub-as-index> + # parser bug? + % perl -le 'sub foo {0}; $x[0]=0;$x[foo]<=0' + Unterminated <> operator at -e line 1. + % perl -le 'sub foo {0}; $x[0]=0;$x[foo()]<=0' + + A right square bracket now forces expectation of an operator. + + <9.unary-minus-to-regexp-var> + % cat minus-reg + #From: Michael Cook + #Newsgroups: comp.lang.perl + #Subject: bug: print -$1 + #Date: 01 Feb 1995 15:31:25 GMT + #Message-ID: + + $_ = "123"; + /\d+/; + print $&, "\n"; + print -$&, "\n"; + print 0-$&, "\n"; + + % perl minus-reg + 123 + 123 + -123 + + Apparently already fixed in my copy. + + <10.vec-segv> + % cat vec-bug + ## Offset values are changed for my machine. + + #From: augustin@gdstech.grumman.com (Conrad Augustin) + #Subject: perl5 vec() bug? + #Message-ID: <1994Nov22.193728.25762@gdstech.grumman.com> + #Date: Tue, 22 Nov 1994 19:37:28 GMT + + #The following two statements each produce a segmentation fault in perl5: + + #vec($a, 21406, 32) = 1; # seg fault + vec($a, 42813, 16) = 1; # seg fault + + #When the offset values are one less, all's well: + #vec($a, 21405, 32) = 1; # ok + #vec($a, 42812, 16) = 1; # ok + + #Interestingly, this is ok for all high values of N: + #$N=1000000; vec($a, $N, 8) = 1; + + % perl vec-bug + zsh: 1806 segmentation fault perl vec-bug + + Can't reproduce this one. + + +NETaa13773: $/ not correctly localized in BEGIN +Files patched: perl.c + (same) + +NETaa13773: foo::bar was misparsed if foo was a reserved word +Files patched: toke.c toke.c + (same) + +NETaa13773: right square bracket didn't force expectation of operator +Files patched: toke.c + (same) + +NETaa13773: scalar ((x) x $repeat) left stack mark +Files patched: op.c + (same) + +NETaa13778: -w coredumps on <$> +From: Hans Mulder +Files patched: pp_hot.c toke.c + Now produces suggested error message. Also installed guard in warning code + that coredumped. + +NETaa13779: foreach didn't use savestack mechanism +From: Hans Mulder +Files patched: cop.h pp_ctl.c + The foreach mechanism saved the old scalar value on the context stack + rather than the savestack. It could consequently get out of sync if + unexpectedly unwound. + +NETaa13785: GIMME sometimes used wrong context frame +From: Greg Earle +Files patched: embed.h global.sym op.h pp_ctl.c proto.h + The expression inside the return was taking its context from the immediately + surrounding block rather than the innermost surrounding subroutine call. + +NETaa13794: TieHash produces ${pack} warnings +From: Stanley Donald Capelik x74321 24-5200 021876 +Files patched: lib/TieHash.pm + Changed $pack to $pkg. + +NETaa13797: could modify sv_undef through auto-vivification +From: Ilya Zakharevich +Files patched: pp.c + Inserted the missing check for readonly values on auto-vivification. + +NETaa13798: if (...) {print} treats print as quoted +From: Larry Wall +Files patched: toke.c + The trailing paren of the condition was setting expectations to XOPERATOR + rather than XBLOCK, so it was being treated like ${print}. + +NETaa13926: commonality was not detected in assignments using COND_EXPR +From: Mark Hanson +Files patched: opcode.h opcode.pl + The assignment compiler didn't check the 2nd and 3rd args of a ?: + for commonality. It still doesn't, but I made ?: into a "dangerous" + operator so it is forced to treat it as common. + +NETaa13957: was marking the PUSHMARK as modifiable rather than the arg +From: David Couture +Files patched: op.c sv.c + It was marking the PUSHMARK as modifiable rather than the arg. + +NETaa13962: documentation of behavior of scalar <*> was unclear +From: Tom Christiansen +Files patched: pod/perlop.pod + Added the following to perlop: + + A glob only evaluates its (embedded) argument when it is starting a new + list. All values must be read before it will start over. In a list + context this isn't important, because you automatically get them all + anyway. In a scalar context, however, the operator returns the next value + each time it is called, or a FALSE value if you've just run out. Again, + FALSE is returned only once. So if you're expecting a single value from + a glob, it is much better to say + + ($file) = ; + + than + + $file = ; + + because the latter will alternate between returning a filename and + returning FALSE. + + +NETaa13992: regexp comments not seen after + in non-extended regexp +From: Mark Knutsen +Files patched: regcomp.c + The code to skip regexp comments was guarded by a conditional that only + let it work when /x was in effect. + +NETaa14014: use subs should not count as definition, only as declaration +From: Keith Thompson +Files patched: sv.c + On *foo = \&bar, doesn't set GVf_IMPORTED if foo and bar are in same package. + +NETaa14021: sv_inc and sv_dec "upgraded" magical SV to non-magical +From: Paul A Sand +Also: Andreas Koenig +Files patched: sv.c + The sv_inc() and sv_dec() routines "upgraded" null magical SVs to non-magical. + +NETaa14086: require should check tainting +From: Karl Simon Berg +Files patched: pp_ctl.c + Since we shouldn't allow tainted requires anyway, it now says: + + Insecure dependency in require while running with -T switch at tst.pl line 1. + +NETaa14104: negation fails on magical variables like $1 +From: tim +Files patched: pp.c + Negation was failing on magical values like $1. It was testing the wrong + bits and also failed to provide a final "else" if none of the bits matched. + +NETaa14107: deep sort return leaked contexts +From: Quentin Fennessy +Files patched: pp_ctl.c + Needed to call dounwind() appropriately. + +NETaa14129: attempt to localize via a reference core dumps +From: Michele Sardo +Files patched: op.c pod/perldiag.pod + Now produces an error "Can't localize a reference", with explanation in + perldiag. + +NETaa14138: substr() and s/// can cause core dump +From: Andrew Vignaux +Files patched: pp_hot.c + Forgot to call SvOOK_off() on the SV before freeing its string. + +NETaa14145: ${@INC}[0] dumped core in debugger +From: Hans Mulder +Files patched: sv.c + Now croaks "Bizarre copy of ARRAY in block exit", which is better than + a core dump. The fact that ${@INC}[0] means $INC[0] outside the debugger + is a different bug. + +NETaa14147: bitwise assignment ops wipe out byte of target string +From: Jim Richardson +Files patched: doop.c + The code was assuming that the target was not either of the two operands, + which is false for an assignment operator. + +NETaa14153: lexing of lexicals in patterns fooled by character class +From: Dave Bianchi +Files patched: toke.c + It never called the dwimmer, which is how it fooled it. + +NETaa14154: allowed autoloaded methods by recognizing sub method; declaration +From: Larry Wall +Files patched: gv.c + Made sub method declaration sufficient for autoloader to stop searching on. + +NETaa14156: shouldn't optimize block scope on tainting +From: Pete Peterson +Files patched: op.c toke.c + I totally disabled the block scope optimization when running tainted. + +NETaa14157: -T and -B only allowed 1/30 "odd" characters--changed to 1/3 +From: Tor Lillqvist +Files patched: pp_sys.c + Applied suggested patch. + +NETaa14160: deref of null symbol should produce null list +From: Jared Rhine +Files patched: pp_hot.c + It didn't check for list context before returning undef. + +NETaa14162: POSIX::gensym now returns a symbol reference +From: Josh N. Pritikin +Also: Tim Bunce +Files patched: ext/POSIX/POSIX.pm + Applied suggested patch. + +NETaa14164: POSIX autoloader now distinguishes non-constant "constants" +From: Tim Bunce +Files patched: ext/POSIX/POSIX.pm ext/POSIX/POSIX.xs + The .xs file now distinguishes non-constant "constants" by setting EAGAIN. + This will also let us use #ifdef within the .xs file to de-constantify + any other macros that happen not to be constants even if they don't use + an argument. + +NETaa14166: missing semicolon after "my" induces core dump +From: Thomas Kofler +Files patched: toke.c + The parser was left thinking it was still processing a "my", and flubbed. + I made it wipe out the "in_my" variable on a syntax error. + +NETaa14166: missing semicolon after "my" induces core dump" +Files patched: toke.c + (same) + +NETaa14206: can now use English and strict at the same time +From: Andrew Wilcox +Files patched: sv.c + It now counts imported symbols as okay under "use strict". + +NETaa14206: can now use English and strict at the same time +Files patched: gv.c pod/perldiag.pod + (same) + +NETaa14265: elseif now produces severe warning +From: Yutao Feng +Files patched: pod/perldiag.pod toke.c + Now complains explicitly about "elseif". + +NETaa14279: list assignment propagated taintedness to independent scalars +From: Tim Freeman +Files patched: pp_hot.c + List assignment needed to be modified so that tainting didn't propagate + between independent scalar values. + +NETaa14312: undef in @EXPORTS core dumps +From: William Setzer +Files patched: lib/Exporter.pm + Now says: + + Unable to create sub named "t::" at lib/Exporter.pm line 159. + Illegal null symbol in @t::EXPORT at -e line 1 + BEGIN failed--compilation aborted at -e line 1. + + +NETaa14312: undef in @EXPORTS core dumps +Files patched: pod/perldiag.pod sv.c + (same) + +NETaa14321: literal @array check shouldn't happen inside embedded expressions +From: Mark H. Nodine +Files patched: toke.c + The general solution to this is to disable the literal @array check within + any embedded expression. For instance, this also failed bogusly: + + print "$foo{@foo}"; + + The reason fixing this also fixes the s///e problem is that the lexer + effectively puts the RHS into a do {} block, making the expression + embedded within curlies, as far as the error message is concerned. + +NETaa14322: now localizes $! during POSIX::AUTOLOAD +From: Larry Wall +Files patched: ext/POSIX/POSIX.pm + Added local $! = 0. + +NETaa14324: defined() causes spurious sub existence +From: "Andreas Koenig" +Files patched: op.c pp.c + It called pp_rv2cv which wrongly assumed it could add any sub it referenced. + +NETaa14336: use Module () forces import of nothing +From: Tim Bunce +Files patched: op.c + use Module () now refrains from calling import at all. + +NETaa14353: added special HE allocator +From: Larry Wall +Files patched: global.sym + +NETaa14353: added special HE allocator +Files patched: hv.c perl.h + +NETaa14353: array extension now converts old memory to SV storage. +Files patched: av.c av.h sv.c + +NETaa14353: hashes now convert old storage into SV arenas. +Files patched: global.sym + +NETaa14353: hashes now convert old storage into SV arenas. +Files patched: hv.c perl.h + +NETaa14353: upgraded SV arena allocation +Files patched: proto.h + +NETaa14353: upgraded SV arena allocation +Files patched: perl.c sv.c + +NETaa14422: added rudimentary prototypes +From: Gisle Aas +Files patched: Makefile.SH op.c op.c perly.c perly.c.diff perly.h perly.y proto.h sv.c toke.c + Message-Id: <9509290018.AA21548@scalpel.netlabs.com> + To: doughera@lafcol.lafayette.edu (Andy Dougherty) + Cc: perl5-porters@africa.nicoh.com + Subject: Re: Jumbo Configure patch vs. 1m. + Date: Thu, 28 Sep 95 17:18:54 -0700 + From: lwall@scalpel.netlabs.com (Larry Wall) + + : No. Larry's currently got the patch pumpkin for all such core perl topics. + + I dunno whether you should let me have the patch pumpkin or not. To fix + a Sev 2 I just hacked in rudimentary prototypes. :-) + + We can now define true unary subroutines, as well as argumentless + subroutines: + + sub baz () { 12; } # Must not have argument + sub bar ($) { $_[0] * 7 } # Must have exactly one argument + sub foo ($@) { print "@_\n" } # Must have at least one argument + foo bar baz / 2 || "oops", "is the answer"; + + This prints "42 is the answer" on my machine. That is, it's the same as + + foo( bar( baz() / 2) || "oops", "is the answer"); + + Attempting to compile + + foo; + + results in + + Too few arguments for main::foo at ./try line 8, near "foo;" + + Compiling + + bar 1,2,3; + + results in + + Too many arguments for main::bar at ./try line 8, near "foo;" + + But + + @array = ('a','b','c'); + foo @array, @array; + + prints "3 a b c" because the $ puts the first arg of foo into scalar context. + + The main win at this point is that we can say + + sub AAA () { 1; } + sub BBB () { 2; } + + and the user can say AAA + BBB and get 3. + + I'm not quite sure how this interacts with autoloading though. I fear + POSIX.pm will need to say + + sub E2BIG (); + sub EACCES (); + sub EAGAIN (); + sub EBADF (); + sub EBUSY (); + ... + sub _SC_STREAM_MAX (); + sub _SC_TZNAME_MAX (); + sub _SC_VERSION (); + + unless we can figure out how to efficiently declare a default prototype + at import time. Meaning, not using eval. Currently + + *foo = \&bar; + + (the ordinary import mechanism) implicitly stubs &bar with no prototype if + &bar is not yet declared. It's almost like you want an AUTOPROTO to + go with your AUTOLOAD. + + Another thing to rub one's 5 o'clock shadow over is that there's no way + to apply a prototype to a method call at compile time. + + And no, I don't want to have the + + sub howabout ($formal, @arguments) { ... } + + argument right now. + + Larry + +NETaa14444: lexical scalar didn't autovivify +From: Gurusamy Sarathy +Files patched: op.c pp_hot.c + It didn't have code in pp_padsv to do the right thing. + +NETaa14448: caller could dump core when used within an eval or require +From: Danny R. Faught +Files patched: pp_ctl.c + caller() was incorrectly assuming the context stack contained a subroutine + context when it in fact contained an eval context. + +NETaa14451: improved error message on bad pipe filehandle +From: Danny R. Faught +Files patched: pp_sys.c + Now says the slightly more informative + + Can't use an undefined value as filehandle reference at ./try line 3. + +NETaa14462: pp_dbstate had a scope leakage on recursion suppression +From: Tim Bunce +Files patched: pp_ctl.c + Swapped the code in question around. + +NETaa14482: sv_unref freed ref prematurely at times +From: Gurusamy Sarathy +Files patched: sv.c + Made sv_unref() mortalize rather than free the old reference. + +NETaa14484: appending string to array produced bizarre results +From: Greg Ward +Also: Malcolm Beattie +Files patched: pp_hot.c + Will now say, "Can't coerce ARRAY to string". + +NETaa14525: assignment to globs didn't reset them correctly +From: Gurusamy Sarathy +Files patched: sv.c + Applied parts of patch not overridden by subsequent patch. + +NETaa14529: a partially matching subpattern could spoof infinity detector +From: Wayne Berke +Files patched: regexec.c + A partial match on a subpattern could fool the infinite regress detector + into thinking progress had been made. + The previous workaround prevented another bug (NETaa14529) from being fixed, + so I've backed it out. I'll need to think more about how to detect failure + to progress. I'm still hopeful it's not equivalent to the halting problem. + +NETaa14535: patches from Gurusamy Sarathy +From: Gurusamy Sarathy +Files patched: op.c pp.c pp_hot.c regexec.c sv.c toke.c + Applied most recent suggested patches. + +NETaa14538: method calls were treated like do {} under loop modifiers +From: Ilya Zakharevich +Files patched: perly.c perly.y + Needed to take the OPf_SPECIAL flag off of entersubs from method reductions. + (It was probably a cut-and-paste error from long ago.) + +NETaa14540: foreach (@array) no longer does extra stack copy +From: darrinm@lmc.com +Files patched: Todo op.c pp_ctl.c pp_hot.c + Fixed by doing the foreach(@array) optimization, so it iterates + directly through the array, and can detect the implicit shift from + referencing <>. + +NETaa14548: magic sets didn't check private OK bits +From: W. Bradley Rubenstein +Files patched: mg.c + The magic code was getting mixed up between private and public POK bits. + +NETaa14550: made ~ magic magical +From: Tim Bunce +Files patched: sv.c + Applied suggested patch. + +NETaa14551: humongous header causes infinite loop in format +From: Grace Lee +Files patched: pp_sys.c + Needed to check for page exhaustion after doing top-of-form. + +NETaa14558: attempt to call undefined top format core dumped +From: Hallvard B Furuseth +Files patched: pod/perldiag.pod pp_sys.c + Now issues an error on attempts to call a non-existent top format. + +NETaa14561: Gurusamy Sarathy's G_KEEPERR patch +From: Andreas Koenig +Also: Gurusamy Sarathy +Also: Tim Bunce +Files patched: cop.h interp.sym perl.c perl.h pp_ctl.c pp_sys.c sv.c toke.c + Applied latest patch. + +NETaa14581: shouldn't execute BEGIN when there are compilation errors +From: Rickard Westman +Files patched: op.c + Perl should not try to execute BEGIN and END blocks if there's been a + compilation error. + +NETaa14582: got SEGV sorting sparse array +From: Rick Pluta +Files patched: pp_ctl.c + Now weeds out undefined values much like Perl 4 did. + Now sorts undefined values to the front. + +NETaa14582: sort was letting unsortable values through to comparison routine +Files patched: pp_ctl.c + (same) + +NETaa14614: now does dbmopen with perl_eval_sv() +From: The Man +Files patched: perl.c pp_sys.c proto.h + dbmopen now invokes perl_eval_sv(), which should handle error conditions + better. + +NETaa14636: Jumbo Dynaloader patch +From: Tim Bunce +Files patched: ext/DynaLoader/DynaLoader.pm ext/DynaLoader/dl_dld.xs + ext/DynaLoader/dl_dlopen.xs ext/DynaLoader/dl_hpux.xs + ext/DynaLoader/dl_next.xs ext/DynaLoader/dl_vms.xs ext/DynaLoader/dlutils.c + Applied suggested patches. + +NETaa14637: checkcomma routine was stupid about bareword sub calls +From: Tim Bunce +Files patched: toke.c + The checkcomma routine was stupid about bareword sub calls. + +NETaa14639: (?i) didn't reset on runtime patterns +From: Mark A. Scheel +Files patched: op.h pp_ctl.c toke.c + It didn't distinguish between permanent flags outside the pattern and + temporary flags within the pattern. + +NETaa14649: selecting anonymous globs dumps core +From: Chip Salzenberg +Files patched: cop.h doio.c embed.h global.sym perl.c pp_sys.c proto.h + Applied suggested patch, but reversed the increment and decrement to avoid + decrementing and freeing what we're going to increment. + +NETaa14655: $? returned negative value on AIX +From: Kim Frutiger +Also: Stephen D. Lee +Files patched: pp_sys.c + Applied suggested patch. + +NETaa14658: infinite loop in c2ph +From: Nick Gianniotis +Files patched: c2ph.SH + Applied suggested patch. + +NETaa14668: {2,} could match once +From: Hugo van der Sanden +Files patched: regexec.c + When an internal pattern failed a conjecture, it didn't back off on the + number of times it thought it had matched. + +NETaa14673: open $undefined dumped core +From: Samuli K{rkk{inen +Files patched: pp_sys.c + pp_open() didn't check its argument for globness. + +NETaa14683: stringifies were running pad out of space +From: Robin Barker +Files patched: op.h toke.c + Increased PADOFFSET to a U32, and made lexer not put double-quoted strings + inside OP_STRINGIFY unless they really needed it. + +NETaa14689: shouldn't have . in @INC when tainting +From: William R. Somsky +Files patched: perl.c + Now does not put . into @INC when tainting. It may still be added with a + + use lib "."; + + or, to put it at the end, + + BEGIN { push(@INC, ".") } + + but this is not recommended unless a chdir to a known location has been done + first. + +NETaa14690: values inside tainted SVs were ignored +From: "James M. Stern" +Files patched: pp.c pp_ctl.c + It was assuming that a tainted value was a string. + +NETaa14692: format name required qualification under use strict +From: Tom Christiansen +Files patched: gv.c + Now treats format names the same as subroutine names. + +NETaa14695: added simple regexp caching +From: John Rowe +Files patched: pp_ctl.c + Applied suggested patch. + +NETaa14697: regexp comments were sometimes wrongly treated as literal text +From: Tom Christiansen +Files patched: regcomp.c + The literal-character grabber didn't know about extended comments. + + (By the way, Tom, the boxed form of quoting in the previous enclosure is + exceeding antisocial when you want to extract the code from it.) + +NETaa14704: closure got wrong outer scope if outer sub was predeclared +From: Marc Paquette +Files patched: op.c + The outer scope of the anonymous sub was set to the stub rather than to + the actual subroutine. I kludged it by making the outer scope of the + stub be the actual subroutine, if anything is depending on the stub. + +NETaa14705: $foo .= $foo did free memory read +From: Gerd Knops +Files patched: sv.c + Now modifies address to copy if it was reallocated. + +NETaa14711: added (&) and (*) prototypes for blocks and symbols +From: Kenneth Albanowski +Files patched: Makefile.SH op.c perly.c perly.h perly.y toke.c + & now means that it must have an anonymous sub as that argument. If + it's the first argument, the sub may be specified as a block in the + indirect object slot, much like grep or sort, which have prototypes of (&@). + + Also added * so you can do things like + + sub myopen (*;$); + + myopen(FOO, $filename); + +NETaa14713: setuid FROM root now defaults to not do tainting +From: Tony Camas +Files patched: mg.c perl.c pp_hot.c + Applied suggested patch. + +NETaa14714: duplicate magics could be added to an SV +From: Yary Hluchan +Files patched: sv.c sv.c + The sv_magic() routine didn't properly check to see if it already had a + magic of that type. Ordinarily it would have, but it was called during + mg_get(), which forces the magic flags off temporarily. + +NETaa14734: ref should never return undef +From: Dale Amon +Files patched: pp.c t/op/overload.t + Now returns null string. + +NETaa14751: slice of undefs now returns null list +From: Tim Bunce +Files patched: pp.c pp_hot.c + Null list clobberation is now done in lslice, not aassign. + +NETaa14789: select coredumped on Linux +From: Ulrich Kunitz +Files patched: pp_sys.c + Applied suggested patches, more or less. + +NETaa14789: straightened out ins and out of duping +Files patched: lib/IPC/Open3.pm + (same) + +NETaa14791: implemented internal SUPER class +From: Nick Ing-Simmons +Also: Dean Roehrich +Files patched: gv.c + Applied suggested patch. + +NETaa14845: s/// didn't handle offset strings +From: Ken MacLeod +Files patched: pp_ctl.c + Needed a call to SvOOK_off(targ) in pp_substcont(). + +NETaa14851: Use of << to mean <<"" is deprecated +From: Larry Wall +Files patched: toke.c + +NETaa14865: added HINT_BLOCK_SCOPE to "elsif" +From: Jim Avera +Files patched: perly.y + Needed to set HINT_BLOCK_SCOPE on "elsif" to prevent the do block from + being optimized away, which caused the statement transition in elsif + to reset the stack too far back. + +NETaa14876: couldn't delete localized GV safely +From: John Hughes +Files patched: pp.c scope.c + The reference count of the "borrowed" GV needed to be incremented while + there was a reference to it in the savestack. + +NETaa14887: couldn't negate magical scalars +From: ian +Also: Gurusamy Sarathy +Files patched: pp.c + Applied suggested patch, more or less. (It's not necessary to test both + SvNIOK and SvNIOKp, since the private bits are always set if the public + bits are set.) + +NETaa14893: /m modifier was sticky +From: Jim Avera +Files patched: pp_ctl.c + pp_match() and pp_subst() were using an improperly scoped SAVEINT to restore + the value of the internal variable multiline. + +NETaa14893: /m modifier was sticky +Files patched: cop.h pp_hot.c + (same) + +Needed to make install paths absolute. +Files patched: installperl + +derived it +Files patched: perly.h + +makedir() looped on a symlink to a directory. +Files patched: installperl + + ------------- Version 5.001 ------------- diff --git a/Changes.Conf b/Changes.Conf index 0f383ce39e..f77944a3b7 100644 --- a/Changes.Conf +++ b/Changes.Conf @@ -11,6 +11,8 @@ work on a wider range of platforms. This is a brief summary of the most important changes: + Slightly changed installation directories. See INSTALL. + Include 5.000 - 5.001 upgrage notes :-) (see below). You might want to read through them as well as these notes. @@ -18,14 +20,15 @@ This is a brief summary of the most important changes: now view perl module documentation with either your system's man(1) program or with the supplied perldoc script. - Support Linux ELF dynamic loading. - Many hint file updates. Improve and simplify detection of local libraries and header files. Expand documentation of installation process in new INSTALL file. + Try to reduce Unixisms (such as SH file extraction) to enhance + portability to other platforms. There's still a long way to go. + Upgrade Traps and Pitfalls: Since a lot has changed in the build process, you are probably best off diff --git a/Configure b/Configure index b9a1be8e04..432398c004 100755 --- a/Configure +++ b/Configure @@ -20,7 +20,7 @@ # $Id: Head.U,v 3.0.1.8 1995/07/25 13:40:02 ram Exp $ # -# Generated on Thu Oct 19 10:47:09 EDT 1995 [metaconfig 3.0 PL58] +# Generated on Mon Nov 20 09:55:37 EST 1995 [metaconfig 3.0 PL58] cat >/tmp/c1$$ < .temp cf_by=`$cat .temp` $rm -f .temp -: determine where manual pages are on this system +: determine the architecture name echo " " -case "$sysman" in -'') - syspath='/usr/man/man1 /usr/man/mann /usr/man/manl /usr/man/local/man1' - syspath="$syspath /usr/man/u_man/man1 /usr/share/man/man1" - syspath="$syspath /usr/catman/u_man/man1 /usr/man/l_man/man1" - syspath="$syspath /usr/local/man/u_man/man1 /usr/local/man/l_man/man1" - syspath="$syspath /usr/man/man.L /local/man/man1 /usr/local/man/man1" - sysman=`./loc . /usr/man/man1 $syspath` +if xxx=`./loc arch blurfl $pth`; $test -f "$xxx"; then + tarch=`arch`"-$osname" +elif xxx=`./loc uname blurfl $pth`; $test -f "$xxx" ; then + if uname -m > tmparch 2>&1 ; then + tarch=`$sed -e 's/ /_/g' -e 's/$/'"-$osname/" tmparch` + else + tarch="$osname" + fi + $rm -f tmparch +else + tarch="$osname" +fi +case "$myarchname" in +''|"$tarch") ;; +*) + echo "(Your architecture name used to be $myarchname.)" + archname='' ;; esac -if $test -d "$sysman"; then - echo "System manual is in $sysman." >&4 +case "$archname" in +'') dflt="$tarch";; +*) dflt="$archname";; +esac +rp='What is your architecture name' +. ./myread +archname="$ans" +myarchname="$tarch" + +: is AFS running? +echo " " +if test -d /afs; then + echo "AFS may be running... I'll be extra cautious then..." >&4 + afs=true else - echo "Could not find manual pages in source form." >&4 + echo "AFS does not seem to be running..." >&4 + afs=false fi -: see what memory models we can support -case "$models" in -'') - $cat >pdp11.c <<'EOP' -main() { -#ifdef pdp11 - exit(0); -#else - exit(1); -#endif -} -EOP - cc -o pdp11 pdp11.c >/dev/null 2>&1 - if ./pdp11 2>/dev/null; then - dflt='unsplit split' - else - tans=`./loc . X /lib/small /lib/large /usr/lib/small /usr/lib/large /lib/medium /usr/lib/medium /lib/huge` - case "$tans" in - X) dflt='none';; - *) if $test -d /lib/small || $test -d /usr/lib/small; then - dflt='small' - else - dflt='' - fi - if $test -d /lib/medium || $test -d /usr/lib/medium; then - dflt="$dflt medium" - fi - if $test -d /lib/large || $test -d /usr/lib/large; then - dflt="$dflt large" - fi - if $test -d /lib/huge || $test -d /usr/lib/huge; then - dflt="$dflt huge" - fi - esac - fi;; -*) dflt="$models";; +: decide how portable to be. Allow command line overrides. +case "$d_portable" in +"$undef") ;; +*) d_portable="$define" ;; esac -$cat <filexp </dev/null 2>&1 || \ - $contains '\-i' $sysman/cc.1 >/dev/null 2>&1; then - dflt='-i' - else - dflt='none' - fi;; - *) dflt="$split";; - esac - rp="What flag indicates separate I and D space?" - . ./myread - tans="$ans" - case "$tans" in - none) tans='';; - esac - split="$tans" - unsplit='';; -*large*|*small*|*medium*|*huge*) - case "$models" in - *large*) - case "$large" in - '') dflt='-Ml';; - *) dflt="$large";; - esac - rp="What flag indicates large model?" - . ./myread - tans="$ans" - case "$tans" in - none) tans=''; - esac - large="$tans";; - *) large='';; - esac - case "$models" in - *huge*) case "$huge" in - '') dflt='-Mh';; - *) dflt="$huge";; - esac - rp="What flag indicates huge model?" - . ./myread - tans="$ans" - case "$tans" in - none) tans=''; - esac - huge="$tans";; - *) huge="$large";; - esac - case "$models" in - *medium*) case "$medium" in - '') dflt='-Mm';; - *) dflt="$medium";; - esac - rp="What flag indicates medium model?" - . ./myread - tans="$ans" - case "$tans" in - none) tans=''; - esac - medium="$tans";; - *) medium="$large";; - esac - case "$models" in - *small*) case "$small" in - '') dflt='none';; - *) dflt="$small";; - esac - rp="What flag indicates small model?" - . ./myread - tans="$ans" - case "$tans" in - none) tans=''; + ~*) + if $test -f /bin/csh; then + /bin/csh -f -c "glob \$1" + failed=\$? + echo "" + exit \$failed + else + name=\`$expr x\$1 : '..\([^/]*\)'\` + dir=\`$sed -n -e "/^\${name}:/{s/^[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:\([^:]*\).*"'\$'"/\1/" -e p -e q -e '}' &2 + exit 1 + fi + case "\$1" in + */*) + echo \$dir/\`$expr x\$1 : '..[^/]*/\(.*\)'\` + ;; + *) + echo \$dir + ;; esac - small="$tans";; - *) small='';; - esac + fi ;; *) - echo "Unrecognized memory models--you may have to edit Makefile.SH" >&4 + echo \$1 ;; esac - -: make some quick guesses about what we are up against -echo " " -$echo $n "Hmm... $c" -echo exit 1 >bsd -echo exit 1 >usg -echo exit 1 >v7 -echo exit 1 >osf1 -echo exit 1 >eunice -echo exit 1 >xenix -echo exit 1 >venix -d_bsd="$undef" -$cat /usr/include/signal.h /usr/include/sys/signal.h >foo 2>/dev/null -if test -f /osf_boot || $contains 'OSF/1' /usr/include/ctype.h >/dev/null 2>&1 -then - echo "Looks kind of like an OSF/1 system, but we'll see..." - echo exit 0 >osf1 -elif test `echo abc | tr a-z A-Z` = Abc ; then - xxx=`./loc addbib blurfl $pth` - if $test -f $xxx; then - echo "Looks kind of like a USG system with BSD features, but we'll see..." - echo exit 0 >bsd - echo exit 0 >usg - else - if $contains SIGTSTP foo >/dev/null 2>&1 ; then - echo "Looks kind of like an extended USG system, but we'll see..." - else - echo "Looks kind of like a USG system, but we'll see..." - fi - echo exit 0 >usg - fi -elif $contains SIGTSTP foo >/dev/null 2>&1 ; then - echo "Looks kind of like a BSD system, but we'll see..." - d_bsd="$define" - echo exit 0 >bsd -else - echo "Looks kind of like a Version 7 system, but we'll see..." - echo exit 0 >v7 -fi -case "$eunicefix" in -*unixtovms*) - $cat <<'EOI' -There is, however, a strange, musty smell in the air that reminds me of -something...hmm...yes...I've got it...there's a VMS nearby, or I'm a Blit. -EOI - echo exit 0 >eunice - d_eunice="$define" -: it so happens the Eunice I know will not run shell scripts in Unix format - ;; -*) - echo " " - echo "Congratulations. You aren't running Eunice." - d_eunice="$undef" - ;; -esac -if test -f /xenix; then - echo "Actually, this looks more like a XENIX system..." - echo exit 0 >xenix - d_xenix="$define" -else - echo " " - echo "It's not Xenix..." - d_xenix="$undef" -fi -chmod +x xenix -$eunicefix xenix -if test -f /venix; then - echo "Actually, this looks more like a VENIX system..." - echo exit 0 >venix -else - echo " " - if ./xenix; then - : null - else - echo "Nor is it Venix..." - fi -fi -chmod +x bsd usg v7 osf1 eunice xenix venix -$eunicefix bsd usg v7 osf1 eunice xenix venix -$rm -f foo - -: see if we need a special compiler -echo " " -if ./usg; then - case "$cc" in - '') case "$Mcc" in - /*) dflt='Mcc';; - *) case "$large" in - -M*) dflt='cc';; - *) if $contains '\-M' $sysman/cc.1 >/dev/null 2>&1 ; then - if $contains '\-M' $sysman/cpp.1 >/dev/null 2>&1; then - dflt='cc' - else - dflt='cc -M' - fi - else - dflt='cc' - fi;; - esac;; - esac;; - *) dflt="$cc";; - esac - $cat <<'EOM' -On some systems the default C compiler will not resolve multiple global -references that happen to have the same name. On some such systems the "Mcc" -command may be used to force these to be resolved. On other systems a "cc -M" -command is required. (Note that the -M flag on other systems indicates a -memory model to use!) If you have the Gnu C compiler, you might wish to use -that instead. - -EOM - rp="What command will force resolution on this system?" - . ./myread - cc="$ans" -else - case "$cc" in - '') dflt=cc;; - *) dflt="$cc";; - esac - rp="Use which C compiler?" - . ./myread - cc="$ans" -fi -echo " " -echo "Checking for GNU cc in disguise and/or its version number..." >&4 -$cat >gccvers.c < -int main() { -#ifdef __GNUC__ -#ifdef __VERSION__ - printf("%s\n", __VERSION__); -#else - printf("%s\n", "1"); -#endif -#endif - exit(0); -} -EOM -if $cc -o gccvers gccvers.c >/dev/null 2>&1; then - gccversion=`./gccvers` - case "$gccversion" in - '') echo "You are not using GNU cc." ;; - *) echo "You are using GNU cc $gccversion." ;; - esac -else - echo " " - echo "*** WHOA THERE!!! ***" >&4 - echo " Your C compiler \"$cc\" doesn't seem to be working!" >&4 - case "$knowitall" in - '') - echo " You'd better start hunting for one and let me know about it." >&4 - exit 1 - ;; - esac -fi -$rm -f gccvers* -case "$gccversion" in -1*) cpp=`./loc gcc-cpp $cpp $pth` ;; -esac - -: decide how portable to be. Allow command line overrides. -case "$d_portable" in -"$undef") ;; -*) d_portable="$define" ;; -esac - -: set up shell script to do ~ expansion -cat >filexp <&2 - exit 1 - fi - case "\$1" in - */*) - echo \$dir/\`$expr x\$1 : '..[^/]*/\(.*\)'\` - ;; - *) - echo \$dir - ;; - esac - fi - ;; -*) - echo \$1 - ;; -esac -EOSS -chmod +x filexp -$eunicefix filexp +EOSS +chmod +x filexp +$eunicefix filexp : now set up to get a file name cat <<'EOSC' >getfile @@ -2428,255 +2171,25 @@ dflt="$orig_dflt" rm -f getfile.ok EOSC -: What should the include directory be ? -echo " " -$echo $n "Hmm... $c" -dflt='/usr/include' -incpath='' -mips_type='' -if $test -f /bin/mips && /bin/mips; then - echo "Looks like a MIPS system..." - $cat >usr.c <<'EOCP' -#ifdef SYSTYPE_BSD43 -/bsd43 -#endif -EOCP - if $cc -E usr.c > usr.out && $contains / usr.out >/dev/null 2>&1; then - dflt='/bsd43/usr/include' - incpath='/bsd43' - mips_type='BSD 4.3' - else - mips_type='System V' - fi - $rm -f usr.c usr.out - echo "and you're compiling with the $mips_type compiler and libraries." - xxx_prompt=y - echo "exit 0" >mips -else - echo "Doesn't look like a MIPS system." - xxx_prompt=n - echo "exit 1" >mips -fi -chmod +x mips -$eunicefix mips -echo " " -case "$usrinc" in -'') ;; -*) dflt="$usrinc";; -esac -case "$xxx_prompt" in -y) fn=d/ - rp='Where are the include files you want to use?' - . ./getfile - usrinc="$ans" +: determine root of directory hierarchy where package will be installed. +case "$prefix" in +'') + dflt=`./loc . /usr/local /usr/local /local /opt /usr` ;; -*) usrinc="$dflt" +*) + dflt="$prefix" ;; esac +$cat <&4 -cat <<'EOT' >testcpp.c -#define ABC abc -#define XYZ xyz -ABC.XYZ -EOT -cd .. -echo 'cat >.$$.c; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' >cppstdin -chmod 755 cppstdin -wrapper=`pwd`/cppstdin -ok='false' -cd UU - -if $test "X$cppstdin" != "X" && \ - $cppstdin $cppminus testcpp.out 2>&1 && \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 -then - echo "You used to use $cppstdin $cppminus so we'll use that again." - case "$cpprun" in - '') echo "But let's see if we can live without a wrapper..." ;; - *) - if $cpprun $cpplast testcpp.out 2>&1 && \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 - then - echo "(And we'll use $cpprun $cpplast to preprocess directly.)" - ok='true' - else - echo "(However, $cpprun $cpplast does not work, let's see...)" - fi - ;; - esac -else - case "$cppstdin" in - '') ;; - *) - echo "Good old $cppstdin $cppminus does not seem to be of any help..." - ;; - esac -fi - -if $ok; then - : nothing -elif echo 'Maybe "'"$cc"' -E" will work...'; \ - $cc -E testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "Yup, it does." - x_cpp="$cc -E" - x_minus=''; -elif echo 'Nope...maybe "'"$cc"' -E -" will work...'; \ - $cc -E - testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "Yup, it does." - x_cpp="$cc -E" - x_minus='-'; -elif echo 'Nope...maybe "'"$cc"' -P" will work...'; \ - $cc -P testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "Yipee, that works!" - x_cpp="$cc -P" - x_minus=''; -elif echo 'Nope...maybe "'"$cc"' -P -" will work...'; \ - $cc -P - testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "At long last!" - x_cpp="$cc -P" - x_minus='-'; -elif echo 'No such luck, maybe "'$cpp'" will work...'; \ - $cpp testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "It works!" - x_cpp="$cpp" - x_minus=''; -elif echo 'Nixed again...maybe "'$cpp' -" will work...'; \ - $cpp - testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "Hooray, it works! I was beginning to wonder." - x_cpp="$cpp" - x_minus='-'; -elif echo 'Uh-uh. Time to get fancy. Trying a wrapper...'; \ - $wrapper testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - x_cpp="$wrapper" - x_minus='' - echo "Eureka!" -else - dflt='' - rp="No dice. I can't find a C preprocessor. Name one:" - . ./myread - x_cpp="$ans" - x_minus='' - $x_cpp testcpp.out 2>&1 - if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "OK, that will do." >&4 - else -echo "Sorry, I can't get that to work. Go find one and rerun Configure." >&4 - exit 1 - fi -fi - -case "$ok" in -false) - cppstdin="$x_cpp" - cppminus="$x_minus" - cpprun="$x_cpp" - cpplast="$x_minus" - set X $x_cpp - shift - case "$1" in - "$cpp") - echo "Perhaps can we force $cc -E using a wrapper..." - if $wrapper testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 - then - echo "Yup, we can." - cppstdin="$wrapper" - cppminus=''; - else - echo "Nope, we'll have to live without it..." - fi - ;; - esac - case "$cpprun" in - "$wrapper") - cpprun='' - cpplast='' - ;; - esac - ;; -esac - -case "$cppstdin" in -"$wrapper") ;; -*) $rm -f $wrapper;; -esac -$rm -f testcpp.c testcpp.out - -: Set private lib path -case "$plibpth" in -'') if ./mips; then - plibpth="$incpath/usr/lib /usr/local/lib /usr/ccs/lib" - fi;; -esac -case "$libpth" in -' ') dlist='';; -'') dlist="$loclibpth $plibpth $glibpth";; -*) dlist="$libpth";; -esac - -: Now check and see which directories actually exist, avoiding duplicates -libpth='' -for xxx in $dlist -do - if $test -d $xxx; then - case " $libpth " in - *" $xxx "*) ;; - *) libpth="$libpth $xxx";; - esac - fi -done -$cat <<'EOM' - -Some systems have incompatible or broken versions of libraries. Among -the directories listed in the question below, please remove any you -know not to be holding relevant libraries, and add any that are needed. -Say "none" for none. - -EOM -case "$libpth" in -'') dflt='none';; -*) - set X $libpth - shift - dflt=${1+"$@"} - ;; -esac -rp="Directories to use for library searches?" -. ./myread -case "$ans" in -none) libpth=' ';; -*) libpth="$ans";; -esac - -: determine root of directory hierarchy where package will be installed. -case "$prefix" in -'') - dflt=`./loc . /usr/local /usr/local /local /opt /usr` - ;; -*) - dflt="$prefix" - ;; -esac -$cat <&4 - afs=true -else - echo "AFS does not seem to be running..." >&4 - afs=false -fi - -: determine where public executables go -echo " " -set dflt bin bin +: determine where private library files go +: Usual default is /usr/local/lib/perl5. Also allow things like +: /opt/perl/lib, since /opt/perl/lib/perl5 would be redundant. +case "$prefix" in +*perl*) set dflt privlib lib ;; +*) set dflt privlib lib/$package ;; +esac eval $prefixit -fn=d~ -rp='Pathname where the public executables will reside?' +$cat <&4 +if $test -r ../patchlevel.h;then + patchlevel=`awk '/PATCHLEVEL/ {print $3}' < ../patchlevel.h` +else + patchlevel=0 fi +echo "(You have $package $baserev PL$patchlevel.)" : set the prefixup variable, to restore leading tilda escape prefixup='case "$prefixexp" in @@ -2769,76 +2295,81 @@ prefixup='case "$prefixexp" in *) eval "$1=\`echo \$$1 | sed \"s,^$prefixexp,$prefix,\"\`";; esac' -: determine where public executable scripts go -set scriptdir scriptdir +: determine where public architecture dependent libraries go +set archlib archlib eval $prefixit -case "$scriptdir" in +case "$archlib" in '') - dflt="$bin" - : guess some guesses - $test -d /usr/share/scripts && dflt=/usr/share/scripts - $test -d /usr/share/bin && dflt=/usr/share/bin - $test -d /usr/local/script && dflt=/usr/local/script - $test -d $prefixexp/script && dflt=$prefixexp/script - set dflt - eval $prefixup - ;; -*) dflt="$scriptdir" + case "$privlib" in + '') + dflt=`./loc . "." $prefixexp/lib /usr/local/lib /usr/lib /lib` + set dflt + eval $prefixup + ;; + *) version=`echo $baserev $patchlevel | $awk '{print $1 + $2/1000.0}'` + dflt="$privlib/$archname/$version" + ;; + esac ;; +*) dflt="$archlib";; esac -$cat <whoa +dflt=y echo " " -if xxx=`./loc arch blurfl $pth`; $test -f "$xxx"; then - tarch=`arch`"-$osname" -elif xxx=`./loc uname blurfl $pth`; $test -f "$xxx" ; then - if uname -m > tmparch 2>&1 ; then - tarch=`$sed -e 's/ /_/g' -e 's/$/'"-$osname/" tmparch` - else - tarch="$osname" - fi - $rm -f tmparch -else - tarch="$osname" -fi -case "$myarchname" in -''|"$tarch") ;; -*) - echo "(Your architecture name used to be $myarchname.)" - archname='' - ;; -esac -case "$archname" in -'') dflt="$tarch";; -*) dflt="$archname";; -esac -rp='What is your architecture name' +echo "*** WHOA THERE!!! ***" >&4 +echo " The $hint value for \$$var on this machine was \"$was\"!" >&4 +rp=" Keep the $hint value?" . ./myread -archname="$ans" -myarchname="$tarch" +case "$ans" in +y) td=$was; tu=$was;; +esac +EOSC -: determine where public architecture dependent libraries go -set archlib archlib -eval $prefixit -case "$archlib" in -'') - case "$privlib" in - '') - dflt=`./loc . "." $prefixexp/lib /usr/local/lib /usr/lib /lib` - set dflt - eval $prefixup +: function used to set $1 to $val +setvar='var=$1; eval "was=\$$1"; td=$define; tu=$undef; +case "$val$was" in +$define$undef) . ./whoa; eval "$var=\$td";; +$undef$define) . ./whoa; eval "$var=\$tu";; +*) eval "$var=$val";; +esac' + +: determine where old public architecture dependent libraries might be +case "$oldarchlib" in +'') case "$privlib" in + '') ;; + *) dflt="$privlib/$archname" ;; - *) dflt="$privlib/$archname";; esac ;; -*) dflt="$archlib";; +*) dflt="$oldarchlib" + ;; esac +if $test ! -d "$dflt/auto"; then + dflt=none +fi cat <&4 else - installsitelib="$sitelibexp" + echo "Could not find manual pages in source form." >&4 fi -case "$sitelibexp" in -'') d_sitelib=undef ;; -*) d_sitelib=define ;; -esac - : determine where manual pages go set man1dir man1dir none eval $prefixit @@ -3032,7 +2541,7 @@ case "$man1dir" in ;; esac echo " " -fn=dn~ +fn=dn+~ rp="Where do the main $spackage manual pages (source) go?" . ./getfile if test "X$man1direxp" != "X$ansexp"; then @@ -3090,27 +2599,6 @@ case "$man1dir" in ;; esac -: set up the script used to warn in case of inconsistency -cat <<'EOSC' >whoa -dflt=y -echo " " -echo "*** WHOA THERE!!! ***" >&4 -echo " The $hint value for \$$var on this machine was \"$was\"!" >&4 -rp=" Keep the $hint value?" -. ./myread -case "$ans" in -y) td=$was; tu=$was;; -esac -EOSC - -: function used to set $1 to $val -setvar='var=$1; eval "was=\$$1"; td=$define; tu=$undef; -case "$val$was" in -$define$undef) . ./whoa; eval "$var=\$td";; -$undef$define) . ./whoa; eval "$var=\$tu";; -*) eval "$var=$val";; -esac' - : see if we can have long filenames echo " " rmlist="$rmlist /tmp/cf$$" @@ -3185,14 +2673,23 @@ EOM esac echo "If you don't want the manual sources installed, answer 'none'." +: We dont use /usr/local/man/man3 because some man programs will +: only show the /usr/local/man/man3 contents, and not the system ones, +: thus man less will show the perl module less.pm, but not the system +: less command. We might also conflict with TCL man pages. +: However, something like /opt/perl/man/man3 is fine. case "$man3dir" in -'') dflt="$privlib/man/man3" ;; +'') case "$prefix" in + *perl*) dflt=`echo $man1dir | $sed 's/man1/man3/g'` ;; + *) dflt="$privlib/man/man3" ;; + esac + ;; ' ') dflt=none;; *) dflt="$man3dir" ;; esac echo " " -fn=dn~ +fn=dn+~ rp="Where do the $spackage library man pages (source) go?" . ./getfile if test "X$man3direxp" != "X$ansexp"; then @@ -3251,742 +2748,1098 @@ case "$man3dir" in ;; esac -: see if we have to deal with yellow pages, now NIS. -if $test -d /usr/etc/yp || $test -d /etc/yp; then - if $test -f /usr/etc/nibindd; then - echo " " - echo "I'm fairly confident you're on a NeXT." - echo " " - rp='Do you get the hosts file via NetInfo?' - dflt=y - case "$hostcat" in - nidump*) ;; - '') ;; - *) dflt=n;; - esac - . ./myread - case "$ans" in - y*) hostcat='nidump hosts .';; - *) case "$hostcat" in - nidump*) hostcat='';; - esac - ;; - esac - fi - case "$hostcat" in - nidump*) ;; - *) - case "$hostcat" in - *ypcat*) dflt=y;; - '') if $contains '^\+' /etc/passwd >/dev/null 2>&1; then - dflt=y - else - dflt=n - fi;; - *) dflt=n;; - esac - echo " " - rp='Are you getting the hosts file via yellow pages?' - . ./myread - case "$ans" in - y*) hostcat='ypcat hosts';; - *) hostcat='cat /etc/hosts';; - esac - ;; - esac -fi - -: now get the host name -echo " " -echo "Figuring out host name..." >&4 -case "$myhostname" in -'') cont=true - echo 'Maybe "hostname" will work...' - if tans=`sh -c hostname 2>&1` ; then - myhostname=$tans - phostname=hostname - cont='' - fi +: determine where public executable scripts go +set scriptdir scriptdir +eval $prefixit +case "$scriptdir" in +'') + dflt="$bin" + : guess some guesses + $test -d /usr/share/scripts && dflt=/usr/share/scripts + $test -d /usr/share/bin && dflt=/usr/share/bin + $test -d /usr/local/script && dflt=/usr/local/script + $test -d $prefixexp/script && dflt=$prefixexp/script + set dflt + eval $prefixup + ;; +*) dflt="$scriptdir" ;; -*) cont='';; esac -if $test "$cont"; then - if ./xenix; then - echo 'Oh, dear. Maybe "/etc/systemid" is the key...' - if tans=`cat /etc/systemid 2>&1` ; then - myhostname=$tans - phostname='cat /etc/systemid' - echo "Whadyaknow. Xenix always was a bit strange..." - cont='' - fi - elif $test -r /etc/systemid; then - echo "(What is a non-Xenix system doing with /etc/systemid?)" - fi -fi -if $test "$cont"; then - echo 'No, maybe "uuname -l" will work...' - if tans=`sh -c 'uuname -l' 2>&1` ; then - myhostname=$tans - phostname='uuname -l' - else - echo 'Strange. Maybe "uname -n" will work...' - if tans=`sh -c 'uname -n' 2>&1` ; then - myhostname=$tans - phostname='uname -n' - else - echo 'Oh well, maybe I can mine it out of whoami.h...' - if tans=`sh -c $contains' sysname $usrinc/whoami.h' 2>&1` ; then - myhostname=`echo "$tans" | $sed 's/^.*"\(.*\)"/\1/'` - phostname="sed -n -e '"'/sysname/s/^.*\"\\(.*\\)\"/\1/{'"' -e p -e q -e '}' <$usrinc/whoami.h" - else - case "$myhostname" in - '') echo "Does this machine have an identity crisis or something?" - phostname='';; - *) - echo "Well, you said $myhostname before..." - phostname='echo $myhostname';; - esac - fi - fi - fi +$cat <hosts - dflt=.`$awk "/[0-9].*$myhostname/ {for(i=2; i<=NF;i++) print \\\$i}" \ - hosts | $sort | $uniq | \ - $sed -n -e "s/$myhostname\.\([a-zA-Z_.]\)/\1/p"` - case "$dflt" in - .) echo "(You do not have fully-qualified names in /etc/hosts)" - tans=`./loc resolv.conf X /etc /usr/etc` - if $test -f "$tans"; then - echo "(Attempting domain name extraction from $tans)" - dflt=.`egrep '^domain' $tans | $sed 's/domain[ ]*\(.*\)/\1/' \ - | ./tr '[A-Z]' '[a-z]' 2>/dev/null` - fi - ;; - esac - case "$dflt" in - .) echo "(No help from resolv.conf either -- attempting clever guess)" - dflt=.`sh -c domainname 2>/dev/null` - case "$dflt" in - '') dflt='.';; - .nis.*|.yp.*|.main.*) dflt=`echo $dflt | $sed -e 's/^\.[^.]*//'`;; - esac - ;; - esac - case "$dflt" in - .) echo "(Lost all hope -- silly guess then)" - dflt='.uucp' - ;; - esac - $rm -f hosts - ;; - *) dflt="$mydomain";; - esac;; -esac -echo " " -rp="What is your domain name?" -. ./myread -tans="$ans" -case "$ans" in -'') ;; -.*) ;; -*) tans=".$tans";; -esac -mydomain="$tans" - -: translate upper to lower if necessary -case "$mydomain" in -*[A-Z]*) - echo "(Normalizing case in your domain name)" - mydomain=`echo $mydomain | ./tr '[A-Z]' '[a-z]'` - ;; -esac - -: a little sanity check here -case "$phostname" in -'') ;; -*) - case `$phostname | ./tr '[A-Z]' '[a-z]'` in - $myhostname$mydomain|$myhostname) ;; - *) - case "$phostname" in - sed*) - echo "(That doesn't agree with your whoami.h file, by the way.)" - ;; - *) - echo "(That doesn't agree with your $phostname command, by the way.)" - ;; - esac - ;; - esac - ;; +: determine perl absolute location +case "$perlpath" in +'') perlpath=$binexp/perl ;; esac -$cat <pdp11.c <<'EOP' +main() { +#ifdef pdp11 + exit(0); +#else + exit(1); +#endif +} +EOP + cc -o pdp11 pdp11.c >/dev/null 2>&1 + if ./pdp11 2>/dev/null; then + dflt='unsplit split' + else + tans=`./loc . X /lib/small /lib/large /usr/lib/small /usr/lib/large /lib/medium /usr/lib/medium /lib/huge` + case "$tans" in + X) dflt='none';; + *) if $test -d /lib/small || $test -d /usr/lib/small; then + dflt='small' + else + dflt='' + fi + if $test -d /lib/medium || $test -d /usr/lib/medium; then + dflt="$dflt medium" + fi + if $test -d /lib/large || $test -d /usr/lib/large; then + dflt="$dflt large" + fi + if $test -d /lib/huge || $test -d /usr/lib/huge; then + dflt="$dflt huge" + fi + esac + fi;; +*) dflt="$models";; esac -$cat </dev/null 2>&1 || \ + $contains '\-i' $sysman/cc.1 >/dev/null 2>&1; then + dflt='-i' + else + dflt='none' + fi;; + *) dflt="$split";; esac - case "$optimize" in - *-g*) dflt="$dflt -DDEBUGGING";; + rp="What flag indicates separate I and D space?" + . ./myread + tans="$ans" + case "$tans" in + none) tans='';; esac - case "$gccversion" in - 2*) if test -d /etc/conf/kconfig.d && - $contains _POSIX_VERSION $usrinc/sys/unistd.h >/dev/null 2>&1 - then - dflt="$dflt -posix" - fi - ;; + split="$tans" + unsplit='';; +*large*|*small*|*medium*|*huge*) + case "$models" in + *large*) + case "$large" in + '') dflt='-Ml';; + *) dflt="$large";; + esac + rp="What flag indicates large model?" + . ./myread + tans="$ans" + case "$tans" in + none) tans=''; + esac + large="$tans";; + *) large='';; esac + case "$models" in + *huge*) case "$huge" in + '') dflt='-Mh';; + *) dflt="$huge";; + esac + rp="What flag indicates huge model?" + . ./myread + tans="$ans" + case "$tans" in + none) tans=''; + esac + huge="$tans";; + *) huge="$large";; + esac + case "$models" in + *medium*) case "$medium" in + '') dflt='-Mm';; + *) dflt="$medium";; + esac + rp="What flag indicates medium model?" + . ./myread + tans="$ans" + case "$tans" in + none) tans=''; + esac + medium="$tans";; + *) medium="$large";; + esac + case "$models" in + *small*) case "$small" in + '') dflt='none';; + *) dflt="$small";; + esac + rp="What flag indicates small model?" + . ./myread + tans="$ans" + case "$tans" in + none) tans=''; + esac + small="$tans";; + *) small='';; + esac + ;; +*) + echo "Unrecognized memory models--you may have to edit Makefile.SH" >&4 ;; esac -case "$mips_type" in -*BSD*|'') inclwanted="$locincpth $usrinc";; -*) inclwanted="$locincpth $inclwanted $usrinc/bsd";; -esac -for thisincl in $inclwanted; do - if $test -d $thisincl; then - if $test x$thisincl != x$usrinc; then - case "$dflt" in - *$thisincl*);; - *) dflt="$dflt -I$thisincl";; - esac +: make some quick guesses about what we are up against +echo " " +$echo $n "Hmm... $c" +echo exit 1 >bsd +echo exit 1 >usg +echo exit 1 >v7 +echo exit 1 >osf1 +echo exit 1 >eunice +echo exit 1 >xenix +echo exit 1 >venix +d_bsd="$undef" +$cat /usr/include/signal.h /usr/include/sys/signal.h >foo 2>/dev/null +if test -f /osf_boot || $contains 'OSF/1' /usr/include/ctype.h >/dev/null 2>&1 +then + echo "Looks kind of like an OSF/1 system, but we'll see..." + echo exit 0 >osf1 +elif test `echo abc | tr a-z A-Z` = Abc ; then + xxx=`./loc addbib blurfl $pth` + if $test -f $xxx; then + echo "Looks kind of like a USG system with BSD features, but we'll see..." + echo exit 0 >bsd + echo exit 0 >usg + else + if $contains SIGTSTP foo >/dev/null 2>&1 ; then + echo "Looks kind of like an extended USG system, but we'll see..." + else + echo "Looks kind of like a USG system, but we'll see..." fi + echo exit 0 >usg fi -done - -inctest='if $contains $2 $usrinc/$1 >/dev/null 2>&1; then - xxx=true; -elif $contains $2 $usrinc/sys/$1 >/dev/null 2>&1; then - xxx=true; -else - xxx=false; -fi; -if $xxx; then - case "$dflt" in - *$2*);; - *) dflt="$dflt -D$2";; - esac; -fi' - -if ./osf1; then - set signal.h __LANGUAGE_C__; eval $inctest +elif $contains SIGTSTP foo >/dev/null 2>&1 ; then + echo "Looks kind of like a BSD system, but we'll see..." + d_bsd="$define" + echo exit 0 >bsd else - set signal.h LANGUAGE_C; eval $inctest + echo "Looks kind of like a Version 7 system, but we'll see..." + echo exit 0 >v7 fi -set signal.h NO_PROTOTYPE; eval $inctest -set signal.h _NO_PROTO; eval $inctest - -case "$dflt" in -'') dflt=none;; -esac -case "$ccflags" in -'') ;; -*) dflt="$ccflags";; -esac -$cat <eunice + d_eunice="$define" +: it so happens the Eunice I know will not run shell scripts in Unix format + ;; *) echo " " - echo "Let me guess what the preprocessor flags are..." >&4 - set X $cppflags - shift - cppflags='' - $cat >cpp.c <<'EOM' -#define BLURFL foo - -BLURFL xx LFRULB -EOM - previous='' - for flag in $* - do - case "$flag" in - -*) ftry="$flag";; - *) ftry="$previous $flag";; - esac - if $cppstdin -DLFRULB=bar $ftry $cppminus cpp1.out 2>/dev/null && \ - $cpprun -DLFRULB=bar $ftry $cpplast cpp2.out 2>/dev/null && \ - $contains 'foo.*xx.*bar' cpp1.out >/dev/null 2>&1 && \ - $contains 'foo.*xx.*bar' cpp2.out >/dev/null 2>&1 - then - cppflags="$cppflags $ftry" - previous='' - else - previous="$flag" - fi - done - set X $cppflags - shift - cppflags=${1+"$@"} - case "$cppflags" in - *-*) echo "They appear to be: $cppflags";; - esac - $rm -f cpp.c cpp?.out + echo "Congratulations. You aren't running Eunice." + d_eunice="$undef" ;; esac - -: flags used in final linking phase - -case "$ldflags" in -'') if ./venix; then - dflt='-i -z' +if test -f /xenix; then + echo "Actually, this looks more like a XENIX system..." + echo exit 0 >xenix + d_xenix="$define" +else + echo " " + echo "It's not Xenix..." + d_xenix="$undef" +fi +chmod +x xenix +$eunicefix xenix +if test -f /venix; then + echo "Actually, this looks more like a VENIX system..." + echo exit 0 >venix +else + echo " " + if ./xenix; then + : null else - dflt='' + echo "Nor is it Venix..." fi - case "$ccflags" in - *-posix*) dflt="$dflt -posix" ;; - esac - ;; -*) dflt="$ldflags";; -esac - -: Try to guess additional flags to pick up local libraries. -for thislibdir in $libpth; do - case " $loclibpth " in - *" $thislibdir "*) - case "$dflt " in - "-L$thislibdir ") ;; - *) dflt="$dflt -L$thislibdir" ;; - esac - ;; - esac -done - -case "$dflt" in -'') dflt='none' ;; -esac - -$cat <&4 -set X $cc $optimize $ccflags $ldflags try.c -o try -shift -$cat >try.msg </dev/null 2>&1 ; then + if $contains '\-M' $sysman/cpp.1 >/dev/null 2>&1; then + dflt='cc' + else + dflt='cc -M' + fi + else + dflt='cc' + fi;; + esac;; + esac;; + *) dflt="$cc";; + esac + $cat <<'EOM' +On some systems the default C compiler will not resolve multiple global +references that happen to have the same name. On some such systems the "Mcc" +command may be used to force these to be resolved. On other systems a "cc -M" +command is required. (Note that the -M flag on other systems indicates a +memory model to use!) If you have the Gnu C compiler, you might wish to use +that instead. EOM -$cat > try.c <<'EOF' -#include -main() { exit(0); } -EOF -dflt=y -if sh -c "$cc $optimize $ccflags try.c -o try $ldflags" >>try.msg 2>&1; then - if sh -c './try' >>try.msg 2>&1; then - dflt=n - else - echo "The program compiled OK, but exited with status $?." >>try.msg - rp="You have a problem. Shall I abort Configure" - dflt=y - fi + rp="What command will force resolution on this system?" + . ./myread + cc="$ans" else - echo "I can't compile the test program." >>try.msg - rp="You have a BIG problem. Shall I abort Configure" - dflt=y + case "$cc" in + '') dflt=cc;; + *) dflt="$cc";; + esac + rp="Use which C compiler?" + . ./myread + cc="$ans" fi -case "$dflt" in -y) - $cat try.msg - case "$knowitall" in - '') - echo "(The supplied flags might be incorrect with this C compiler.)" - ;; - *) dflt=n;; +echo " " +echo "Checking for GNU cc in disguise and/or its version number..." >&4 +$cat >gccvers.c < +int main() { +#ifdef __GNUC__ +#ifdef __VERSION__ + printf("%s\n", __VERSION__); +#else + printf("%s\n", "1"); +#endif +#endif + exit(0); +} +EOM +if $cc -o gccvers gccvers.c >/dev/null 2>&1; then + gccversion=`./gccvers` + case "$gccversion" in + '') echo "You are not using GNU cc." ;; + *) echo "You are using GNU cc $gccversion." ;; esac +else echo " " - . ./myread - case "$ans" in - n*|N*) ;; - *) echo "Ok. Stopping Configure." >&4 + echo "*** WHOA THERE!!! ***" >&4 + echo " Your C compiler \"$cc\" doesn't seem to be working!" >&4 + case "$knowitall" in + '') + echo " You'd better start hunting for one and let me know about it." >&4 exit 1 ;; esac - ;; -n) echo "OK, that should do.";; +fi +$rm -f gccvers* +case "$gccversion" in +1*) cpp=`./loc gcc-cpp $cpp $pth` ;; esac -$rm -f try try.* core -: compute shared library extension -case "$so" in -'') - if xxx=`./loc libc.sl X $libpth`; $test -f "$xxx"; then - dflt='sl' - else - dflt='so' - fi - ;; -*) dflt="$so";; -esac -$cat <&4 -case "$libs" in -' '|'') dflt='';; -*) dflt="$libs";; -esac -case "$libswanted" in -'') libswanted='c_s';; -esac -for thislib in $libswanted; do - - if xxx=`./loc lib$thislib.$so.[0-9]'*' X $libpth`; $test -f "$xxx"; then - echo "Found -l$thislib (shared)." - case " $dflt " in - *"-l$thislib "*);; - *) dflt="$dflt -l$thislib";; - esac - elif xxx=`./loc lib$thislib.$so X $libpth` ; $test -f "$xxx"; then - echo "Found -l$thislib (shared)." - case " $dflt " in - *"-l$thislib "*);; - *) dflt="$dflt -l$thislib";; - esac - elif xxx=`./loc lib$thislib.a X $libpth`; $test -f "$xxx"; then - echo "Found -l$thislib." - case " $dflt " in - *"-l$thislib "*);; - *) dflt="$dflt -l$thislib";; - esac - elif xxx=`./loc $thislib.a X $libpth`; $test -f "$xxx"; then - echo "Found -l$thislib." - case " $dflt " in - *"-l$thislib "*);; - *) dflt="$dflt -l$thislib";; - esac - elif xxx=`./loc lib${thislib}_s.a X $libpth`; $test -f "$xxx"; then - echo "Found -l${thislib}_s." - case " $dflt " in - *"-l$thislib "*);; - *) dflt="$dflt -l${thislib}_s";; - esac - elif xxx=`./loc Slib$thislib.a X $xlibpth`; $test -f "$xxx"; then - echo "Found -l$thislib." - case " $dflt " in - *"-l$thislib "*);; - *) dflt="$dflt -l$thislib";; - esac +$echo $n "Hmm... $c" +dflt='/usr/include' +incpath='' +mips_type='' +if $test -f /bin/mips && /bin/mips; then + echo "Looks like a MIPS system..." + $cat >usr.c <<'EOCP' +#ifdef SYSTYPE_BSD43 +/bsd43 +#endif +EOCP + if $cc -E usr.c > usr.out && $contains / usr.out >/dev/null 2>&1; then + dflt='/bsd43/usr/include' + incpath='/bsd43' + mips_type='BSD 4.3' else - echo "No -l$thislib." + mips_type='System V' fi -done -set X $dflt -shift -dflt="$*" -case "$libs" in -'') dflt="$dflt";; -*) dflt="$libs";; -esac -case "$dflt" in -' '|'') dflt='none';; -esac - -$cat <mips +else + echo "Doesn't look like a MIPS system." + xxx_prompt=n + echo "exit 1" >mips +fi +chmod +x mips +$eunicefix mips echo " " -rp="Any additional libraries?" -. ./myread -case "$ans" in -none) libs=' ';; -*) libs="$ans";; +case "$usrinc" in +'') ;; +*) dflt="$usrinc";; esac - -: see if nm is to be used to determine whether a symbol is defined or not -case "$usenm" in -'') - dflt=`egrep 'inlibc|csym' ../Configure | wc -l 2>/dev/null` - if $test $dflt -gt 20; then - dflt=y - else - dflt=n - fi +case "$xxx_prompt" in +y) fn=d/ + rp='Where are the include files you want to use?' + . ./getfile + usrinc="$ans" ;; -*) - case "$usenm" in - true) dflt=y;; - *) dflt=n;; - esac +*) usrinc="$dflt" ;; esac -$cat <&4 +cat <<'EOT' >testcpp.c +#define ABC abc +#define XYZ xyz +ABC.XYZ +EOT +cd .. +echo 'cat >.$$.c; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' >cppstdin +chmod 755 cppstdin +wrapper=`pwd`/cppstdin +ok='false' +cd UU + +if $test "X$cppstdin" != "X" && \ + $cppstdin $cppminus testcpp.out 2>&1 && \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 +then + echo "You used to use $cppstdin $cppminus so we'll use that again." + case "$cpprun" in + '') echo "But let's see if we can live without a wrapper..." ;; + *) + if $cpprun $cpplast testcpp.out 2>&1 && \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 + then + echo "(And we'll use $cpprun $cpplast to preprocess directly.)" + ok='true' else - try='' + echo "(However, $cpprun $cpplast does not work, let's see...)" fi - libnames="$libnames $try" ;; - *) libnames="$libnames $thislib" ;; esac - done - ;; -esac -xxx=normal -case "$libc" in -unknown) - set /usr/ccs/lib/libc.$so - $test -r $1 || set /usr/lib/libc.$so +else + case "$cppstdin" in + '') ;; + *) + echo "Good old $cppstdin $cppminus does not seem to be of any help..." + ;; + esac +fi + +if $ok; then + : nothing +elif echo 'Maybe "'"$cc"' -E" will work...'; \ + $cc -E testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "Yup, it does." + x_cpp="$cc -E" + x_minus=''; +elif echo 'Nope...maybe "'"$cc"' -E -" will work...'; \ + $cc -E - testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "Yup, it does." + x_cpp="$cc -E" + x_minus='-'; +elif echo 'Nope...maybe "'"$cc"' -P" will work...'; \ + $cc -P testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "Yipee, that works!" + x_cpp="$cc -P" + x_minus=''; +elif echo 'Nope...maybe "'"$cc"' -P -" will work...'; \ + $cc -P - testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "At long last!" + x_cpp="$cc -P" + x_minus='-'; +elif echo 'No such luck, maybe "'$cpp'" will work...'; \ + $cpp testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "It works!" + x_cpp="$cpp" + x_minus=''; +elif echo 'Nixed again...maybe "'$cpp' -" will work...'; \ + $cpp - testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "Hooray, it works! I was beginning to wonder." + x_cpp="$cpp" + x_minus='-'; +elif echo 'Uh-uh. Time to get fancy. Trying a wrapper...'; \ + $wrapper testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + x_cpp="$wrapper" + x_minus='' + echo "Eureka!" +else + dflt='' + rp="No dice. I can't find a C preprocessor. Name one:" + . ./myread + x_cpp="$ans" + x_minus='' + $x_cpp testcpp.out 2>&1 + if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "OK, that will do." >&4 + else +echo "Sorry, I can't get that to work. Go find one and rerun Configure." >&4 + exit 1 + fi +fi + +case "$ok" in +false) + cppstdin="$x_cpp" + cppminus="$x_minus" + cpprun="$x_cpp" + cpplast="$x_minus" + set X $x_cpp + shift + case "$1" in + "$cpp") + echo "Perhaps can we force $cc -E using a wrapper..." + if $wrapper testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 + then + echo "Yup, we can." + cppstdin="$wrapper" + cppminus=''; + else + echo "Nope, we'll have to live without it..." + fi + ;; + esac + case "$cpprun" in + "$wrapper") + cpprun='' + cpplast='' + ;; + esac + ;; +esac + +case "$cppstdin" in +"$wrapper") ;; +*) $rm -f $wrapper;; +esac +$rm -f testcpp.c testcpp.out + +: Set private lib path +case "$plibpth" in +'') if ./mips; then + plibpth="$incpath/usr/lib /usr/local/lib /usr/ccs/lib" + fi;; +esac +case "$libpth" in +' ') dlist='';; +'') dlist="$loclibpth $plibpth $glibpth";; +*) dlist="$libpth";; +esac + +: Now check and see which directories actually exist, avoiding duplicates +libpth='' +for xxx in $dlist +do + if $test -d $xxx; then + case " $libpth " in + *" $xxx "*) ;; + *) libpth="$libpth $xxx";; + esac + fi +done +$cat <<'EOM' + +Some systems have incompatible or broken versions of libraries. Among +the directories listed in the question below, please remove any you +know not to be holding relevant libraries, and add any that are needed. +Say "none" for none. + +EOM +case "$libpth" in +'') dflt='none';; +*) + set X $libpth + shift + dflt=${1+"$@"} + ;; +esac +rp="Directories to use for library searches?" +. ./myread +case "$ans" in +none) libpth=' ';; +*) libpth="$ans";; +esac + +: determine optimize, if desired, or use for debug flag also +case "$optimize" in +' ') dflt='none';; +'') dflt='-O';; +*) dflt="$optimize";; +esac +$cat </dev/null 2>&1 + then + dflt="$dflt -posix" + fi + ;; + esac + ;; +esac + +case "$mips_type" in +*BSD*|'') inclwanted="$locincpth $usrinc";; +*) inclwanted="$locincpth $inclwanted $usrinc/bsd";; +esac +for thisincl in $inclwanted; do + if $test -d $thisincl; then + if $test x$thisincl != x$usrinc; then + case "$dflt" in + *$thisincl*);; + *) dflt="$dflt -I$thisincl";; + esac + fi + fi +done + +inctest='if $contains $2 $usrinc/$1 >/dev/null 2>&1; then + xxx=true; +elif $contains $2 $usrinc/sys/$1 >/dev/null 2>&1; then + xxx=true; +else + xxx=false; +fi; +if $xxx; then + case "$dflt" in + *$2*);; + *) dflt="$dflt -D$2";; + esac; +fi' + +if ./osf1; then + set signal.h __LANGUAGE_C__; eval $inctest +else + set signal.h LANGUAGE_C; eval $inctest +fi +set signal.h NO_PROTOTYPE; eval $inctest +set signal.h _NO_PROTO; eval $inctest + +case "$dflt" in +'') dflt=none;; +esac +case "$ccflags" in +'') ;; +*) dflt="$ccflags";; +esac +$cat <&4 + set X $cppflags + shift + cppflags='' + $cat >cpp.c <<'EOM' +#define BLURFL foo + +BLURFL xx LFRULB +EOM + previous='' + for flag in $* + do + case "$flag" in + -*) ftry="$flag";; + *) ftry="$previous $flag";; + esac + if $cppstdin -DLFRULB=bar $ftry $cppminus cpp1.out 2>/dev/null && \ + $cpprun -DLFRULB=bar $ftry $cpplast cpp2.out 2>/dev/null && \ + $contains 'foo.*xx.*bar' cpp1.out >/dev/null 2>&1 && \ + $contains 'foo.*xx.*bar' cpp2.out >/dev/null 2>&1 + then + cppflags="$cppflags $ftry" + previous='' + else + previous="$flag" + fi + done + set X $cppflags + shift + cppflags=${1+"$@"} + case "$cppflags" in + *-*) echo "They appear to be: $cppflags";; + esac + $rm -f cpp.c cpp?.out + ;; +esac + +: flags used in final linking phase + +case "$ldflags" in +'') if ./venix; then + dflt='-i -z' + else + dflt='' + fi + case "$ccflags" in + *-posix*) dflt="$dflt -posix" ;; + esac + ;; +*) dflt="$ldflags";; +esac + +: Try to guess additional flags to pick up local libraries. +for thislibdir in $libpth; do + case " $loclibpth " in + *" $thislibdir "*) + case "$dflt " in + "-L$thislibdir ") ;; + *) dflt="$dflt -L$thislibdir" ;; + esac + ;; + esac +done + +case "$dflt" in +'') dflt='none' ;; +esac + +$cat <&4 +set X $cc $optimize $ccflags $ldflags try.c -o try +shift +$cat >try.msg < try.c <<'EOF' +#include +main() { exit(0); } +EOF +dflt=y +if sh -c "$cc $optimize $ccflags try.c -o try $ldflags" >>try.msg 2>&1; then + if sh -c './try' >>try.msg 2>&1; then + dflt=n + else + echo "The program compiled OK, but exited with status $?." >>try.msg + rp="You have a problem. Shall I abort Configure" + dflt=y + fi +else + echo "I can't compile the test program." >>try.msg + rp="You have a BIG problem. Shall I abort Configure" + dflt=y +fi +case "$dflt" in +y) + $cat try.msg + case "$knowitall" in + '') + echo "(The supplied flags might be incorrect with this C compiler.)" + ;; + *) dflt=n;; + esac + echo " " + . ./myread + case "$ans" in + n*|N*) ;; + *) echo "Ok. Stopping Configure." >&4 + exit 1 + ;; + esac + ;; +n) echo "OK, that should do.";; +esac +$rm -f try try.* core + +: compute shared library extension +case "$so" in +'') + if xxx=`./loc libc.sl X $libpth`; $test -f "$xxx"; then + dflt='sl' + else + dflt='so' + fi + ;; +*) dflt="$so";; +esac +$cat <&4 +case "$libs" in +' '|'') dflt='';; +*) dflt="$libs";; +esac +case "$libswanted" in +'') libswanted='c_s';; +esac +for thislib in $libswanted; do + + if xxx=`./loc lib$thislib.$so.[0-9]'*' X $libpth`; $test -f "$xxx"; then + echo "Found -l$thislib (shared)." + case " $dflt " in + *"-l$thislib "*);; + *) dflt="$dflt -l$thislib";; + esac + elif xxx=`./loc lib$thislib.$so X $libpth` ; $test -f "$xxx"; then + echo "Found -l$thislib (shared)." + case " $dflt " in + *"-l$thislib "*);; + *) dflt="$dflt -l$thislib";; + esac + elif xxx=`./loc lib$thislib.a X $libpth`; $test -f "$xxx"; then + echo "Found -l$thislib." + case " $dflt " in + *"-l$thislib "*);; + *) dflt="$dflt -l$thislib";; + esac + elif xxx=`./loc $thislib.a X $libpth`; $test -f "$xxx"; then + echo "Found -l$thislib." + case " $dflt " in + *"-l$thislib "*);; + *) dflt="$dflt -l$thislib";; + esac + elif xxx=`./loc lib${thislib}_s.a X $libpth`; $test -f "$xxx"; then + echo "Found -l${thislib}_s." + case " $dflt " in + *"-l$thislib "*);; + *) dflt="$dflt -l${thislib}_s";; + esac + elif xxx=`./loc Slib$thislib.a X $xlibpth`; $test -f "$xxx"; then + echo "Found -l$thislib." + case " $dflt " in + *"-l$thislib "*);; + *) dflt="$dflt -l$thislib";; + esac + else + echo "No -l$thislib." + fi +done +set X $dflt +shift +dflt="$*" +case "$libs" in +'') dflt="$dflt";; +*) dflt="$libs";; +esac +case "$dflt" in +' '|'') dflt='none';; +esac + +$cat </dev/null` + if $test $dflt -gt 20; then + dflt=y + else + dflt=n + fi + ;; +*) + case "$usenm" in + true) dflt=y;; + *) dflt=n;; + esac + ;; +esac +$cat < #include #include +#define MY_O_NONBLOCK $o_nonblock extern int errno; $signal_t blech(x) int x; { exit(3); } +EOCP + $cat >> try.c <<'EOCP' main() { int pd[2]; @@ -5540,7 +5396,7 @@ main() int ret; close(pd[1]); /* Parent reads from pd[0] */ close(pu[0]); /* Parent writes (blocking) to pu[1] */ - if (-1 == fcntl(pd[0], F_SETFL, $o_nonblock)) + if (-1 == fcntl(pd[0], F_SETFL, MY_O_NONBLOCK)) exit(1); signal(SIGALRM, blech); alarm(5); @@ -6665,745 +6521,751 @@ echo " " if set times val -f d_times; eval $csym; $val; then echo 'times() found.' >&4 d_times="$define" - inc='' - case "$i_systimes" in - "$define") inc='sys/times.h';; - esac - set clock_t clocktype long stdio.h sys/types.h $inc - eval $typedef - dflt="$clocktype" - echo " " - rp="What type is returned by times() on this system?" - . ./myread - clocktype="$ans" -else - echo 'times() NOT found, hope that will do.' >&4 - d_times="$undef" - clocktype='int' -fi - -: see if truncate exists -set truncate d_truncate -eval $inlibc - -: see if tzname[] exists -echo " " -if set tzname val -a d_tzname; eval $csym; $val; then - val="$define" - echo 'tzname[] found.' >&4 -else - val="$undef" - echo 'tzname[] NOT found.' >&4 -fi -set d_tzname -eval $setvar - -: see if umask exists -set umask d_umask -eval $inlibc - -: see how we will look up host name -echo " " -if false; then - : dummy stub to allow use of elif -elif set uname val -f d_uname; eval $csym; $val; then - if ./xenix; then - $cat <<'EOM' -uname() was found, but you're running xenix, and older versions of xenix -have a broken uname(). If you don't really know whether your xenix is old -enough to have a broken system call, use the default answer. - -EOM - dflt=y - case "$d_uname" in - "$define") dflt=n;; - esac - rp='Is your uname() broken?' - . ./myread - case "$ans" in - n*) d_uname="$define"; call=uname;; - esac - else - echo 'uname() found.' >&4 - d_uname="$define" - call=uname - fi -fi -case "$d_gethname" in -'') d_gethname="$undef";; -esac -case "$d_uname" in -'') d_uname="$undef";; -esac -case "$d_phostname" in -'') d_phostname="$undef";; -esac - -: backward compatibility for d_hvfork -if test X$d_hvfork != X; then - d_vfork="$d_hvfork" - d_hvfork='' -fi -: see if there is a vfork -val='' -set vfork val -eval $inlibc - -: Ok, but do we want to use it. vfork is reportedly unreliable in -: perl on Solaris 2.x, and probably elsewhere. -case "$val" in -$define) - echo " " - case "$usevfork" in - false) dflt='n';; - *) dflt='y';; - esac - rp="Some systems have problems with vfork(). Do you want to use it?" - . ./myread - case "$ans" in - y|Y) ;; - *) - echo "Ok, we won't use vfork()." - val="$undef" - ;; - esac - ;; -esac -set d_vfork -eval $setvar -case "$d_vfork" in -$define) usevfork='true';; -*) usevfork='false';; -esac - -: see if this is an sysdir system -set sys/dir.h i_sysdir -eval $inhdr - -: see if this is an sysndir system -set sys/ndir.h i_sysndir -eval $inhdr + inc='' + case "$i_systimes" in + "$define") inc='sys/times.h';; + esac + set clock_t clocktype long stdio.h sys/types.h $inc + eval $typedef + dflt="$clocktype" + echo " " + rp="What type is returned by times() on this system?" + . ./myread + clocktype="$ans" +else + echo 'times() NOT found, hope that will do.' >&4 + d_times="$undef" + clocktype='int' +fi -: see if closedir exists -set closedir d_closedir +: see if truncate exists +set truncate d_truncate eval $inlibc -case "$d_closedir" in -"$define") - echo " " - echo "Checking whether closedir() returns a status..." >&4 - cat > closedir.c < -#if defined(NeXT) && defined(I_SYS_DIR) /* NeXT needs dirent + sys/dir.h */ -#include -#endif -#else -#ifdef I_SYS_NDIR -#include -#else -#ifdef I_SYS_DIR -#ifdef hp9000s500 -#include /* may be wrong in the future */ -#else -#include -#endif -#endif -#endif -#endif -int main() { return closedir(opendir(".")); } -EOM - if $cc $ccflags $ldflags -o closedir closedir.c $libs > /dev/null 2>&1; then - if ./closedir > /dev/null 2>&1 ; then - echo "Yes, it does." - val="$undef" - else - echo "No, it doesn't." - val="$define" - fi - else - echo "(I can't seem to compile the test program--assuming it doesn't)" - val="$define" - fi - ;; -*) - val="$undef"; - ;; -esac -set d_void_closedir -eval $setvar -$rm -f closedir* -: check for volatile keyword +: see if tzname[] exists echo " " -echo 'Checking to see if your C compiler knows about "volatile"...' >&4 -$cat >try.c <<'EOCP' -main() -{ - typedef struct _goo_struct goo_struct; - goo_struct * volatile goo = ((goo_struct *)0); - struct _goo_struct { - long long_int; - int reg_int; - char char_var; - }; - typedef unsigned short foo_t; - char *volatile foo; - volatile int bar; - volatile foo_t blech; - foo = foo; -} -EOCP -if $cc -c $ccflags try.c >/dev/null 2>&1 ; then +if set tzname val -a d_tzname; eval $csym; $val; then val="$define" - echo "Yup, it does." + echo 'tzname[] found.' >&4 else val="$undef" - echo "Nope, it doesn't." + echo 'tzname[] NOT found.' >&4 fi -set d_volatile +set d_tzname eval $setvar -$rm -f try.* - -: see if there is a wait4 -set wait4 d_wait4 -eval $inlibc - -: see if waitpid exists -set waitpid d_waitpid -eval $inlibc - -: see if wcstombs exists -set wcstombs d_wcstombs -eval $inlibc -: see if wctomb exists -set wctomb d_wctomb +: see if umask exists +set umask d_umask eval $inlibc -: preserve RCS keywords in files with variable substitution, grrr -Date='$Date' -Id='$Id' -Log='$Log' -RCSfile='$RCSfile' -Revision='$Revision' +: see if we have to deal with yellow pages, now NIS. +if $test -d /usr/etc/yp || $test -d /etc/yp; then + if $test -f /usr/etc/nibindd; then + echo " " + echo "I'm fairly confident you're on a NeXT." + echo " " + rp='Do you get the hosts file via NetInfo?' + dflt=y + case "$hostcat" in + nidump*) ;; + '') ;; + *) dflt=n;; + esac + . ./myread + case "$ans" in + y*) hostcat='nidump hosts .';; + *) case "$hostcat" in + nidump*) hostcat='';; + esac + ;; + esac + fi + case "$hostcat" in + nidump*) ;; + *) + case "$hostcat" in + *ypcat*) dflt=y;; + '') if $contains '^\+' /etc/passwd >/dev/null 2>&1; then + dflt=y + else + dflt=n + fi;; + *) dflt=n;; + esac + echo " " + rp='Are you getting the hosts file via yellow pages?' + . ./myread + case "$ans" in + y*) hostcat='ypcat hosts';; + *) hostcat='cat /etc/hosts';; + esac + ;; + esac +fi -: check for alignment requirements +: now get the host name echo " " -case "$alignbytes" in -'') echo "Checking alignment constraints..." >&4 - $cat >try.c <<'EOCP' -struct foobar { - char foo; - double bar; -} try; -main() -{ - printf("%d\n", (char *)&try.bar - (char *)&try.foo); -} -EOCP - if $cc $ccflags try.c -o try >/dev/null 2>&1; then - dflt=`./try` +echo "Figuring out host name..." >&4 +case "$myhostname" in +'') cont=true + echo 'Maybe "hostname" will work...' + if tans=`sh -c hostname 2>&1` ; then + myhostname=$tans + phostname=hostname + cont='' + fi + ;; +*) cont='';; +esac +if $test "$cont"; then + if ./xenix; then + echo 'Oh, dear. Maybe "/etc/systemid" is the key...' + if tans=`cat /etc/systemid 2>&1` ; then + myhostname=$tans + phostname='cat /etc/systemid' + echo "Whadyaknow. Xenix always was a bit strange..." + cont='' + fi + elif $test -r /etc/systemid; then + echo "(What is a non-Xenix system doing with /etc/systemid?)" + fi +fi +if $test "$cont"; then + echo 'No, maybe "uuname -l" will work...' + if tans=`sh -c 'uuname -l' 2>&1` ; then + myhostname=$tans + phostname='uuname -l' else - dflt='8' - echo"(I can't seem to compile the test program...)" + echo 'Strange. Maybe "uname -n" will work...' + if tans=`sh -c 'uname -n' 2>&1` ; then + myhostname=$tans + phostname='uname -n' + else + echo 'Oh well, maybe I can mine it out of whoami.h...' + if tans=`sh -c $contains' sysname $usrinc/whoami.h' 2>&1` ; then + myhostname=`echo "$tans" | $sed 's/^.*"\(.*\)"/\1/'` + phostname="sed -n -e '"'/sysname/s/^.*\"\\(.*\\)\"/\1/{'"' -e p -e q -e '}' <$usrinc/whoami.h" + else + case "$myhostname" in + '') echo "Does this machine have an identity crisis or something?" + phostname='';; + *) + echo "Well, you said $myhostname before..." + phostname='echo $myhostname';; + esac + fi + fi fi +fi +: you do not want to know about this +set $myhostname +myhostname=$1 + +: verify guess +if $test "$myhostname" ; then + dflt=y + rp='Your host name appears to be "'$myhostname'".'" Right?" + . ./myread + case "$ans" in + y*) ;; + *) myhostname='';; + esac +fi + +: bad guess or no guess +while $test "X$myhostname" = X ; do + dflt='' + rp="Please type the (one word) name of your host:" + . ./myread + myhostname="$ans" +done + +: translate upper to lower if necessary +case "$myhostname" in +*[A-Z]*) + echo "(Normalizing case in your host name)" + myhostname=`echo $myhostname | ./tr '[A-Z]' '[a-z]'` ;; -*) dflt="$alignbytes" +esac + +case "$myhostname" in +*.*) + dflt=`expr "X$myhostname" : "X[^.]*\(\..*\)"` + myhostname=`expr "X$myhostname" : "X\([^.]*\)\."` + echo "(Trimming domain name from host name--host name is now $myhostname)" ;; +*) case "$mydomain" in + '') + $hostcat >hosts + dflt=.`$awk "/[0-9].*$myhostname/ {for(i=2; i<=NF;i++) print \\\$i}" \ + hosts | $sort | $uniq | \ + $sed -n -e "s/$myhostname\.\([a-zA-Z_.]\)/\1/p"` + case "$dflt" in + .) echo "(You do not have fully-qualified names in /etc/hosts)" + tans=`./loc resolv.conf X /etc /usr/etc` + if $test -f "$tans"; then + echo "(Attempting domain name extraction from $tans)" + dflt=.`egrep '^domain' $tans | $sed 's/domain[ ]*\(.*\)/\1/' \ + | ./tr '[A-Z]' '[a-z]' 2>/dev/null` + fi + ;; + esac + case "$dflt" in + .) echo "(No help from resolv.conf either -- attempting clever guess)" + dflt=.`sh -c domainname 2>/dev/null` + case "$dflt" in + '') dflt='.';; + .nis.*|.yp.*|.main.*) dflt=`echo $dflt | $sed -e 's/^\.[^.]*//'`;; + esac + ;; + esac + case "$dflt" in + .) echo "(Lost all hope -- silly guess then)" + dflt='.uucp' + ;; + esac + $rm -f hosts + ;; + *) dflt="$mydomain";; + esac;; esac -rp="Doubles must be aligned on a how-many-byte boundary?" +echo " " +rp="What is your domain name?" . ./myread -alignbytes="$ans" -$rm -f try.c try +tans="$ans" +case "$ans" in +'') ;; +.*) ;; +*) tans=".$tans";; +esac +mydomain="$tans" -: check for ordering of bytes in a long -case "$byteorder" in -'') - $cat <<'EOM' - -In the following, larger digits indicate more significance. A big-endian -machine like a Pyramid or a Motorola 680?0 chip will come out to 4321. A -little-endian machine like a Vax or an Intel 80?86 chip would be 1234. Other -machines may have weird orders like 3412. A Cray will report 87654321. If -the test program works the default is probably right. -I'm now running the test program... -EOM - $cat >try.c <<'EOCP' -#include -main() -{ - int i; - union { - unsigned long l; - char c[sizeof(long)]; - } u; +: translate upper to lower if necessary +case "$mydomain" in +*[A-Z]*) + echo "(Normalizing case in your domain name)" + mydomain=`echo $mydomain | ./tr '[A-Z]' '[a-z]'` + ;; +esac - if (sizeof(long) > 4) - u.l = (0x08070605L << 32) | 0x04030201L; - else - u.l = 0x04030201L; - for (i = 0; i < sizeof(long); i++) - printf("%c", u.c[i]+'0'); - printf("\n"); - exit(0); -} -EOCP - xxx_prompt=y - if $cc $ccflags try.c -o try >/dev/null 2>&1 && ./try > /dev/null; then - dflt=`./try` - case "$dflt" in - [1-4][1-4][1-4][1-4]|12345678|87654321) - echo "(The test program ran ok.)" - echo "byteorder=$dflt" - xxx_prompt=n +: a little sanity check here +case "$phostname" in +'') ;; +*) + case `$phostname | ./tr '[A-Z]' '[a-z]'` in + $myhostname$mydomain|$myhostname) ;; + *) + case "$phostname" in + sed*) + echo "(That doesn't agree with your whoami.h file, by the way.)" + ;; + *) + echo "(That doesn't agree with your $phostname command, by the way.)" ;; - ????|????????) echo "(The test program ran ok.)" ;; - *) echo "(The test program didn't run right for some reason.)" ;; esac - else - dflt='4321' - cat <<'EOM' -(I can't seem to compile the test program. Guessing big-endian...) -EOM - fi - case "$xxx_prompt" in - y) - rp="What is the order of bytes in a long?" - . ./myread - byteorder="$ans" - ;; - *) byteorder=$dflt - ;; + ;; esac ;; esac -$rm -f try.c try -: how do we catenate cpp tokens here? +: see how we will look up host name echo " " -echo "Checking to see how your cpp does stuff like catenate tokens..." >&4 -$cat >cpp_stuff.c <<'EOCP' -#define RCAT(a,b)a/**/b -#define ACAT(a,b)a ## b -RCAT(Rei,ser) -ACAT(Cir,cus) -EOCP -$cppstdin $cppflags $cppminus cpp_stuff.out 2>&1 -if $contains 'Circus' cpp_stuff.out >/dev/null 2>&1; then - echo "Oh! Smells like ANSI's been here." - echo "We can catify or stringify, separately or together!" - cpp_stuff=42 -elif $contains 'Reiser' cpp_stuff.out >/dev/null 2>&1; then - echo "Ah, yes! The good old days!" - echo "However, in the good old days we don't know how to stringify and" - echo "catify at the same time." - cpp_stuff=1 -else - $cat >&4 <&4 + d_uname="$define" + call=uname + fi fi -$rm -f cpp_stuff.* +case "$d_gethname" in +'') d_gethname="$undef";; +esac +case "$d_uname" in +'') d_uname="$undef";; +esac +case "$d_phostname" in +'') d_phostname="$undef";; +esac -: see if this is a db.h system -set db.h i_db -eval $inhdr +: backward compatibility for d_hvfork +if test X$d_hvfork != X; then + d_vfork="$d_hvfork" + d_hvfork='' +fi +: see if there is a vfork +val='' +set vfork val +eval $inlibc -case "$i_db" in -define) - : Check the return type needed for hash +: Ok, but do we want to use it. vfork is reportedly unreliable in +: perl on Solaris 2.x, and probably elsewhere. +case "$val" in +$define) echo " " - echo "Checking return type needed for hash for Berkeley DB ..." >&4 - $cat >try.c < -#include -u_int32_t hash_cb (ptr, size) -const void *ptr; -size_t size; -{ -} -HASHINFO info; -main() -{ - info.hash = hash_cb; -} -EOCP - if $cc $ccflags -c try.c >try.out 2>&1 ; then - if $contains warning try.out >>/dev/null 2>&1 ; then - db_hashtype='int' - else - db_hashtype='u_int32_t' - fi - else - echo "I can't seem to compile the test program." >&4 - db_hashtype=int - fi - $rm -f try.* - echo "Your version of Berkeley DB uses $db_hashtype for hash." - ;; -*) db_hashtype=int + case "$usevfork" in + false) dflt='n';; + *) dflt='y';; + esac + rp="Some systems have problems with vfork(). Do you want to use it?" + . ./myread + case "$ans" in + y|Y) ;; + *) + echo "Ok, we won't use vfork()." + val="$undef" + ;; + esac ;; esac +set d_vfork +eval $setvar +case "$d_vfork" in +$define) usevfork='true';; +*) usevfork='false';; +esac -case "$i_db" in -define) - : Check the return type needed for prefix +: see if this is an sysdir system +set sys/dir.h i_sysdir +eval $inhdr + +: see if this is an sysndir system +set sys/ndir.h i_sysndir +eval $inhdr + +: see if closedir exists +set closedir d_closedir +eval $inlibc + +case "$d_closedir" in +"$define") echo " " - echo "Checking return type needed for prefix for Berkeley DB ..." >&4 - cat >try.c <&4 + cat > closedir.c < +#if defined(NeXT) && defined(I_SYS_DIR) /* NeXT needs dirent + sys/dir.h */ +#include #endif -#include -#include -size_t prefix_cb (key1, key2) -const DBT *key1; -const DBT *key2; -{ -} -BTREEINFO info; -main() -{ - info.prefix = prefix_cb; -} -EOCP - if $cc $ccflags -c try.c >try.out 2>&1 ; then - if $contains warning try.out >>/dev/null 2>&1 ; then - db_prefixtype='int' +#else +#ifdef I_SYS_NDIR +#include +#else +#ifdef I_SYS_DIR +#ifdef hp9000s500 +#include /* may be wrong in the future */ +#else +#include +#endif +#endif +#endif +#endif +int main() { return closedir(opendir(".")); } +EOM + if $cc $ccflags $ldflags -o closedir closedir.c $libs > /dev/null 2>&1; then + if ./closedir > /dev/null 2>&1 ; then + echo "Yes, it does." + val="$undef" else - db_prefixtype='size_t' + echo "No, it doesn't." + val="$define" fi else - echo "I can't seem to compile the test program." >&4 - db_prefixtype='int' + echo "(I can't seem to compile the test program--assuming it doesn't)" + val="$define" fi - $rm -f try.* - echo "Your version of Berkeley DB uses $db_prefixtype for prefix." ;; -*) db_prefixtype='int' +*) + val="$undef"; ;; esac - -: check for void type -echo " " -echo "Checking to see how well your C compiler groks the void type..." >&4 -echo " " -$cat >&4 <try.c <<'EOCP' -#if TRY & 1 -void main() { -#else -main() { -#endif - extern void moo(); /* function returning void */ - void (*goo)(); /* ptr to func returning void */ -#if TRY & 8 - void *hue; /* generic ptr */ -#endif -#if TRY & 2 - void (*foo[10])(); -#endif - -#if TRY & 4 - if(goo == moo) { - exit(0); - } -#endif - exit(0); +echo 'Checking to see if your C compiler knows about "volatile"...' >&4 +$cat >try.c <<'EOCP' +main() +{ + typedef struct _goo_struct goo_struct; + goo_struct * volatile goo = ((goo_struct *)0); + struct _goo_struct { + long long_int; + int reg_int; + char char_var; + }; + typedef unsigned short foo_t; + char *volatile foo; + volatile int bar; + volatile foo_t blech; + foo = foo; } EOCP - if $cc -c -DTRY=$defvoidused try.c >.out 2>&1 ; then - voidflags=$defvoidused - echo "It appears to support void to the level $package wants ($defvoidused)." - if $contains warning .out >/dev/null 2>&1; then - echo "However, you might get some warnings that look like this:" - $cat .out - fi - else -echo "Hmm, your compiler has some difficulty with void. Checking further..." >&4 - if $cc -c -DTRY=1 try.c >/dev/null 2>&1 ; then - echo "It supports 1..." - if $cc -c -DTRY=3 try.c >/dev/null 2>&1 ; then - echo "It also supports 2..." - if $cc -c -DTRY=7 try.c >/dev/null 2>&1 ; then - voidflags=7 - echo "And it supports 4 but not 8 definitely." - else - echo "It doesn't support 4..." - if $cc -c -DTRY=11 try.c >/dev/null 2>&1 ; then - voidflags=11 - echo "But it supports 8." - else - voidflags=3 - echo "Neither does it support 8." - fi - fi - else - echo "It does not support 2..." - if $cc -c -DTRY=13 try.c >/dev/null 2>&1 ; then - voidflags=13 - echo "But it supports 4 and 8." - else - if $cc -c -DTRY=5 try.c >/dev/null 2>&1 ; then - voidflags=5 - echo "And it supports 4 but has not heard about 8." - else - echo "However it supports 8 but not 4." - fi - fi - fi - else - echo "There is no support at all for void." - voidflags=0 - fi - fi -esac -: Only prompt user if voidflags is not 15. If voidflags is 15, then -: we presume all is well. -case "$voidflags" in -15) ;; -*) dflt="$voidflags"; - rp="Your void support flags add up to what?" - . ./myread - voidflags="$ans" - ;; -esac -$rm -f try.* .out +if $cc -c $ccflags try.c >/dev/null 2>&1 ; then + val="$define" + echo "Yup, it does." +else + val="$undef" + echo "Nope, it doesn't." +fi +set d_volatile +eval $setvar +$rm -f try.* -: see if dbm.h is available -: see if dbmclose exists -set dbmclose d_dbmclose +: see if there is a wait4 +set wait4 d_wait4 eval $inlibc -case "$d_dbmclose" in -$define) - set dbm.h i_dbm - eval $inhdr - case "$i_dbm" in - $define) - val="$undef" - set i_rpcsvcdbm - eval $setvar - ;; - *) set rpcsvc/dbm.h i_rpcsvcdbm - eval $inhdr - ;; - esac +: see if waitpid exists +set waitpid d_waitpid +eval $inlibc + +: see if wcstombs exists +set wcstombs d_wcstombs +eval $inlibc + +: see if wctomb exists +set wctomb d_wctomb +eval $inlibc + +: preserve RCS keywords in files with variable substitution, grrr +Date='$Date' +Id='$Id' +Log='$Log' +RCSfile='$RCSfile' +Revision='$Revision' + +: check for alignment requirements +echo " " +case "$alignbytes" in +'') echo "Checking alignment constraints..." >&4 + $cat >try.c <<'EOCP' +struct foobar { + char foo; + double bar; +} try; +main() +{ + printf("%d\n", (char *)&try.bar - (char *)&try.foo); +} +EOCP + if $cc $ccflags try.c -o try >/dev/null 2>&1; then + dflt=`./try` + else + dflt='8' + echo"(I can't seem to compile the test program...)" + fi ;; -*) echo "We won't be including " - val="$undef" - set i_dbm - eval $setvar - val="$undef" - set i_rpcsvcdbm - eval $setvar +*) dflt="$alignbytes" ;; esac +rp="Doubles must be aligned on a how-many-byte boundary?" +. ./myread +alignbytes="$ans" +$rm -f try.c try -: see if ndbm.h is available -set ndbm.h t_ndbm -eval $inhdr -case "$t_ndbm" in -$define) - : see if dbm_open exists - set dbm_open d_dbm_open - eval $inlibc - case "$d_dbm_open" in - $undef) - t_ndbm="$undef" - echo "We won't be including " - ;; - esac - ;; -esac -val="$t_ndbm" -set i_ndbm -eval $setvar +: Define several unixisms. These can be overridden in hint files. +ar='ar' +exe_ext='' +lib_ext='.a' +obj_ext='.o' +path_sep='/' +: Extra object files needed on this platform. +archobjs='' +: Which makefile gets called first. This is used by make depend. +firstmakefile='makefile' -: see if gdbm.h is available -set gdbm.h t_gdbm -eval $inhdr -case "$t_gdbm" in -$define) - : see if gdbm_open exists - set gdbm_open d_gdbm_open - eval $inlibc - case "$d_gdbm_open" in - $undef) - t_gdbm="$undef" - echo "We won't be including " +: check for ordering of bytes in a long +case "$byteorder" in +'') + $cat <<'EOM' + +In the following, larger digits indicate more significance. A big-endian +machine like a Pyramid or a Motorola 680?0 chip will come out to 4321. A +little-endian machine like a Vax or an Intel 80?86 chip would be 1234. Other +machines may have weird orders like 3412. A Cray will report 87654321. If +the test program works the default is probably right. +I'm now running the test program... +EOM + $cat >try.c <<'EOCP' +#include +main() +{ + int i; + union { + unsigned long l; + char c[sizeof(long)]; + } u; + + if (sizeof(long) > 4) + u.l = (0x08070605L << 32) | 0x04030201L; + else + u.l = 0x04030201L; + for (i = 0; i < sizeof(long); i++) + printf("%c", u.c[i]+'0'); + printf("\n"); + exit(0); +} +EOCP + xxx_prompt=y + if $cc $ccflags try.c -o try >/dev/null 2>&1 && ./try > /dev/null; then + dflt=`./try` + case "$dflt" in + [1-4][1-4][1-4][1-4]|12345678|87654321) + echo "(The test program ran ok.)" + echo "byteorder=$dflt" + xxx_prompt=n + ;; + ????|????????) echo "(The test program ran ok.)" ;; + *) echo "(The test program didn't run right for some reason.)" ;; + esac + else + dflt='4321' + cat <<'EOM' +(I can't seem to compile the test program. Guessing big-endian...) +EOM + fi + case "$xxx_prompt" in + y) + rp="What is the order of bytes in a long?" + . ./myread + byteorder="$ans" + ;; + *) byteorder=$dflt ;; esac ;; esac -val="$t_gdbm" -set i_gdbm -eval $setvar +$rm -f try.c try +: how do we catenate cpp tokens here? echo " " -echo "Looking for extensions..." >&4 -cd ../ext -: If we are using the old config.sh, known_extensions may contain -: old or inaccurate or duplicate values. -known_extensions='' -: We do not use find because it might not be available. -: We do not just use MANIFEST because the user may have dropped -: some additional extensions into the source tree and expect them -: to be built. -for xxx in * ; do - if $test -f $xxx/$xxx.xs; then - known_extensions="$known_extensions $xxx" - else - if $test -d $xxx; then - cd $xxx - for yyy in * ; do - if $test -f $yyy/$yyy.xs; then - known_extensions="$known_extensions $xxx/$yyy" - fi - done - cd .. - fi - fi -done -set X $known_extensions -shift -known_extensions="$*" -cd ../UU - -: Now see which are supported on this system. -avail_ext='' -for xxx in $known_extensions ; do - case "$xxx" in - DB_File) case "$i_db" in - $define) avail_ext="$avail_ext $xxx" ;; - esac - ;; - GDBM_File) case "$i_gdbm" in - $define) avail_ext="$avail_ext $xxx" ;; - esac - ;; - NDBM_File) case "$i_ndbm" in - $define) avail_ext="$avail_ext $xxx" ;; - esac - ;; - ODBM_File) case "${i_dbm}${i_rpcsvcdbm}" in - *"${define}"*) avail_ext="$avail_ext $xxx" ;; - esac - ;; - POSIX) case "$useposix" in - true|define|y) avail_ext="$avail_ext $xxx" ;; - esac - ;; - Socket) case "$d_socket" in - $define) avail_ext="$avail_ext $xxx" ;; - esac - ;; - *) avail_ext="$avail_ext $xxx" - ;; - esac -done - -set X $avail_ext -shift -avail_ext="$*" - -case $usedl in -$define) - $cat <&4 +$cat >cpp_stuff.c <<'EOCP' +#define RCAT(a,b)a/**/b +#define ACAT(a,b)a ## b +RCAT(Rei,ser) +ACAT(Cir,cus) +EOCP +$cppstdin $cppflags $cppminus cpp_stuff.out 2>&1 +if $contains 'Circus' cpp_stuff.out >/dev/null 2>&1; then + echo "Oh! Smells like ANSI's been here." + echo "We can catify or stringify, separately or together!" + cpp_stuff=42 +elif $contains 'Reiser' cpp_stuff.out >/dev/null 2>&1; then + echo "Ah, yes! The good old days!" + echo "However, in the good old days we don't know how to stringify and" + echo "catify at the same time." + cpp_stuff=1 +else + $cat >&4 <&4 + $cat >try.c < +#include +u_int32_t hash_cb (ptr, size) +const void *ptr; +size_t size; +{ +} +HASHINFO info; +main() +{ + info.hash = hash_cb; +} +EOCP + if $cc $ccflags -c try.c >try.out 2>&1 ; then + if $contains warning try.out >>/dev/null 2>&1 ; then + db_hashtype='int' + else + db_hashtype='u_int32_t' + fi + else + echo "I can't seem to compile the test program." >&4 + db_hashtype=int + fi + $rm -f try.* + echo "Your version of Berkeley DB uses $db_hashtype for hash." + ;; +*) db_hashtype=int + ;; +esac - case "$dflt" in - '') dflt=none;; - esac - rp="What extensions do you wish to load statically?" - . ./myread - case "$ans" in - none) static_ext=' ' ;; - *) static_ext="$ans" ;; - esac +case "$i_db" in +define) + : Check the return type needed for prefix + echo " " + echo "Checking return type needed for prefix for Berkeley DB ..." >&4 + cat >try.c < +#include +size_t prefix_cb (key1, key2) +const DBT *key1; +const DBT *key2; +{ +} +BTREEINFO info; +main() +{ + info.prefix = prefix_cb; +} +EOCP + if $cc $ccflags -c try.c >try.out 2>&1 ; then + if $contains warning try.out >>/dev/null 2>&1 ; then + db_prefixtype='int' + else + db_prefixtype='size_t' + fi + else + echo "I can't seem to compile the test program." >&4 + db_prefixtype='int' + fi + $rm -f try.* + echo "Your version of Berkeley DB uses $db_prefixtype for prefix." ;; -*) - $cat <&4 +echo " " +$cat >&4 <try.c <<'EOCP' +#if TRY & 1 +void main() { +#else +main() { +#endif + extern void moo(); /* function returning void */ + void (*goo)(); /* ptr to func returning void */ +#if TRY & 8 + void *hue; /* generic ptr */ +#endif +#if TRY & 2 + void (*foo[10])(); +#endif - case "$dflt" in - '') dflt=none;; - esac - rp="What extensions do you wish to include?" +#if TRY & 4 + if(goo == moo) { + exit(0); + } +#endif + exit(0); +} +EOCP + if $cc -c -DTRY=$defvoidused try.c >.out 2>&1 ; then + voidflags=$defvoidused + echo "It appears to support void to the level $package wants ($defvoidused)." + if $contains warning .out >/dev/null 2>&1; then + echo "However, you might get some warnings that look like this:" + $cat .out + fi + else +echo "Hmm, your compiler has some difficulty with void. Checking further..." >&4 + if $cc -c -DTRY=1 try.c >/dev/null 2>&1 ; then + echo "It supports 1..." + if $cc -c -DTRY=3 try.c >/dev/null 2>&1 ; then + echo "It also supports 2..." + if $cc -c -DTRY=7 try.c >/dev/null 2>&1 ; then + voidflags=7 + echo "And it supports 4 but not 8 definitely." + else + echo "It doesn't support 4..." + if $cc -c -DTRY=11 try.c >/dev/null 2>&1 ; then + voidflags=11 + echo "But it supports 8." + else + voidflags=3 + echo "Neither does it support 8." + fi + fi + else + echo "It does not support 2..." + if $cc -c -DTRY=13 try.c >/dev/null 2>&1 ; then + voidflags=13 + echo "But it supports 4 and 8." + else + if $cc -c -DTRY=5 try.c >/dev/null 2>&1 ; then + voidflags=5 + echo "And it supports 4 but has not heard about 8." + else + echo "However it supports 8 but not 4." + fi + fi + fi + else + echo "There is no support at all for void." + voidflags=0 + fi + fi +esac +: Only prompt user if voidflags is not 15. If voidflags is 15, then +: we presume all is well. +case "$voidflags" in +15) ;; +*) dflt="$voidflags"; + rp="Your void support flags add up to what?" . ./myread - case "$ans" in - none) static_ext=' ' ;; - *) static_ext="$ans" ;; - esac + voidflags="$ans" ;; esac - -set X $dynamic_ext $static_ext -shift -extensions="$*" +$rm -f try.* .out : see what type file positions are declared as in the library set fpos_t fpostype long stdio.h sys/types.h @@ -7478,19 +7340,6 @@ rp="What type is used for file modes?" . ./myread modetype="$ans" -: set the base revision -baserev=5.0 - -: get the patchlevel -echo " " -echo "Getting the current patchlevel..." >&4 -if $test -r ../patchlevel.h;then - patchlevel=`awk '/PATCHLEVEL/ {print $3}' < ../patchlevel.h` -else - patchlevel=0 -fi -echo "(You have $package $baserev PL$patchlevel.)" - : Cruising for prototypes echo " " echo "Checking out function prototypes..." >&4 @@ -7822,6 +7671,7 @@ esac : Trace out the files included by signal.h, then look for SIGxxx names. : Remove SIGARRAYSIZE used by HPUX. +: Remove SIGTYP void lines used by OS2. xxx=`echo '#include ' | $cppstdin $cppminus $cppflags 2>/dev/null | $grep '^[ ]*#.*include' | @@ -7838,10 +7688,10 @@ case "$xxxfiles" in '') xxxfiles=`./findhdr signal.h` ;; esac xxx=`awk ' -$1 ~ /^#define$/ && $2 ~ /^SIG[A-Z0-9]*$/ && $2 !~ /SIGARRAYSIZE/ { +$1 ~ /^#define$/ && $2 ~ /^SIG[A-Z0-9]*$/ && $2 !~ /SIGARRAYSIZE/ && $3 !~ /void/ { print substr($2, 4, 20) } -$1 == "#" && $2 ~ /^define$/ && $3 ~ /^SIG[A-Z0-9]*$/ && $3 !~ /SIGARRAYSIZE/ { +$1 == "#" && $2 ~ /^define$/ && $3 ~ /^SIG[A-Z0-9]*$/ && $3 !~ /SIGARRAYSIZE/ && $4 !~ /void/ { print substr($3, 4, 20) }' $xxxfiles` : Append some common names just in case the awk scan failed. @@ -7850,11 +7700,19 @@ xxx="$xxx LOST PHONE PIPE POLL PROF PWR QUIT SEGV STKFLT STOP SYS TERM TRAP" xxx="$xxx TSTP TTIN TTOU URG USR1 USR2 USR3 USR4 VTALRM" xxx="$xxx WINCH WIND WINDOW XCPU XFSZ" : generate a few handy files for later -echo $xxx | $tr ' ' '\012' | $awk ' -BEGIN { - printf "#include \n"; - printf "main() {\n"; -} +$cat > signal.c <<'EOP' +#include +#include +int main() { +#ifdef NSIG +printf("NSIG %d\n", NSIG); +#else +#ifdef _NSIG +printf("NSIG %d\n", _NSIG); +#endif +#endif +EOP +echo $xxx | $tr ' ' '\012' | $sort | $uniq | $awk ' { printf "#ifdef SIG"; printf $1; printf "\n" printf "printf(\""; printf $1; printf " %%d\\n\",SIG"; @@ -7864,12 +7722,43 @@ BEGIN { END { printf "}\n"; } -' >signal.c -$cat >signal.cmd <>signal.c +$cat >signal.awk <<'EOP' +BEGIN { ndups = 0 } +$1 ~ /^NSIG$/ { nsig = $2 } +($1 !~ /^NSIG$/) && (NF == 2) { + if ($2 > maxsig) { maxsig = $2 } + if (sig_name[$2]) { + dup_name[ndups] = $1 + dup_num[ndups] = $2 + ndups++ + } + else { + sig_name[$2] = $1 + sig_num[$2] = $2 + } + +} +END { + if (nsig == 0) { nsig = maxsig + 1 } + for (n = 1; n < nsig; n++) { + if (sig_name[n]) { + printf("%s %d\n", sig_name[n], sig_num[n]) + } + else { + printf("NUM%d %d\n", n, n) + } + } + for (n = 0; n < ndups; n++) { + printf("%s %d\n", dup_name[n], dup_num[n]) + } +} +EOP +$cat >signal_cmd </dev/null 2>&1; then - ./signal | $sort -n +1 | $uniq >signal.lst + ./signal | $sort -n +1 | $uniq | $awk -f signal.awk >signal.lst else echo "(I can't seem be able to compile the test program -- Guessing)" echo 'kill -l' >signal @@ -7884,17 +7773,25 @@ else fi $rm -f signal.c signal signal.o EOS -chmod a+x signal.cmd -$eunicefix signal.cmd +chmod a+x signal_cmd +$eunicefix signal_cmd : generate list of signal names echo " " case "$sig_name" in +'') sig_num='' ;; +esac +case "$sig_num" in +'') sig_name='' ;; +esac +case "$sig_name" in '') - echo "Generating a list of signal names..." >&4 - ./signal.cmd + echo "Generating a list of signal names and numbers..." >&4 + ./signal_cmd sig_name=`$awk '{printf "%s ", $1}' signal.lst` sig_name="ZERO $sig_name" + sig_num=`$awk '{printf "%d ", $2}' signal.lst` + sig_num="0 $sig_num" ;; esac echo "The following signals are available:" @@ -7913,21 +7810,7 @@ echo $sig_name | $awk \ } printf "\n" }' - -: generate list of signal numbers -echo " " -case "$sig_num" in -'') - echo "Generating a list of signal numbers..." >&4 - ./signal.cmd - sig_num=`$awk '{printf "%d ", $2}' signal.lst` - sig_num="0 $sig_num" - ;; -esac -case "$sig_max" in -'') sig_max=`$tail -1 signal.lst | $awk '{print $2}'` ;; -esac -echo "The maximum signal number defined is $sig_max." +$rm -f signal signal.c signal.awk signal.lst signal_cmd : see what type is used for size_t set size_t sizetype 'unsigned int' stdio.h sys/types.h @@ -8017,12 +7900,42 @@ xxx) *) dflt="$1" ;; esac ;; -*) dflt="$uidtype";; +*) dflt="$uidtype";; +esac +echo " " +rp="What is the type for user ids returned by getuid()?" +. ./myread +uidtype="$ans" + +: see if dbm.h is available +: see if dbmclose exists +set dbmclose d_dbmclose +eval $inlibc + +case "$d_dbmclose" in +$define) + set dbm.h i_dbm + eval $inhdr + case "$i_dbm" in + $define) + val="$undef" + set i_rpcsvcdbm + eval $setvar + ;; + *) set rpcsvc/dbm.h i_rpcsvcdbm + eval $inhdr + ;; + esac + ;; +*) echo "We won't be including " + val="$undef" + set i_dbm + eval $setvar + val="$undef" + set i_rpcsvcdbm + eval $setvar + ;; esac -echo " " -rp="What is the type for user ids returned by getuid()?" -. ./myread -uidtype="$ans" : see if this is a sys/file.h system val='' @@ -8081,6 +7994,10 @@ eval $setvar set grp.h i_grp eval $inhdr +: see if locale.h is available +set locale.h i_locale +eval $inhdr + : see if this is a math.h system set math.h i_math eval $inhdr @@ -8109,6 +8026,26 @@ esac set i_memory eval $setvar +: see if ndbm.h is available +set ndbm.h t_ndbm +eval $inhdr +case "$t_ndbm" in +$define) + : see if dbm_open exists + set dbm_open d_dbm_open + eval $inlibc + case "$d_dbm_open" in + $undef) + t_ndbm="$undef" + echo "We won't be including " + ;; + esac + ;; +esac +val="$t_ndbm" +set i_ndbm +eval $setvar + : see if net/errno.h is available val='' set net/errno.h val @@ -8453,6 +8390,223 @@ case "$d_vfork" in ;; esac +: see if gdbm.h is available +set gdbm.h t_gdbm +eval $inhdr +case "$t_gdbm" in +$define) + : see if gdbm_open exists + set gdbm_open d_gdbm_open + eval $inlibc + case "$d_gdbm_open" in + $undef) + t_gdbm="$undef" + echo "We won't be including " + ;; + esac + ;; +esac +val="$t_gdbm" +set i_gdbm +eval $setvar + +echo " " +echo "Looking for extensions..." >&4 +cd ../ext +: If we are using the old config.sh, known_extensions may contain +: old or inaccurate or duplicate values. +known_extensions='' +: We do not use find because it might not be available. +: We do not just use MANIFEST because the user may have dropped +: some additional extensions into the source tree and expect them +: to be built. +for xxx in * ; do + if $test -f $xxx/$xxx.xs; then + known_extensions="$known_extensions $xxx" + else + if $test -d $xxx; then + cd $xxx + for yyy in * ; do + if $test -f $yyy/$yyy.xs; then + known_extensions="$known_extensions $xxx/$yyy" + fi + done + cd .. + fi + fi +done +set X $known_extensions +shift +known_extensions="$*" +cd ../UU + +: Now see which are supported on this system. +avail_ext='' +for xxx in $known_extensions ; do + case "$xxx" in + DB_File) case "$i_db" in + $define) avail_ext="$avail_ext $xxx" ;; + esac + ;; + GDBM_File) case "$i_gdbm" in + $define) avail_ext="$avail_ext $xxx" ;; + esac + ;; + NDBM_File) case "$i_ndbm" in + $define) avail_ext="$avail_ext $xxx" ;; + esac + ;; + ODBM_File) case "${i_dbm}${i_rpcsvcdbm}" in + *"${define}"*) avail_ext="$avail_ext $xxx" ;; + esac + ;; + POSIX) case "$useposix" in + true|define|y) avail_ext="$avail_ext $xxx" ;; + esac + ;; + Socket) case "$d_socket" in + $define) avail_ext="$avail_ext $xxx" ;; + esac + ;; + *) avail_ext="$avail_ext $xxx" + ;; + esac +done + +set X $avail_ext +shift +avail_ext="$*" + +case $usedl in +$define) + $cat < expected > actual ; diff expected actual -open(EVAL, "| perl5 -x") || die "Can't pipe to perl5\n"; -while () { - m/prints ``(.*)''$/ && print STDERR $1,"\n"; - print EVAL $_; -} -__END__ -#!/usr/local/bin/perl5 -# -# Perl5a6 notes: Patchlevel 3 -# -# This document is in the public domain. -# -# Written by Tony Sanders -# -# Quick examples of the new Perl5 features as of alpha6. Look in the -# file Changes, the man page, and in the test suite (esp t/op/ref.t) -# for more information. There are also a number of files in the alpha6 -# release (e.g., tie*) that show how to use various features. Also, there -# are a number of package modules in lib/*.pm that are of interest. -# -# Thanks to the following for their input: -# Johan.Vromans@NL.net -# Daniel Faken -# Tom Christiansen -# Dean Roehrich -# Larry Wall -# Lionel Cons -# - -# BEGIN { } - # executed at load time - print "doody\n"; - BEGIN { print "howdy\n"; } # prints ``howdy'' - # then prints ``doody'' -# END { } - # executed at exit time in reverse order of definition - END { print "blue sky\n"; } # will print ``blue sky'' - END { print "goodbye\n"; } # will print ``goodbye'' - -# (expr?lval:lval) = value; - # The (?:) operator can be used as an lvalue. - $a = 1; $b = 2; - (defined $b ? $a : $b) = 10; - print "$a:$b\n"; # prints ``10:2'' - -# new functions: abs, chr, uc, ucfirst, lc, lcfirst - print abs(-10), "\n"; # prints ``10'' - print chr(64), "\n"; # prints ``@'' - print uc("the"), "\n"; # prints ``THE'' - print ucfirst("the"), "\n"; # prints ``The'' - print lc("THE"), "\n"; # prints ``the'' - print lcfirst("THE"), "\n"; # prints ``tHE'' - -# references - # references - $thing1 = "testing"; - $ref = \$thing1; # \ creates a reference - print $$ref,"\n" if ${$ref} eq $$ref; # deref, prints ``testing'' - - # symbolic references - sub bat { "baz"; } - sub baz { print "foobar\n" }; - &{&bat}; # prints ``foobar'' - -# symbol table assignment: *foo = \&func; - # replaces an item in the symbol table (function, scalar, array, hash) - # *foo = \$bar replaces the scalar - # *foo = \%bar replaces the hash table - # *foo = \@bar replaces the array - # *foo = \&bar replaces the function - # *foo = *bar all of the above (including FILEHANDLE!) - # XXX: can't do just filehandles (yet) - # - # This can be used to import and rename a symbol from another package: - # *myfunc = \&otherpack::otherfunc; - -# AUTOLOAD { ...; } - # called if method not found, passed function name in $AUTOLOAD - # @_ are the arguments to the function. -# goto &func; - # goto's a function, used by AUTOLOAD to jump to the function -# qw/arg list/; qw(arg list); - # quoted words, yields a list; works like split(' ', 'arg list') - # not a function, more like q//; - { - package AutoLoader; - AUTOLOAD { - eval "sub $AUTOLOAD" . '{ print "@_\n"}'; - goto &$AUTOLOAD } - package JAPH; - @ISA = (AutoLoader); - sub foo2 { &bar } - foo2 qw(Just another Perl hacker,); - # prints ``Just another Perl hacker,'' - } -# Larry notes: -# You might point out that there's a canned Autoloader base class in the -# library. Another subtlety is that $AUTOLOAD is always in the same -# package as the AUTOLOAD routine, so if you call another package's -# AUTOLOAD explicitly you have to set $AUTOLOAD in that package first. - -# my - # lexical scoping - sub samp1 { print $z,"\n" } - sub samp2 { my($z) = "world"; &samp1 } - $z = "hello"; - &samp2; # prints ``hello'' - -# package; - # empty package; for catching non-local variable references - sub samp3 { - my $x = shift; # local() would work also - package; # empty package - $main::count += $x; # this is ok. - # $y = 1; # would be a compile time error - } - -# => - # works like comma (,); use for key/value pairs - # sometimes used to disambiguate the final expression in a block - # might someday supply warnings if you get out of sync - %foo = ( abc => foo ); - print $foo{abc},"\n"; # prints ``foo'' - -# :: - # works like tick (') (use of ' is deprecated in perl5) - print $main::foo{abc},"\n"; # prints ``foo'' - -# bless ref; - # Bless takes a reference and returns an "object" - $oref = bless \$scalar; - -# -> - # dereferences an "object" - $x = { def => bar }; # $x is ref to anonymous hash - print $x->{def},"\n"; # prints ``bar'' - - # method derefs must be bless'ed - { - # initial cap is encouraged to avoid naming conflicts - package Sample; - sub samp4 { my($this) = shift; print $this->{def},"\n"; } - sub samp5 { print "samp5: ", $_[1], "\n"; } - $main::y = bless $main::x; # $x is ref, $y is "object" - } - $y->samp4(); # prints ``bar'' - - # indirect object calls (same as $y->samp5(arglist)) - samp5 $y arglist; # prints ``samp5: arglist'' - - # static method calls (often used for constructors, see below) - samp5 Sample arglist; # prints ``samp5: arglist'' - -# function calls without & - sub samp6 { print "look ma\n"; } - samp6; # prints ``look ma'' - - # "forward" decl - sub samp7; - samp7; # prints ``look pa'' - sub samp7 { print "look pa\n"; } - - # no decl requires ()'s or initial & - &samp8; # prints ``look da'' - samp8(); # prints ``look da'' - sub samp8 { print "look da\n"; } - -# ref - # returns "object" type - { - package OBJ1; - $x = bless \$y; # returns "object" $x in "class" OBJ1 - print ref $x,"\n"; # prints ``OBJ1'' - } - - # and non-references return undef. - $z = 1; - print "non-ref\n" unless ref $z; # prints ``non-ref'' - - # ref's to "builtins" return type - print ref \$ascalar,"\n"; # prints ``SCALAR'' - print ref \@array,"\n"; # prints ``ARRAY'' - print ref \%hash,"\n"; # prints ``HASH'' - sub func { print shift,"\n"; } - print ref \&func,"\n"; # prints ``CODE'' - print ref \\$scalar,"\n"; # prints ``REF'' - -# tie - # bind a variable to a package with magic functions: - # new, DESTROY, fetch, store, delete, firstkey, nextkey - # The exact function list varies with the variable type, - # see the man page and tie* for more details. - # Usage: tie variable, PackageName, ARGLIST - { - package TIEPACK; - sub new { print "NEW: @_\n"; local($x) = $_[1]; bless \$x } - sub fetch { print "fetch ", ref $_[0], "\n"; ${$_[0]} } - sub store { print "store $_[1]\n"; ${$_[0]} = $_[1] } - DESTROY { print "DESTROY ", ref $_[0], "\n" } - } - tie $h, TIEPACK, "black_tie"; # prints ``NEW: TIEPACK black_tie'' - print $h, "\n"; # prints ``fetch TIEPACK'' - # prints ``black_tie'' - $h = 'bar'; # prints ``store bar'' - untie $h; # prints ``DESTROY SCALAR'' - -# References - $sref = \$scalar; # $$sref is scalar - $aref = \@array; # @$aref is array - $href = \%hash; # %$href is hash table - $fref = \&func; # &$fref is function - $refref = \$fref; # ref to ref to function - &$$refref("call the function"); # prints ``call the function'' - -# Anonymous data-structures - %hash = ( abc => foo ); # hash in perl4 (works in perl5 also) - print $hash{abc},"\n"; # prints ``foo'' - $ref = { abc => bar }; # reference to anon hash - print $ref->{abc},"\n"; # prints ``bar'' - - @ary = ( 0, 1, 2 ); # array in perl4 (works in perl5 also) - print $ary[1],"\n"; # prints ``1'' - $ref = [ 3, 4, 5 ]; # reference to anon array - print $ref->[1],"\n"; # prints ``4'' - -# Nested data-structures - @foo = ( 0, { name => foobar }, 2, 3 ); # $#foo == 3 - $aref = [ 0, { name => foobar }, 2, 3 ]; # ref to anon array - $href = { # ref to hash of arrays - John => [ Mary, Pat, Blanch ], - Paul => [ Sally, Jill, Jane ], - Mark => [ Ann, Bob, Dawn ], - }; - print $href->{Paul}->[0], "\n"; # prints ``Sally'' - print $href->{Paul}[0],"\n"; # shorthand version, prints ``Sally'' - print @{$href->{Mark}},"\n"; # prints ``AnnBobDawn'' - -# @ISA - # Multiple Inheritance (get rich quick) - { - package OBJ2; sub abc { print "abc\n"; } - package OBJ3; sub def { print "def\n"; } - package OBJ4; @ISA = ("OBJ2", "OBJ3"); - $x = bless { foo => bar }; - $x->abc; # prints ``abc'' - $x->def; # prints ``def'' - } - -# Packages, Classes, Objects, Methods, Constructors, Destructors, etc. - # XXX: need more explinations and samples - { - package OBJ5; - sub new { print "NEW: @_\n"; my($x) = "empty"; bless \$x } - sub output { my($this) = shift; print "value = $$this\n"; } - DESTROY { print "OBJ5 DESTROY\n" } - } - # Constructors are often written as static method calls: - $x = new OBJ5; # prints ``NEW: OBJ5'' - $x->output; # prints ``value = empty'' - # The destructor is responsible for calling any base class destructors. - undef $x; # prints ``OBJ5 DESTROY'' - -# require Package; - # same as: BEGIN { require 'Package.pm'; } -# require ; - # checks against the perl version number - require 5.000; # requires perl 5.0 or better - -# Package Modules -# =============== -# Yes, these are all very sketchy. See the .pm file for details. - -# DynamicLoader (builtin) - # Public: &bootstrap - # Load a shared library package on systems that support it - # This incomplete example was extracted from lib/POSIX.pm - # - # package POSIX; - # requires Exporter; require AutoLoader; - # @ISA = (Exporter, AutoLoader, DynamicLoader); - # @EXPORT = qw(closedir, opendir, [..., lots of functions]); - # bootstrap POSIX; - -# Larry notes: -# The gist of it is that DynamicLoader::bootstrap is only called if main.c -# didn't already define MYPACKAGE::bootstrap. So the .pm file doesn't know -# (or care) whether the module is statically or dynamically loaded. - -# AutoLoader.pm - # Public: &AUTOLOAD - # Causes functions from .../lib/perl/auto/PACKAGE/*.al to autoload - # when used but not defined. - -# Config.pm - # Exports: %Config - # The data from the Configure script for perl programs (yeah) - -# English.pm - # Exports: (lots of verbose variables) - # The "english" versions of things like $_ $| $= - -# Exporter.pm - # Public: &import - # import PACKAGE [@symbols] - # requires PACKAGE to define @EXPORT - { - package FOOBAR; - require Exporter; - @ISA = (Exporter); - @EXPORT = (foo, bar); - sub foo { print "FOO\n" }; - sub bar { print "BAR\n" }; - 1; - package BAT; - # require FOOBAR; # not in this example - import FOOBAR; - @ISA = (); - &foo; # prints ``FOO'' - } - -# FileHandle.pm - # Exports: (lots of filehandle functions) - # English versions of various filehandle operations - -# Hostname.pm - # Exports: &hostname - # Routine to get hostname - # { - # require Hostname; import Hostname; - # print &hostname,"\n"; # prints your hostname - # } - -# POSIX.pm - # Exports: (posix functions and defines) - # POSIX.1 bindings - -# SDBM_File.pm - # SDBM interfaces (use with `tie') - # Other DBM interfaces work the same way - -# when the script exits the END section gets executed and prints ``goodbye'' -# ENDs are executed in reverse order of definition. prints ``blue sky'' -__END__ diff --git a/EXTERN.h b/EXTERN.h index 765c558255..dedd37958c 100644 --- a/EXTERN.h +++ b/EXTERN.h @@ -7,8 +7,21 @@ * */ +/* + * EXT designates a global var which is defined in perl.h + * dEXT designates a global var which is defined in another + * file, so we can't count on finding it in perl.h + * (this practice should be avoided). + */ #undef EXT -#define EXT extern +#undef dEXT +#if defined(VMS) && !defined(__GNUC__) +# define EXT globalref +# define dEXT globaldef {"$GLOBAL_RW_VARS"} noshare +#else +# define EXT extern +# define dEXT +#endif #undef INIT #define INIT(x) diff --git a/INSTALL b/INSTALL index b72e43ce34..de7ca20841 100644 --- a/INSTALL +++ b/INSTALL @@ -25,7 +25,7 @@ experiencing difficulties building perl, you should probably I re-use your old config.sh. Simply remove it or rename it, e.g. mv config.sh config.sh.old - + Then run Configure. =head1 Run Configure. @@ -46,6 +46,9 @@ to get a listing. To compile with gcc, for example, you can run This is the preferred way to specify gcc (or another alternative compiler) so that the hints files can set appropriate defaults. +If you want to use your old config.sh but override some of the items +with command line options, you need to use B. + If you are willing to accept all the defaults, and you want terse output, you can run @@ -57,7 +60,12 @@ the default installation directory, when Configure prompts you or by using the Configure command line option -Dprefix='/some/directory', e.g. - Configure -Dprefix=/opt/local + Configure -Dprefix=/opt/perl + +If your prefix contains the string "perl", then the directories +are simplified. For example, if you use prefix=/opt/perl, +then Configure will suggest /opt/perl/lib instead of +/usr/local/lib/perl5/. By default, Configure will compile perl to use dynamic loading, if your system supports it. If you want to force perl to be compiled @@ -82,10 +90,12 @@ Cross compiling is currently not supported. =head2 Including locally-installed libraries -Perl5 comes with a number of database extensions, including interfaces -to dbm, ndbm, gdbm, and Berkeley db. For each extension, if Configure -can find the appropriate header files and libraries, it will automatically -include that extension. +Perl5 comes with interfaces to number of database extensions, including +dbm, ndbm, gdbm, and Berkeley db. For each extension, if +Configure can find the appropriate header files and libraries, it will +automatically include that extension. The gdbm and db libraries +are B included with perl. See the library documentation for +how to obtain the libraries. I If your database header (.h) files are not in a directory normally searched by your C compiler, then you will need to @@ -159,6 +169,66 @@ F, then you have to include both, namely =back +=head2 Installation Directories. + +The installation directories can all be changed by answering the +appropriate questions in Configure. For convenience, all the +installation questions are near the beginning of Configure. + +By default, Configure uses the following directories for +library files (archname is a string like sun4-sunos, determined +by Configure) + + /usr/local/lib/perl5/archname/5.002 + /usr/local/lib/perl5/ + /usr/local/lib/site_perl/archname + /usr/local/lib/site_perl + +and the following directories for manual pages: + + /usr/local/man/man1 + /usr/local/lib/perl5/man/man3 + +(Actually, Configure recognizes the SVR3-style +/usr/local/man/l_man/man1 directories, if present, and uses those +instead.) The module man pages are stuck in that strange spot so that +they don't collide with other man pages stored in /usr/local/man/man3, +and so that Perl's man pages don't hide system man pages. On some +systems, B would end up calling up Perl's less.pm module man +page, rather than the B program. + +If you specify a prefix that contains the string "perl", then the +directory structure is simplified. For example, if you Configure +with -Dprefix=/opt/perl, then the defaults are + + /opt/perl/lib/archname/5.002 + /opt/perl/lib + /opt/perl/lib/site_perl/archname + /opt/perl/lib/site_perl + + /opt/perl/man/man1 + /opt/perl/man/man3 + +The perl executable will search the libraries in the order given +above. + +The directories site_perl and site_perl/archname are empty, but are +intended to be used for installing local or site-wide extensions. Perl +will automatically look in these directories. Previously, most sites +just put their local extensions in with the standard distribution. + +In order to support using things like #!/usr/local/bin/perl5.002 after +a later version is released, architecture-dependent libraries are +stored in a version-specific directory, such as +/usr/local/lib/perl5/archname/5.002/. In 5.000 and 5.001, these files +were just stored in /usr/local/lib/perl5/archname/. If you will not be +using 5.001 binaries, you can delete the standard extensions from the +/usr/local/lib/perl5/archname/ directory. Locally-added extensions can +be moved to the site_perl and site_perl/archname directories. + +Again, these are just the defaults, and can be changed as you run +Configure. + =head2 Changing the installation directory Configure distinguishes between the directory in which perl (and its @@ -189,6 +259,7 @@ directory of your choice): installprivlib=`echo $installprivlib | sed "s!$prefix!$installprefix!"` installscript=`echo $installscript | sed "s!$prefix!$installprefix!"` installsitelib=`echo $installsitelib | sed "s!$prefix!$installprefix!"` + installsitearch=`echo $installsitearch | sed "s!$prefix!$installprefix!"` Then, you can Configure and install in the usual way: @@ -291,7 +362,7 @@ The output is stored in F. The only difference between F and F is the dependencies at the bottom of F. If you have to make any changes, you should edit F, not F since the Unix B command reads -F. +F first. Configure will offer to do this step for you, so it isn't listed explicitly above. @@ -401,7 +472,7 @@ ignore any messages about chown not working. If you want to see exactly what will happen without installing anything, you can run - + ./perl installperl -n ./perl installman -n @@ -432,6 +503,13 @@ B will install the following: man pages under /usr/local/lib/perl5/man/man3. pod/*.pod in $privlib/pod/. +Installperl will also create the library directories $siteperl and +$sitearch listed in config.sh. Usually, these are something like + /usr/local/lib/site_perl/ + /usr/local/lib/site_perl/$archname +where $archname is something like sun4-sunos. These directories +will be used for installing extensions. + Perl's *.h header files and the libperl.a library are also installed under $archlib so that any user may later build new extensions even if the Perl source is no longer available. @@ -454,6 +532,32 @@ to generate the html versions, and to generate the LaTeX versions. +=head1 Coexistence with earlier versions of perl5. + +You can safely install the current version of perl5 and still run +scripts under the old binaries. Instead of starting your script with +#!/usr/local/bin/perl, just start it with #!/usr/local/bin/perl5.001 +(or whatever version you want to run.) + +The architecture-dependent files are stored in a version-specific +directory (such as F) so that +they are still accessible. I perl5.000 and perl5.001 did not +put their architecture-dependent libraries in a version-specific +directory. They are simply in F. If +you will not be using 5.000 or 5.001, you may safely remove those +files. + +The standard library files in F +should be useable by all versions of perl5. + +Most extensions will not need to be recompiled to use with a newer +version of perl. If you do run into problems, and you want to continue +to use the old version of perl along with your extension, simply move +those extension files to the appropriate version directory, such as +F. Then perl5.002 will find your +files in the 5.002 directory, and newer versions of perl will find your +newer extension in the site_perl directory. + =head1 Coexistence with perl4 You can safely install perl5 even if you want to keep perl4 around. diff --git a/INTERN.h b/INTERN.h index 7a9d475fa3..d89d2e68a4 100644 --- a/INTERN.h +++ b/INTERN.h @@ -7,8 +7,21 @@ * */ +/* + * EXT designates a global var which is defined in perl.h + * dEXT designates a global var which is defined in another + * file, so we can't count on finding it in perl.h + * (this practice should be avoided). + */ #undef EXT -#define EXT +#undef dEXT +#if defined(VMS) && !defined(__GNUC__) +# define EXT globaldef {"$GLOBAL_RW_VARS"} noshare +# define dEXT globaldef {"$GLOBAL_RW_VARS"} noshare +#else +# define EXT +# define dEXT +#endif #undef INIT #define INIT(x) = x diff --git a/MANIFEST b/MANIFEST index 690f9f1521..ca4e99c699 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4,7 +4,6 @@ Changes.Conf Recent changes in the Configure & build process configure Crude emulation of GNU configure Configure Portability tool Copying The GNU General Public License -Doc/perl5-notes Samples of new functionality EXTERN.h Included before foreign .h files INSTALL Detailed installation instructions. INTERN.h Included before domestic .h files @@ -16,7 +15,7 @@ Todo The Wishlist XSUB.h Include file for extension subroutines av.c Array value code av.h Array value header -c2ph.SH program to translate dbx stabs to perl +c2ph.PL program to translate dbx stabs to perl c2ph.doc documentation for c2ph cflags.SH A script that emits C compilation flags per file config_H Sample config.h @@ -73,12 +72,7 @@ eg/van/vanexp A program to expire vanished files eg/van/vanish A program to put files in a trashcan eg/who A sample who program eg/wrapsuid A setuid script wrapper generator -emacs/cperl-mode An alternate perl-mode -emacs/emacs19 Notes about emacs 19 -emacs/perl-mode.el Emacs major mode for perl -emacs/perldb.el Emacs debugging -emacs/perldb.pl Emacs debugging -emacs/tedstuff Some optional patches +emacs/cperl-mode.el An alternate perl-mode embed.h Maps symbols to safer names embed.pl Produces embed.h ext/DB_File/DB_File.pm Berkeley DB extension Perl module @@ -86,12 +80,6 @@ ext/DB_File/DB_File.xs Berkeley DB extension external subroutines ext/DB_File/DB_File_BS Berkeley DB extension mkbootstrap fodder ext/DB_File/Makefile.PL Berkeley DB extension makefile writer ext/DB_File/typemap Berkeley DB extension interface types -ext/Devel/DProf/DProf.pm Perl Profiler extension Perl module -ext/Devel/DProf/DProf.xs Perl Profiler extension external subroutines -ext/Devel/DProf/Makefile.PL Perl Profiler extension makefile writer -ext/Devel/DProf/README Perl Profiler extension info -ext/Devel/DProf/dprofpp Perl Profiler extension utility -ext/Devel/DProf/test.pl Perl Profiler extension test ext/DynaLoader/DynaLoader.pm Dynamic Loader perl module ext/DynaLoader/Makefile.PL Dynamic Loader makefile writer ext/DynaLoader/README Dynamic Loader notes and intro @@ -101,6 +89,7 @@ ext/DynaLoader/dl_dlopen.xs BSD/SunOS4&5 dlopen() style implementation ext/DynaLoader/dl_hpux.xs HP-UX implementation ext/DynaLoader/dl_next.xs Next implementation ext/DynaLoader/dl_none.xs Stub implementation +ext/DynaLoader/dl_os2.xs OS/2 implementation ext/DynaLoader/dl_vms.xs VMS implementation ext/DynaLoader/dlutils.c Dynamic loader utilities for dl_*.xs files ext/Fcntl/Fcntl.pm Fcntl extension Perl module @@ -167,7 +156,7 @@ global.sym Symbols that need hiding when embedded globals.c File to declare global symbols (for shared library) gv.c Glob value code gv.h Glob value header -h2ph.SH A thing to turn C .h files into perl .ph files +h2ph.PL A thing to turn C .h files into perl .ph files h2pl/README How to turn .ph files into .pl files h2pl/cbreak.pl cbreak routines using .ph h2pl/cbreak2.pl cbreak routines using .pl @@ -180,7 +169,7 @@ h2pl/mksizes Program to make %sizeof array h2pl/mkvars Program to make .pl from .ph files h2pl/tcbreak cbreak test routine using .ph h2pl/tcbreak2 cbreak test routine using .pl -h2xs.SH Program to make .xs files from C header files +h2xs.PL Program to make .xs files from C header files handy.h Handy definitions hints/3b1.sh Hints for named architecture hints/3b1cc Hints for named architecture @@ -207,6 +196,7 @@ hints/i386.sh Hints for named architecture hints/irix_4.sh Hints for named architecture hints/irix_5.sh Hints for named architecture hints/irix_6.sh Hints for named architecture +hints/irix_6_2.sh Hints for named architecture hints/isc.sh Hints for named architecture hints/isc_2.sh Hints for named architecture hints/linux.sh Hints for named architecture @@ -219,13 +209,14 @@ hints/netbsd.sh Hints for named architecture hints/next_3.sh Hints for named architecture hints/next_3_0.sh Hints for named architecture hints/opus.sh Hints for named architecture +hints/os2.sh Hints for named architecture hints/powerunix.sh Hints for named architecture +hints/sco.sh Hints for named architecture hints/sco_2_3_0.sh Hints for named architecture hints/sco_2_3_1.sh Hints for named architecture hints/sco_2_3_2.sh Hints for named architecture hints/sco_2_3_3.sh Hints for named architecture hints/sco_2_3_4.sh Hints for named architecture -hints/sco_3.sh Hints for named architecture hints/solaris_2.sh Hints for named architecture hints/stellar.sh Hints for named architecture hints/sunos_4_0.sh Hints for named architecture @@ -243,7 +234,6 @@ hv.h Hash value header installman Perl script to install man pages for pods. installperl Perl script to do "make install" dirty work interp.sym Interpreter specific symbols to hide in a struct -ioctl.pl Sample ioctl.pl keywords.h The keyword numbers keywords.pl Program to write keywords.h lib/AnyDBM_File.pm Perl module to emulate dbmopen @@ -287,6 +277,7 @@ lib/Text/Abbrev.pm An abbreviation table builder lib/Text/ParseWords.pm Perl module to split words on arbitrary delimiter lib/Text/Soundex.pm Perl module to implement Soundex lib/Text/Tabs.pm Do expand and unexpand +lib/Text/Wrap.pm Paragraph formatter lib/TieHash.pm Base class for tied hashes lib/Time/Local.pm Reverse translation of localtime, gmtime lib/abbrev.pl An abbreviation table builder @@ -299,6 +290,7 @@ lib/chat2.inter A chat2 with interaction lib/chat2.pl Randal's famous expect-ish routines lib/complete.pl A command completion subroutine lib/ctime.pl A ctime workalike +lib/diagnostics.pm Print verbose diagnostics lib/dotsh.pl Code to "dot" in a shell script lib/dumpvar.pl A variable dumper lib/exceptions.pl catch and throw routines @@ -319,10 +311,12 @@ lib/look.pl A "look" equivalent lib/newgetopt.pl A perl library supporting long option parsing lib/open2.pl Open a two-ended pipe lib/open3.pl Open a three-ended pipe +lib/overload.pm Module for overloading perl operators. lib/perl5db.pl Perl debugging routines lib/pwd.pl Routines to keep track of PWD environment variable lib/shellwords.pl Perl library to split into words with shell quoting lib/sigtrap.pm For trapping an abort and giving traceback +lib/splain Standalone program to print verbose diagnostics. lib/stat.pl Perl library supporting stat function lib/strict.pm For "use strict" lib/subs.pm Declare overriding subs @@ -345,11 +339,21 @@ op.c Opcode syntax tree code op.h Opcode syntax tree header opcode.h Automatically generated opcode header opcode.pl Opcode header generatore +os2/Makefile.SH Shared library generation for OS/2 +os2/POSIX.mkfifo POSIX.xs patch. +os2/README OS/2 info. +os2/diff.Makefile Patches to Makefile.SH +os2/diff.configure Patches to Makefile.SH +os2/diff.installperl Patches to installperl +os2/diff.mkdep Patches to makedepend.SH +os2/diff.x2pMakefile Patches to x2p/Makefile.SH +os2/os2.c Missing code for OS/2 +os2/os2ish.h Header for OS/2 patchlevel.h The current patch level of perl perl.c main() perl.h Global declarations perl_exp.SH Creates list of exported symbols for AIX. -perldoc.SH A simple tool to find & display perl's documentation +perldoc.PL A simple tool to find & display perl's documentation perlsh A poor man's perl shell perly.c A byacc'ed perly.y perly.c.diff Fixup perly.c to allow recursion @@ -365,11 +369,13 @@ pod/perlcall.pod Callback info pod/perldata.pod Data structure info pod/perldebug.pod Debugger info pod/perldiag.pod Diagnostic info +pod/perldsc.pod Data Structures Cookbook pod/perlembed.pod Embedding info pod/perlform.pod Format info pod/perlfunc.pod Function info pod/perlguts.pod Internals info pod/perlipc.pod IPC info +pod/perllol.pod How to use lists of lists. pod/perlmod.pod Module info pod/perlobj.pod Object info pod/perlop.pod Operator info @@ -385,9 +391,10 @@ pod/perlsyn.pod Syntax info pod/perltrap.pod Trap info pod/perlvar.pod Variable info pod/perlxs.pod XS api info -pod/pod2html.SH Precursor for translator to turn pod into HTML -pod/pod2latex.SH Precursor for translator to turn pod into LaTeX -pod/pod2man.SH Precursor for translator to turn pod into manpage +pod/perlxstut.pod XS tutorial +pod/pod2html.PL Precursor for translator to turn pod into HTML +pod/pod2latex.PL Precursor for translator to turn pod into LaTeX +pod/pod2man.PL Precursor for translator to turn pod into manpage pod/splitman Splits perlfunc into multiple man pages pp.c Push/Pop code pp.h Push/Pop code defs @@ -444,7 +451,6 @@ t/lib/ndbm.t See if NDBM_File works t/lib/odbm.t See if ODBM_File works t/lib/posix.t See if POSIX works t/lib/sdbm.t See if SDBM_File works -t/lib/socket.t See if Socket works t/lib/soundex.t See if Soundex works t/op/append.t See if . works t/op/array.t See if array operations work @@ -506,25 +512,27 @@ unixish.h Defines that are assumed on Unix util.c Utility routines util.h Public declarations for the above vms/Makefile VMS port -vms/config.vms VMS port -vms/descrip.mms VMS port +vms/config.vms default config.h for VMS +vms/descrip.mms MM[SK] description file for build vms/ext/Filespec.pm VMS-Unix file syntax interconversion vms/ext/MM_VMS.pm VMS-specific methods for MakeMaker vms/ext/VMS/stdio/Makefile.PL MakeMaker driver for VMS::stdio vms/ext/VMS/stdio/stdio.pm VMS options to stdio routines vms/ext/VMS/stdio/stdio.xs VMS options to stdio routines -vms/gen_shrfls.pl VMS port -vms/genconfig.pl VMS port -vms/genopt.com VMS port -vms/mms2make.pl VMS port -vms/perlshr.c VMS port -vms/perlvms.pod VMS port -vms/sockadapt.c VMS port -vms/sockadapt.h VMS port -vms/test.com VMS port -vms/vms.c VMS port -vms/vmsish.h VMS port -vms/writemain.pl VMS port +vms/gen_shrfls.pl generate options files and glue for shareable image +vms/genconfig.pl retcon config.sh from config.h +vms/genopt.com hack to write options files in case of broken makes +vms/mms2make.pl convert descrip.mms to make syntax +vms/perlvms.pod VMS-specific additions to Perl documentation +vms/perly_c.vms perly.c with fixed declarations for global syms +vms/perly_h.vms perly.h with fixed declarations for global syms +vms/sockadapt.c glue for SockshShr socket support +vms/sockadapt.h glue for SockshShr socket support +vms/test.com DCL driver for regression tests +vms/vms.c VMS-specific C code for Perl core +vms/vms_yfix.pl convert Unix perly.[ch] to VMS perly_[ch].vms +vms/vmsish.h VMS-specific C header for Perl core +vms/writemain.pl Generate perlmain.c from miniperlmain.c+extensions writemain.SH Generate perlmain.c from miniperlmain.c+extensions x2p/EXTERN.h Same as above x2p/INTERN.h Same as above @@ -535,11 +543,11 @@ x2p/a2p.man Manual page for awk to perl translator x2p/a2p.y A yacc grammer for awk x2p/a2py.c Awk compiler, sort of x2p/cflags.SH A script that emits C compilation flags per file -x2p/find2perl.SH A find to perl translator +x2p/find2perl.PL A find to perl translator x2p/handy.h Handy definitions x2p/hash.c Associative arrays again x2p/hash.h Public declarations for the above -x2p/s2p.SH Sed to perl translator +x2p/s2p.PL Sed to perl translator x2p/s2p.man Manual page for sed to perl translator x2p/str.c String handling package x2p/str.h Public declarations for the above diff --git a/Makefile.SH b/Makefile.SH index 1f1b11b613..b3ac78be5a 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -126,6 +126,20 @@ shellflags = $shellflags ## To use an alternate make, set \$altmake in config.sh. MAKE = ${altmake-make} + +# These variables will be used in a future version to make +# the make file more portable to non-unix systems. +AR = $ar +EXE_EXT = $exe_ext +LIB_EXT = $lib_ext +OBJ_EXT = $obj_ext +PATH_SEP = $path_sep + +FIRSTMAKEFILE = $firstmakefile + +# Any special object files needed by this architecture, e.g. os2/os2.obj +ARCHOBJS = $archobjs + !GROK!THIS! ## In the following dollars and backticks do not need the extra backslash. @@ -135,11 +149,24 @@ CCCMD = `sh $(shellflags) cflags $(perllib) $@` private = preplibrary lib/ExtUtils/Miniperl.pm lib/Config.pm -sh = Makefile.SH c2ph.SH cflags.SH config_h.SH h2ph.SH h2xs.SH makeaperl.SH \ - makedepend.SH makedir.SH perl_exp.SH perldoc.SH writemain.SH +# Files to be built with variable substitution before miniperl +# is available. +sh = Makefile.SH cflags.SH config_h.SH makeaperl.SH makedepend.SH \ + makedir.SH perl_exp.SH writemain.SH + +shextract = Makefile cflags config.h makeaperl makedepend \ + makedir perl_exp writemain + +# Files to be built with variable substitution after miniperl is +# available. Dependencies handled manually below (for now). -addedbyconf = UU Makefile c2ph cflags config.h h2ph h2xs makeaperl \ - makedepend makedir perl_exp perldoc writemain +pl = c2ph.PL h2ph.PL h2xs.PL perldoc.PL \ + pod/pod2html.PL pod/pod2latex.PL pod/pod2man.PL + +plextract = c2ph h2ph h2xs perldoc \ + pod/pod2html pod/pod2latex pod/pod2man + +addedbyconf = UU $(shextract) $(plextract) pstruct h1 = EXTERN.h INTERN.h XSUB.h av.h config.h cop.h cv.h dosish.h h2 = embed.h form.h gv.h handy.h hv.h keywords.h mg.h op.h @@ -157,7 +184,8 @@ obj1 = $(mallocobj) gv.o toke.o perly.o op.o regcomp.o dump.o util.o mg.o obj2 = hv.o av.o run.o pp_hot.o sv.o pp.o scope.o pp_ctl.o pp_sys.o obj3 = doop.o doio.o regexec.o taint.o deb.o globals.o -obj = $(obj1) $(obj2) $(obj3) + +obj = $(obj1) $(obj2) $(obj3) $(ARCHOBJS) # Once perl has been Configure'd and built ok you build different # perl variants (Debugging, Embedded, Multiplicity etc) by saying: @@ -178,7 +206,7 @@ SHELL = /bin/sh .c.o: $(CCCMD) $(PLDLFLAGS) $*.c -all: makefile miniperl $(private) $(public) $(dynamic_ext) +all: makefile miniperl $(private) $(plextract) $(public) $(dynamic_ext) @echo " "; echo " Making x2p stuff"; cd x2p; $(MAKE) all # This is now done by installman only if you actually want the man pages. @@ -187,7 +215,7 @@ all: makefile miniperl $(private) $(public) $(dynamic_ext) # Phony target to force checking subdirectories. # Apparently some makes require an action for the FORCE target. FORCE: - @true + @sh -c true # The $& notation tells Sequent machines that it can do a parallel make, # and is harmless otherwise. @@ -232,7 +260,7 @@ $spitshell >>Makefile <<'!NO!SUBS!' *) $spitshell >>Makefile <<'!NO!SUBS!' rm -f $(perllib) - ar rcu $(perllib) perl.o $(obj) + $(AR) rcu $(perllib) perl.o $(obj) @$(ranlib) $(perllib) !NO!SUBS! ;; @@ -257,7 +285,7 @@ sperl.o: perl.c perly.h patchlevel.h $(h) # We have to call our ./makedir because Ultrix 4.3 make can't handle the line # test -d lib/auto || mkdir lib/auto # -preplibrary: miniperl lib/Config.pm +preplibrary: miniperl lib/Config.pm $(plextract) @./makedir lib/auto @echo " AutoSplitting perl library" @./miniperl -Ilib -e 'use AutoSplit; \ @@ -271,6 +299,9 @@ lib/Config.pm: config.sh miniperl lib/ExtUtils/Miniperl.pm: miniperlmain.c miniperl minimod.PL lib/Config.pm ./miniperl minimod.PL > tmp && mv tmp $@ +$(plextract): miniperl lib/Config.pm + ./miniperl -Ilib $@.PL + install: all install.perl install.man install.perl: all @@ -291,11 +322,12 @@ install.man: all # normally shouldn't remake perly.[ch]. run_byacc: FORCE - @ echo 'Expect' 109 shift/reduce and 1 reduce/reduce conflict + @ echo 'Expect' 129 shift/reduce and 1 reduce/reduce conflict $(BYACC) -d perly.y sh $(shellflags) ./perly.fixer y.tab.c perly.c mv y.tab.h perly.h echo 'extern YYSTYPE yylval;' >>perly.h + - perl vms/vms_yfix.pl perly.c perly.h vms/perly_c.vms vms/perly_h.vms # We don't want to regenerate perly.c and perly.h, but they might # appear out-of-date after a patch is applied or a new distribution is @@ -351,6 +383,7 @@ clean: realclean: clean -cd x2p; $(MAKE) realclean -cd pod; $(MAKE) realclean + -cd os2; rm -f Makefile -@for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) ; do \ sh ext/util/make_ext realclean $$x ; \ done @@ -407,6 +440,9 @@ hlist: $(h) shlist: $(sh) echo $(sh) | tr ' ' '\012' >.shlist +pllist: $(pl) + echo $(pl) | tr ' ' '\012' >.pllist + # AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE # If this runs make out of memory, delete /usr/include lines. !NO!SUBS! diff --git a/README.vms b/README.vms index e68d32d35c..c0da401af1 100644 --- a/README.vms +++ b/README.vms @@ -1,4 +1,4 @@ -Last revised: 08-Feb-1995 by Charles Bailey bailey@genetics.upenn.edu +Last revised: 12-Jun-1995 by Charles Bailey bailey@genetics.upenn.edu The VMS port of Perl is still under development. At this time, the Perl binaries built under VMS handle internal operations properly, for the most @@ -20,12 +20,15 @@ which affect Perl performance: - Newlines are lost on I/O through pipes, causing lines to run together. This shows up as RMS RTB errors when reading from a pipe. You can work around this by having one process write data to a file, and - then having the other read the file, instead of the pipe. + then having the other read the file, instead of the pipe. This is + fixed in version 4 of DECC. - The modf() routine returns a non-integral value for some values above INT_MAX; the Perl "int" operator will return a non-integral value in - these cases. -Both of these bugs have been fixed in later releases of the DECCRTL, but some -systems running AXP/VMS 1.5 still have the old RTLs. + these cases. This is fixed in version 4 of DECC. + - On the AXP, if SYSNAM privilege is enabled, the CRTL chdir() routine + changes the process default device and directory permanently, even + though the call specified that the change should not persist after + Perl exited. This is fixed by DEC CSC patch AXPACRT04_061. * Other software required @@ -50,27 +53,33 @@ SOCKET when invoking MMS, however, socket support will be included. As distributed, Perl for VMS includes support for the SOCKETSHR socket library, which is layered on MadGoat software's vendor-independent NETLIB interface. This provides support for all socket calls used by Perl except the -[g|s]et*ent() routines, which are replaced for the moment by stubs which +[g|s]etnet*() routines, which are replaced for the moment by stubs which generate a fatal error if a Perl script attempts to call one of these routines. -If you'd like to link Perl directly to your IP stack to take advantage of these -routines or to eliminate the intermediate NETLIB, then make the following -changes: +You can link Perl directly to your TCP/IP stack's library, *as long as* it +supplies shims for stdio routines which will properly handle both sockets and +normal file descriptors. This is necessary because Perl does not distinguish +between the two, and will try to make normal stdio calls such as read() and +getc() on socket file descriptors. If you'd like to link Perl directly to +your IP stack, then make the following changes: - In Descrip.MMS, locate the section beginning with .ifdef SOCKET, and change the SOCKLIB macro so that it translates to the filespec of your IP stack's socket library. This will be added to the RTL options file. - Edit the file SockAdapt.H in the [.VMS] subdirectory so that it - includes the In.H, NetDb.H, and, if necessary, Errno.H header files - for your IP stack, or so that it declares the standard TCP/IP data - structures appropriately (see the distributed copy of SockAdapt.H - for a collection of the structures needed by Perl.) You should also - define any logical names necessary to find these files before invoking - MMS to build Perl. + includes the Socket.h, In.H, Inet.H, NetDb.H, and, if necessary, + Errno.H header files for your IP stack, or so that it declares the + standard TCP/IP constants and data structures appropriately. (See + the distributed copy of SockAdapt.H for a collection of the structures + needed by Perl itself, and [.ext.Socket]Socket.xs for a list of the + constants used by the Socket extension, if you elect to built it.) + You should also define any logical names necessary for your C compiler + to find these files before invoking MM[KS] to build Perl. - Edit the file SockAdapt.C in the [.VMS] subdirectory so that it contains routines which substitute for any IP library routines required by Perl which your IP stack does not provide. This may require a little trial and error; we'll try to compile a complete list soon of socket routines required by Perl. + * Building Perl under VMS Since you're reading this, presumably you've unpacked the Perl distribution @@ -189,8 +198,9 @@ Once the build is complete, you'll need to do the following: - Define the logical name PERLSHR as the full file specification of PERLSHR.EXE, so executable images linked to it can find it. Alternatively, you can justput PERLSHR.EXE int SYS$SHARE. - - Place the files from the [.lib] subdirectory in the distribution package - into a [.lib] subdirectory off the root directory described above. + - Place the files from the [.lib...] directory tree in the distribution + package into a [.lib...] directory tree off the root directory described + above. - Most of the Perl documentation lives in the [.pod] subdirectory, and is written in a simple markup format which can be easily read. In this directory as well are pod2man and pod2html translators to reformat the @@ -214,13 +224,24 @@ the single line subscribe perl5-porters This is a moderately high-volume list at the moment (25-50 messages/day). -Finally, if you're interested in ongoing information about the VMS port, you -can subscribe to the VMSperl mailing list by sending a request to +If you're interested in ongoing information about the VMS port, you can +subscribe to the VMSperl mailing list by sending a request to bailey@genetics.upenn.edu (it's to a human, not a list server - this is a small operation at the moment). And, as always, we welcome any help or code you'd like to offer - you can send mail to bailey@genetics.upenn.edu or directly to the VMSperl list at vmsperl@genetics.upenn.edu. +Finally, if you'd like to try out the latest changes to VMS Perl, you can +retrieve a test distribution kit by anonymous ftp from genetics.upenn.edu, in +the file [.perl5]perl5_ppp_yymmddx.zip, where "ppp" is the current Perl +patchlevel, and "yymmddx" is a sequence number indicating the date that +particular kit was assembled. These test kits contain "unofficial" patches +from the perl5-porters group, test patches for important bugs, and VMS-specific +fixes and improvements which have occurred since the last Perl release. Most +of these changes will be incorporated in the next release of Perl, but until +Larry Wall's looked at them and said they're OK, none of them should be +considered official. + Good luck using Perl. Please let us know how it works for you - we can't guarantee that we'll be able to fix bugs quickly, but we'll try, and we'd certainly like to know they're out there. diff --git a/Todo b/Todo index 595725a098..114a488691 100644 --- a/Todo +++ b/Todo @@ -34,7 +34,7 @@ Possible pragmas Optimizations constant function cache switch structures - foreach(@array) + eval qw() at compile time foreach (1..1000000) foreach(reverse...) Set KEEP on constant split @@ -51,7 +51,6 @@ Optimizations Vague possibilities ref function in list context Populate %SIG at startup if appropriate - sub mysplice(@, $, $, ...) data prettyprint function? (or is it, as I suspect, a lib routine?) make tr/// return histogram in list context? undef wantarray in void context diff --git a/XSUB.h b/XSUB.h index a8c2c26ff7..4792d22c21 100644 --- a/XSUB.h +++ b/XSUB.h @@ -1,4 +1,4 @@ -#define ST(off) stack_base[ax + off] +#define ST(off) stack_base[ax + (off)] #ifdef CAN_PROTOTYPE #define XS(name) void name(CV* cv) @@ -19,16 +19,17 @@ /* Simple macros to put new mortal values onto the stack. */ /* Typically used to return values from XS functions. */ -#define XST_mIV(i,v) ST(i)=sv_2mortal(newSViv(v)); -#define XST_mNV(i,v) ST(i)=sv_2mortal(newSVnv(v)); -#define XST_mPV(i,v) ST(i)=sv_2mortal(newSVpv(v,0)); -#define XST_mNO(i) ST(i)=sv_mortalcopy(&sv_no); -#define XST_mYES(i) ST(i)=sv_mortalcopy(&sv_yes); -#define XST_mUNDEF(i) ST(i)=sv_newmortal(); +#define XST_mIV(i,v) (ST(i) = sv_2mortal(newSViv(v)) ) +#define XST_mNV(i,v) (ST(i) = sv_2mortal(newSVnv(v)) ) +#define XST_mPV(i,v) (ST(i) = sv_2mortal(newSVpv(v,0))) +#define XST_mNO(i) (ST(i) = &sv_no ) +#define XST_mYES(i) (ST(i) = &sv_yes ) +#define XST_mUNDEF(i) (ST(i) = &sv_undef) -#define XSRETURN_IV(v) XST_mIV(0,v); XSRETURN(1) -#define XSRETURN_NV(v) XST_mNV(0,v); XSRETURN(1) -#define XSRETURN_PV(v) XST_mPV(0,v); XSRETURN(1) -#define XSRETURN_NO XST_mNO(0); XSRETURN(1) -#define XSRETURN_YES XST_mYES(0); XSRETURN(1) -#define XSRETURN_UNDEF XST_mUNDEF(0); XSRETURN(1) +#define XSRETURN_IV(v) do { XST_mIV(0,v); XSRETURN(1); } while (0) +#define XSRETURN_NV(v) do { XST_mNV(0,v); XSRETURN(1); } while (0) +#define XSRETURN_PV(v) do { XST_mPV(0,v); XSRETURN(1); } while (0) +#define XSRETURN_NO do { XST_mNO(0); XSRETURN(1); } while (0) +#define XSRETURN_YES do { XST_mYES(0); XSRETURN(1); } while (0) +#define XSRETURN_UNDEF do { XST_mUNDEF(0); XSRETURN(1); } while (0) +#define XSRETURN_EMPTY do { XSRETURN(0); } while (0) diff --git a/av.c b/av.c index 7116cc4482..0e20af89a5 100644 --- a/av.c +++ b/av.c @@ -64,9 +64,30 @@ I32 key; } else { if (AvALLOC(av)) { + U32 bytes; + newmax = key + AvMAX(av) / 5; resize: +#ifdef STRANGE_MALLOC Renew(AvALLOC(av),newmax+1, SV*); +#else + bytes = (newmax + 1) * sizeof(SV*); +#define MALLOC_OVERHEAD 16 + tmp = MALLOC_OVERHEAD; + while (tmp - MALLOC_OVERHEAD < bytes) + tmp += tmp; + tmp -= MALLOC_OVERHEAD; + tmp /= sizeof(SV*); + assert(tmp > newmax); + newmax = tmp - 1; + New(2,ary, newmax+1, SV*); + Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*); + if (AvMAX(av) > 64 && !AvREUSED(av)) + sv_add_arena((char*)AvALLOC(av), AvMAX(av) * sizeof(SV*),0); + else + Safefree(AvALLOC(av)); + AvALLOC(av) = ary; +#endif ary = AvALLOC(av) + AvMAX(av) + 1; tmp = newmax - AvMAX(av); if (av == stack) { /* Oops, grew stack (via av_store()?) */ @@ -305,6 +326,7 @@ register AV *av; AvALLOC(av) = 0; SvPVX(av) = 0; AvMAX(av) = AvFILL(av) = -1; + AvREUSED_on(av); /* Avoid leak of making SVs out of old memory again. */ if (AvARYLEN(av)) { SvREFCNT_dec(AvARYLEN(av)); AvARYLEN(av) = 0; diff --git a/av.h b/av.h index 082a8abd36..93dcc0cfdc 100644 --- a/av.h +++ b/av.h @@ -23,6 +23,7 @@ struct xpvav { #define AVf_REAL 1 /* free old entries */ #define AVf_REIFY 2 /* can become real */ +#define AVf_REUSED 4 /* got undeffed--don't turn old memory into SVs now */ #define Nullav Null(AV*) @@ -39,6 +40,9 @@ struct xpvav { #define AvREIFY(av) (AvFLAGS(av) & AVf_REIFY) #define AvREIFY_on(av) (AvFLAGS(av) |= AVf_REIFY) #define AvREIFY_off(av) (AvFLAGS(av) &= ~AVf_REIFY) +#define AvREUSED(av) (AvFLAGS(av) & AVf_REUSED) +#define AvREUSED_on(av) (AvFLAGS(av) |= AVf_REUSED) +#define AvREUSED_off(av) (AvFLAGS(av) &= ~AVf_REUSED) #define AvREALISH(av) AvFLAGS(av) /* REAL or REIFY -- shortcut */ diff --git a/c2ph.PL b/c2ph.PL new file mode 100644 index 0000000000..b5049b3d11 --- /dev/null +++ b/c2ph.PL @@ -0,0 +1,1184 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir(dirname($0)); +($file = basename($0)) =~ s/\.PL$//; +$file =~ s/\.pl$// + if ($Config{'osname'} eq 'VMS' or + $Config{'osname'} eq 'OS2'); # "case-forgiving" + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{'startperl'} + eval 'exec perl -S \$0 "\$@"' + if 0; +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; +# +# +# c2ph (aka pstruct) +# Tom Christiansen, +# +# As pstruct, dump C structures as generated from 'cc -g -S' stabs. +# As c2ph, do this PLUS generate perl code for getting at the structures. +# +# See the usage message for more. If this isn't enough, read the code. +# + +$RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $'; + + +###################################################################### + +# some handy data definitions. many of these can be reset later. + +$bitorder = 'b'; # ascending; set to B for descending bit fields + +%intrinsics = +%template = ( + 'char', 'c', + 'unsigned char', 'C', + 'short', 's', + 'short int', 's', + 'unsigned short', 'S', + 'unsigned short int', 'S', + 'short unsigned int', 'S', + 'int', 'i', + 'unsigned int', 'I', + 'long', 'l', + 'long int', 'l', + 'unsigned long', 'L', + 'unsigned long', 'L', + 'long unsigned int', 'L', + 'unsigned long int', 'L', + 'long long', 'q', + 'long long int', 'q', + 'unsigned long long', 'Q', + 'unsigned long long int', 'Q', + 'float', 'f', + 'double', 'd', + 'pointer', 'p', + 'null', 'x', + 'neganull', 'X', + 'bit', $bitorder, +); + +&buildscrunchlist; +delete $intrinsics{'neganull'}; +delete $intrinsics{'bit'}; +delete $intrinsics{'null'}; + +# use -s to recompute sizes +%sizeof = ( + 'char', '1', + 'unsigned char', '1', + 'short', '2', + 'short int', '2', + 'unsigned short', '2', + 'unsigned short int', '2', + 'short unsigned int', '2', + 'int', '4', + 'unsigned int', '4', + 'long', '4', + 'long int', '4', + 'unsigned long', '4', + 'unsigned long int', '4', + 'long unsigned int', '4', + 'long long', '8', + 'long long int', '8', + 'unsigned long long', '8', + 'unsigned long long int', '8', + 'float', '4', + 'double', '8', + 'pointer', '4', +); + +($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5); + +($offset_fmt, $size_fmt) = ('d', 'd'); + +$indent = 2; + +$CC = 'cc'; +$CFLAGS = '-g -S'; +$DEFINES = ''; + +$perl++ if $0 =~ m#/?c2ph$#; + +require 'getopts.pl'; + +eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift; + +&Getopts('aixdpvtnws:') || &usage(0); + +$opt_d && $debug++; +$opt_t && $trace++; +$opt_p && $perl++; +$opt_v && $verbose++; +$opt_n && ($perl = 0); + +if ($opt_w) { + ($type_width, $member_width, $offset_width) = (45, 35, 8); +} +if ($opt_x) { + ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 ); +} + +eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift; + +sub PLUMBER { + select(STDERR); + print "oops, apperent pager foulup\n"; + $isatty++; + &usage(1); +} + +sub usage { + local($oops) = @_; + unless (-t STDOUT) { + select(STDERR); + } elsif (!$oops) { + $isatty++; + $| = 1; + print "hit for further explanation: "; + ; + open (PIPE, "|". ($ENV{PAGER} || 'more')); + $SIG{PIPE} = PLUMBER; + select(PIPE); + } + + print "usage: $0 [-dpnP] [var=val] [files ...]\n"; + + exit unless $isatty; + + print < 1) { + warn "Only one *.s file allowed!\n"; + &usage; + } + } + elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) { + local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#; + $chdir = "cd $dir; " if $dir; + &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1; + $ARGV[0] =~ s/\.c$/.s/; + } + else { + $TMP = "/tmp/c2ph.$$.c"; + &system("cat @ARGV > $TMP") && exit 1; + &system("cd /tmp; $CC $CFLAGS $DEFINES $TMP") && exit 1; + unlink $TMP; + $TMP =~ s/\.c$/.s/; + @ARGV = ($TMP); + } +} + +if ($opt_s) { + for (split(/[\s,]+/, $opt_s)) { + $interested{$_}++; + } +} + + +$| = 1 if $debug; + +main: { + + if ($trace) { + if (-t && !@ARGV) { + print STDERR "reading from your keyboard: "; + } else { + print STDERR "reading from " . (@ARGV ? "@ARGV" : "").": "; + } + } + +STAB: while (<>) { + if ($trace && !($. % 10)) { + $lineno = $..''; + print STDERR $lineno, "\b" x length($lineno); + } + next unless /^\s*\.stabs\s+/; + $line = $_; + s/^\s*\.stabs\s+//; + if (s/\\\\"[d,]+$//) { + $saveline .= $line; + $savebar = $_; + next STAB; + } + if ($saveline) { + s/^"//; + $_ = $savebar . $_; + $line = $saveline; + } + &stab; + $savebar = $saveline = undef; + } + print STDERR "$.\n" if $trace; + unlink $TMP if $TMP; + + &compute_intrinsics if $perl && !$opt_i; + + print STDERR "resolving types\n" if $trace; + + &resolve_types; + &adjust_start_addrs; + + $sum = 2 + $type_width + $member_width; + $pmask1 = "%-${type_width}s %-${member_width}s"; + $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s"; + + + + if ($perl) { + # resolve template -- should be in stab define order, but even this isn't enough. + print STDERR "\nbuilding type templates: " if $trace; + for $i (reverse 0..$#type) { + next unless defined($name = $type[$i]); + next unless defined $struct{$name}; + ($iname = $name) =~ s/\..*//; + $build_recursed = 0; + &build_template($name) unless defined $template{&psou($name)} || + $opt_s && !$interested{$iname}; + } + print STDERR "\n\n" if $trace; + } + + print STDERR "dumping structs: " if $trace; + + local($iam); + + + + foreach $name (sort keys %struct) { + ($iname = $name) =~ s/\..*//; + next if $opt_s && !$interested{$iname}; + print STDERR "$name " if $trace; + + undef @sizeof; + undef @typedef; + undef @offsetof; + undef @indices; + undef @typeof; + undef @fieldnames; + + $mname = &munge($name); + + $fname = &psou($name); + + print "# " if $perl && $verbose; + $pcode = ''; + print "$fname {\n" if !$perl || $verbose; + $template{$fname} = &scrunch($template{$fname}) if $perl; + &pstruct($name,$name,0); + print "# " if $perl && $verbose; + print "}\n" if !$perl || $verbose; + print "\n" if $perl && $verbose; + + if ($perl) { + print "$pcode"; + + printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name}); + + print < $sizeof{$b}; } + + + foreach $name (sort keys %intrinsics) { + print '$',&munge($name),"'typedef = '", $template{$name}, "';\n"; + } + + print "\n1;\n" if $perl; + + exit; +} + +######################################################################################## + + +sub stab { + next unless $continued || /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun + s/"// || next; + s/",([x\d]+),([x\d]+),([x\d]+),.*// || next; + + next if /^\s*$/; + + $size = $3 if $3; + $_ = $continued . $_ if length($continued); + if (s/\\\\$//) { + # if last 2 chars of string are '\\' then stab is continued + # in next stab entry + chop; + $continued = $_; + next; + } + $continued = ''; + + + $line = $_; + + if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) { + print "$name is a typedef for some funky pointers: $pdecl\n" if $debug; + &pdecl($pdecl); + next; + } + + + + if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) { + local($ident) = $2; + push(@intrinsics, $ident); + $typeno = &typeno($3); + $type[$typeno] = $ident; + print STDERR "intrinsic $ident in new type $typeno\n" if $debug; + next; + } + + if (($name, $typeordef, $typeno, $extra, $struct, $_) + = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/) + { + $typeno = &typeno($typeno); # sun foolery + } + elsif (/^[\$\w]+:/) { + next; # variable + } + else { + warn "can't grok stab: <$_> in: $line " if $_; + next; + } + + #warn "got size $size for $name\n"; + $sizeof{$name} = $size if $size; + + s/;[-\d]*;[-\d]*;$//; # we don't care about ranges + + $typenos{$name} = $typeno; + + unless (defined $type[$typeno]) { + &panic("type 0??") unless $typeno; + $type[$typeno] = $name unless defined $type[$typeno]; + printf "new type $typeno is $name" if $debug; + if ($extra =~ /\*/ && defined $type[$struct]) { + print ", a typedef for a pointer to " , $type[$struct] if $debug; + } + } else { + printf "%s is type %d", $name, $typeno if $debug; + print ", a typedef for " , $type[$typeno] if $debug; + } + print "\n" if $debug; + #next unless $extra =~ /[su*]/; + + #$type[$struct] = $name; + + if ($extra =~ /[us*]/) { + &sou($name, $extra); + $_ = &sdecl($name, $_, 0); + } + elsif (/^=ar/) { + print "it's a bare array typedef -- that's pretty sick\n" if $debug; + $_ = "$typeno$_"; + $scripts = ''; + $_ = &adecl($_,1); + + } + elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc + push(@intrinsics, $2); + $typeno = &typeno($3); + $type[$typeno] = $2; + print STDERR "intrinsic $2 in new type $typeno\n" if $debug; + } + elsif (s/^=e//) { # blessed be thy compiler; mine won't do this + &edecl; + } + else { + warn "Funny remainder for $name on line $_ left in $line " if $_; + } +} + +sub typeno { # sun thinks types are (0,27) instead of just 27 + local($_) = @_; + s/\(\d+,(\d+)\)/$1/; + $_; +} + +sub pstruct { + local($what,$prefix,$base) = @_; + local($field, $fieldname, $typeno, $count, $offset, $entry); + local($fieldtype); + local($type, $tname); + local($mytype, $mycount, $entry2); + local($struct_count) = 0; + local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt); + local($bits,$bytes); + local($template); + + + local($mname) = &munge($name); + + sub munge { + local($_) = @_; + s/[\s\$\.]/_/g; + $_; + } + + local($sname) = &psou($what); + + $nesting++; + + for $field (split(/;/, $struct{$what})) { + $pad = $prepad = 0; + $entry = ''; + ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field); + + $type = $type[$typeno]; + + $type =~ /([^[]*)(\[.*\])?/; + $mytype = $1; + $count .= $2; + $fieldtype = &psou($mytype); + + local($fname) = &psou($name); + + if ($build_templates) { + + $pad = ($offset - ($lastoffset + $lastlength))/8 + if defined $lastoffset; + + if (! $finished_template{$sname}) { + if ($isaunion{$what}) { + $template{$sname} .= 'X' x $revpad . ' ' if $revpad; + } else { + $template{$sname} .= 'x' x $pad . ' ' if $pad; + } + } + + $template = &fetch_template($type); + &repeat_template($template,$count); + + if (! $finished_template{$sname}) { + $template{$sname} .= $template; + } + + $revpad = $length/8 if $isaunion{$what}; + + ($lastoffset, $lastlength) = ($offset, $length); + + } else { + print '# ' if $perl && $verbose; + $entry = sprintf($pmask1, + ' ' x ($nesting * $indent) . $fieldtype, + "$prefix.$fieldname" . $count); + + $entry =~ s/(\*+)( )/$2$1/; + + printf $pmask2, + $entry, + ($base+$offset)/8, + ($bits = ($base+$offset)%8) ? ".$bits" : " ", + $length/8, + ($bits = $length % 8) ? ".$bits": "" + if !$perl || $verbose; + + if ($perl) { + $template = &fetch_template($type); + &repeat_template($template,$count); + } + + if ($perl && $nesting == 1) { + + push(@sizeof, int($length/8) .",\t# $fieldname"); + push(@offsetof, int($offset/8) .",\t# $fieldname"); + local($little) = &scrunch($template); + push(@typedef, "'$little', \t# $fieldname"); + $type =~ s/(struct|union) //; + push(@typeof, "'$mytype" . ($count ? $count : '') . + "',\t# $fieldname"); + push(@fieldnames, "'$fieldname',"); + } + + print ' ', ' ' x $indent x $nesting, $template + if $perl && $verbose; + + print "\n" if !$perl || $verbose; + + } + if ($perl) { + local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1; + $mycount *= &scripts2count($count) if $count; + if ($nesting==1 && !$build_templates) { + $pcode .= sprintf("sub %-32s { %4d; }\n", + "${mname}'${fieldname}", $struct_count); + push(@indices, $struct_count); + } + $struct_count += $mycount; + } + + + &pstruct($type, "$prefix.$fieldname", $base+$offset) + if $recurse && defined $struct{$type}; + } + + $countof{$what} = $struct_count unless defined $countof{$whati}; + + $template{$sname} .= '$' if $build_templates; + $finished_template{$sname}++; + + if ($build_templates && !defined $sizeof{$name}) { + local($fmt) = &scrunch($template{$sname}); + print STDERR "no size for $name, punting with $fmt..." if $debug; + eval '$sizeof{$name} = length(pack($fmt, ()))'; + if ($@) { + chop $@; + warn "couldn't get size for \$name: $@"; + } else { + print STDERR $sizeof{$name}, "\n" if $debUg; + } + } + + --$nesting; +} + + +sub psize { + local($me) = @_; + local($amstruct) = $struct{$me} ? 'struct ' : ''; + + print '$sizeof{\'', $amstruct, $me, '\'} = '; + printf "%d;\n", $sizeof{$me}; +} + +sub pdecl { + local($pdecl) = @_; + local(@pdecls); + local($tname); + + warn "pdecl: $pdecl\n" if $debug; + + $pdecl =~ s/\(\d+,(\d+)\)/$1/g; + $pdecl =~ s/\*//g; + @pdecls = split(/=/, $pdecl); + $typeno = $pdecls[0]; + $tname = pop @pdecls; + + if ($tname =~ s/^f//) { $tname = "$tname&"; } + #else { $tname = "$tname*"; } + + for (reverse @pdecls) { + $tname .= s/^f// ? "&" : "*"; + #$tname =~ s/^f(.*)/$1&/; + print "type[$_] is $tname\n" if $debug; + $type[$_] = $tname unless defined $type[$_]; + } +} + + + +sub adecl { + ($arraytype, $unknown, $lower, $upper) = (); + #local($typeno); + # global $typeno, @type + local($_, $typedef) = @_; + + while (s/^((\d+|\(\d+,\d+\))=)?ar(\d+|\(\d+,\d+\));//) { + ($arraytype, $unknown) = ($2, $3); + $arraytype = &typeno($arraytype); + $unknown = &typeno($unknown); + if (s/^(\d+);(\d+);//) { + ($lower, $upper) = ($1, $2); + $scripts .= '[' . ($upper+1) . ']'; + } else { + warn "can't find array bounds: $_"; + } + } + if (s/^([(,)\d*f=]*),(\d+),(\d+);//) { + ($start, $length) = ($2, $3); + $whatis = $1; + if ($whatis =~ /^(\d+|\(\d+,\d+\))=/) { + $typeno = &typeno($1); + &pdecl($whatis); + } else { + $typeno = &typeno($whatis); + } + } elsif (s/^(\d+)(=[*suf]\d*)//) { + local($whatis) = $2; + + if ($whatis =~ /[f*]/) { + &pdecl($whatis); + } elsif ($whatis =~ /[su]/) { # + print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n" + if $debug; + #$type[$typeno] = $name unless defined $type[$typeno]; + ##printf "new type $typeno is $name" if $debug; + $typeno = $1; + $type[$typeno] = "$prefix.$fieldname"; + local($name) = $type[$typeno]; + &sou($name, $whatis); + $_ = &sdecl($name, $_, $start+$offset); + 1; + $start = $start{$name}; + $offset = $sizeof{$name}; + $length = $offset; + } else { + warn "what's this? $whatis in $line "; + } + } elsif (/^\d+$/) { + $typeno = $_; + } else { + warn "bad array stab: $_ in $line "; + next STAB; + } + #local($wasdef) = defined($type[$typeno]) && $debug; + #if ($typedef) { + #print "redefining $type[$typeno] to " if $wasdef; + #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno]; + #print "$type[$typeno]\n" if $wasdef; + #} else { + #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype]; + #} + $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno]; + print "type[$arraytype] is $type[$arraytype]\n" if $debug; + print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug; + $_; +} + + + +sub sdecl { + local($prefix, $_, $offset) = @_; + + local($fieldname, $scripts, $type, $arraytype, $unknown, + $whatis, $pdecl, $upper,$lower, $start,$length) = (); + local($typeno,$sou); + + +SFIELD: + while (/^([^;]+);/) { + $scripts = ''; + warn "sdecl $_\n" if $debug; + if (s/^([\$\w]+)://) { + $fieldname = $1; + } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # + $typeno = &typeno($1); + $type[$typeno] = "$prefix.$fieldname"; + local($name) = "$prefix.$fieldname"; + &sou($name,$2); + $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); + $start = $start{$name}; + $offset += $sizeof{$name}; + #print "done with anon, start is $start, offset is $offset\n"; + #next SFIELD; + } else { + warn "weird field $_ of $line" if $debug; + next STAB; + #$fieldname = &gensym; + #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); + } + + if (/^(\d+|\(\d+,\d+\))=ar/) { + $_ = &adecl($_); + } + elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) { + ($start, $length) = ($2, $3); + &panic("no length?") unless $length; + $typeno = &typeno($1) if $1; + } + elsif (s/^(\d+)=xs\w+:,(\d+),(\d+);//) { + ($start, $length) = ($2, $3); + &panic("no length?") unless $length; + $typeno = &typeno($1) if $1; + } + elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) { + ($pdecl, $start, $length) = ($1,$5,$6); + &pdecl($pdecl); + } + elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct + ($typeno, $sou) = ($1, $2); + $typeno = &typeno($typeno); + if (defined($type[$typeno])) { + warn "now how did we get type $1 in $fieldname of $line?"; + } else { + print "anon type $typeno is $prefix.$fieldname\n" if $debug; + $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno]; + }; + local($name) = "$prefix.$fieldname"; + &sou($name,$sou); + print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug; + $type[$typeno] = "$prefix.$fieldname"; + $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); + $start = $start{$name}; + $length = $sizeof{$name}; + } + else { + warn "can't grok stab for $name ($_) in line $line "; + next STAB; + } + + &panic("no length for $prefix.$fieldname") unless $length; + $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';'; + } + if (s/;\d*,(\d+),(\d+);//) { + local($start, $size) = ($1, $2); + $sizeof{$prefix} = $size; + print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug; + $start{$prefix} = $start; + } + $_; +} + +sub edecl { + s/;$//; + $enum{$name} = $_; + $_ = ''; +} + +sub resolve_types { + local($sou); + for $i (0 .. $#type) { + next unless defined $type[$i]; + $_ = $type[$i]; + unless (/\d/) { + print "type[$i] $type[$i]\n" if $debug; + next; + } + print "type[$i] $_ ==> " if $debug; + s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e; + s/^(\d+)\&/&type($1)/e; + s/^(\d+)/&type($1)/e; + s/(\*+)([^*]+)(\*+)/$1$3$2/; + s/\((\*+)(\w+)(\*+)\)/$3($1$2)/; + s/^(\d+)([\*\[].*)/&type($1).$2/e; + #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge; + $type[$i] = $_; + print "$_\n" if $debug; + } +} +sub type { &psou($type[$_[0]] || ""); } + +sub adjust_start_addrs { + for (sort keys %start) { + ($basename = $_) =~ s/\.[^.]+$//; + $start{$_} += $start{$basename}; + print "start: $_ @ $start{$_}\n" if $debug; + } +} + +sub sou { + local($what, $_) = @_; + /u/ && $isaunion{$what}++; + /s/ && $isastruct{$what}++; +} + +sub psou { + local($what) = @_; + local($prefix) = ''; + if ($isaunion{$what}) { + $prefix = 'union '; + } elsif ($isastruct{$what}) { + $prefix = 'struct '; + } + $prefix . $what; +} + +sub scrunch { + local($_) = @_; + + return '' if $_ eq ''; + + study; + + s/\$//g; + s/ / /g; + 1 while s/(\w) \1/$1$1/g; + + # i wanna say this, but perl resists my efforts: + # s/(\w)(\1+)/$2 . length($1)/ge; + + &quick_scrunch; + + s/ $//; + + $_; +} + +sub buildscrunchlist { + $scrunch_code = "sub quick_scrunch {\n"; + for (values %intrinsics) { + $scrunch_code .= "\ts/(${_}{2,})/'$_' . length(\$1)/ge;\n"; + } + $scrunch_code .= "}\n"; + print "$scrunch_code" if $debug; + eval $scrunch_code; + &panic("can't eval scrunch_code $@ \nscrunch_code") if $@; +} + +sub fetch_template { + local($mytype) = @_; + local($fmt); + local($count) = 1; + + &panic("why do you care?") unless $perl; + + if ($mytype =~ s/(\[\d+\])+$//) { + $count .= $1; + } + + if ($mytype =~ /\*/) { + $fmt = $template{'pointer'}; + } + elsif (defined $template{$mytype}) { + $fmt = $template{$mytype}; + } + elsif (defined $struct{$mytype}) { + if (!defined $template{&psou($mytype)}) { + &build_template($mytype) unless $mytype eq $name; + } + elsif ($template{&psou($mytype)} !~ /\$$/) { + #warn "incomplete template for $mytype\n"; + } + $fmt = $template{&psou($mytype)} || '?'; + } + else { + warn "unknown fmt for $mytype\n"; + $fmt = '?'; + } + + $fmt x $count . ' '; +} + +sub compute_intrinsics { + local($TMP) = "/tmp/c2ph-i.$$.c"; + open (TMP, ">$TMP") || die "can't open $TMP: $!"; + select(TMP); + + print STDERR "computing intrinsic sizes: " if $trace; + + undef %intrinsics; + + print <<'EOF'; +main() { + char *mask = "%d %s\n"; +EOF + + for $type (@intrinsics) { + next if !type || $type eq 'void' || $type =~ /complex/; # sun stuff + print <<"EOF"; + printf(mask,sizeof($type), "$type"); +EOF + } + + print <<'EOF'; + printf(mask,sizeof(char *), "pointer"); + exit(0); +} +EOF + close TMP; + + select(STDOUT); + open(PIPE, "cd /tmp && $CC $TMP && /tmp/a.out|"); + while () { + chop; + split(' ',$_,2);; + print "intrinsic $_[1] is size $_[0]\n" if $debug; + $sizeof{$_[1]} = $_[0]; + $intrinsics{$_[1]} = $template{$_[0]}; + } + close(PIPE) || die "couldn't read intrinsics!"; + unlink($TMP, '/tmp/a.out'); + print STDERR "done\n" if $trace; +} + +sub scripts2count { + local($_) = @_; + + s/^\[//; + s/\]$//; + s/\]\[/*/g; + $_ = eval; + &panic("$_: $@") if $@; + $_; +} + +sub system { + print STDERR "@_\n" if $trace; + system @_; +} + +sub build_template { + local($name) = @_; + + &panic("already got a template for $name") if defined $template{$name}; + + local($build_templates) = 1; + + local($lparen) = '(' x $build_recursed; + local($rparen) = ')' x $build_recursed; + + print STDERR "$lparen$name$rparen " if $trace; + $build_recursed++; + &pstruct($name,$name,0); + print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug; + --$build_recursed; +} + + +sub panic { + + select(STDERR); + + print "\npanic: @_\n"; + + exit 1 if $] <= 4.003; # caller broken + + local($i,$_); + local($p,$f,$l,$s,$h,$a,@a,@sub); + for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { + @a = @DB'args; + for (@a) { + if (/^StB\000/ && length($_) == length($_main{'_main'})) { + $_ = sprintf("%s",$_); + } + else { + s/'/\\'/g; + s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; + s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; + } + } + $w = $w ? '@ = ' : '$ = '; + $a = $h ? '(' . join(', ', @a) . ')' : ''; + push(@sub, "$w&$s$a from file $f line $l\n"); + last if $signal; + } + for ($i=0; $i <= $#sub; $i++) { + last if $signal; + print $sub[$i]; + } + exit 1; +} + +sub squishseq { + local($num); + local($last) = -1e8; + local($string); + local($seq) = '..'; + + while (defined($num = shift)) { + if ($num == ($last + 1)) { + $string .= $seq unless $inseq++; + $last = $num; + next; + } elsif ($inseq) { + $string .= $last unless $last == -1e8; + } + + $string .= ',' if defined $string; + $string .= $num; + $last = $num; + $inseq = 0; + } + $string .= $last if $inseq && $last != -e18; + $string; +} + +sub repeat_template { + # local($template, $scripts) = @_; have to change caller's values + + if ( $_[1] ) { + local($ncount) = &scripts2count($_[1]); + if ($_[0] =~ /^\s*c\s*$/i) { + $_[0] = "A$ncount "; + $_[1] = ''; + } else { + $_[0] = $template x $ncount; + } + } +} +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +unlink 'pstruct'; +link c2ph, pstruct; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; diff --git a/c2ph.SH b/c2ph.SH deleted file mode 100755 index 18027434fc..0000000000 --- a/c2ph.SH +++ /dev/null @@ -1,1169 +0,0 @@ -case $CONFIG in -'') - if test ! -f config.sh; then - ln ../config.sh . || \ - ln ../../config.sh . || \ - ln ../../../config.sh . || \ - (echo "Can't find config.sh."; exit 1) - fi - . config.sh - ;; -esac -: This forces SH files to create target in same directory as SH file. -: This is so that make depend always knows where to find SH derivatives. -case "$0" in -*/*) cd `expr X$0 : 'X\(.*\)/'` ;; -esac -echo "Extracting c2ph (with variable substitutions)" -: This section of the file will have variable substitutions done on it. -: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. -: Protect any dollar signs and backticks that you do not want interpreted -: by putting a backslash in front. You may delete these comments. -rm -f c2ph -$spitshell >c2ph <>c2ph <<'!NO!SUBS!' -# -# c2ph (aka pstruct) -# Tom Christiansen, -# -# As pstruct, dump C structures as generated from 'cc -g -S' stabs. -# As c2ph, do this PLUS generate perl code for getting at the structures. -# -# See the usage message for more. If this isn't enough, read the code. -# - -$RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $'; - - -###################################################################### - -# some handy data definitions. many of these can be reset later. - -$bitorder = 'b'; # ascending; set to B for descending bit fields - -%intrinsics = -%template = ( - 'char', 'c', - 'unsigned char', 'C', - 'short', 's', - 'short int', 's', - 'unsigned short', 'S', - 'unsigned short int', 'S', - 'short unsigned int', 'S', - 'int', 'i', - 'unsigned int', 'I', - 'long', 'l', - 'long int', 'l', - 'unsigned long', 'L', - 'unsigned long', 'L', - 'long unsigned int', 'L', - 'unsigned long int', 'L', - 'long long', 'q', - 'long long int', 'q', - 'unsigned long long', 'Q', - 'unsigned long long int', 'Q', - 'float', 'f', - 'double', 'd', - 'pointer', 'p', - 'null', 'x', - 'neganull', 'X', - 'bit', $bitorder, -); - -&buildscrunchlist; -delete $intrinsics{'neganull'}; -delete $intrinsics{'bit'}; -delete $intrinsics{'null'}; - -# use -s to recompute sizes -%sizeof = ( - 'char', '1', - 'unsigned char', '1', - 'short', '2', - 'short int', '2', - 'unsigned short', '2', - 'unsigned short int', '2', - 'short unsigned int', '2', - 'int', '4', - 'unsigned int', '4', - 'long', '4', - 'long int', '4', - 'unsigned long', '4', - 'unsigned long int', '4', - 'long unsigned int', '4', - 'long long', '8', - 'long long int', '8', - 'unsigned long long', '8', - 'unsigned long long int', '8', - 'float', '4', - 'double', '8', - 'pointer', '4', -); - -($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5); - -($offset_fmt, $size_fmt) = ('d', 'd'); - -$indent = 2; - -$CC = 'cc'; -$CFLAGS = '-g -S'; -$DEFINES = ''; - -$perl++ if $0 =~ m#/?c2ph$#; - -require 'getopts.pl'; - -eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift; - -&Getopts('aixdpvtnws:') || &usage(0); - -$opt_d && $debug++; -$opt_t && $trace++; -$opt_p && $perl++; -$opt_v && $verbose++; -$opt_n && ($perl = 0); - -if ($opt_w) { - ($type_width, $member_width, $offset_width) = (45, 35, 8); -} -if ($opt_x) { - ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 ); -} - -eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift; - -sub PLUMBER { - select(STDERR); - print "oops, apperent pager foulup\n"; - $isatty++; - &usage(1); -} - -sub usage { - local($oops) = @_; - unless (-t STDOUT) { - select(STDERR); - } elsif (!$oops) { - $isatty++; - $| = 1; - print "hit for further explanation: "; - ; - open (PIPE, "|". ($ENV{PAGER} || 'more')); - $SIG{PIPE} = PLUMBER; - select(PIPE); - } - - print "usage: $0 [-dpnP] [var=val] [files ...]\n"; - - exit unless $isatty; - - print < 1) { - warn "Only one *.s file allowed!\n"; - &usage; - } - } - elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) { - local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#; - $chdir = "cd $dir; " if $dir; - &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1; - $ARGV[0] =~ s/\.c$/.s/; - } - else { - $TMP = "/tmp/c2ph.$$.c"; - &system("cat @ARGV > $TMP") && exit 1; - &system("cd /tmp; $CC $CFLAGS $DEFINES $TMP") && exit 1; - unlink $TMP; - $TMP =~ s/\.c$/.s/; - @ARGV = ($TMP); - } -} - -if ($opt_s) { - for (split(/[\s,]+/, $opt_s)) { - $interested{$_}++; - } -} - - -$| = 1 if $debug; - -main: { - - if ($trace) { - if (-t && !@ARGV) { - print STDERR "reading from your keyboard: "; - } else { - print STDERR "reading from " . (@ARGV ? "@ARGV" : "").": "; - } - } - -STAB: while (<>) { - if ($trace && !($. % 10)) { - $lineno = $..''; - print STDERR $lineno, "\b" x length($lineno); - } - next unless /^\s*\.stabs\s+/; - $line = $_; - s/^\s*\.stabs\s+//; - if (s/\\\\"[d,]+$//) { - $saveline .= $line; - $savebar = $_; - next STAB; - } - if ($saveline) { - s/^"//; - $_ = $savebar . $_; - $line = $saveline; - } - &stab; - $savebar = $saveline = undef; - } - print STDERR "$.\n" if $trace; - unlink $TMP if $TMP; - - &compute_intrinsics if $perl && !$opt_i; - - print STDERR "resolving types\n" if $trace; - - &resolve_types; - &adjust_start_addrs; - - $sum = 2 + $type_width + $member_width; - $pmask1 = "%-${type_width}s %-${member_width}s"; - $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s"; - - - - if ($perl) { - # resolve template -- should be in stab define order, but even this isn't enough. - print STDERR "\nbuilding type templates: " if $trace; - for $i (reverse 0..$#type) { - next unless defined($name = $type[$i]); - next unless defined $struct{$name}; - ($iname = $name) =~ s/\..*//; - $build_recursed = 0; - &build_template($name) unless defined $template{&psou($name)} || - $opt_s && !$interested{$iname}; - } - print STDERR "\n\n" if $trace; - } - - print STDERR "dumping structs: " if $trace; - - local($iam); - - - - foreach $name (sort keys %struct) { - ($iname = $name) =~ s/\..*//; - next if $opt_s && !$interested{$iname}; - print STDERR "$name " if $trace; - - undef @sizeof; - undef @typedef; - undef @offsetof; - undef @indices; - undef @typeof; - undef @fieldnames; - - $mname = &munge($name); - - $fname = &psou($name); - - print "# " if $perl && $verbose; - $pcode = ''; - print "$fname {\n" if !$perl || $verbose; - $template{$fname} = &scrunch($template{$fname}) if $perl; - &pstruct($name,$name,0); - print "# " if $perl && $verbose; - print "}\n" if !$perl || $verbose; - print "\n" if $perl && $verbose; - - if ($perl) { - print "$pcode"; - - printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name}); - - print < $sizeof{$b}; } - - - foreach $name (sort keys %intrinsics) { - print '$',&munge($name),"'typedef = '", $template{$name}, "';\n"; - } - - print "\n1;\n" if $perl; - - exit; -} - -######################################################################################## - - -sub stab { - next unless $continued || /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun - s/"// || next; - s/",([x\d]+),([x\d]+),([x\d]+),.*// || next; - - next if /^\s*$/; - - $size = $3 if $3; - $_ = $continued . $_ if length($continued); - if (s/\\\\$//) { - # if last 2 chars of string are '\\' then stab is continued - # in next stab entry - chop; - $continued = $_; - next; - } - $continued = ''; - - - $line = $_; - - if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) { - print "$name is a typedef for some funky pointers: $pdecl\n" if $debug; - &pdecl($pdecl); - next; - } - - - - if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) { - local($ident) = $2; - push(@intrinsics, $ident); - $typeno = &typeno($3); - $type[$typeno] = $ident; - print STDERR "intrinsic $ident in new type $typeno\n" if $debug; - next; - } - - if (($name, $typeordef, $typeno, $extra, $struct, $_) - = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/) - { - $typeno = &typeno($typeno); # sun foolery - } - elsif (/^[\$\w]+:/) { - next; # variable - } - else { - warn "can't grok stab: <$_> in: $line " if $_; - next; - } - - #warn "got size $size for $name\n"; - $sizeof{$name} = $size if $size; - - s/;[-\d]*;[-\d]*;$//; # we don't care about ranges - - $typenos{$name} = $typeno; - - unless (defined $type[$typeno]) { - &panic("type 0??") unless $typeno; - $type[$typeno] = $name unless defined $type[$typeno]; - printf "new type $typeno is $name" if $debug; - if ($extra =~ /\*/ && defined $type[$struct]) { - print ", a typedef for a pointer to " , $type[$struct] if $debug; - } - } else { - printf "%s is type %d", $name, $typeno if $debug; - print ", a typedef for " , $type[$typeno] if $debug; - } - print "\n" if $debug; - #next unless $extra =~ /[su*]/; - - #$type[$struct] = $name; - - if ($extra =~ /[us*]/) { - &sou($name, $extra); - $_ = &sdecl($name, $_, 0); - } - elsif (/^=ar/) { - print "it's a bare array typedef -- that's pretty sick\n" if $debug; - $_ = "$typeno$_"; - $scripts = ''; - $_ = &adecl($_,1); - - } - elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc - push(@intrinsics, $2); - $typeno = &typeno($3); - $type[$typeno] = $2; - print STDERR "intrinsic $2 in new type $typeno\n" if $debug; - } - elsif (s/^=e//) { # blessed be thy compiler; mine won't do this - &edecl; - } - else { - warn "Funny remainder for $name on line $_ left in $line " if $_; - } -} - -sub typeno { # sun thinks types are (0,27) instead of just 27 - local($_) = @_; - s/\(\d+,(\d+)\)/$1/; - $_; -} - -sub pstruct { - local($what,$prefix,$base) = @_; - local($field, $fieldname, $typeno, $count, $offset, $entry); - local($fieldtype); - local($type, $tname); - local($mytype, $mycount, $entry2); - local($struct_count) = 0; - local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt); - local($bits,$bytes); - local($template); - - - local($mname) = &munge($name); - - sub munge { - local($_) = @_; - s/[\s\$\.]/_/g; - $_; - } - - local($sname) = &psou($what); - - $nesting++; - - for $field (split(/;/, $struct{$what})) { - $pad = $prepad = 0; - $entry = ''; - ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field); - - $type = $type[$typeno]; - - $type =~ /([^[]*)(\[.*\])?/; - $mytype = $1; - $count .= $2; - $fieldtype = &psou($mytype); - - local($fname) = &psou($name); - - if ($build_templates) { - - $pad = ($offset - ($lastoffset + $lastlength))/8 - if defined $lastoffset; - - if (! $finished_template{$sname}) { - if ($isaunion{$what}) { - $template{$sname} .= 'X' x $revpad . ' ' if $revpad; - } else { - $template{$sname} .= 'x' x $pad . ' ' if $pad; - } - } - - $template = &fetch_template($type); - &repeat_template($template,$count); - - if (! $finished_template{$sname}) { - $template{$sname} .= $template; - } - - $revpad = $length/8 if $isaunion{$what}; - - ($lastoffset, $lastlength) = ($offset, $length); - - } else { - print '# ' if $perl && $verbose; - $entry = sprintf($pmask1, - ' ' x ($nesting * $indent) . $fieldtype, - "$prefix.$fieldname" . $count); - - $entry =~ s/(\*+)( )/$2$1/; - - printf $pmask2, - $entry, - ($base+$offset)/8, - ($bits = ($base+$offset)%8) ? ".$bits" : " ", - $length/8, - ($bits = $length % 8) ? ".$bits": "" - if !$perl || $verbose; - - if ($perl) { - $template = &fetch_template($type); - &repeat_template($template,$count); - } - - if ($perl && $nesting == 1) { - - push(@sizeof, int($length/8) .",\t# $fieldname"); - push(@offsetof, int($offset/8) .",\t# $fieldname"); - local($little) = &scrunch($template); - push(@typedef, "'$little', \t# $fieldname"); - $type =~ s/(struct|union) //; - push(@typeof, "'$mytype" . ($count ? $count : '') . - "',\t# $fieldname"); - push(@fieldnames, "'$fieldname',"); - } - - print ' ', ' ' x $indent x $nesting, $template - if $perl && $verbose; - - print "\n" if !$perl || $verbose; - - } - if ($perl) { - local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1; - $mycount *= &scripts2count($count) if $count; - if ($nesting==1 && !$build_templates) { - $pcode .= sprintf("sub %-32s { %4d; }\n", - "${mname}'${fieldname}", $struct_count); - push(@indices, $struct_count); - } - $struct_count += $mycount; - } - - - &pstruct($type, "$prefix.$fieldname", $base+$offset) - if $recurse && defined $struct{$type}; - } - - $countof{$what} = $struct_count unless defined $countof{$whati}; - - $template{$sname} .= '$' if $build_templates; - $finished_template{$sname}++; - - if ($build_templates && !defined $sizeof{$name}) { - local($fmt) = &scrunch($template{$sname}); - print STDERR "no size for $name, punting with $fmt..." if $debug; - eval '$sizeof{$name} = length(pack($fmt, ()))'; - if ($@) { - chop $@; - warn "couldn't get size for \$name: $@"; - } else { - print STDERR $sizeof{$name}, "\n" if $debUg; - } - } - - --$nesting; -} - - -sub psize { - local($me) = @_; - local($amstruct) = $struct{$me} ? 'struct ' : ''; - - print '$sizeof{\'', $amstruct, $me, '\'} = '; - printf "%d;\n", $sizeof{$me}; -} - -sub pdecl { - local($pdecl) = @_; - local(@pdecls); - local($tname); - - warn "pdecl: $pdecl\n" if $debug; - - $pdecl =~ s/\(\d+,(\d+)\)/$1/g; - $pdecl =~ s/\*//g; - @pdecls = split(/=/, $pdecl); - $typeno = $pdecls[0]; - $tname = pop @pdecls; - - if ($tname =~ s/^f//) { $tname = "$tname&"; } - #else { $tname = "$tname*"; } - - for (reverse @pdecls) { - $tname .= s/^f// ? "&" : "*"; - #$tname =~ s/^f(.*)/$1&/; - print "type[$_] is $tname\n" if $debug; - $type[$_] = $tname unless defined $type[$_]; - } -} - - - -sub adecl { - ($arraytype, $unknown, $lower, $upper) = (); - #local($typeno); - # global $typeno, @type - local($_, $typedef) = @_; - - while (s/^((\d+|\(\d+,\d+\))=)?ar(\d+|\(\d+,\d+\));//) { - ($arraytype, $unknown) = ($2, $3); - $arraytype = &typeno($arraytype); - $unknown = &typeno($unknown); - if (s/^(\d+);(\d+);//) { - ($lower, $upper) = ($1, $2); - $scripts .= '[' . ($upper+1) . ']'; - } else { - warn "can't find array bounds: $_"; - } - } - if (s/^([(,)\d*f=]*),(\d+),(\d+);//) { - ($start, $length) = ($2, $3); - $whatis = $1; - if ($whatis =~ /^(\d+|\(\d+,\d+\))=/) { - $typeno = &typeno($1); - &pdecl($whatis); - } else { - $typeno = &typeno($whatis); - } - } elsif (s/^(\d+)(=[*suf]\d*)//) { - local($whatis) = $2; - - if ($whatis =~ /[f*]/) { - &pdecl($whatis); - } elsif ($whatis =~ /[su]/) { # - print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n" - if $debug; - #$type[$typeno] = $name unless defined $type[$typeno]; - ##printf "new type $typeno is $name" if $debug; - $typeno = $1; - $type[$typeno] = "$prefix.$fieldname"; - local($name) = $type[$typeno]; - &sou($name, $whatis); - $_ = &sdecl($name, $_, $start+$offset); - 1; - $start = $start{$name}; - $offset = $sizeof{$name}; - $length = $offset; - } else { - warn "what's this? $whatis in $line "; - } - } elsif (/^\d+$/) { - $typeno = $_; - } else { - warn "bad array stab: $_ in $line "; - next STAB; - } - #local($wasdef) = defined($type[$typeno]) && $debug; - #if ($typedef) { - #print "redefining $type[$typeno] to " if $wasdef; - #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno]; - #print "$type[$typeno]\n" if $wasdef; - #} else { - #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype]; - #} - $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno]; - print "type[$arraytype] is $type[$arraytype]\n" if $debug; - print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug; - $_; -} - - - -sub sdecl { - local($prefix, $_, $offset) = @_; - - local($fieldname, $scripts, $type, $arraytype, $unknown, - $whatis, $pdecl, $upper,$lower, $start,$length) = (); - local($typeno,$sou); - - -SFIELD: - while (/^([^;]+);/) { - $scripts = ''; - warn "sdecl $_\n" if $debug; - if (s/^([\$\w]+)://) { - $fieldname = $1; - } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # - $typeno = &typeno($1); - $type[$typeno] = "$prefix.$fieldname"; - local($name) = "$prefix.$fieldname"; - &sou($name,$2); - $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); - $start = $start{$name}; - $offset += $sizeof{$name}; - #print "done with anon, start is $start, offset is $offset\n"; - #next SFIELD; - } else { - warn "weird field $_ of $line" if $debug; - next STAB; - #$fieldname = &gensym; - #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); - } - - if (/^(\d+|\(\d+,\d+\))=ar/) { - $_ = &adecl($_); - } - elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) { - ($start, $length) = ($2, $3); - &panic("no length?") unless $length; - $typeno = &typeno($1) if $1; - } - elsif (s/^(\d+)=xs\w+:,(\d+),(\d+);//) { - ($start, $length) = ($2, $3); - &panic("no length?") unless $length; - $typeno = &typeno($1) if $1; - } - elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) { - ($pdecl, $start, $length) = ($1,$5,$6); - &pdecl($pdecl); - } - elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct - ($typeno, $sou) = ($1, $2); - $typeno = &typeno($typeno); - if (defined($type[$typeno])) { - warn "now how did we get type $1 in $fieldname of $line?"; - } else { - print "anon type $typeno is $prefix.$fieldname\n" if $debug; - $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno]; - }; - local($name) = "$prefix.$fieldname"; - &sou($name,$sou); - print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug; - $type[$typeno] = "$prefix.$fieldname"; - $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); - $start = $start{$name}; - $length = $sizeof{$name}; - } - else { - warn "can't grok stab for $name ($_) in line $line "; - next STAB; - } - - &panic("no length for $prefix.$fieldname") unless $length; - $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';'; - } - if (s/;\d*,(\d+),(\d+);//) { - local($start, $size) = ($1, $2); - $sizeof{$prefix} = $size; - print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug; - $start{$prefix} = $start; - } - $_; -} - -sub edecl { - s/;$//; - $enum{$name} = $_; - $_ = ''; -} - -sub resolve_types { - local($sou); - for $i (0 .. $#type) { - next unless defined $type[$i]; - $_ = $type[$i]; - unless (/\d/) { - print "type[$i] $type[$i]\n" if $debug; - next; - } - print "type[$i] $_ ==> " if $debug; - s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e; - s/^(\d+)\&/&type($1)/e; - s/^(\d+)/&type($1)/e; - s/(\*+)([^*]+)(\*+)/$1$3$2/; - s/\((\*+)(\w+)(\*+)\)/$3($1$2)/; - s/^(\d+)([\*\[].*)/&type($1).$2/e; - #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge; - $type[$i] = $_; - print "$_\n" if $debug; - } -} -sub type { &psou($type[$_[0]] || ""); } - -sub adjust_start_addrs { - for (sort keys %start) { - ($basename = $_) =~ s/\.[^.]+$//; - $start{$_} += $start{$basename}; - print "start: $_ @ $start{$_}\n" if $debug; - } -} - -sub sou { - local($what, $_) = @_; - /u/ && $isaunion{$what}++; - /s/ && $isastruct{$what}++; -} - -sub psou { - local($what) = @_; - local($prefix) = ''; - if ($isaunion{$what}) { - $prefix = 'union '; - } elsif ($isastruct{$what}) { - $prefix = 'struct '; - } - $prefix . $what; -} - -sub scrunch { - local($_) = @_; - - return '' if $_ eq ''; - - study; - - s/\$//g; - s/ / /g; - 1 while s/(\w) \1/$1$1/g; - - # i wanna say this, but perl resists my efforts: - # s/(\w)(\1+)/$2 . length($1)/ge; - - &quick_scrunch; - - s/ $//; - - $_; -} - -sub buildscrunchlist { - $scrunch_code = "sub quick_scrunch {\n"; - for (values %intrinsics) { - $scrunch_code .= "\ts/($_\{2,})/'$_' . length(\$1)/ge;\n"; - } - $scrunch_code .= "}\n"; - print "$scrunch_code" if $debug; - eval $scrunch_code; - &panic("can't eval scrunch_code $@ \nscrunch_code") if $@; -} - -sub fetch_template { - local($mytype) = @_; - local($fmt); - local($count) = 1; - - &panic("why do you care?") unless $perl; - - if ($mytype =~ s/(\[\d+\])+$//) { - $count .= $1; - } - - if ($mytype =~ /\*/) { - $fmt = $template{'pointer'}; - } - elsif (defined $template{$mytype}) { - $fmt = $template{$mytype}; - } - elsif (defined $struct{$mytype}) { - if (!defined $template{&psou($mytype)}) { - &build_template($mytype) unless $mytype eq $name; - } - elsif ($template{&psou($mytype)} !~ /\$$/) { - #warn "incomplete template for $mytype\n"; - } - $fmt = $template{&psou($mytype)} || '?'; - } - else { - warn "unknown fmt for $mytype\n"; - $fmt = '?'; - } - - $fmt x $count . ' '; -} - -sub compute_intrinsics { - local($TMP) = "/tmp/c2ph-i.$$.c"; - open (TMP, ">$TMP") || die "can't open $TMP: $!"; - select(TMP); - - print STDERR "computing intrinsic sizes: " if $trace; - - undef %intrinsics; - - print <<'EOF'; -main() { - char *mask = "%d %s\n"; -EOF - - for $type (@intrinsics) { - next if !type || $type eq 'void' || $type =~ /complex/; # sun stuff - print <<"EOF"; - printf(mask,sizeof($type), "$type"); -EOF - } - - print <<'EOF'; - printf(mask,sizeof(char *), "pointer"); - exit(0); -} -EOF - close TMP; - - select(STDOUT); - open(PIPE, "cd /tmp && $CC $TMP && /tmp/a.out|"); - while () { - chop; - split(' ',$_,2);; - print "intrinsic $_[1] is size $_[0]\n" if $debug; - $sizeof{$_[1]} = $_[0]; - $intrinsics{$_[1]} = $template{$_[0]}; - } - close(PIPE) || die "couldn't read intrinsics!"; - unlink($TMP, '/tmp/a.out'); - print STDERR "done\n" if $trace; -} - -sub scripts2count { - local($_) = @_; - - s/^\[//; - s/\]$//; - s/\]\[/*/g; - $_ = eval; - &panic("$_: $@") if $@; - $_; -} - -sub system { - print STDERR "@_\n" if $trace; - system @_; -} - -sub build_template { - local($name) = @_; - - &panic("already got a template for $name") if defined $template{$name}; - - local($build_templates) = 1; - - local($lparen) = '(' x $build_recursed; - local($rparen) = ')' x $build_recursed; - - print STDERR "$lparen$name$rparen " if $trace; - $build_recursed++; - &pstruct($name,$name,0); - print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug; - --$build_recursed; -} - - -sub panic { - - select(STDERR); - - print "\npanic: @_\n"; - - exit 1 if $] <= 4.003; # caller broken - - local($i,$_); - local($p,$f,$l,$s,$h,$a,@a,@sub); - for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { - @a = @DB'args; - for (@a) { - if (/^StB\000/ && length($_) == length($_main{'_main'})) { - $_ = sprintf("%s",$_); - } - else { - s/'/\\'/g; - s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; - s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; - s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; - } - } - $w = $w ? '@ = ' : '$ = '; - $a = $h ? '(' . join(', ', @a) . ')' : ''; - push(@sub, "$w&$s$a from file $f line $l\n"); - last if $signal; - } - for ($i=0; $i <= $#sub; $i++) { - last if $signal; - print $sub[$i]; - } - exit 1; -} - -sub squishseq { - local($num); - local($last) = -1e8; - local($string); - local($seq) = '..'; - - while (defined($num = shift)) { - if ($num == ($last + 1)) { - $string .= $seq unless $inseq++; - $last = $num; - next; - } elsif ($inseq) { - $string .= $last unless $last == -1e8; - } - - $string .= ',' if defined $string; - $string .= $num; - $last = $num; - $inseq = 0; - } - $string .= $last if $inseq && $last != -e18; - $string; -} - -sub repeat_template { - # local($template, $scripts) = @_; have to change caller's values - - if ( $_[1] ) { - local($ncount) = &scripts2count($_[1]); - if ($_[0] =~ /^\s*c\s*$/i) { - $_[0] = "A$ncount "; - $_[1] = ''; - } else { - $_[0] = $template x $ncount; - } - } -} diff --git a/cflags.SH b/cflags.SH index bb0f2163b6..9dc5c90127 100755 --- a/cflags.SH +++ b/cflags.SH @@ -64,7 +64,7 @@ case $# in 0) set *.c; echo "The current C flags are:" ;; esac -set `echo "$* " | sed 's/\.[oc] / /g'` +set `echo "$* " | sed -e 's/\.[oc] / /g' -e 's/\.obj / /g'` for file do diff --git a/config_H b/config_H index b20821f0f6..03d71d21c8 100644 --- a/config_H +++ b/config_H @@ -11,12 +11,12 @@ * that running config_h.SH again will wipe out any changes you've made. * For a more permanent change edit config.sh and rerun config_h.SH. * - * $Id: Config_h.U,v 3.0.1.3 1995/01/30 14:25:39 ram Exp $ + * $Id: Config_h.U,v 3.0.1.4 1995/09/25 09:10:49 ram Exp $ */ -/* Configuration time: Tue Jul 25 15:36:03 EDT 1995 - * Configured by: andy - * Target system: crystal crystal 3.2 2 i386 +/* Configuration time: Mon Nov 20 15:21:41 EST 1995 + * Configured by: doughera + * Target system: sunos fractal 5.4 generic_101946-29 i86pc i386 */ #ifndef _config_h_ @@ -28,31 +28,16 @@ */ #define MEM_ALIGNBYTES 4 /**/ -/* ARCHLIB_EXP: - * This symbol contains the ~name expanded version of ARCHLIB, to be used - * in programs that are not prepared to deal with ~ expansion at run-time. - */ -#define ARCHLIB_EXP "/usr/local/lib/perl5/i386-isc" /**/ - /* BIN: * This symbol holds the path of the bin directory where the package will * be installed. Program must be prepared to deal with ~name substitution. */ -#define BIN "/usr/local/bin" /**/ - -/* BYTEORDER: - * This symbol hold the hexadecimal constant defined in byteorder, - * i.e. 0x1234 or 0x4321, etc... - */ -#define BYTEORDER 0x1234 /* large digits for MSB */ +#define BIN "/opt/perl/bin" /**/ /* CAT2: * This macro catenates 2 tokens together. */ -/* STRINGIFY: - * This macro surrounds its token with double quotes. - */ -#if 1 == 1 +#if 42 == 1 #define CAT2(a,b)a/**/b #define CAT3(a,b,c)a/**/b/**/c #define CAT4(a,b,c,d)a/**/b/**/c/**/d @@ -60,7 +45,7 @@ #define STRINGIFY(a)"a" /* If you can get stringification with catify, tell me how! */ #endif -#if 1 == 42 +#if 42 == 42 #define CAT2(a,b)a ## b #define CAT3(a,b,c)a ## b ## c #define CAT4(a,b,c,d)a ## b ## c ## d @@ -88,7 +73,7 @@ * output. This symbol will have the value "-" if CPPSTDIN needs a minus * to specify standard input, otherwise the value is "". */ -#define CPPSTDIN "cc -E" +#define CPPSTDIN "gcc -E" #define CPPMINUS "-" /* HAS_ALARM: @@ -101,7 +86,7 @@ * This symbol indicates the C compiler can check for function attributes, * such as printf formats. This is normally only supported by GNU cc. */ -/*#define HASATTRIBUTE /**/ +#define HASATTRIBUTE /**/ #ifndef HASATTRIBUTE #define __attribute__(_arg_) #endif @@ -110,25 +95,25 @@ * This symbol is defined if the bcmp() routine is available to * compare blocks of memory. */ -#define HAS_BCMP /**/ +/*#define HAS_BCMP /**/ /* HAS_BCOPY: * This symbol is defined if the bcopy() routine is available to * copy blocks of memory. */ -#define HAS_BCOPY /**/ +/*#define HAS_BCOPY /**/ /* HAS_BZERO: * This symbol is defined if the bzero() routine is available to * set a memory block to 0. */ -#define HAS_BZERO /**/ +/*#define HAS_BZERO /**/ /* CASTI32: * This symbol is defined if the C compiler can cast negative * or large floating point numbers to 32-bit ints. */ -/*#define CASTI32 /**/ +#define CASTI32 /**/ /* CASTNEGFLOAT: * This symbol is defined if the C compiler can cast negative @@ -142,8 +127,8 @@ * 2 = couldn't cast >= 0x80000000 * 4 = couldn't cast in argument expression list */ -/*#define CASTNEGFLOAT /**/ -#define CASTFLAGS 7 /**/ +#define CASTNEGFLOAT /**/ +#define CASTFLAGS 0 /**/ /* HAS_CHOWN: * This symbol, if defined, indicates that the chown routine is @@ -175,7 +160,7 @@ * within your programs. The mere use of the "const" keyword will * trigger the necessary tests. */ -/*#define HASCONST /**/ +#define HASCONST /**/ #ifndef HASCONST #define const #endif @@ -211,7 +196,7 @@ * available to return a string describing the last error that * occurred from a call to dlopen(), dlclose() or dlsym(). */ -/*#define HAS_DLERROR /**/ +#define HAS_DLERROR /**/ /* SETUID_SCRIPTS_ARE_SECURE_NOW: * This symbol, if defined, indicates that the bug that prevents @@ -230,7 +215,7 @@ * subprocesses to which it must pass the filename rather than the * file descriptor of the script to be executed. */ -/*#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/ +#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/ /*#define DOSUID /**/ /* HAS_DUP2: @@ -243,13 +228,13 @@ * This symbol, if defined, indicates that the fchmod routine is available * to change mode of opened files. If unavailable, use chmod(). */ -/*#define HAS_FCHMOD /**/ +#define HAS_FCHMOD /**/ /* HAS_FCHOWN: * This symbol, if defined, indicates that the fchown routine is available * to change ownership of opened files. If unavailable, use chown(). */ -/*#define HAS_FCHOWN /**/ +#define HAS_FCHOWN /**/ /* HAS_FCNTL: * This symbol, if defined, indicates to the C program that @@ -261,13 +246,13 @@ * This symbol, if defined, indicates that the fgetpos routine is * available to get the file position indicator, similar to ftell(). */ -/*#define HAS_FGETPOS /**/ +#define HAS_FGETPOS /**/ /* FLEXFILENAMES: * This symbol, if defined, indicates that the system supports filenames * longer than 14 characters. */ -/*#define FLEXFILENAMES /**/ +#define FLEXFILENAMES /**/ /* HAS_FLOCK: * This symbol, if defined, indicates that the flock routine is @@ -285,24 +270,7 @@ * This symbol, if defined, indicates that the fsetpos routine is * available to set the file position indicator, similar to fseek(). */ -/*#define HAS_FSETPOS /**/ - -/* Gconvert: - * This preprocessor macro is defined to convert a floating point - * number to a string without a trailing decimal point. This - * emulates the behavior of sprintf("%g"), but is sometimes much more - * efficient. If gconvert() is not available, but gcvt() drops the - * trailing decimal point, then gcvt() is used. If all else fails, - * a macro using sprintf("%g") is used. Arguments for the Gconvert - * macro are: value, number of digits, whether trailing zeros should - * be retained, and the output buffer. - * Possible values are: - * d_Gconvert='gconvert((x),(n),(t),(b))' - * d_Gconvert='gcvt((x),(n),(b))' - * d_Gconvert='sprintf((b),"%.*g",(n),(x))' - * The last two assume trailing zeros should not be kept. - */ -#define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x)) +#define HAS_FSETPOS /**/ /* HAS_GETGROUPS: * This symbol, if defined, indicates that the getgroups() routine is @@ -315,7 +283,7 @@ * This symbol, if defined, indicates that the gethostent routine is * available to lookup host names in some data base or other. */ -/*#define HAS_GETHOSTENT /**/ +#define HAS_GETHOSTENT /**/ /* HAS_UNAME: * This symbol, if defined, indicates that the C program may use the @@ -420,19 +388,19 @@ * This symbol, if defined, indicates that the mblen routine is available * to find the number of bytes in a multibye character. */ -/*#define HAS_MBLEN /**/ +#define HAS_MBLEN /**/ /* HAS_MBSTOWCS: * This symbol, if defined, indicates that the mbstowcs routine is * available to covert a multibyte string into a wide character string. */ -/*#define HAS_MBSTOWCS /**/ +#define HAS_MBSTOWCS /**/ /* HAS_MBTOWC: * This symbol, if defined, indicates that the mbtowc routine is available * to covert a multibyte to a wide character. */ -/*#define HAS_MBTOWC /**/ +#define HAS_MBTOWC /**/ /* HAS_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available @@ -452,7 +420,7 @@ * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your * own version. */ -/*#define HAS_MEMMOVE /**/ +#define HAS_MEMMOVE /**/ /* HAS_MEMSET: * This symbol, if defined, indicates that the memset routine is available @@ -524,6 +492,12 @@ */ #define HAS_PIPE /**/ +/* HAS_POLL: + * This symbol, if defined, indicates that the poll routine is + * available to poll active file descriptors. + */ +#define HAS_POLL /**/ + /* HAS_READDIR: * This symbol, if defined, indicates that the readdir routine is * available to read directory entries. You may have to include @@ -575,7 +549,7 @@ * probably use memmove() or memcpy(). If neither is defined, roll your * own version. */ -#define HAS_SAFE_BCOPY /**/ +/*#define HAS_SAFE_BCOPY /**/ /* HAS_SAFE_MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available @@ -663,7 +637,7 @@ * available to change the real, effective and saved gid of the current * process. */ -#define HAS_SETREGID /**/ +/*#define HAS_SETREGID /**/ /*#define HAS_SETRESGID /**/ /* HAS_SETREUID: @@ -676,7 +650,7 @@ * available to change the real, effective and saved uid of the current * process. */ -#define HAS_SETREUID /**/ +/*#define HAS_SETREUID /**/ /*#define HAS_SETRESUID /**/ /* HAS_SETRGID: @@ -714,8 +688,8 @@ * but not always right so it should be emitted by the program only * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs. */ -#define Shmat_t char * /**/ -/*#define HAS_SHMAT_PROTOTYPE /**/ +#define Shmat_t void * /**/ +#define HAS_SHMAT_PROTOTYPE /**/ /* HAS_SOCKET: * This symbol, if defined, indicates that the BSD socket interface is @@ -726,13 +700,13 @@ * supported. */ #define HAS_SOCKET /**/ -/*#define HAS_SOCKETPAIR /**/ +#define HAS_SOCKETPAIR /**/ /* USE_STAT_BLOCKS: * This symbol is defined if this system has a stat structure declaring * st_blksize and st_blocks. */ -/*#define USE_STAT_BLOCKS /**/ +#define USE_STAT_BLOCKS /**/ /* USE_STDIO_PTR: * This symbol is defined if the _ptr and _cnt fields (or similar) @@ -898,7 +872,7 @@ * This symbol, if defined, indicates that the truncate routine is * available to truncate files. */ -/*#define HAS_TRUNCATE /**/ +#define HAS_TRUNCATE /**/ /* HAS_TZNAME: * This symbol, if defined, indicates that the tzname[] array is @@ -929,7 +903,7 @@ * This symbol, if defined, indicates that this C compiler knows about * the volatile declaration. */ -/*#define HASVOLATILE /**/ +#define HASVOLATILE /**/ #ifndef HASVOLATILE #define volatile #endif @@ -963,13 +937,13 @@ * This symbol, if defined, indicates that the wcstombs routine is * available to convert wide character strings to multibyte strings. */ -/*#define HAS_WCSTOMBS /**/ +#define HAS_WCSTOMBS /**/ /* HAS_WCTOMB: * This symbol, if defined, indicates that the wctomb routine is available * to covert a wide character to a multibyte. */ -/*#define HAS_WCTOMB /**/ +#define HAS_WCTOMB /**/ /* Fpos_t: * This symbol holds the type used to declare file positions in libc. @@ -1036,7 +1010,7 @@ * This symbol, if defined, indicates that exists and should * be included. */ -/*#define I_DLFCN /**/ +#define I_DLFCN /**/ /* I_FCNTL: * This manifest constant tells the C program to include . @@ -1085,7 +1059,7 @@ * This symbol, if defined, indicates that exists and * should be included. */ -#define I_NET_ERRNO /**/ +/*#define I_NET_ERRNO /**/ /* I_NETINET_IN: * This symbol, if defined, indicates to the C program that it should @@ -1151,7 +1125,7 @@ * This symbol, if defined, indicates to the C program that it should * include . */ -#define I_SYS_DIR /**/ +/*#define I_SYS_DIR /**/ /* I_SYS_FILE: * This symbol, if defined, indicates to the C program that it should @@ -1181,7 +1155,7 @@ * This symbol, if defined, indicates to the C program that it should * include in order to get definition of struct timeval. */ -/*#define I_SYS_SELECT /**/ +#define I_SYS_SELECT /**/ /* I_SYS_TIMES: * This symbol, if defined, indicates to the C program that it should @@ -1251,8 +1225,8 @@ * This symbol, if defined, indicates to the C program that it should * include . */ -/*#define I_STDARG /**/ -#define I_VARARGS /**/ +#define I_STDARG /**/ +/*#define I_VARARGS /**/ /* I_VFORK: * This symbol, if defined, indicates to the C program that it should @@ -1260,12 +1234,6 @@ */ /*#define I_VFORK /**/ -/* INTSIZE: - * This symbol contains the size of an int, so that the C preprocessor - * can make decisions based on it. - */ -#define INTSIZE 4 /**/ - /* Off_t: * This symbol holds the type used to declare offsets in the kernel. * It can be int, long, off_t, etc... It may be necessary to include @@ -1281,11 +1249,32 @@ */ #define Mode_t mode_t /* file mode parameter for system calls */ -/* PRIVLIB_EXP: - * This symbol contains the ~name expanded version of PRIVLIB, to be used - * in programs that are not prepared to deal with ~ expansion at run-time. - */ -#define PRIVLIB_EXP "/usr/local/lib/perl5" /**/ +/* VAL_O_NONBLOCK: + * This symbol is to be used during open() or fcntl(F_SETFL) to turn on + * non-blocking I/O for the file descriptor. Note that there is no way + * back, i.e. you cannot turn it blocking again this way. If you wish to + * alternatively switch between blocking and non-blocking, use the + * ioctl(FIOSNBIO) call instead, but that is not supported by all devices. + */ +/* VAL_EAGAIN: + * This symbol holds the errno error code set by read() when no data was + * present on the non-blocking file descriptor. + */ +/* RD_NODATA: + * This symbol holds the return code from read() when no data is present + * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is + * not defined, then you can't distinguish between no data and EOF by + * issuing a read(). You'll have to find another way to tell for sure! + */ +/* EOF_NONBLOCK: + * This symbol, if defined, indicates to the C program that a read() on + * a non-blocking file descriptor will return 0 on EOF, and not the value + * held in RD_NODATA (-1 usually, in that case!). + */ +#define VAL_O_NONBLOCK O_NONBLOCK +#define VAL_EAGAIN EAGAIN +#define RD_NODATA -1 +#define EOF_NONBLOCK /* CAN_PROTOTYPE: * If defined, this macro indicates that the C compiler can handle @@ -1298,7 +1287,7 @@ * * int main _((int argc, char *argv[])); */ -/*#define CAN_PROTOTYPE /**/ +#define CAN_PROTOTYPE /**/ #ifdef CAN_PROTOTYPE #define _(args) args #else @@ -1317,7 +1306,7 @@ * is often a directory that is mounted across diverse architectures. * Programs must be prepared to deal with ~name expansion. */ -#define SCRIPTDIR "/usr/local/bin" /**/ +#define SCRIPTDIR "/opt/perl/bin" /**/ /* Select_fd_set_t: * This symbol holds the type used for the 2nd, 3rd, and 4th @@ -1327,16 +1316,6 @@ */ #define Select_fd_set_t fd_set * /**/ -/* SIG_NAME: - * This symbol contains a list of signal names in order. This is intended - * to be used as a static array initialization, like this: - * char *sig_name[] = { SIG_NAME }; - * The signals in the list are separated with commas, and each signal - * is surrounded by double quotes. There is no leading SIG in the signal - * name, i.e. SIGQUIT is known as "QUIT". - */ -#define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","ABRT","EMT","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","USR1","USR2","CLD","PWR","WINCH","21","POLL","CONT","STOP","TSTP","TTIN","TTOU" /**/ - /* Size_t: * This symbol holds the type used to declare length parameters * for string functions. It is usually size_t, but may be @@ -1353,7 +1332,7 @@ * to get any typedef'ed information. * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). */ -#define SSize_t int /* signed count of bytes */ +#define SSize_t ssize_t /* signed count of bytes */ /* STDCHAR: * This symbol is defined to be the type of char used in stdio.h. @@ -1368,31 +1347,6 @@ */ #define Uid_t uid_t /* UID type */ -/* VOIDFLAGS: - * This symbol indicates how much support of the void type is given by this - * compiler. What various bits mean: - * - * 1 = supports declaration of void - * 2 = supports arrays of pointers to functions returning void - * 4 = supports comparisons between pointers to void functions and - * addresses of void functions - * 8 = suports declaration of generic void pointers - * - * The package designer should define VOIDUSED to indicate the requirements - * of the package. This can be done either by #defining VOIDUSED before - * including config.h, or by defining defvoidused in Myinit.U. If the - * latter approach is taken, only those flags will be tested. If the - * level of void support necessary is not present, defines void to int. - */ -#ifndef VOIDUSED -#define VOIDUSED 15 -#endif -#define VOIDFLAGS 15 -#if (VOIDFLAGS & VOIDUSED) != VOIDUSED -#define void int /* is void to be avoided? */ -#define M_VOID /* Xenix strikes again */ -#endif - /* VMS: * This symbol, if defined, indicates that the program is running under * VMS. It is currently only set in conjunction with the EUNICE symbol. @@ -1404,6 +1358,18 @@ */ #define LOC_SED "/bin/sed" /**/ +/* ARCHLIB_EXP: + * This symbol contains the ~name expanded version of ARCHLIB, to be used + * in programs that are not prepared to deal with ~ expansion at run-time. + */ +#define ARCHLIB_EXP "/opt/perl/lib/i86pc-solaris/5.002" /**/ + +/* BYTEORDER: + * This symbol hold the hexadecimal constant defined in byteorder, + * i.e. 0x1234 or 0x4321, etc... + */ +#define BYTEORDER 0x1234 /* large digits for MSB */ + /* CSH: * This symbol, if defined, indicates that the C-shell exists. * If defined, contains the full pathname of csh. @@ -1418,11 +1384,45 @@ */ /*#define DLSYM_NEEDS_UNDERSCORE /* */ +/* Gconvert: + * This preprocessor macro is defined to convert a floating point + * number to a string without a trailing decimal point. This + * emulates the behavior of sprintf("%g"), but is sometimes much more + * efficient. If gconvert() is not available, but gcvt() drops the + * trailing decimal point, then gcvt() is used. If all else fails, + * a macro using sprintf("%g") is used. Arguments for the Gconvert + * macro are: value, number of digits, whether trailing zeros should + * be retained, and the output buffer. + * Possible values are: + * d_Gconvert='gconvert((x),(n),(t),(b))' + * d_Gconvert='gcvt((x),(n),(b))' + * d_Gconvert='sprintf((b),"%.*g",(n),(x))' + * The last two assume trailing zeros should not be kept. + */ +#define Gconvert(x,n,t,b) gconvert((x),(n),(t),(b)) + /* USE_DYNAMIC_LOADING: * This symbol, if defined, indicates that dynamic loading of * some sort is available. */ -/*#define USE_DYNAMIC_LOADING /**/ +#define USE_DYNAMIC_LOADING /**/ + +/* I_DBM: + * This symbol, if defined, indicates that exists and should + * be included. + */ +/* I_RPCSVC_DBM: + * This symbol, if defined, indicates that exists and + * should be included. + */ +/*#define I_DBM /**/ +#define I_RPCSVC_DBM /**/ + +/* I_LOCALE: + * This symbol, if defined, indicates to the C program that it should + * include . + */ +#define I_LOCALE /**/ /* I_SYS_STAT: * This symbol, if defined, indicates to the C program that it should @@ -1430,6 +1430,12 @@ */ #define I_SYS_STAT /**/ +/* INTSIZE: + * This symbol contains the size of an int, so that the C preprocessor + * can make decisions based on it. + */ +#define INTSIZE 4 /**/ + /* Free_t: * This variable contains the return type of free(). It is usually * void, but occasionally int. @@ -1437,7 +1443,7 @@ /* Malloc_t: * This symbol is the type of pointer returned by malloc and realloc. */ -#define Malloc_t char * /**/ +#define Malloc_t void * /**/ #define Free_t void /**/ /* MYMALLOC: @@ -1445,10 +1451,79 @@ */ #define MYMALLOC /**/ -/* SITELIB_EXP: - * This symbol contains the ~name expanded version of SITELIB, to be used +/* OLDARCHLIB_EXP: + * This symbol contains the ~name expanded version of OLDARCHLIB, to be + * used in programs that are not prepared to deal with ~ expansion at + * run-time. + */ +/*#define OLDARCHLIB_EXP "" /**/ + +/* PRIVLIB_EXP: + * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -/*#define SITELIB_EXP "" /**/ +#define PRIVLIB_EXP "/opt/perl/lib" /**/ + +/* SIG_NAME: + * This symbol contains a list of signal names in order of + * signal number. This is intended + * to be used as a static array initialization, like this: + * char *sig_name[] = { SIG_NAME }; + * The signals in the list are separated with commas, and each signal + * is surrounded by double quotes. There is no leading SIG in the signal + * name, i.e. SIGQUIT is known as "QUIT". + * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn, + * etc., where nn is the actual signal number (e.g. NUM37). + * The signal number for sig_name[i] is stored in sig_num[i]. + * The last element is 0 to terminate the list with a NULL. This + * corresponds to the 0 at the end of the sig_num list. + */ +/* SIG_NUM: + * This symbol contains a list of signal numbers, in the same order as the + * SIG_NAME list. It is suitable for static array initialization, as in: + * int sig_num[] = { SIG_NUM }; + * The signals in the list are separated with commas, and the indices + * within that list and the SIG_NAME list match, so it's easy to compute + * the signal name from a number or vice versa at the price of a small + * dynamic linear lookup. + * Duplicates are allowed, but are moved to the end of the list. + * The signal number corresponding to sig_name[i] is sig_number[i]. + * if (i < NSIG) then sig_number[i] == i. + * The last element is 0, corresponding to the 0 at the end of + * the sig_name list. + */ +#define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","ABRT","EMT","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","USR1","USR2","CHLD","PWR","WINCH","URG","IO","STOP","TSTP","CONT","TTIN","TTOU","VTALRM","PROF","XCPU","XFSZ","WAITING","LWP","FREEZE","THAW","RTMIN","NUM37","NUM38","NUM39","NUM40","NUM41","NUM42","RTMAX","IOT","CLD","POLL",0 /**/ +#define SIG_NUM 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,6,18,22,0 /**/ + +/* SITEARCH_EXP: + * This symbol contains the ~name expanded version of SITEARCH, to be used + * in programs that are not prepared to deal with ~ expansion at run-time. + */ +#define SITEARCH_EXP "/opt/perl/lib/site_perl/i86pc-solaris" /**/ + +/* VOIDFLAGS: + * This symbol indicates how much support of the void type is given by this + * compiler. What various bits mean: + * + * 1 = supports declaration of void + * 2 = supports arrays of pointers to functions returning void + * 4 = supports comparisons between pointers to void functions and + * addresses of void functions + * 8 = suports declaration of generic void pointers + * + * The package designer should define VOIDUSED to indicate the requirements + * of the package. This can be done either by #defining VOIDUSED before + * including config.h, or by defining defvoidused in Myinit.U. If the + * latter approach is taken, only those flags will be tested. If the + * level of void support necessary is not present, defines void to int. + */ +#ifndef VOIDUSED +#define VOIDUSED 15 +#endif +#define VOIDFLAGS 15 +#if (VOIDFLAGS & VOIDUSED) != VOIDUSED +#define void int /* is void to be avoided? */ +#define M_VOID /* Xenix strikes again */ +#endif #endif diff --git a/config_h.SH b/config_h.SH old mode 100755 new mode 100644 index f76b0446ed..1d17167165 --- a/config_h.SH +++ b/config_h.SH @@ -25,7 +25,7 @@ sed <config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' * that running config_h.SH again will wipe out any changes you've made. * For a more permanent change edit config.sh and rerun config_h.SH. * - * \$Id: Config_h.U,v 3.0.1.3 1995/01/30 14:25:39 ram Exp $ + * \$Id: Config_h.U,v 3.0.1.4 1995/09/25 09:10:49 ram Exp $ */ /* Configuration time: $cf_time @@ -42,12 +42,6 @@ sed <config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #define MEM_ALIGNBYTES $alignbytes /**/ -/* ARCHLIB_EXP: - * This symbol contains the ~name expanded version of ARCHLIB, to be used - * in programs that are not prepared to deal with ~ expansion at run-time. - */ -#$d_archlib ARCHLIB_EXP "$archlibexp" /**/ - /* BIN: * This symbol holds the path of the bin directory where the package will * be installed. Program must be prepared to deal with ~name substitution. @@ -57,9 +51,6 @@ sed <config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' /* CAT2: * This macro catenates 2 tokens together. */ -/* STRINGIFY: - * This macro surrounds its token with double quotes. - */ #if $cpp_stuff == 1 #define CAT2(a,b)a/**/b #define CAT3(a,b,c)a/**/b/**/c @@ -1299,12 +1290,6 @@ sed <config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' #define RD_NODATA $rd_nodata #$d_eofnblk EOF_NONBLOCK -/* PRIVLIB_EXP: - * This symbol contains the ~name expanded version of PRIVLIB, to be used - * in programs that are not prepared to deal with ~ expansion at run-time. - */ -#define PRIVLIB_EXP "$privlibexp" /**/ - /* CAN_PROTOTYPE: * If defined, this macro indicates that the C compiler can handle * function prototypes. @@ -1387,6 +1372,12 @@ sed <config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #define LOC_SED "$full_sed" /**/ +/* ARCHLIB_EXP: + * This symbol contains the ~name expanded version of ARCHLIB, to be used + * in programs that are not prepared to deal with ~ expansion at run-time. + */ +#$d_archlib ARCHLIB_EXP "$archlibexp" /**/ + /* BYTEORDER: * This symbol hold the hexadecimal constant defined in byteorder, * i.e. 0x1234 or 0x4321, etc... @@ -1441,6 +1432,12 @@ sed <config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' #$i_dbm I_DBM /**/ #$i_rpcsvcdbm I_RPCSVC_DBM /**/ +/* I_LOCALE: + * This symbol, if defined, indicates to the C program that it should + * include . + */ +#$i_locale I_LOCALE /**/ + /* I_SYS_STAT: * This symbol, if defined, indicates to the C program that it should * include . @@ -1468,40 +1465,55 @@ sed <config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$d_mymalloc MYMALLOC /**/ +/* OLDARCHLIB_EXP: + * This symbol contains the ~name expanded version of OLDARCHLIB, to be + * used in programs that are not prepared to deal with ~ expansion at + * run-time. + */ +#$d_oldarchlib OLDARCHLIB_EXP "$oldarchlibexp" /**/ + +/* PRIVLIB_EXP: + * This symbol contains the ~name expanded version of PRIVLIB, to be used + * in programs that are not prepared to deal with ~ expansion at run-time. + */ +#define PRIVLIB_EXP "$privlibexp" /**/ + /* SIG_NAME: - * This symbol contains a list of signal names in order. This is intended + * This symbol contains a list of signal names in order of + * signal number. This is intended * to be used as a static array initialization, like this: * char *sig_name[] = { SIG_NAME }; * The signals in the list are separated with commas, and each signal * is surrounded by double quotes. There is no leading SIG in the signal - * name, i.e. SIGQUIT is known as "QUIT". Duplicates are allowed. + * name, i.e. SIGQUIT is known as "QUIT". + * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn, + * etc., where nn is the actual signal number (e.g. NUM37). * The signal number for sig_name[i] is stored in sig_num[i]. * The last element is 0 to terminate the list with a NULL. This * corresponds to the 0 at the end of the sig_num list. - * See SIG_NUM and SIG_MAX. */ -#define SIG_NAME "`echo $sig_name | sed 's/ /","/g'`",0 /**/ - /* SIG_NUM: - * This symbol contains a list of signal number, in the same order as the + * This symbol contains a list of signal numbers, in the same order as the * SIG_NAME list. It is suitable for static array initialization, as in: * int sig_num[] = { SIG_NUM }; * The signals in the list are separated with commas, and the indices * within that list and the SIG_NAME list match, so it's easy to compute * the signal name from a number or vice versa at the price of a small - * dynamic linear lookup. Duplicates are allowed, so you can't assume - * sig_num[i] == i. Instead, the signal number corresponding to - * sig_name[i] is sig_number[i]. - * The last element is 0, corresponding to the 0 at the end of - * the sig_name list. + * dynamic linear lookup. + * Duplicates are allowed, but are moved to the end of the list. + * The signal number corresponding to sig_name[i] is sig_number[i]. + * if (i < NSIG) then sig_number[i] == i. + * The last element is 0, corresponding to the 0 at the end of + * the sig_name list. */ +#define SIG_NAME "`echo $sig_name | sed 's/ /","/g'`",0 /**/ #define SIG_NUM `echo $sig_num 0 | sed 's/ /,/g'` /**/ -/* SITELIB_EXP: - * This symbol contains the ~name expanded version of SITELIB, to be used +/* SITEARCH_EXP: + * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#$d_sitelib SITELIB_EXP "$sitelibexp" /**/ +#define SITEARCH_EXP "$sitearchexp" /**/ /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this diff --git a/configure b/configure old mode 100644 new mode 100755 diff --git a/cop.h b/cop.h index 3953dd47b9..88bed59c1c 100644 --- a/cop.h +++ b/cop.h @@ -42,8 +42,9 @@ struct block_sub { #define PUSHFORMAT(cx) \ cx->blk_sub.cv = cv; \ cx->blk_sub.gv = gv; \ + cx->blk_sub.hasargs = 0; \ cx->blk_sub.dfoutgv = defoutgv; \ - cx->blk_sub.hasargs = 0; + (void)SvREFCNT_inc(cx->blk_sub.dfoutgv) #define POPSUB(cx) \ if (cx->blk_sub.hasargs) { /* put back old @_ */ \ @@ -56,7 +57,8 @@ struct block_sub { } #define POPFORMAT(cx) \ - defoutgv = cx->blk_sub.dfoutgv; + setdefout(cx->blk_sub.dfoutgv); \ + SvREFCNT_dec(cx->blk_sub.dfoutgv); /* eval context */ struct block_eval { @@ -103,9 +105,7 @@ struct block_loop { cx->blk_loop.itersave = *cx->blk_loop.itervar; #define POPLOOP(cx) \ - newsp = stack_base + cx->blk_loop.resetsp; \ - if (cx->blk_loop.itervar) \ - *cx->blk_loop.itervar = cx->blk_loop.itersave; + newsp = stack_base + cx->blk_loop.resetsp; /* context common to subroutines, evals and loops */ struct block { @@ -172,6 +172,7 @@ struct subst { I32 sbu_maxiters; I32 sbu_safebase; I32 sbu_once; + I32 sbu_oldsave; char * sbu_orig; SV * sbu_dstr; SV * sbu_targ; @@ -184,6 +185,7 @@ struct subst { #define sb_maxiters cx_u.cx_subst.sbu_maxiters #define sb_safebase cx_u.cx_subst.sbu_safebase #define sb_once cx_u.cx_subst.sbu_once +#define sb_oldsave cx_u.cx_subst.sbu_oldsave #define sb_orig cx_u.cx_subst.sbu_orig #define sb_dstr cx_u.cx_subst.sbu_dstr #define sb_targ cx_u.cx_subst.sbu_targ @@ -197,6 +199,7 @@ struct subst { cx->sb_maxiters = maxiters, \ cx->sb_safebase = safebase, \ cx->sb_once = once, \ + cx->sb_oldsave = oldsave, \ cx->sb_orig = orig, \ cx->sb_dstr = dstr, \ cx->sb_targ = targ, \ @@ -231,3 +234,4 @@ struct context { #define G_DISCARD 2 /* Call FREETMPS. */ #define G_EVAL 4 /* Assume eval {} around subroutine call. */ #define G_NOARGS 8 /* Don't construct a @_ array. */ +#define G_KEEPERR 16 /* Append errors to $@ rather than overwriting it */ diff --git a/doio.c b/doio.c index 1a5c786ca6..c01c14e9b8 100644 --- a/doio.c +++ b/doio.c @@ -344,7 +344,7 @@ register GV *gv; if (inplace) { TAINT_PROPER("inplace open"); if (strEQ(oldname,"-")) { - defoutgv = gv_fetchpv("STDOUT",TRUE,SVt_PVIO); + setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO)); return IoIFP(GvIOp(gv)); } #ifndef FLEXFILENAMES @@ -423,7 +423,7 @@ register GV *gv; do_close(gv,FALSE); continue; } - defoutgv = argvoutgv; + setdefout(argvoutgv); lastfd = fileno(IoIFP(GvIOp(argvoutgv))); (void)Fstat(lastfd,&statbuf); #ifdef HAS_FCHMOD @@ -448,7 +448,7 @@ register GV *gv; } if (inplace) { (void)do_close(argvoutgv,FALSE); - defoutgv = gv_fetchpv("STDOUT",TRUE,SVt_PVIO); + setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO)); } return Nullfp; } diff --git a/doop.c b/doop.c index b18972469a..d8615995c4 100644 --- a/doop.c +++ b/doop.c @@ -319,6 +319,10 @@ register SV **sarg; } /* end of switch, copy results */ *t = ch; + if (xs == buf && xlen >= sizeof(buf)) { /* Ooops! */ + fputs("panic: sprintf overflow - memory corrupted!\n",stderr); + my_exit(1); + } SvGROW(sv, SvCUR(sv) + (f - s) + xlen + 1 + pre + post); sv_catpvn(sv, s, f - s); if (pre) { @@ -530,7 +534,6 @@ SV *right; (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1); } SvCUR_set(sv, len); - *SvEND(sv) = '\0'; (void)SvPOK_only(sv); #ifdef LIBERAL if (len >= sizeof(long)*4 && @@ -600,6 +603,8 @@ SV *right; sv_catpvn(sv, rsave + len, rightlen - len); else if (leftlen > len) sv_catpvn(sv, lsave + len, leftlen - len); + else + *SvEND(sv) = '\0'; break; } } diff --git a/emacs/cperl-mode b/emacs/cperl-mode deleted file mode 100644 index eb4aae2ab6..0000000000 --- a/emacs/cperl-mode +++ /dev/null @@ -1,710 +0,0 @@ -Article 15212 of comp.lang.perl: -Path: netlabs!news.cerf.net!usc!howland.reston.ans.net!spool.mu.edu!umn.edu!news-feed-2.peachnet.edu!concert!duke!khera -From: khera@cs.duke.edu (Vivek Khera) -Newsgroups: comp.lang.perl -Subject: cperl-mode.el -Message-ID: -Date: 21 Oct 93 18:08:51 GMT -Sender: news@duke.cs.duke.edu -Organization: Duke University CS Dept., Durham, NC -Lines: 694 -Nntp-Posting-Host: thneed.cs.duke.edu -X-Md4-Signature: 40dd9bccfb99794a9da2ee891b5bf557 -X-Md5-Signature: e4baa8cf00c94092ebf9712514e4696b - -Since I've received requests to do so, I'm posting the cperl-mode.el -file. This allows Emacs (both version 18 and 19) to do nice things -when editing Perl code. Indentation works well, and it doesn't get -confused like the perl-mode.el that comes with Emacs 19. - -Install this file as cperl-mode.el, and add the following to your -.emacs file: - -(autoload 'perl-mode "cperl-mode" "alternate mode for editing Perl programs" t) - -This cperl-mode.el is not exactly the same as when it was originally -posted here. I made the following changes: perl-mode is an alias for -cperl-mode, and the major mode name is perl-mode, not cperl-mode. -This is so it is easier to use with Emacs 19. I suppose one could -install this as perl-mode.el and then not have to put the autoload -line in (for Emacs 19). - -Anyway, I'm not maintaining this, so don't send me bugs. - ---cut here-- -;;; From: olson@mcs.anl.gov (Bob Olson) -;;; Newsgroups: comp.lang.perl -;;; Subject: cperl-mode: Another perl mode for Gnuemacs -;;; Date: 14 Aug 91 15:20:01 GMT - -;; Perl code editing commands for Emacs -;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc. - -;; This file is part of GNU Emacs. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor -;; accepts responsibility to anyone for the consequences of using it -;; or for whether it serves any particular purpose or works at all, -;; unless he says so in writing. Refer to the GNU Emacs General Public -;; License for full details. - -;; Everyone is granted permission to copy, modify and redistribute -;; GNU Emacs, but only under the conditions described in the -;; GNU Emacs General Public License. A copy of this license is -;; supposed to have been given to you along with GNU Emacs so you -;; can know your rights and responsibilities. It should be in a -;; file named COPYING. Among other things, the copyright notice -;; and this notice must be preserved on all copies. - - -(defvar cperl-mode-abbrev-table nil - "Abbrev table in use in Cperl-mode buffers.") -(define-abbrev-table 'cperl-mode-abbrev-table ()) - -(defvar cperl-mode-map () - "Keymap used in C mode.") -(if cperl-mode-map - () - (setq cperl-mode-map (make-sparse-keymap)) - (define-key cperl-mode-map "{" 'electric-cperl-brace) - (define-key cperl-mode-map "}" 'electric-cperl-brace) - (define-key cperl-mode-map ";" 'electric-cperl-semi) - (define-key cperl-mode-map ":" 'electric-cperl-terminator) - (define-key cperl-mode-map "\e\C-h" 'mark-cperl-function) - (define-key cperl-mode-map "\e\C-q" 'indent-cperl-exp) - (define-key cperl-mode-map "\177" 'backward-delete-char-untabify) - (define-key cperl-mode-map "\t" 'cperl-indent-command)) - -(autoload 'cperl-macro-expand "cmacexp" - "Display the result of expanding all C macros occurring in the region. -The expansion is entirely correct because it uses the C preprocessor." - t) - -(defvar cperl-mode-syntax-table nil - "Syntax table in use in Cperl-mode buffers.") - -(if cperl-mode-syntax-table - () - (setq cperl-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\\ "\\" cperl-mode-syntax-table) - (modify-syntax-entry ?/ ". 14" cperl-mode-syntax-table) - (modify-syntax-entry ?* ". 23" cperl-mode-syntax-table) - (modify-syntax-entry ?+ "." cperl-mode-syntax-table) - (modify-syntax-entry ?- "." cperl-mode-syntax-table) - (modify-syntax-entry ?= "." cperl-mode-syntax-table) - (modify-syntax-entry ?% "." cperl-mode-syntax-table) - (modify-syntax-entry ?< "." cperl-mode-syntax-table) - (modify-syntax-entry ?> "." cperl-mode-syntax-table) - (modify-syntax-entry ?& "." cperl-mode-syntax-table) - (modify-syntax-entry ?| "." cperl-mode-syntax-table)) - - -(defvar cperl-indent-level 2 - "*Indentation of C statements with respect to containing block.") -(defvar cperl-brace-imaginary-offset 0 - "*Imagined indentation of a C open brace that actually follows a statement.") -(defvar cperl-brace-offset 0 - "*Extra indentation for braces, compared with other text in same context.") -(defvar cperl-argdecl-indent 5 - "*Indentation level of declarations of C function arguments.") -(defvar cperl-label-offset -2 - "*Offset of C label lines and case statements relative to usual indentation.") -(defvar cperl-continued-statement-offset 2 - "*Extra indent for lines not starting new statements.") -(defvar cperl-continued-brace-offset 0 - "*Extra indent for substatements that start with open-braces. -This is in addition to cperl-continued-statement-offset.") - -(defvar cperl-auto-newline nil - "*Non-nil means automatically newline before and after braces, -and after colons and semicolons, inserted in C code.") - -(defvar cperl-tab-always-indent t - "*Non-nil means TAB in C mode should always reindent the current line, -regardless of where in the line point is when the TAB command is used.") - -;; provide an alias for working with emacs 19. the perl-mode that comes -;; with it is really bad, and this lets us seamlessly replace it. -(fset 'perl-mode 'cperl-mode) -(defun cperl-mode () - "Major mode for editing C code. -Expression and list commands understand all C brackets. -Tab indents for C code. -Comments are delimited with /* ... */. -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. -\\{cperl-mode-map} -Variables controlling indentation style: - cperl-tab-always-indent - Non-nil means TAB in C mode should always reindent the current line, - regardless of where in the line point is when the TAB command is used. - cperl-auto-newline - Non-nil means automatically newline before and after braces, - and after colons and semicolons, inserted in C code. - cperl-indent-level - Indentation of C statements within surrounding block. - The surrounding block's indentation is the indentation - of the line on which the open-brace appears. - cperl-continued-statement-offset - Extra indentation given to a substatement, such as the - then-clause of an if or body of a while. - cperl-continued-brace-offset - Extra indentation given to a brace that starts a substatement. - This is in addition to cperl-continued-statement-offset. - cperl-brace-offset - Extra indentation for line if it starts with an open brace. - cperl-brace-imaginary-offset - An open brace following other text is treated as if it were - this far to the right of the start of its line. - cperl-argdecl-indent - Indentation level of declarations of C function arguments. - cperl-label-offset - Extra indentation for line that is a label, or case or default. - -Settings for K&R and BSD indentation styles are - cperl-indent-level 5 8 - cperl-continued-statement-offset 5 8 - cperl-brace-offset -5 -8 - cperl-argdecl-indent 0 8 - cperl-label-offset -5 -8 - -Turning on C mode calls the value of the variable cperl-mode-hook with no args, -if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map cperl-mode-map) - (setq major-mode 'perl-mode) - (setq mode-name "CPerl") - (setq local-abbrev-table cperl-mode-abbrev-table) - (set-syntax-table cperl-mode-syntax-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "^$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'cperl-indent-line) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'comment-start) - (setq comment-start "# ") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column 32) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "# *") - (make-local-variable 'comment-indent-hook) - (setq comment-indent-hook 'cperl-comment-indent) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (run-hooks 'cperl-mode-hook)) - -;; This is used by indent-for-comment -;; to decide how much to indent a comment in C code -;; based on its context. -(defun cperl-comment-indent () - (if (looking-at "^#") - 0 ;Existing comment at bol stays there. - (save-excursion - (skip-chars-backward " \t") - (max (1+ (current-column)) ;Else indent at comment column - comment-column)))) ; except leave at least one space. - -(defun electric-cperl-brace (arg) - "Insert character and correct line's indentation." - (interactive "P") - (let (insertpos) - (if (and (not arg) - (eolp) - (or (save-excursion - (skip-chars-backward " \t") - (bolp)) - (if cperl-auto-newline (progn (cperl-indent-line) (newline) t) nil))) - (progn - (insert last-command-char) - (cperl-indent-line) - (if cperl-auto-newline - (progn - (newline) - ;; (newline) may have done auto-fill - (setq insertpos (- (point) 2)) - (cperl-indent-line))) - (save-excursion - (if insertpos (goto-char (1+ insertpos))) - (delete-char -1)))) - (if insertpos - (save-excursion - (goto-char insertpos) - (self-insert-command (prefix-numeric-value arg))) - (self-insert-command (prefix-numeric-value arg))))) - -(defun electric-cperl-semi (arg) - "Insert character and correct line's indentation." - (interactive "P") - (if cperl-auto-newline - (electric-cperl-terminator arg) - (self-insert-command (prefix-numeric-value arg)))) - -(defun electric-cperl-terminator (arg) - "Insert character and correct line's indentation." - (interactive "P") - (let (insertpos (end (point))) - (if (and (not arg) (eolp) - (not (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (or (= (following-char) ?#) - ;; Colon is special only after a label, or case .... - ;; So quickly rule out most other uses of colon - ;; and do no indentation for them. - (and (eq last-command-char ?:) - (not (looking-at "case[ \t]")) - (save-excursion - (forward-word 1) - (skip-chars-forward " \t") - (< (point) end))) - (progn - (beginning-of-defun) - (let ((pps (parse-partial-sexp (point) end))) - (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))))) - (progn - (insert last-command-char) - (cperl-indent-line) - (and cperl-auto-newline - (not (cperl-inside-parens-p)) - (progn - (newline) - (setq insertpos (- (point) 2)) - (cperl-indent-line))) - (save-excursion - (if insertpos (goto-char (1+ insertpos))) - (delete-char -1)))) - (if insertpos - (save-excursion - (goto-char insertpos) - (self-insert-command (prefix-numeric-value arg))) - (self-insert-command (prefix-numeric-value arg))))) - -(defun cperl-inside-parens-p () - (condition-case () - (save-excursion - (save-restriction - (narrow-to-region (point) - (progn (beginning-of-defun) (point))) - (goto-char (point-max)) - (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\())) - (error nil))) - -(defun cperl-indent-command (&optional whole-exp) - (interactive "P") - "Indent current line as C code, or in some cases insert a tab character. -If cperl-tab-always-indent is non-nil (the default), always indent current line. -Otherwise, indent the current line only if point is at the left margin -or in the line's indentation; otherwise insert a tab. - -A numeric argument, regardless of its value, -means indent rigidly all the lines of the expression starting after point -so that this line becomes properly indented. -The relative indentation among the lines of the expression are preserved." - (if whole-exp - ;; If arg, always indent this line as C - ;; and shift remaining lines of expression the same amount. - (let ((shift-amt (cperl-indent-line)) - beg end) - (save-excursion - (if cperl-tab-always-indent - (beginning-of-line)) - (setq beg (point)) - (forward-sexp 1) - (setq end (point)) - (goto-char beg) - (forward-line 1) - (setq beg (point))) - (if (> end beg) - (indent-code-rigidly beg end shift-amt "#"))) - (if (and (not cperl-tab-always-indent) - (save-excursion - (skip-chars-backward " \t") - (not (bolp)))) - (insert-tab) - (cperl-indent-line)))) - -(defun cperl-indent-line () - "Indent current line as C code. -Return the amount the indentation changed by." - (let ((indent (calculate-cperl-indent nil)) - beg shift-amt - (case-fold-search nil) - (pos (- (point-max) (point)))) - (beginning-of-line) - (setq beg (point)) - (cond ((eq indent nil) - (setq indent (current-indentation))) - ((eq indent t) - (setq indent (calculate-cperl-indent-within-comment))) - ((looking-at "[ \t]*#") - (setq indent 0)) - (t - (skip-chars-forward " \t") - (if (listp indent) (setq indent (car indent))) - (cond ((or (looking-at "case[ \t]") - (and (looking-at "[A-Za-z]") - (save-excursion - (forward-sexp 1) - (looking-at ":")))) - (setq indent (max 1 (+ indent cperl-label-offset)))) - ((and (looking-at "else\\b") - (not (looking-at "else\\s_"))) - (setq indent (save-excursion - (cperl-backward-to-start-of-if) - (current-indentation)))) - ((= (following-char) ?}) - (setq indent (- indent cperl-indent-level))) - ((= (following-char) ?{) - (setq indent (+ indent cperl-brace-offset)))))) - (skip-chars-forward " \t") - (setq shift-amt (- indent (current-column))) - (if (zerop shift-amt) - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - (delete-region beg (point)) - (indent-to indent) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos)))) - shift-amt)) - -(defun calculate-cperl-indent (&optional parse-start) - "Return appropriate indentation for current line as C code. -In usual case returns an integer: the column to indent to. -Returns nil if line starts inside a string, t if in a comment." - (save-excursion - (beginning-of-line) - (let ((indent-point (point)) - (case-fold-search nil) - state - containing-sexp) - (if parse-start - (goto-char parse-start) - (beginning-of-defun)) - (while (< (point) indent-point) - (setq parse-start (point)) - (setq state (parse-partial-sexp (point) indent-point 0)) - (setq containing-sexp (car (cdr state)))) - (cond ((or (nth 3 state) (nth 4 state)) - ;; return nil or t if should not change this line - (nth 4 state)) - ((null containing-sexp) - ;; Line is at top level. May be data or function definition, - ;; or may be function argument declaration. - ;; Indent like the previous top level line - ;; unless that ends in a closeparen without semicolon, - ;; in which case this line is the first argument decl. - (goto-char indent-point) - (skip-chars-forward " \t") - (if (= (following-char) ?{) - 0 ; Unless it starts a function body - (cperl-backward-to-noncomment (or parse-start (point-min))) - ;; Look at previous line that's at column 0 - ;; to determine whether we are in top-level decls - ;; or function's arg decls. Set basic-indent accordinglu. - (let ((basic-indent - (save-excursion - (re-search-backward "^[^ \^L\t\n#]" nil 'move) - (if (and (looking-at "\\sw\\|\\s_") - (looking-at ".*(") - (progn - (goto-char (1- (match-end 0))) - (forward-sexp 1) - (and (< (point) indent-point) - (not (memq (following-char) - '(?\, ?\;)))))) - cperl-argdecl-indent 0)))) - ;; Now add a little if this is a continuation line. - (+ basic-indent (if (or (bobp) - (memq (preceding-char) '(?\) ?\; ?\}))) - 0 cperl-continued-statement-offset))))) - ((/= (char-after containing-sexp) ?{) - ;; line is expression, not statement: - ;; indent to just after the surrounding open. - (goto-char (1+ containing-sexp)) - (current-column)) - (t - ;; Statement level. Is it a continuation or a new statement? - ;; Find previous non-comment character. - (goto-char indent-point) - (cperl-backward-to-noncomment containing-sexp) - ;; Back up over label lines, since they don't - ;; affect whether our line is a continuation. - (while (or (eq (preceding-char) ?\,) - (and (eq (preceding-char) ?:) - (or (eq (char-after (- (point) 2)) ?\') - (memq (char-syntax (char-after (- (point) 2))) - '(?w ?_))))) - (if (eq (preceding-char) ?\,) - (cperl-backward-to-start-of-continued-exp containing-sexp)) - (beginning-of-line) - (cperl-backward-to-noncomment containing-sexp)) - ;; Now we get the answer. - (if (not (memq (preceding-char) '(nil ?\, ?\; ?\} ?\{))) - ;; This line is continuation of preceding line's statement; - ;; indent cperl-continued-statement-offset more than the - ;; previous line of the statement. - (progn - (cperl-backward-to-start-of-continued-exp containing-sexp) - (+ cperl-continued-statement-offset (current-column) - (if (save-excursion (goto-char indent-point) - (skip-chars-forward " \t") - (eq (following-char) ?{)) - cperl-continued-brace-offset 0))) - ;; This line starts a new statement. - ;; Position following last unclosed open. - (goto-char containing-sexp) - ;; Is line first statement after an open-brace? - (or - ;; If no, find that first statement and indent like it. - (save-excursion - (forward-char 1) - (let ((colon-line-end 0)) - (while (progn (skip-chars-forward " \t\n") - (looking-at "#\\|/\\*\\|case[ \t\n].*:\\|[a-zA-Z0-9_$]*:")) - ;; Skip over comments and labels following openbrace. - (cond ((= (following-char) ?\#) - (forward-line 1)) - ((= (following-char) ?\/) - (forward-char 2) - (search-forward "*/" nil 'move)) - ;; case or label: - (t - (save-excursion (end-of-line) - (setq colon-line-end (point))) - (search-forward ":")))) - ;; The first following code counts - ;; if it is before the line we want to indent. - (and (< (point) indent-point) - (if (> colon-line-end (point)) - (- (current-indentation) cperl-label-offset) - (current-column))))) - ;; If no previous statement, - ;; indent it relative to line brace is on. - ;; For open brace in column zero, don't let statement - ;; start there too. If cperl-indent-level is zero, - ;; use cperl-brace-offset + cperl-continued-statement-offset instead. - ;; For open-braces not the first thing in a line, - ;; add in cperl-brace-imaginary-offset. - (+ (if (and (bolp) (zerop cperl-indent-level)) - (+ cperl-brace-offset cperl-continued-statement-offset) - cperl-indent-level) - ;; Move back over whitespace before the openbrace. - ;; If openbrace is not first nonwhite thing on the line, - ;; add the cperl-brace-imaginary-offset. - (progn (skip-chars-backward " \t") - (if (bolp) 0 cperl-brace-imaginary-offset)) - ;; If the openbrace is preceded by a parenthesized exp, - ;; move to the beginning of that; - ;; possibly a different line - (progn - (if (eq (preceding-char) ?\)) - (forward-sexp -1)) - ;; Get initial indentation of the line we are on. - (current-indentation)))))))))) - -(defun calculate-cperl-indent-within-comment () - "Return the indentation amount for line, assuming that -the current line is to be regarded as part of a block comment." - (let (end star-start) - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (setq star-start (= (following-char) ?\*)) - (skip-chars-backward " \t\n") - (setq end (point)) - (beginning-of-line) - (skip-chars-forward " \t") - (and (re-search-forward "/\\*[ \t]*" end t) - star-start - (goto-char (1+ (match-beginning 0)))) - (current-column)))) - - -(defun cperl-backward-to-noncomment (lim) - (let (opoint stop) - (while (not stop) - (skip-chars-backward " \t\n\f" lim) - (setq opoint (point)) - (if (and (>= (point) (+ 2 lim)) - (save-excursion - (forward-char -2) - (looking-at "\\*/"))) - (search-backward "/*" lim 'move) - (beginning-of-line) - (skip-chars-forward " \t") - (setq stop (or (not (looking-at "#")) (<= (point) lim))) - (if stop (goto-char opoint) - (beginning-of-line)))))) - -(defun cperl-backward-to-start-of-continued-exp (lim) - (if (= (preceding-char) ?\)) - (forward-sexp -1)) - (beginning-of-line) - (if (<= (point) lim) - (goto-char (1+ lim))) - (skip-chars-forward " \t")) - -(defun cperl-backward-to-start-of-if (&optional limit) - "Move to the start of the last ``unbalanced'' if." - (or limit (setq limit (save-excursion (beginning-of-defun) (point)))) - (let ((if-level 1) - (case-fold-search nil)) - (while (not (zerop if-level)) - (backward-sexp 1) - (cond ((looking-at "else\\b") - (setq if-level (1+ if-level))) - ((looking-at "if\\b") - (setq if-level (1- if-level))) - ((< (point) limit) - (setq if-level 0) - (goto-char limit)))))) - - -(defun mark-cperl-function () - "Put mark at end of C function, point at beginning." - (interactive) - (push-mark (point)) - (end-of-defun) - (push-mark (point)) - (beginning-of-defun) - (backward-paragraph)) - -(defun indent-cperl-exp () - "Indent each line of the C grouping following point." - (interactive) - (let ((indent-stack (list nil)) - (contain-stack (list (point))) - (case-fold-search nil) - restart outer-loop-done inner-loop-done state ostate - this-indent last-sexp - at-else at-brace - (opoint (point)) - (next-depth 0)) - (save-excursion - (forward-sexp 1)) - (save-excursion - (setq outer-loop-done nil) - (while (and (not (eobp)) (not outer-loop-done)) - (setq last-depth next-depth) - ;; Compute how depth changes over this line - ;; plus enough other lines to get to one that - ;; does not end inside a comment or string. - ;; Meanwhile, do appropriate indentation on comment lines. - (setq innerloop-done nil) - (while (and (not innerloop-done) - (not (and (eobp) (setq outer-loop-done t)))) - (setq ostate state) - (setq state (parse-partial-sexp (point) (progn (end-of-line) (point)) - nil nil state)) - (setq next-depth (car state)) - (if (and (car (cdr (cdr state))) - (>= (car (cdr (cdr state))) 0)) - (setq last-sexp (car (cdr (cdr state))))) - (if (or (nth 4 ostate)) - (cperl-indent-line)) - (if (or (nth 3 state)) - (forward-line 1) - (setq innerloop-done t))) - (if (<= next-depth 0) - (setq outer-loop-done t)) - (if outer-loop-done - nil - ;; If this line had ..))) (((.. in it, pop out of the levels - ;; that ended anywhere in this line, even if the final depth - ;; doesn't indicate that they ended. - (while (> last-depth (nth 6 state)) - (setq indent-stack (cdr indent-stack) - contain-stack (cdr contain-stack) - last-depth (1- last-depth))) - (if (/= last-depth next-depth) - (setq last-sexp nil)) - ;; Add levels for any parens that were started in this line. - (while (< last-depth next-depth) - (setq indent-stack (cons nil indent-stack) - contain-stack (cons nil contain-stack) - last-depth (1+ last-depth))) - (if (null (car contain-stack)) - (setcar contain-stack (or (car (cdr state)) - (save-excursion (forward-sexp -1) - (point))))) - (forward-line 1) - (skip-chars-forward " \t") - (if (eolp) - nil - (if (and (car indent-stack) - (>= (car indent-stack) 0)) - ;; Line is on an existing nesting level. - ;; Lines inside parens are handled specially. - (if (/= (char-after (car contain-stack)) ?{) - (setq this-indent (car indent-stack)) - ;; Line is at statement level. - ;; Is it a new statement? Is it an else? - ;; Find last non-comment character before this line - (save-excursion - (setq at-else (looking-at "else\\W")) - (setq at-brace (= (following-char) ?{)) - (cperl-backward-to-noncomment opoint) - (if (not (memq (preceding-char) '(nil ?\, ?\; ?} ?: ?{))) - ;; Preceding line did not end in comma or semi; - ;; indent this line cperl-continued-statement-offset - ;; more than previous. - (progn - (cperl-backward-to-start-of-continued-exp (car contain-stack)) - (setq this-indent - (+ cperl-continued-statement-offset (current-column) - (if at-brace cperl-continued-brace-offset 0)))) - ;; Preceding line ended in comma or semi; - ;; use the standard indent for this level. - (if at-else - (progn (cperl-backward-to-start-of-if opoint) - (setq this-indent (current-indentation))) - (setq this-indent (car indent-stack)))))) - ;; Just started a new nesting level. - ;; Compute the standard indent for this level. - (let ((val (calculate-cperl-indent - (if (car indent-stack) - (- (car indent-stack)))))) - (setcar indent-stack - (setq this-indent val)))) - ;; Adjust line indentation according to its contents - (if (or (looking-at "case[ \t]") - (and (looking-at "[A-Za-z]") - (save-excursion - (forward-sexp 1) - (looking-at ":")))) - (setq this-indent (max 1 (+ this-indent cperl-label-offset)))) - (if (= (following-char) ?}) - (setq this-indent (- this-indent cperl-indent-level))) - (if (= (following-char) ?{) - (setq this-indent (+ this-indent cperl-brace-offset))) - ;; Put chosen indentation into effect. - (or (= (current-column) this-indent) - (= (following-char) ?\#) - (progn - (delete-region (point) (progn (beginning-of-line) (point))) - (indent-to this-indent))) - ;; Indent any comment following the text. - (or (looking-at comment-start-skip) - (if (re-search-forward comment-start-skip (save-excursion (end-of-line) (point)) t) - (progn (indent-for-comment) (beginning-of-line))))))))) -; (message "Indenting C expression...done") - ) ---cut here-- --- -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= -Vivek Khera, Gradual Student/Systems Guy Department of Computer Science -Internet: khera@cs.duke.edu Box 90129 - RIPEM/PGP/MIME spoken here Durham, NC 27708-0129 (919)660-6528 - - diff --git a/emacs/cperl-mode.el b/emacs/cperl-mode.el new file mode 100644 index 0000000000..5a400ef2b7 --- /dev/null +++ b/emacs/cperl-mode.el @@ -0,0 +1,2566 @@ +;;; This code started from the following message of long time ago (IZ): + +;;; From: olson@mcs.anl.gov (Bob Olson) +;;; Newsgroups: comp.lang.perl +;;; Subject: cperl-mode: Another perl mode for Gnuemacs +;;; Date: 14 Aug 91 15:20:01 GMT + +;; Perl code editing commands for Emacs +;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc. + +;; This file is not (yet) part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Corrections made by Ilya Zakharevich ilya@math.mps.ohio-state.edu +;;; XEmacs changes by Peter Arius arius@informatik.uni-erlangen.de + +;; $Id: cperl-mode.el,v 1.15 1995/10/07 22:23:37 ilya Exp ilya $ + +;;; To use this mode put the following into your .emacs file: + +;; (autoload 'perl-mode "cperl-mode" "alternate mode for editing Perl programs" t) + +;;; You can either fine-tune the bells and whistles of this mode or +;;; bulk enable them by putting + +;; (setq cperl-hairy t) + +;;; in your .emacs file. (Emacs rulers do not consider it politically +;;; correct to make whistles enabled by default.) + +;;; Additional useful commands to put into your .emacs file: + +;; (setq auto-mode-alist +;; (append '(("\\.[pP][Llm]$" . perl-mode)) auto-mode-alist )) +;; (setq interpreter-mode-alist (append interpreter-mode-alist +;; '(("miniperl" . perl-mode)))) + +;;; The mode information (on C-h m) provides customization help. +;;; If you use font-lock feature of this mode, it is advisable to use +;;; eather lazy-lock-mode or fast-lock-mode (available on ELisp +;;; archive in files lazy-lock.el and fast-lock.el). I prefer lazy-lock. + +;;; Faces used now: three faces for first-class and second-class keywords +;;; and control flow words, one for each: comments, string, labels, +;;; functions definitions and packages, arrays, hashes, and variable +;;; definitions. If you do not see all these faces, your font-lock does +;;; not define them, so you need to define them manually. Maybe you have +;;; an obsolete font-lock from 19.28 or earlier. Upgrade. + +;;; If you have grayscale monitor, and do not have the variable +;;; font-lock-display-type bound to 'grayscale, insert + +;;; (setq font-lock-display-type 'grayscale) + +;;; to your .emacs file. + +;;;; This mode supports font-lock, imenu and compile-mode. In the +;;;; hairy version font-lock is on, but you should activate imenu +;;;; yourself (note that compile-mode is not standard yet). Well, you +;;;; can use imenu from keyboard anyway (M-x imenu), but it is better +;;;; to bind it like that: + +;; (define-key global-map [M-S-down-mouse-3] 'imenu) + +;;; In fact the version of font-lock that this version supports can be +;;; much newer than the version you actually have. This means that a +;;; lot of faces can be set up, but are not visible on your screen +;;; since the coloring rules for this faces are not defined. + +;;; Tips: ======================================== + +;;; get newest version of this package from +;;; ftp://ftp.math.ohio-state.edu/pub/users/ilya/lisp +;;; and/or +;;; ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl + +;;; Get support packages font-lock-extra.el, imenu-go.el from the same place. +;;; (Look for other files there too... ;-) Get a patch for imenu.el. + +;;; Get perl5-info from +;; http://www.metronet.com:70/9/perlinfo/perl5/manual/perl5-info.tar.gz +;;; (may be quite obsolete, but still useful). + +;;; If you use imenu-go, run imenu on perl5-info buffer (can do it from +;;; CPerl menu). + +;;;; Known problems: ======================================== + +;;; The very new pod +;;; features. The rules are: + +;;; /\n=/ should start comment mode, and +;;; /\n=cut\s/ should stop comment mode + +;;; Expansion of keywords tries to detect this kind of commenting, but +;;; a "=" that starts a perl row (as in multiline comment and here +;;; document) can confuse it. + +;;; The main trick (to +;;; make $ a "backslash") makes constructions like ${aaa} look like +;;; unbalanced braces. The only trick I can think out is to insert it as +;;; $ {aaa} (legal in perl5, not in perl4). + +;;;; Known non-problems: ======================================== + +;;; Perl quoting rules are too hard for CPerl. Try to help it: add +;;; comments with embedded quotes to fix CPerl misunderstandings: + +;;; $a='500$'; # '; + +;;; You won't need it too often. + +;;; Now the indentation code is pretty wise. If you still get wrong +;;; indentation in situation that you think the code should be able to +;;; parse, try: + +;;; a) Check what Emacs thinks about balance of your parentheses. +;;; b) Supply the code to me (IZ). + +;;; Updates: ======================================== + +;;; Made less hairy by default: parentheses not electric, +;;; linefeed not magic. Bug with abbrev-mode corrected. + +;;;; After 1.4: +;;; Better indentation: +;;; subs inside braces should work now, +;;; Toplevel braces obey customization. +;;; indent-for-comment knows about bad cases, cperl-indent-for-comment +;;; moves cursor to a correct place. +;;; cperl-indent-exp written from the scratch! Slow... (quadratic!) :-( +;;; (50 secs on DB::DB (sub of 430 lines), 486/66) +;;; Minor documentation fixes. +;;; Imenu understands packages as prefixes (including nested). +;;; Hairy options can be switched off one-by-one by setting to null. +;;; Names of functions and variables changed to conform to `cperl-' style. + +;;;; After 1.5: +;;; Some bugs with indentation of labels (and embedded subs) corrected. +;;; `cperl-indent-region' done (slow :-()). +;;; `cperl-fill-paragraph' done. +;;; Better package support for `imenu'. +;;; Progress indicator for indentation (with `imenu' loaded). +;;; `Cperl-set' was busted, now setting the individual hairy option +;;; should be better. + +;;;; After 1.6: +;;; `cperl-set-style' done. +;;; `cperl-check-syntax' done. +;;; Menu done. +;;; New config variables `cperl-close-paren-offset' and `cperl-comment-column'. +;;; Bugs with `cperl-auto-newline' corrected. +;;; `cperl-electric-lbrace' can work with `cperl-auto-newline' in situation +;;; like $hash{. + +;;;; 1.7 XEmacs (arius@informatik.uni-erlangen.de): +;;; - use `next-command-event', if `next-command-events' does not exist +;;; - use `find-face' as def. of `is-face' +;;; - corrected def. of `x-color-defined-p' +;;; - added const defs for font-lock-comment-face, +;;; font-lock-keyword-face and font-lock-function-name-face +;;; - added def. of font-lock-variable-name-face +;;; - added (require 'easymenu) inside an `eval-when-compile' +;;; - replaced 4-argument `substitute-key-definition' with ordinary +;;; `define-key's +;;; - replaced `mark-active' in menu definition by `cperl-use-region-p'. +;;; Todo (at least): +;;; - use emacs-vers.el (http://www.cs.utah.edu/~eeide/emacs/emacs-vers.el.gz) +;;; for portable code? +;;; - should `cperl-mode' do a +;;; (if (featurep 'easymenu) (easy-menu-add cperl-menu)) +;;; or should this be left to the user's `cperl-mode-hook'? + +;;; Some bugs introduced by the above fix corrected (IZ ;-). +;;; Some bugs under XEmacs introduced by the correction corrected. + +;;; Some more can remain since there are two many different variants. +;;; Please feedback! + +;;; We do not support fontification of arrays and hashes under +;;; obsolete font-lock any more. Upgrade. + +;;;; after 1.8 Minor bug with parentheses. +;;;; after 1.9 Improvements from Joe Marzot. +;;;; after 1.10 +;;; Does not need easymenu to compile under XEmacs. +;;; `vc-insert-headers' should work better. +;;; Should work with 19.29 and 19.12. +;;; Small improvements to fontification. +;;; Expansion of keywords does not depend on C-? being backspace. + +;;; after 1.10+ +;;; 19.29 and 19.12 supported. +;;; `cperl-font-lock-enhanced' deprecated. Use font-lock-extra.el. +;;; Support for font-lock-extra.el. + +;;;; After 1.11: +;;; Tools submenu. +;;; Support for perl5-info. +;;; `imenu-go-find-at-position' in Tools requires imenu-go.el (see hints above) +;;; Imenu entries do not work with stock imenu.el. Patch sent to maintainers. +;;; Fontifies `require a if b;', __DATA__. +;;; Arglist for auto-fill-mode was incorrect. + +;;;; After 1.12: +;;; `cperl-lineup-step' and `cperl-lineup' added: lineup constructions +;;; vertically. +;;; `cperl-do-auto-fill' updated for 19.29 style. +;;; `cperl-info-on-command' now has a default. +;;; Workaround for broken C-h on XEmacs. +;;; VC strings escaped. +;;; C-h f now may prompt for function name instead of going on, +;;; controlled by `cperl-info-on-command-no-prompt'. + +;;;; After 1.13: +;;; Msb buffer list includes perl files +;;; Indent-for-comment uses indent-to +;;; Can write tag files using etags. + +;;;; After 1.14: +;;; Recognizes (tries to ;-) {...} which are not blocks during indentation. +;;; `cperl-close-paren-offset' affects ?\] too (and ?\} if not block) + +(defvar cperl-extra-newline-before-brace nil + "*Non-nil means that if, elsif, while, until, else, for, foreach +and do constructs look like: + + if () + { + } + +instead of: + + if () { + } +") +(defvar cperl-indent-level 2 + "*Indentation of CPerl statements with respect to containing block.") +(defvar cperl-lineup-step nil + "*`cperl-lineup' will always lineup at multiple of this number. +If `nil', the value of `cperl-indent-level' will be used.") +(defvar cperl-brace-imaginary-offset 0 + "*Imagined indentation of a Perl open brace that actually follows a statement. +An open brace following other text is treated as if it were this far +to the right of the start of its line.") +(defvar cperl-brace-offset 0 + "*Extra indentation for braces, compared with other text in same context.") +(defvar cperl-label-offset -2 + "*Offset of CPerl label lines relative to usual indentation.") +(defvar cperl-min-label-indent 1 + "*Minimal offset of CPerl label lines.") +(defvar cperl-continued-statement-offset 2 + "*Extra indent for lines not starting new statements.") +(defvar cperl-continued-brace-offset 0 + "*Extra indent for substatements that start with open-braces. +This is in addition to cperl-continued-statement-offset.") +(defvar cperl-close-paren-offset -1 + "*Extra indent for substatements that start with close-parenthesis.") + +(defvar cperl-auto-newline nil + "*Non-nil means automatically newline before and after braces, +and after colons and semicolons, inserted in CPerl code.") + +(defvar cperl-tab-always-indent t + "*Non-nil means TAB in CPerl mode should always reindent the current line, +regardless of where in the line point is when the TAB command is used.") + +(defvar cperl-font-lock nil + "*Non-nil (and non-null) means CPerl buffers will use font-lock-mode. +Can be overwritten by `cperl-hairy' if nil.") + +(defvar cperl-electric-lbrace-space nil + "*Non-nil (and non-null) means { after $ in CPerl buffers should be preceeded by ` '. +Can be overwritten by `cperl-hairy' if nil.") + +(defvar cperl-electric-parens "" + "*List of parentheses that should be electric in CPerl, or null. +Can be overwritten by `cperl-hairy' to \"({[<\" if not 'null.") + +(defvar cperl-electric-linefeed nil + "*If true, LFD should be hairy in CPerl, otherwise C-c LFD is hairy. +In any case these two mean plain and hairy linefeeds together. +Can be overwritten by `cperl-hairy' if nil.") + +(defvar cperl-electric-keywords nil + "*Not-nil (and non-null) means keywords are electric in CPerl. +Can be overwritten by `cperl-hairy' if nil.") + +(defvar cperl-hairy nil + "*Not-nil means all the bells and whistles are enabled in CPerl.") + +(defvar cperl-comment-column 32 + "*Column to put comments in CPerl (use \\[cperl-indent]' to lineup with code).") + +(defvar cperl-vc-header-alist '((SCCS "$sccs = '%W\%' ;") + (RCS "$rcs = ' $Id\$ ' ;")) + "*What to use as `vc-header-alist' in CPerl.") + +(defvar cperl-info-on-command-no-prompt nil + "*Not-nil (and non-null) means not to prompt on C-h f. +The opposite behaviour is always available if prefixed with C-c. +Can be overwritten by `cperl-hairy' if nil.") + + +;;; Portability stuff: + +(defsubst cperl-xemacs-p () + (string-match "XEmacs\\|Lucid" emacs-version)) + +(defvar del-back-ch (car (append (where-is-internal 'delete-backward-char) + (where-is-internal 'backward-delete-char-untabify))) + "Character generated by key bound to delete-backward-char.") + +(and (vectorp del-back-ch) (= (length del-back-ch) 1) + (setq del-back-ch (aref del-back-ch 0))) + +(if (cperl-xemacs-p) + ;; "Active regions" are on: use region only if active + ;; "Active regions" are off: use region unconditionally + (defun cperl-use-region-p () + (if zmacs-regions (mark) t)) + (defun cperl-use-region-p () + (if transient-mark-mode mark-active t))) + +(defsubst cperl-enable-font-lock () + (or (cperl-xemacs-p) window-system)) + +(if (boundp 'unread-command-events) + (if (cperl-xemacs-p) + (defun cperl-putback-char (c) ; XEmacs >= 19.12 + (setq unread-command-events (list (character-to-event c)))) + (defun cperl-putback-char (c) ; Emacs 19 + (setq unread-command-events (list c)))) + (defun cperl-putback-char (c) ; XEmacs <= 19.11 + (setq unread-command-event (character-to-event c)))) + +(or (fboundp 'uncomment-region) + (defun uncomment-region (beg end) + (interactive "r") + (comment-region beg end -1))) + +;;; Probably it is too late to set these guys already, but it can help later: + +(setq auto-mode-alist + (append '(("\\.[pP][Llm]$" . perl-mode)) auto-mode-alist )) +(and (boundp 'interpreter-mode-alist) + (setq interpreter-mode-alist (append interpreter-mode-alist + '(("miniperl" . perl-mode))))) +(if (fboundp 'eval-when-compile) + (eval-when-compile + (condition-case nil + (require 'imenu) + (error nil)) + (condition-case nil + (require 'easymenu) + (error nil)) + ;; Calling `cperl-enable-font-lock' below doesn't compile on XEmacs, + ;; macros instead of defsubsts don't work on Emacs, so we do the + ;; expansion manually. Any other suggestions? + (if (or (string-match "XEmacs\\|Lucid" emacs-version) + window-system) + (require 'font-lock)) + (require 'cl) + )) + +(defvar cperl-mode-abbrev-table nil + "Abbrev table in use in Cperl-mode buffers.") + +(add-hook 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-"))) + +(defvar cperl-mode-map () "Keymap used in CPerl mode.") + +(if cperl-mode-map nil + (setq cperl-mode-map (make-sparse-keymap)) + (define-key cperl-mode-map "{" 'cperl-electric-lbrace) + (define-key cperl-mode-map "[" 'cperl-electric-paren) + (define-key cperl-mode-map "(" 'cperl-electric-paren) + (define-key cperl-mode-map "<" 'cperl-electric-paren) + (define-key cperl-mode-map "}" 'cperl-electric-brace) + (define-key cperl-mode-map ";" 'cperl-electric-semi) + (define-key cperl-mode-map ":" 'cperl-electric-terminator) + (define-key cperl-mode-map "\C-j" 'newline-and-indent) + (define-key cperl-mode-map "\C-c\C-j" 'cperl-linefeed) + (define-key cperl-mode-map "\e\C-q" 'cperl-indent-exp) ; Usually not bound + ;;(define-key cperl-mode-map "\M-q" 'cperl-fill-paragraph) + ;;(define-key cperl-mode-map "\e;" 'cperl-indent-for-comment) + (define-key cperl-mode-map "\177" 'backward-delete-char-untabify) + (define-key cperl-mode-map "\t" 'cperl-indent-command) + (if (cperl-xemacs-p) + ;; don't clobber the backspace binding: + (define-key cperl-mode-map [(control h) f] 'cperl-info-on-command) + (define-key cperl-mode-map "\C-hf" 'cperl-info-on-command)) + (if (cperl-xemacs-p) + ;; don't clobber the backspace binding: + (define-key cperl-mode-map [(control c) (control h) f] + 'cperl-info-on-current-command) + (define-key cperl-mode-map "\C-c\C-hf" 'cperl-info-on-current-command)) + (if (and (cperl-xemacs-p) + (<= emacs-minor-version 11) (<= emacs-major-version 19)) + (progn + ;; substitute-key-definition is usefulness-deenhanced... + (define-key cperl-mode-map "\M-q" 'cperl-fill-paragraph) + (define-key cperl-mode-map "\e;" 'cperl-indent-for-comment) + (define-key cperl-mode-map "\e\C-\\" 'cperl-indent-region)) + (substitute-key-definition + 'indent-sexp 'cperl-indent-exp + cperl-mode-map global-map) + (substitute-key-definition + 'fill-paragraph 'cperl-fill-paragraph + cperl-mode-map global-map) + (substitute-key-definition + 'indent-region 'cperl-indent-region + cperl-mode-map global-map) + (substitute-key-definition + 'indent-for-comment 'cperl-indent-for-comment + cperl-mode-map global-map))) + +(condition-case nil + (progn + (require 'easymenu) + (easy-menu-define cperl-menu cperl-mode-map "Menu for CPerl mode" + '("Perl" + ["Beginning of function" beginning-of-defun t] + ["End of function" end-of-defun t] + ["Mark function" mark-defun t] + ["Indent expression" cperl-indent-exp t] + ["Fill paragraph/comment" cperl-fill-paragraph t] + ["Line up a construction" cperl-lineup (cperl-use-region-p)] + "----" + ["Indent region" cperl-indent-region (cperl-use-region-p)] + ["Comment region" comment-region (cperl-use-region-p)] + ["Uncomment region" uncomment-region (cperl-use-region-p)] + "----" + ["Run" mode-compile (fboundp 'mode-compile)] + ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill) + (get-buffer "*compilation*"))] + ["Next error" next-error (get-buffer "*compilation*")] + ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)] + "----" + ["Debugger" perldb t] + "----" + ("Tools" + ["Imenu" imenu (fboundp 'imenu)] + ["Imenu on info" cperl-imenu-on-info (featurep 'imenu)] + ("Tags" + ["Create tags for current file" cperl-etags t] + ["Add tags for current file" (cperl-etags t) t] + ["Create tags for Perl files in directory" (cperl-etags nil t) t] + ["Add tags for Perl files in directory" (cperl-etags t t) t] + ["Create tags for Perl files in (sub)directories" + (cperl-etags nil 'recursive) t] + ["Add tags for Perl files in (sub)directories" + (cperl-etags t 'recursive) t]) + ["Define word at point" imenu-go-find-at-position + (fboundp 'imenu-go-find-at-position)] + ["Help on function" cperl-info-on-command t] + ["Help on function at point" cperl-info-on-current-command t]) + ("Indent styles..." + ["GNU" (cperl-set-style "GNU") t] + ["C++" (cperl-set-style "C++") t] + ["FSF" (cperl-set-style "FSF") t] + ["BSD" (cperl-set-style "BSD") t] + ["Whitesmith" (cperl-set-style "Whitesmith") t])))) + (error nil)) + +(autoload 'c-macro-expand "cmacexp" + "Display the result of expanding all C macros occurring in the region. +The expansion is entirely correct because it uses the C preprocessor." + t) + +(defvar cperl-mode-syntax-table nil + "Syntax table in use in Cperl-mode buffers.") + +(if cperl-mode-syntax-table + () + (setq cperl-mode-syntax-table (make-syntax-table)) + (modify-syntax-entry ?\\ "\\" cperl-mode-syntax-table) + (modify-syntax-entry ?/ "." cperl-mode-syntax-table) + (modify-syntax-entry ?* "." cperl-mode-syntax-table) + (modify-syntax-entry ?+ "." cperl-mode-syntax-table) + (modify-syntax-entry ?- "." cperl-mode-syntax-table) + (modify-syntax-entry ?= "." cperl-mode-syntax-table) + (modify-syntax-entry ?% "." cperl-mode-syntax-table) + (modify-syntax-entry ?< "." cperl-mode-syntax-table) + (modify-syntax-entry ?> "." cperl-mode-syntax-table) + (modify-syntax-entry ?& "." cperl-mode-syntax-table) + (modify-syntax-entry ?$ "\\" cperl-mode-syntax-table) + (modify-syntax-entry ?\n ">" cperl-mode-syntax-table) + (modify-syntax-entry ?# "<" cperl-mode-syntax-table) + (modify-syntax-entry ?' "\"" cperl-mode-syntax-table) + (modify-syntax-entry ?` "\"" cperl-mode-syntax-table) + (modify-syntax-entry ?_ "w" cperl-mode-syntax-table) + (modify-syntax-entry ?| "." cperl-mode-syntax-table)) + + + +;; Make customization possible "in reverse" +;;(defun cperl-set (symbol to) +;; (or (eq (symbol-value symbol) 'null) (set symbol to))) +(defsubst cperl-val (symbol &optional default hairy) + (cond + ((eq (symbol-value symbol) 'null) default) + (cperl-hairy (or hairy t)) + (t (symbol-value symbol)))) + +;; provide an alias for working with emacs 19. the perl-mode that comes +;; with it is really bad, and this lets us seamlessly replace it. +(fset 'perl-mode 'cperl-mode) +(defun cperl-mode () + "Major mode for editing Perl code. +Expression and list commands understand all C brackets. +Tab indents for Perl code. +Paragraphs are separated by blank lines only. +Delete converts tabs to spaces as it moves back. + +Various characters in Perl almost always come in pairs: {}, (), [], +sometimes <>. When the user types the first, she gets the second as +well, with optional special formatting done on {}. (Disabled by +default.) You can always quote (with \\[quoted-insert]) the left +\"paren\" to avoid the expansion. The processing of < is special, +since most the time you mean \"less\". Cperl mode tries to guess +whether you want to type pair <>, and inserts is if it +appropriate. You can set `cperl-electric-parens' to the string that +contains the parenths from the above list you want to be electrical. + +CPerl mode provides expansion of the Perl control constructs: + if, else, elsif, unless, while, until, for, and foreach. +=========(Disabled by default, see `cperl-electric-keywords'.) +The user types the keyword immediately followed by a space, which causes +the construct to be expanded, and the user is positioned where she is most +likely to want to be. +eg. when the user types a space following \"if\" the following appears in +the buffer: + if () { or if () + } { + } +and the cursor is between the parentheses. The user can then type some +boolean expression within the parens. Having done that, typing +\\[cperl-linefeed] places you, appropriately indented on a new line +between the braces. If CPerl decides that you want to insert +\"English\" style construct like + bite if angry; +it will not do any expansion. See also help on variable +`cperl-extra-newline-before-brace'. + +\\[cperl-linefeed] is a convinience replacement for typing carriage +return. It places you in the next line with proper indentation, or if +you type it inside the inline block of control construct, like + foreach (@lines) {print; print} +and you are on a boundary of a statement inside braces, it will +transform the construct into a multiline and will place you into an +apporpriately indented blank line. If you need a usual +`newline-and-indent' behaviour, it is on \\[newline-and-indent], +see documentation on `cperl-electric-linefeed'. + +\\{cperl-mode-map} + +Setting the variable `cperl-font-lock' to t switches on +font-lock-mode, `cperl-electric-lbrace-space' to t switches on +electric space between $ and {, `cperl-electric-parens' is the string +that contains parentheses that should be electric in CPerl, setting +`cperl-electric-keywords' enables electric expansion of control +structures in CPerl. `cperl-electric-linefeed' governs which one of +two linefeed behavior is preferable. You can enable all these options +simultaneously (recommended mode of use) by setting `cperl-hairy' to +t. In this case you can switch separate options off by setting them +to `null'. + +If your site has perl5 documentation in info format, you can use commands +\\[cperl-info-on-current-command] and \\[cperl-info-on-command] to access it. +These keys run commands `cperl-info-on-current-command' and +`cperl-info-on-command', which one is which is controlled by variable +`cperl-info-on-command-no-prompt' (in turn affected by `cperl-hairy'). + +Variables controlling indentation style: + `cperl-tab-always-indent' + Non-nil means TAB in CPerl mode should always reindent the current line, + regardless of where in the line point is when the TAB command is used. + `cperl-auto-newline' + Non-nil means automatically newline before and after braces, + and after colons and semicolons, inserted in Perl code. + `cperl-indent-level' + Indentation of Perl statements within surrounding block. + The surrounding block's indentation is the indentation + of the line on which the open-brace appears. + `cperl-continued-statement-offset' + Extra indentation given to a substatement, such as the + then-clause of an if, or body of a while, or just a statement continuation. + `cperl-continued-brace-offset' + Extra indentation given to a brace that starts a substatement. + This is in addition to `cperl-continued-statement-offset'. + `cperl-brace-offset' + Extra indentation for line if it starts with an open brace. + `cperl-brace-imaginary-offset' + An open brace following other text is treated as if it the line started + this far to the right of the actual line indentation. + `cperl-label-offset' + Extra indentation for line that is a label. + `cperl-min-label-indent' + Minimal indentation for line that is a label. + +Settings for K&R and BSD indentation styles are + `cperl-indent-level' 5 8 + `cperl-continued-statement-offset' 5 8 + `cperl-brace-offset' -5 -8 + `cperl-label-offset' -5 -8 + +If `cperl-indent-level' is 0, the statement after opening brace in column 0 is indented on `cperl-brace-offset'+`cperl-continued-statement-offset'. + +Turning on CPerl mode calls the hooks in the variable `cperl-mode-hook' +with no args." + (interactive) + (kill-all-local-variables) + ;;(if cperl-hairy + ;; (progn + ;; (cperl-set 'cperl-font-lock cperl-hairy) + ;; (cperl-set 'cperl-electric-lbrace-space cperl-hairy) + ;; (cperl-set 'cperl-electric-parens "{[(<") + ;; (cperl-set 'cperl-electric-keywords cperl-hairy) + ;; (cperl-set 'cperl-electric-linefeed cperl-hairy))) + (use-local-map cperl-mode-map) + (if (cperl-val 'cperl-electric-linefeed) + (progn + (local-set-key "\C-J" 'cperl-linefeed) + (local-set-key "\C-C\C-J" 'newline-and-indent))) + (if (cperl-val 'cperl-info-on-command-no-prompt) + (progn + (if (cperl-xemacs-p) + ;; don't clobber the backspace binding: + (local-set-key [(control h) f] 'cperl-info-on-current-command) + (local-set-key "\C-hf" 'cperl-info-on-current-command)) + (if (cperl-xemacs-p) + ;; don't clobber the backspace binding: + (local-set-key [(control c) (control h) f] + 'cperl-info-on-command) + (local-set-key "\C-c\C-hf" 'cperl-info-on-command)))) + (setq major-mode 'perl-mode) + (setq mode-name "CPerl") + (if (not cperl-mode-abbrev-table) + (let ((prev-a-c abbrevs-changed)) + (define-abbrev-table 'cperl-mode-abbrev-table '( + ("if" "if" cperl-electric-keyword 0) + ("elsif" "elsif" cperl-electric-keyword 0) + ("while" "while" cperl-electric-keyword 0) + ("until" "until" cperl-electric-keyword 0) + ("unless" "unless" cperl-electric-keyword 0) + ("else" "else" cperl-electric-else 0) + ("for" "for" cperl-electric-keyword 0) + ("foreach" "foreach" cperl-electric-keyword 0) + ("do" "do" cperl-electric-keyword 0))) + (setq abbrevs-changed prev-a-c))) + (setq local-abbrev-table cperl-mode-abbrev-table) + (abbrev-mode (if (cperl-val 'cperl-electric-keywords) 1 0)) + (set-syntax-table cperl-mode-syntax-table) + (make-local-variable 'paragraph-start) + (setq paragraph-start (concat "^$\\|" page-delimiter)) + (make-local-variable 'paragraph-separate) + (setq paragraph-separate paragraph-start) + (make-local-variable 'paragraph-ignore-fill-prefix) + (setq paragraph-ignore-fill-prefix t) + (make-local-variable 'indent-line-function) + (setq indent-line-function 'cperl-indent-line) + (make-local-variable 'require-final-newline) + (setq require-final-newline t) + (make-local-variable 'comment-start) + (setq comment-start "# ") + (make-local-variable 'comment-end) + (setq comment-end "") + (make-local-variable 'comment-column) + (setq comment-column cperl-comment-column) + (make-local-variable 'comment-start-skip) + (setq comment-start-skip "#+ *") + (make-local-variable 'defun-prompt-regexp) + (setq defun-prompt-regexp "[ \t]*sub\\s +\\([^ \t\n{;]+\\)\\s *") + (make-local-variable 'comment-indent-function) + (setq comment-indent-function 'cperl-comment-indent) + (make-local-variable 'parse-sexp-ignore-comments) + (setq parse-sexp-ignore-comments t) + (make-local-variable 'indent-region-function) + (setq indent-region-function 'cperl-indent-region) + ;;(setq auto-fill-function 'cperl-do-auto-fill) ; Need to switch on and off! + (make-local-variable 'imenu-create-index-function) + (setq imenu-create-index-function + (function imenu-example--create-perl-index)) + (make-local-variable 'vc-header-alist) + (setq vc-header-alist cperl-vc-header-alist) + (or (fboundp 'cperl-old-auto-fill-mode) + (progn + (fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode)) + (defun auto-fill-mode (&optional arg) + (interactive "P") + (cperl-old-auto-fill-mode arg) + (and auto-fill-function (eq major-mode 'perl-mode) + (setq auto-fill-function 'cperl-do-auto-fill))))) + (if (cperl-enable-font-lock) + (if (cperl-val 'cperl-font-lock) (font-lock-mode 1))) + (and (boundp 'msb-menu-cond) + (not cperl-msb-fixed) + (cperl-msb-fix)) + (run-hooks 'cperl-mode-hook)) + +;; Fix for msb.el +(defvar cperl-msb-fixed nil) + +(defun cperl-msb-fix () + ;; Adds perl files to msb menu, supposes that msb is already loaded + (setq cperl-msb-fixed t) + (let* ((l (length msb-menu-cond)) + (last (nth (1- l) msb-menu-cond)) + (precdr (nthcdr (- l 2) msb-menu-cond)) ; cdr of this is last + (handle (1- (nth 1 last)))) + (setcdr precdr (list + (list + '(eq major-mode 'perl-mode) + handle + "Perl Files (%d)") + last)))) + +;; This is used by indent-for-comment +;; to decide how much to indent a comment in CPerl code +;; based on its context. Do fallback if comment is found wrong. + +(defvar cperl-wrong-comment) + +(defun cperl-comment-indent () + (let ((p (point)) (c (current-column)) was) + (if (looking-at "^#") 0 ; Existing comment at bol stays there. + ;; Wrong comment found + (save-excursion + (setq was (cperl-to-comment-or-eol)) + (if (= (point) p) + (progn + (skip-chars-backward " \t") + (max (1+ (current-column)) ; Else indent at comment column + comment-column)) + (if was nil + (insert comment-start) + (backward-char (length comment-start))) + (setq cperl-wrong-comment t) + (indent-to comment-column 1) ; Indent minimum 1 + c))))) ; except leave at least one space. + +;;;(defun cperl-comment-indent-fallback () +;;; "Is called if the standard comment-search procedure fails. +;;;Point is at start of real comment." +;;; (let ((c (current-column)) target cnt prevc) +;;; (if (= c comment-column) nil +;;; (setq cnt (skip-chars-backward "[ \t]")) +;;; (setq target (max (1+ (setq prevc +;;; (current-column))) ; Else indent at comment column +;;; comment-column)) +;;; (if (= c comment-column) nil +;;; (delete-backward-char cnt) +;;; (while (< prevc target) +;;; (insert "\t") +;;; (setq prevc (current-column))) +;;; (if (> prevc target) (progn (delete-char -1) (setq prevc (current-column)))) +;;; (while (< prevc target) +;;; (insert " ") +;;; (setq prevc (current-column))))))) + +(defun cperl-indent-for-comment () + "Substite for `indent-for-comment' in CPerl." + (interactive) + (let (cperl-wrong-comment) + (indent-for-comment) + (if cperl-wrong-comment + (progn (cperl-to-comment-or-eol) + (forward-char (length comment-start)))))) + +(defun cperl-electric-brace (arg &optional only-before) + "Insert character and correct line's indentation. +If ONLY-BEFORE and `cperl-auto-newline', will insert newline before the +place (even in empty line), but not after." + (interactive "P") + (let (insertpos) + (if (and (not arg) ; No args, end (of empty line or auto) + (eolp) + (or (and (null only-before) + (save-excursion + (skip-chars-backward " \t") + (bolp))) + (if cperl-auto-newline + (progn (cperl-indent-line) (newline) t) nil))) + (progn + (if cperl-auto-newline + (setq insertpos (point))) + (insert last-command-char) + (cperl-indent-line) + (if (and cperl-auto-newline (null only-before)) + (progn + (newline) + (cperl-indent-line))) + (save-excursion + (if insertpos (progn (goto-char insertpos) + (search-forward (make-string + 1 last-command-char)) + (setq insertpos (1- (point))))) + (delete-char -1)))) + (if insertpos + (save-excursion + (goto-char insertpos) + (self-insert-command (prefix-numeric-value arg))) + (self-insert-command (prefix-numeric-value arg))))) + +(defun cperl-electric-lbrace (arg) + "Insert character, correct line's indentation, correct quoting by space." + (interactive "P") + (let (pos after (cperl-auto-newline cperl-auto-newline)) + (and (cperl-val 'cperl-electric-lbrace-space) + (eq (preceding-char) ?$) + (save-excursion + (skip-chars-backward "$") + (looking-at "\\(\\$\\$\\)*\\$\\([^\\$]\\|$\\)")) + (insert ? )) + (if (cperl-after-expr) nil (setq cperl-auto-newline nil)) + (cperl-electric-brace arg) + (and (eq last-command-char ?{) + (memq last-command-char + (append (cperl-val 'cperl-electric-parens "" "([{<") nil)) + (setq last-command-char ?} pos (point)) + (progn (cperl-electric-brace arg t) + (goto-char pos))))) + +(defun cperl-electric-paren (arg) + "Insert a matching pair of parentheses." + (interactive "P") + (let ((beg (save-excursion (beginning-of-line) (point)))) + (if (and (memq last-command-char + (append (cperl-val 'cperl-electric-parens "" "([{<") nil)) + (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)) + ;;(not (save-excursion (search-backward "#" beg t))) + (if (eq last-command-char ?<) + (cperl-after-expr nil "{};(,:=") + 1)) + (progn + (insert last-command-char) + (insert (cdr (assoc last-command-char '((?{ .?}) + (?[ . ?]) + (?( . ?)) + (?< . ?>))))) + (forward-char -1)) + (insert last-command-char) + ))) + +(defun cperl-electric-keyword () + "Insert a construction appropriate after a keyword." + (let ((beg (save-excursion (beginning-of-line) (point)))) + (and (save-excursion + (backward-sexp 1) + (cperl-after-expr nil "{};:")) + (save-excursion + (not + (re-search-backward + "[#\"'`]\\|\\" + beg t))) + (save-excursion (or (not (re-search-backward "^=" nil t)) + (looking-at "=cut"))) + (progn + (cperl-indent-line) + ;;(insert " () {\n}") + (cond + (cperl-extra-newline-before-brace + (insert " ()\n") + (insert "{") + (cperl-indent-line) + (insert "\n") + (cperl-indent-line) + (insert "\n}")) + (t + (insert " () {\n}")) + ) + (or (looking-at "[ \t]\\|$") (insert " ")) + (cperl-indent-line) + (search-backward ")") + (cperl-putback-char del-back-ch))))) + +(defun cperl-electric-else () + "Insert a construction appropriate after a keyword." + (let ((beg (save-excursion (beginning-of-line) (point)))) + (and (save-excursion + (backward-sexp 1) + (cperl-after-expr nil "{};:")) + (save-excursion + (not + (re-search-backward + "[#\"'`]\\|\\" + beg t))) + (save-excursion (or (not (re-search-backward "^=" nil t)) + (looking-at "=cut"))) + (progn + (cperl-indent-line) + ;;(insert " {\n\n}") + (cond + (cperl-extra-newline-before-brace + (insert "\n") + (insert "{") + (cperl-indent-line) + (insert "\n\n}")) + (t + (insert " {\n\n}")) + ) + (or (looking-at "[ \t]\\|$") (insert " ")) + (cperl-indent-line) + (forward-line -1) + (cperl-indent-line) + (cperl-putback-char del-back-ch))))) + +(defun cperl-linefeed () + "Go to end of line, open a new line and indent appropriately." + (interactive) + (let ((beg (save-excursion (beginning-of-line) (point))) + (end (save-excursion (end-of-line) (point))) + (pos (point)) start) + (if (and ; Check if we need to split: + ; i.e., on a boundary and inside "{...}" + ;;(not (search-backward "\\(^\\|[^$\\\\]\\)#" beg t)) + (save-excursion (cperl-to-comment-or-eol) + (>= (point) pos)) + (or (save-excursion + (skip-chars-backward " \t" beg) + (forward-char -1) + (looking-at "[;{]")) + (looking-at "[ \t]*}") + (re-search-forward "\\=[ \t]*;" end t)) + (save-excursion + (and + (eq (car (parse-partial-sexp pos end -1)) -1) + (looking-at "[ \t]*\\($\\|#\\)") + ;;(setq finish (point-marker)) + (progn + (backward-sexp 1) + (setq start (point-marker)) + (<= start pos)) + ;;(looking-at "[^{}\n]*}[ \t]*$") ; Will fail if there are intervening {}'s + ;;(search-backward "{" beg t) + ;;(looking-at "{[^{}\n]*}[ \t]*$") + ))) + ;;(or (looking-at "[ \t]*}") ; and on a boundary of statements + ;; (save-excursion + ;; (skip-chars-backward " \t") + ;; (forward-char -1) + ;; (looking-at "[{;]")))) + (progn + (skip-chars-backward " \t") + (or (memq (preceding-char) (append ";{" nil)) + (insert ";")) + (insert "\n") + (forward-line -1) + (cperl-indent-line) + ;;(end-of-line) + ;;(search-backward "{" beg) + (goto-char start) + (or (looking-at "{[ \t]*$") ; If there is a statement + ; before, move it to separate line + (progn + (forward-char 1) + (insert "\n") + (cperl-indent-line))) + (forward-line 1) ; We are on the target line + (cperl-indent-line) + (beginning-of-line) + (or (looking-at "[ \t]*}[ \t]*$") ; If there is a statement + ; after, move it to separate line + (progn + (end-of-line) + (search-backward "}" beg) + (skip-chars-backward " \t") + (or (memq (preceding-char) (append ";{" nil)) + (insert ";")) + (insert "\n") + (cperl-indent-line) + (forward-line -1))) + (forward-line -1) ; We are on the line before target + (end-of-line) + (newline-and-indent)) + (end-of-line) ; else + (if (not (looking-at "\n[ \t]*$")) + (newline-and-indent) + (forward-line 1) + (cperl-indent-line))))) + +(defun cperl-electric-semi (arg) + "Insert character and correct line's indentation." + (interactive "P") + (if cperl-auto-newline + (cperl-electric-terminator arg) + (self-insert-command (prefix-numeric-value arg)))) + +(defun cperl-electric-terminator (arg) + "Insert character and correct line's indentation." + (interactive "P") + (let (insertpos (end (point))) + (if (and (not arg) (eolp) + (not (save-excursion + (beginning-of-line) + (skip-chars-forward " \t") + (or (= (following-char) ?#) + ;; Colon is special only after a label, or case .... + ;; So quickly rule out most other uses of colon + ;; and do no indentation for them. + (and (eq last-command-char ?:) + (not (looking-at "case[ \t]")) + (save-excursion + (forward-word 1) + (skip-chars-forward " \t") + (and (< (point) end) + (progn (goto-char (- end 1)) + (not (looking-at ":")))))) + (progn + (beginning-of-defun) + (let ((pps (parse-partial-sexp (point) end))) + (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))))) + (progn + (if cperl-auto-newline + (setq insertpos (point))) + (insert last-command-char) + (cperl-indent-line) + (if cperl-auto-newline + (progn + (newline) + (cperl-indent-line))) + (save-excursion + (if insertpos (progn (goto-char insertpos) + (search-forward (make-string + 1 last-command-char)) + (setq insertpos (1- (point))))) + (delete-char -1)))) + (if insertpos + (save-excursion + (goto-char insertpos) + (self-insert-command (prefix-numeric-value arg))) + (self-insert-command (prefix-numeric-value arg))))) + +(defun cperl-inside-parens-p () + (condition-case () + (save-excursion + (save-restriction + (narrow-to-region (point) + (progn (beginning-of-defun) (point))) + (goto-char (point-max)) + (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\())) + (error nil))) + +(defun cperl-indent-command (&optional whole-exp) + (interactive "P") + "Indent current line as Perl code, or in some cases insert a tab character. +If `cperl-tab-always-indent' is non-nil (the default), always indent current line. +Otherwise, indent the current line only if point is at the left margin +or in the line's indentation; otherwise insert a tab. + +A numeric argument, regardless of its value, +means indent rigidly all the lines of the expression starting after point +so that this line becomes properly indented. +The relative indentation among the lines of the expression are preserved." + (if whole-exp + ;; If arg, always indent this line as Perl + ;; and shift remaining lines of expression the same amount. + (let ((shift-amt (cperl-indent-line)) + beg end) + (save-excursion + (if cperl-tab-always-indent + (beginning-of-line)) + (setq beg (point)) + (forward-sexp 1) + (setq end (point)) + (goto-char beg) + (forward-line 1) + (setq beg (point))) + (if (> end beg) + (indent-code-rigidly beg end shift-amt "#"))) + (if (and (not cperl-tab-always-indent) + (save-excursion + (skip-chars-backward " \t") + (not (bolp)))) + (insert-tab) + (cperl-indent-line)))) + +(defun cperl-indent-line (&optional symbol) + "Indent current line as Perl code. +Return the amount the indentation changed by." + (let (indent + beg shift-amt + (case-fold-search nil) + (pos (- (point-max) (point)))) + (setq indent (cperl-calculate-indent nil symbol)) + (beginning-of-line) + (setq beg (point)) + (cond ((eq indent nil) + (setq indent (current-indentation))) + ;;((eq indent t) ; Never? + ;; (setq indent (cperl-calculate-indent-within-comment))) + ;;((looking-at "[ \t]*#") + ;; (setq indent 0)) + (t + (skip-chars-forward " \t") + (if (listp indent) (setq indent (car indent))) + (cond ((looking-at "[A-Za-z]+:[^:]") + (and (> indent 0) + (setq indent (max cperl-min-label-indent + (+ indent cperl-label-offset))))) + ;;((and (looking-at "els\\(e\\|if\\)\\b") + ;; (not (looking-at "else\\s_"))) + ;; (setq indent (save-excursion + ;; (cperl-backward-to-start-of-if) + ;; (current-indentation)))) + ((= (following-char) ?}) + (setq indent (- indent cperl-indent-level))) + ((memq (following-char) '(?\) ?\])) ; To line up with opening paren. + (setq indent (+ indent cperl-close-paren-offset))) + ((= (following-char) ?{) + (setq indent (+ indent cperl-brace-offset)))))) + (skip-chars-forward " \t") + (setq shift-amt (- indent (current-column))) + (if (zerop shift-amt) + (if (> (- (point-max) pos) (point)) + (goto-char (- (point-max) pos))) + (delete-region beg (point)) + (indent-to indent) + ;; If initial point was within line's indentation, + ;; position after the indentation. Else stay at same point in text. + (if (> (- (point-max) pos) (point)) + (goto-char (- (point-max) pos)))) + shift-amt)) + +(defsubst cperl-after-label () + ;; Returns true if the point is after label. Does not do save-excursion. + (and (eq (preceding-char) ?:) + (memq (char-syntax (char-after (- (point) 2))) + '(?w ?_)) + (progn + (backward-sexp) + (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:")))) + +(defun cperl-calculate-indent (&optional parse-start symbol) + "Return appropriate indentation for current line as Perl code. +In usual case returns an integer: the column to indent to. +Returns nil if line starts inside a string, t if in a comment." + (save-excursion + (beginning-of-line) + (let ((indent-point (point)) + (case-fold-search nil) + (char-after (save-excursion + (skip-chars-forward " \t") + (following-char))) + state start-indent start start-state moved + containing-sexp old-containing-sexp old-indent) + (or parse-start (null symbol) + (setq parse-start (symbol-value symbol) + start-state (cadr parse-start) + start-indent (nth 2 parse-start) + parse-start (car parse-start) + old-containing-sexp (nth 1 start-state))) + (if parse-start + (goto-char parse-start) + (beginning-of-defun)) + (if start-state nil + ;; Try to go out + (while (< (point) indent-point) + (setq start (point) parse-start start moved nil + state (parse-partial-sexp start indent-point -1)) + (if (> (car state) -1) nil + ;; The current line could start like }}}, so the indentation + ;; corresponds to a different level than what we reached + (setq moved t) + (beginning-of-line 2))) ; Go to the next line. + (if start ; Not at the start of file + (progn + (goto-char start) + (setq start-indent (current-indentation)) + (if moved ; Should correct... + (setq start-indent (- start-indent cperl-indent-level)))) + (setq start-indent 0))) + (if (< (point) indent-point) (setq parse-start (point))) + (or state (setq state (parse-partial-sexp + (point) indent-point -1 nil start-state))) + (setq containing-sexp + (or (car (cdr state)) + (and (>= (nth 6 state) 0) old-containing-sexp)) + old-containing-sexp nil start-state nil) +;; (while (< (point) indent-point) +;; (setq parse-start (point)) +;; (setq state (parse-partial-sexp (point) indent-point -1 nil start-state)) +;; (setq containing-sexp +;; (or (car (cdr state)) +;; (and (>= (nth 6 state) 0) old-containing-sexp)) +;; old-containing-sexp nil start-state nil)) + (if symbol (set symbol (list indent-point state start-indent))) + (goto-char indent-point) + (cond ((or (nth 3 state) (nth 4 state)) + ;; return nil or t if should not change this line + (nth 4 state)) + ((null containing-sexp) + ;; Line is at top level. May be data or function definition, + ;; or may be function argument declaration. + ;; Indent like the previous top level line + ;; unless that ends in a closeparen without semicolon, + ;; in which case this line is the first argument decl. + (skip-chars-forward " \t") + (+ start-indent + (if (= (following-char) ?{) cperl-continued-brace-offset 0) + (progn + (cperl-backward-to-noncomment (or parse-start (point-min))) + (skip-chars-backward " \t\f\n") + ;; Look at previous line that's at column 0 + ;; to determine whether we are in top-level decls + ;; or function's arg decls. Set basic-indent accordingly. + ;; Now add a little if this is a continuation line. + (if (or (bobp) + (memq (preceding-char) (append ");}" nil)) + (memq char-after (append ")]}" nil))) + 0 + cperl-continued-statement-offset)))) + ((/= (char-after containing-sexp) ?{) + ;; line is expression, not statement: + ;; indent to just after the surrounding open. + (goto-char (1+ containing-sexp)) + (current-column)) + ((progn + ;; Containing-expr starts with \{. Check whether it is a hash. + (goto-char containing-sexp) + (cperl-backward-to-noncomment (or parse-start (point-min))) + (skip-chars-backward " \t\n\f") + (not + (or (memq (preceding-char) (append ";)}$@&%" nil)) ; Or label! + ; Label may be mixed up with `$blah :' + (save-excursion (cperl-after-label)) + (and (eq (char-syntax (preceding-char)) ?w) + (progn + (backward-sexp) + (or (looking-at "\\sw+[ \t\n\f]*{") ; Method call syntax + (progn + (skip-chars-backward " \t\n\f") + (and (eq (char-syntax (preceding-char)) ?w) + (progn + (backward-sexp) + (looking-at + "sub[ \t]+\\sw+[ \t\n\f]*{")))))))))) + (goto-char containing-sexp) + (+ (current-column) 1 ; Correct indentation of trailing ?\} + (if (eq char-after ?\}) (+ cperl-indent-level + cperl-close-paren-offset) + 0))) + (t + ;; Statement level. Is it a continuation or a new statement? + ;; Find previous non-comment character. + (goto-char indent-point) + (cperl-backward-to-noncomment containing-sexp) + ;; Back up over label lines, since they don't + ;; affect whether our line is a continuation. + (while (or (eq (preceding-char) ?\,) + (and (eq (preceding-char) ?:) + (or ;;(eq (char-after (- (point) 2)) ?\') ; ???? + (memq (char-syntax (char-after (- (point) 2))) + '(?w ?_))))) + (if (eq (preceding-char) ?\,) + (cperl-backward-to-start-of-continued-exp containing-sexp)) + (beginning-of-line) + (cperl-backward-to-noncomment containing-sexp)) + ;; Now we get the answer. + (if (not (memq (preceding-char) (append ",;}{" '(nil)))) ; Was ?\, + ;; This line is continuation of preceding line's statement; + ;; indent `cperl-continued-statement-offset' more than the + ;; previous line of the statement. + (progn + (cperl-backward-to-start-of-continued-exp containing-sexp) + (+ (if (memq char-after (append "}])" nil)) + 0 ; Closing parenth + cperl-continued-statement-offset) + (current-column) + (if (eq char-after ?\{) + cperl-continued-brace-offset 0))) + ;; This line starts a new statement. + ;; Position following last unclosed open. + (goto-char containing-sexp) + ;; Is line first statement after an open-brace? + (or + ;; If no, find that first statement and indent like + ;; it. If the first statement begins with label, do + ;; not belive when the indentation of the label is too + ;; small. + (save-excursion + (forward-char 1) + (setq old-indent (current-indentation)) + (let ((colon-line-end 0)) + (while (progn (skip-chars-forward " \t\n") + (looking-at "#\\|[a-zA-Z0-9_$]*:[^:]")) + ;; Skip over comments and labels following openbrace. + (cond ((= (following-char) ?\#) + (forward-line 1)) + ;; label: + (t + (save-excursion (end-of-line) + (setq colon-line-end (point))) + (search-forward ":")))) + ;; The first following code counts + ;; if it is before the line we want to indent. + (and (< (point) indent-point) + (if (> colon-line-end (point)) ; After label + (if (> (current-indentation) + cperl-min-label-indent) + (- (current-indentation) cperl-label-offset) + ;; Do not belive: `max' is involved + (+ old-indent cperl-indent-level)) + (current-column))))) + ;; If no previous statement, + ;; indent it relative to line brace is on. + ;; For open brace in column zero, don't let statement + ;; start there too. If cperl-indent-level is zero, + ;; use cperl-brace-offset + cperl-continued-statement-offset instead. + ;; For open-braces not the first thing in a line, + ;; add in cperl-brace-imaginary-offset. + + ;; If first thing on a line: ????? + (+ (if (and (bolp) (zerop cperl-indent-level)) + (+ cperl-brace-offset cperl-continued-statement-offset) + cperl-indent-level) + ;; Move back over whitespace before the openbrace. + ;; If openbrace is not first nonwhite thing on the line, + ;; add the cperl-brace-imaginary-offset. + (progn (skip-chars-backward " \t") + (if (bolp) 0 cperl-brace-imaginary-offset)) + ;; If the openbrace is preceded by a parenthesized exp, + ;; move to the beginning of that; + ;; possibly a different line + (progn + (if (eq (preceding-char) ?\)) + (forward-sexp -1)) + ;; Get initial indentation of the line we are on. + ;; If line starts with label, calculate label indentation + (if (save-excursion + (beginning-of-line) + (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_]*:[^:]")) + (if (> (current-indentation) cperl-min-label-indent) + (- (current-indentation) cperl-label-offset) + (cperl-calculate-indent + (if (<= parse-start (point)) parse-start))) + (current-indentation))))))))))) + +(defvar cperl-indent-alist + '((string nil) + (comment nil) + (toplevel 0) + (toplevel-after-parenth 2) + (toplevel-continued 2) + (expression 1)) + "Alist of indentation rules for CPerl mode. +The values mean: + nil: do not indent; + number: add this amount of indentation.") + +(defun cperl-where-am-i (&optional parse-start start-state) + ;; Unfinished + "Return a list (TYPE POS) of the start of enclosing construction. +POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'." + (save-excursion + (let ((start-point (point)) + (case-fold-search nil) + state start-indent start moved + containing-sexp old-containing-sexp old-indent) + (if parse-start + (goto-char parse-start) + (beginning-of-defun)) + (if start-state nil + ;; Try to go out, if sub is not on the outermost level + (while (< (point) start-point) + (setq start (point) parse-start start moved nil + state (parse-partial-sexp start start-point -1)) + (if (> (car state) -1) nil + ;; The current line could start like }}}, so the indentation + ;; corresponds to a different level than what we reached + (setq moved t) + (beginning-of-line 2))) ; Go to the next line. + (if start (goto-char start))) ; Not at the start of file + (skip-chars-forward " \t") + (setq start (point)) + (if (< (point) start-point) (setq parse-start (point))) + (or state (setq state (parse-partial-sexp + (point) start-point -1 nil start-state))) + (setq containing-sexp + (or (car (cdr state)) + (and (>= (nth 6 state) 0) old-containing-sexp)) + old-containing-sexp nil start-state nil) +;; (while (< (point) start-point) +;; (setq parse-start (point)) +;; (setq state (parse-partial-sexp (point) start-point -1 nil start-state)) +;; (setq containing-sexp +;; (or (car (cdr state)) +;; (and (>= (nth 6 state) 0) old-containing-sexp)) +;; old-containing-sexp nil start-state nil)) + (goto-char start-point) + (cond ((nth 3 state) ; In string + (list 'string nil (nth 3 state))) ; What started string + ((nth 4 state) ; In comment + '(comment)) + ((null containing-sexp) + ;; Line is at top level. + ;; Indent like the previous top level line + ;; unless that ends in a closeparen without semicolon, + ;; in which case this line is the first argument decl. + (cperl-backward-to-noncomment (or parse-start (point-min))) + (skip-chars-backward " \t\f\n") ; Why??? + (cond + ((or (bobp) + (memq (preceding-char) (append ";}" nil))) + (list 'toplevel start)) + ((eq (preceding-char) ?\) ) + (list 'toplevel-after-parenth start)) + (t (list 'toplevel-continued start)))) + ((/= (char-after containing-sexp) ?{) + ;; line is expression, not statement: + ;; indent to just after the surrounding open. + (list 'expression containing-sexp)) + ((progn + ;; Containing-expr starts with \{. Check whether it is a hash. + (goto-char containing-sexp) + (cperl-backward-to-noncomment (or parse-start (point-min))) + (skip-chars-backward " \t\n\f") + (not + (or (memq (preceding-char) (append ";)}$@&%" nil)) ; Or label! + ; Label may be mixed up with `$blah :' + (save-excursion (cperl-after-label)) + (and (eq (char-syntax (preceding-char)) ?w) + (progn + (backward-sexp) + (looking-at "\\sw+[ \t\n\f]*{")))))) ; Method call syntax + (list 'expression containing-sexp)) + (t + ;; Statement level. Is it a continuation or a new statement? + ;; Find previous non-comment character. + (cperl-backward-to-noncomment containing-sexp) + ;; Back up over label lines, since they don't + ;; affect whether our line is a continuation. + (while (or (eq (preceding-char) ?\,) + (cperl-after-label)) + (if (eq (preceding-char) ?\,) + (cperl-backward-to-start-of-continued-exp containing-sexp)) + (beginning-of-line) + (cperl-backward-to-noncomment containing-sexp)) + ;; Now we get the answer. + (if (not (memq (preceding-char) (append ";}{" '(nil)))) ; Was ?\, + ;; This line is continuation of preceding line's statement. + '(statement-continued containing-sexp) + ;; This line starts a new statement. + ;; Position following last unclosed open. + (goto-char containing-sexp) + ;; Is line first statement after an open-brace? + (or + ;; If no, find that first statement and indent like + ;; it. If the first statement begins with label, do + ;; not belive when the indentation of the label is too + ;; small. + (save-excursion + (forward-char 1) + (setq old-indent (current-indentation)) + (let ((colon-line-end 0)) + (while (progn (skip-chars-forward " \t\n") + (looking-at "#\\|[a-zA-Z0-9_$]*:[^:]")) + ;; Skip over comments and labels following openbrace. + (cond ((= (following-char) ?\#) + (forward-line 1)) + ;; label: + (t + (save-excursion (end-of-line) + (setq colon-line-end (point))) + (search-forward ":")))) + ;; The first following code counts + ;; if it is before the line we want to indent. + (and (< (point) start-point) + (if (> colon-line-end (point)) ; After label + (if (> (current-indentation) + cperl-min-label-indent) + (- (current-indentation) cperl-label-offset) + ;; Do not belive: `max' is involved + (+ old-indent cperl-indent-level)) + (current-column))))) + ;; If no previous statement, + ;; indent it relative to line brace is on. + ;; For open brace in column zero, don't let statement + ;; start there too. If cperl-indent-level is zero, + ;; use cperl-brace-offset + cperl-continued-statement-offset instead. + ;; For open-braces not the first thing in a line, + ;; add in cperl-brace-imaginary-offset. + + ;; If first thing on a line: ????? + (+ (if (and (bolp) (zerop cperl-indent-level)) + (+ cperl-brace-offset cperl-continued-statement-offset) + cperl-indent-level) + ;; Move back over whitespace before the openbrace. + ;; If openbrace is not first nonwhite thing on the line, + ;; add the cperl-brace-imaginary-offset. + (progn (skip-chars-backward " \t") + (if (bolp) 0 cperl-brace-imaginary-offset)) + ;; If the openbrace is preceded by a parenthesized exp, + ;; move to the beginning of that; + ;; possibly a different line + (progn + (if (eq (preceding-char) ?\)) + (forward-sexp -1)) + ;; Get initial indentation of the line we are on. + ;; If line starts with label, calculate label indentation + (if (save-excursion + (beginning-of-line) + (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_]*:[^:]")) + (if (> (current-indentation) cperl-min-label-indent) + (- (current-indentation) cperl-label-offset) + (cperl-calculate-indent + (if (<= parse-start (point)) parse-start))) + (current-indentation))))))))))) + +(defun cperl-calculate-indent-within-comment () + "Return the indentation amount for line, assuming that +the current line is to be regarded as part of a block comment." + (let (end star-start) + (save-excursion + (beginning-of-line) + (skip-chars-forward " \t") + (setq end (point)) + (and (= (following-char) ?#) + (forward-line -1) + (cperl-to-comment-or-eol) + (setq end (point))) + (goto-char end) + (current-column)))) + + +(defun cperl-to-comment-or-eol () + "Goes to position before comment on the current line, or to end of line. +Returns true if comment is found." + (let (state stop-in cpoint (lim (progn (end-of-line) (point)))) + (beginning-of-line) + (if (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t) + (if (eq (preceding-char) ?\#) (progn (backward-char 1) t)) + ;; Else + (while (not stop-in) + (setq state (parse-partial-sexp (point) lim nil nil nil t)) + ; stop at comment + ;; If fails (beginning-of-line inside sexp), then contains not-comment + ;; Do simplified processing + ;;(if (re-search-forward "[^$]#" lim 1) + ;; (progn + ;; (forward-char -1) + ;; (skip-chars-backward " \t\n\f" lim)) + ;; (goto-char lim)) ; No `#' at all + ;;) + (if (nth 4 state) ; After `#'; + ; (nth 2 state) can be + ; beginning of m,s,qq and so + ; on + (if (nth 2 state) + (progn + (setq cpoint (point)) + (goto-char (nth 2 state)) + (cond + ((looking-at "\\(s\\|tr\\)\\>") + (or (re-search-forward + "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*" + lim 'move) + (setq stop-in t))) + ((looking-at "\\(m\\|q\\([qxw]\\)?\\)\\>") + (or (re-search-forward + "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#" + lim 'move) + (setq stop-in t))) + (t ; It was fair comment + (setq stop-in t) ; Finish + (goto-char (1- cpoint))))) + (setq stop-in t) ; Finish + (forward-char -1)) + (setq stop-in t)) ; Finish + ) + (nth 4 state)))) + +(defun cperl-backward-to-noncomment (lim) + (let (stop p) + (while (and (not stop) (> (point) (or lim 1))) + (skip-chars-backward " \t\n\f" lim) + (setq p (point)) + (beginning-of-line) + (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip + ;; Else + (cperl-to-comment-or-eol) + (skip-chars-backward " \t") + (if (< p (point)) (goto-char p)) + (setq stop t))))) + +(defun cperl-after-expr (&optional lim chars test) + "Returns true if the position is good for start of expression. +TEST is the expression to evaluate at the found position. If absent, +CHARS is a string that contains good characters to have before us." + (let (stop p) + (save-excursion + (while (and (not stop) (> (point) (or lim 1))) + (skip-chars-backward " \t\n\f" lim) + (setq p (point)) + (beginning-of-line) + (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip + ;; Else: last iteration (What to do with labels?) + (cperl-to-comment-or-eol) + (skip-chars-backward " \t") + (if (< p (point)) (goto-char p)) + (setq stop t))) + (or (bobp) + (progn + (backward-char 1) + (if test (eval test) + (memq (following-char) (append (or chars "{};") nil)))))))) + +(defun cperl-backward-to-start-of-continued-exp (lim) + (if (memq (preceding-char) (append ")]}" nil)) + (forward-sexp -1)) + (beginning-of-line) + (if (<= (point) lim) + (goto-char (1+ lim))) + (skip-chars-forward " \t")) + +(defun cperl-backward-to-start-of-if (&optional limit) + "Move to the start of the last ``unbalanced'' if." + (or limit (setq limit (save-excursion (beginning-of-defun) (point)))) + (let ((if-level 1) + (case-fold-search nil)) + (while (not (zerop if-level)) + (backward-sexp 1) + (cond ((looking-at "else\\b") + (setq if-level (1+ if-level))) + ((looking-at "if\\b") + (setq if-level (1- if-level))) + ((<= (point) limit) + (setq if-level 0) + (goto-char limit)))))) + + + +(defvar innerloop-done nil) +(defvar last-depth nil) + +(defun cperl-indent-exp () + "Simple variant of indentation of continued-sexp. +Should be slow. Will not indent comment if it starts at `comment-indent' +or looks like continuation of the comment on the previous line." + (interactive) + (save-excursion + (let ((tmp-end (progn (end-of-line) (point))) top done) + (save-excursion + (while (null done) + (beginning-of-line) + (setq top (point)) + (while (= (nth 0 (parse-partial-sexp (point) tmp-end + -1)) -1) + (setq top (point))) ; Get the outermost parenths in line + (goto-char top) + (while (< (point) tmp-end) + (parse-partial-sexp (point) tmp-end nil t) ; To start-sexp or eol + (or (eolp) (forward-sexp 1))) + (if (> (point) tmp-end) (progn (end-of-line) (setq tmp-end (point))) + (setq done t))) + (goto-char tmp-end) + (setq tmp-end (point-marker))) + (cperl-indent-region (point) tmp-end)))) + +(defun cperl-indent-region (start end) + "Simple variant of indentation of region in CPerl mode. +Should be slow. Will not indent comment if it starts at `comment-indent' +or looks like continuation of the comment on the previous line. +Indents all the lines whose first character is between START and END +inclusive." + (interactive "r") + (save-excursion + (let (st comm indent-info old-comm-indent new-comm-indent + (pm 0) (imenu-scanning-message "Indenting... (%3d%%)")) + (goto-char start) + (setq old-comm-indent (and (cperl-to-comment-or-eol) + (current-column)) + new-comm-indent old-comm-indent) + (goto-char start) + (or (bolp) (beginning-of-line 2)) + (or (fboundp 'imenu-progress-message) + (message "Indenting... For feedback load `imenu'...")) + (while (and (<= (point) end) (not (eobp))) ; bol to check start + (and (fboundp 'imenu-progress-message) + (imenu-progress-message + pm (/ (* 100 (- (point) start)) (- end start -1)))) + (setq st (point) + indent-info nil + ) ; Believe indentation of the current + (if (and (setq comm (looking-at "[ \t]*#")) + (or (eq (current-indentation) (or old-comm-indent + comment-column)) + (setq old-comm-indent nil))) + (if (and old-comm-indent + (= (current-indentation) old-comm-indent)) + (let ((comment-column new-comm-indent)) + (indent-for-comment))) + (progn + (cperl-indent-line 'indent-info) + (or comm + (progn + (if (setq old-comm-indent (and (cperl-to-comment-or-eol) + (current-column))) + (progn (indent-for-comment) + (skip-chars-backward " \t") + (skip-chars-backward "#") + (setq new-comm-indent (current-column)))))))) + (beginning-of-line 2)) + (if (fboundp 'imenu-progress-message) + (imenu-progress-message pm 100) + (message nil))))) + +(defun cperl-slash-is-regexp (&optional pos) + (save-excursion + (goto-char (if pos pos (1- (point)))) + (and + (not (memq (get-text-property (point) 'face) + '(font-lock-string-face font-lock-comment-face))) + (cperl-after-expr nil nil ' + (or (looking-at "[^]a-zA-Z0-9_)}]") + (eq (get-text-property (point) 'face) + 'font-lock-keyword-face)))))) + +;; Stolen from lisp-mode with a lot of improvements + +(defun cperl-fill-paragraph (&optional justify iteration) + "Like \\[fill-paragraph], but handle CPerl comments. +If any of the current line is a comment, fill the comment or the +block of it that point is in, preserving the comment's initial +indentation and initial hashes. Behaves usually outside of comment." + (interactive "P") + (let ( + ;; Non-nil if the current line contains a comment. + has-comment + + ;; If has-comment, the appropriate fill-prefix for the comment. + comment-fill-prefix + ;; Line that contains code and comment (or nil) + start + c spaces len dc (comment-column comment-column)) + ;; Figure out what kind of comment we are looking at. + (save-excursion + (beginning-of-line) + (cond + + ;; A line with nothing but a comment on it? + ((looking-at "[ \t]*#[# \t]*") + (setq has-comment t + comment-fill-prefix (buffer-substring (match-beginning 0) + (match-end 0)))) + + ;; A line with some code, followed by a comment? Remember that the + ;; semi which starts the comment shouldn't be part of a string or + ;; character. + ((cperl-to-comment-or-eol) + (setq has-comment t) + (looking-at "#+[ \t]*") + (setq start (point) c (current-column) + comment-fill-prefix + (concat (make-string (current-column) ?\ ) + (buffer-substring (match-beginning 0) (match-end 0))) + spaces (progn (skip-chars-backward " \t") + (buffer-substring (point) start)) + dc (- c (current-column)) len (- start (point)) + start (point-marker)) + (delete-char len) + (insert (make-string dc ?-))))) + (if (not has-comment) + (fill-paragraph justify) ; Do the usual thing outside of comment + ;; Narrow to include only the comment, and then fill the region. + (save-restriction + (narrow-to-region + ;; Find the first line we should include in the region to fill. + (if start (progn (beginning-of-line) (point)) + (save-excursion + (while (and (zerop (forward-line -1)) + (looking-at "^[ \t]*#+[ \t]*[^ \t\n]"))) + ;; We may have gone to far. Go forward again. + (or (looking-at "^[ \t]*#+[ \t]*[^ \t\n]") + (forward-line 1)) + (point))) + ;; Find the beginning of the first line past the region to fill. + (save-excursion + (while (progn (forward-line 1) + (looking-at "^[ \t]*#+[ \t]*[^ \t\n]"))) + (point))) + ;; Remove existing hashes + (goto-char (point-min)) + (while (progn (forward-line 1) (< (point) (point-max))) + (skip-chars-forward " \t") + (and (looking-at "#+") + (delete-char (- (match-end 0) (match-beginning 0))))) + + ;; Lines with only hashes on them can be paragraph boundaries. + (let ((paragraph-start (concat paragraph-start "\\|^[ \t#]*$")) + (paragraph-separate (concat paragraph-start "\\|^[ \t#]*$")) + (fill-prefix comment-fill-prefix)) + (fill-paragraph justify))) + (if (and start) + (progn + (goto-char start) + (if (> dc 0) + (progn (delete-char dc) (insert spaces))) + (if (or (= (current-column) c) iteration) nil + (setq comment-column c) + (indent-for-comment) + ;; Repeat once more, flagging as iteration + (cperl-fill-paragraph justify t))))))) + +(defun cperl-do-auto-fill () + ;; Break out if the line is short enough + (if (> (save-excursion + (end-of-line) + (current-column)) + fill-column) + (let ((c (save-excursion (beginning-of-line) + (cperl-to-comment-or-eol) (point))) + (s (memq (following-char) '(?\ ?\t))) marker) + (if (>= c (point)) nil + (setq marker (point-marker)) + (cperl-fill-paragraph) + (goto-char marker) + ;; Is not enough, sometimes marker is a start of line + (if (bolp) (progn (re-search-forward "#+[ \t]*") + (goto-char (match-end 0)))) + ;; Following space could have gone: + (if (or (not s) (memq (following-char) '(?\ ?\t))) nil + (insert " ") + (backward-char 1)) + ;; Previous space could have gone: + (or (memq (preceding-char) '(?\ ?\t)) (insert " ")))))) + +(defvar imenu-example--function-name-regexp-perl + "^[ \t]*\\(sub\\|package\\)[ \t\n]+\\([a-zA-Z_0-9:']+\\)[ \t]*") + +(defun imenu-example--create-perl-index (&optional regexp) + (require 'cl) + (let ((index-alist '()) (index-pack-alist '()) packages ends-ranges p + (prev-pos 0) char fchar index name (end-range 0) package) + (goto-char (point-min)) + (imenu-progress-message prev-pos 0) + ;; Search for the function + (save-match-data + (while (re-search-forward + (or regexp imenu-example--function-name-regexp-perl) + nil t) + (imenu-progress-message prev-pos) + ;;(backward-up-list 1) + (save-excursion + (goto-char (match-beginning 1)) + (setq fchar (following-char)) + ) + (setq char (following-char)) + (setq p (point)) + (while (and ends-ranges (>= p (car ends-ranges))) + ;; delete obsolete entries + (setq ends-ranges (cdr ends-ranges) packages (cdr packages))) + (setq package (or (car packages) "") + end-range (or (car ends-ranges) 0)) + (if (eq fchar ?p) + (progn + (setq name (buffer-substring (match-beginning 2) (match-end 2)) + package (concat name "::") + name (concat "package " name) + end-range + (save-excursion + (parse-partial-sexp (point) (point-max) -1) (point)) + ends-ranges (cons end-range ends-ranges) + packages (cons package packages)))) + ;; ) + ;; Skip this function name if it is a prototype declaration. + (if (and (eq fchar ?s) (eq char ?\;)) nil + (if (eq fchar ?p) nil + (setq name (buffer-substring (match-beginning 2) (match-end 2))) + (if (or (> p end-range) (string-match "[:']" name)) nil + (setq name (concat package name)))) + (setq index (imenu-example--name-and-position)) + (setcar index name) + (if (eq fchar ?p) + (push index index-pack-alist) + (push index index-alist))))) + (imenu-progress-message prev-pos 100) + (and index-pack-alist + (push (cons (imenu-create-submenu-name "Packages") index-pack-alist) + index-alist)) + (nreverse index-alist))) + +(defvar cperl-compilation-error-regexp-alist + ;; This look like a paranoiac regexp: could anybody find a better one? (which WORK). + '(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]" + 2 3)) + "Alist that specifies how to match errors in perl output.") + +(if (fboundp 'eval-after-load) + (eval-after-load + "mode-compile" + '(setq perl-compilation-error-regexp-alist + cperl-compilation-error-regexp-alist))) + + +(defvar cperl-faces-init nil) + +(defun cperl-windowed-init () + "Initialization under windowed version." + (add-hook 'font-lock-mode-hook + (function + (lambda () + (if (or + (eq major-mode 'perl-mode) + (eq major-mode 'cperl-mode)) + (progn + (or cperl-faces-init (cperl-init-faces)) + (setq font-lock-keywords perl-font-lock-keywords + cperl-faces-init t))))))) + +(defun cperl-init-faces () + (condition-case nil + (progn + (require 'font-lock) + (let (t-font-lock-keywords) + ;;(defvar cperl-font-lock-enhanced nil + ;; "Set to be non-nil if font-lock allows active highlights.") + (setq + t-font-lock-keywords + (list + (cons + (concat + "\\(^\\|[^$@%&\\]\\)\\<\\(" + (mapconcat + 'identity + '("if" "until" "while" "elsif" "else" "unless" "for" + "foreach" "continue" "exit" "die" "last" "goto" "next" + "redo" "return" "local" "exec" "sub" "do" "dump" "use" + "require" "package" "eval" "my" "BEGIN" "END") + "\\|") ; Flow control + "\\)\\>") 2) ; was "\\)[ \n\t;():,\|&]" + ; In what follows we use `type' style + ; for overwritable buildins + (list + (concat + "\\(^\\|[^$@%&\\]\\)\\<\\(" + ;; "CORE" "__FILE__" "__LINE__" "abs" "accept" "alarm" "and" "atan2" + ;; "bind" "binmode" "bless" "caller" "chdir" "chmod" "chown" "chr" + ;; "chroot" "close" "closedir" "cmp" "connect" "continue" "cos" + ;; "crypt" "dbmclose" "dbmopen" "die" "dump" "endgrent" "endhostent" + ;; "endnetent" "endprotoent" "endpwent" "endservent" "eof" "eq" "exec" + ;; "exit" "exp" "fcntl" "fileno" "flock" "fork" "formline" "ge" "getc" + ;; "getgrent" "getgrgid" "getgrnam" "gethostbyaddr" "gethostbyname" + ;; "gethostent" "getlogin" "getnetbyaddr" "getnetbyname" "getnetent" + ;; "getpeername" "getpgrp" "getppid" "getpriority" "getprotobyname" + ;; "getprotobynumber" "getprotoent" "getpwent" "getpwnam" "getpwuid" + ;; "getservbyname" "getservbyport" "getservent" "getsockname" + ;; "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int" "ioctl" + ;; "join" "kill" "lc" "lcfirst" "le" "length" "link" "listen" + ;; "localtime" "log" "lstat" "lt" "mkdir" "msgctl" "msgget" "msgrcv" + ;; "msgsnd" "ne" "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe" + ;; "quotemeta" "rand" "read" "readdir" "readline" "readlink" + ;; "readpipe" "recv" "ref" "rename" "require" "reset" "reverse" + ;; "rewinddir" "rindex" "rmdir" "seek" "seekdir" "select" "semctl" + ;; "semget" "semop" "send" "setgrent" "sethostent" "setnetent" + ;; "setpgrp" "setpriority" "setprotoent" "setpwent" "setservent" + ;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite" "shutdown" + ;; "sin" "sleep" "socket" "socketpair" "sprintf" "sqrt" "srand" "stat" + ;; "substr" "symlink" "syscall" "sysread" "system" "syswrite" "tell" + ;; "telldir" "time" "times" "truncate" "uc" "ucfirst" "umask" "unlink" + ;; "unpack" "utime" "values" "vec" "wait" "waitpid" "wantarray" "warn" + ;; "write" "x" "xor" + "a\\(bs\\|ccept\\|tan2\\|larm\\|nd\\)\\|" + "b\\(in\\(d\\|mode\\)\\|less\\)\\|" + "c\\(h\\(r\\(\\|oot\\)\\|dir\\|mod\\|own\\)\\|aller\\|rypt\\|" + "lose\\(\\|dir\\)\\|mp\\|o\\(s\\|n\\(tinue\\|nect\\)\\)\\)\\|" + "CORE\\|d\\(ie\\|bm\\(close\\|open\\)\\|ump\\)\\|" + "e\\(x\\(p\\|it\\|ec\\)\\|q\\|nd\\(p\\(rotoent\\|went\\)\\|" + "hostent\\|servent\\|netent\\|grent\\)\\|of\\)\\|" + "f\\(ileno\\|cntl\\|lock\\|or\\(k\\|mline\\)\\)\\|" + "g\\(t\\|lob\\|mtime\\|e\\(\\|t\\(p\\(pid\\|r\\(iority\\|" + "oto\\(byn\\(ame\\|umber\\)\\|ent\\)\\)\\|eername\\|w" + "\\(uid\\|ent\\|nam\\)\\|grp\\)\\|host\\(by\\(addr\\|name\\)\\|" + "ent\\)\\|s\\(erv\\(by\\(port\\|name\\)\\|ent\\)\\|" + "ock\\(name\\|opt\\)\\)\\|c\\|login\\|net\\(by\\(addr\\|name\\)\\|" + "ent\\)\\|gr\\(ent\\|nam\\|gid\\)\\)\\)\\)\\|" + "hex\\|i\\(n\\(t\\|dex\\)\\|octl\\)\\|join\\|kill\\|" + "l\\(i\\(sten\\|nk\\)\\|stat\\|c\\(\\|first\\)\\|t\\|e" + "\\(\\|ngth\\)\\|o\\(caltime\\|g\\)\\)\\|m\\(sg\\(rcv\\|snd\\|" + "ctl\\|get\\)\\|kdir\\)\\|n\\(e\\|ot\\)\\|o\\(pen\\(\\|dir\\)\\|" + "r\\(\\|d\\)\\|ct\\)\\|p\\(ipe\\|ack\\)\\|quotemeta\\|" + "r\\(index\\|and\\|mdir\\|e\\(quire\\|ad\\(pipe\\|\\|lin" + "\\(k\\|e\\)\\|dir\\)\\|set\\|cv\\|verse\\|f\\|winddir\\|name" + "\\)\\)\\|s\\(printf\\|qrt\\|rand\\|tat\\|ubstr\\|e\\(t\\(p\\(r" + "\\(iority\\|otoent\\)\\|went\\|grp\\)\\|hostent\\|s\\(ervent\\|" + "ockopt\\)\\|netent\\|grent\\)\\|ek\\(\\|dir\\)\\|lect\\|" + "m\\(ctl\\|op\\|get\\)\\|nd\\)\\|h\\(utdown\\|m\\(read\\|ctl\\|" + "write\\|get\\)\\)\\|y\\(s\\(read\\|call\\|tem\\|write\\)\\|" + "mlink\\)\\|in\\|leep\\|ocket\\(pair\\|\\)\\)\\|t\\(runcate\\|" + "ell\\(\\|dir\\)\\|ime\\(\\|s\\)\\)\\|u\\(c\\(\\|first\\)\\|" + "time\\|mask\\|n\\(pack\\|link\\)\\)\\|v\\(alues\\|ec\\)\\|" + "w\\(a\\(rn\\|it\\(pid\\|\\)\\|ntarray\\)\\|rite\\)\\|" + "x\\(\\|or\\)\\|__\\(FILE__\\|LINE__\\)" + "\\)\\>") 2 'font-lock-type-face) + ;; In what follows we use `other' style + ;; for nonoverwritable buildins + ;; Somehow 's', 'm' are not autogenerated??? + (list + (concat + "\\(^\\|[^$@%&\\]\\)\\<\\(" + ;; "AUTOLOAD" "BEGIN" "DESTROY" "END" "__END__" "chomp" "chop" + ;; "defined" "delete" "do" "each" "else" "elsif" "eval" "exists" "for" + ;; "foreach" "format" "goto" "grep" "if" "keys" "last" "local" "map" + ;; "my" "next" "no" "package" "pop" "pos" "print" "printf" "push" "q" + ;; "qq" "qw" "qx" "redo" "return" "scalar" "shift" "sort" "splice" + ;; "split" "study" "sub" "tie" "tr" "undef" "unless" "unshift" "untie" + ;; "until" "use" "while" "y" + "AUTOLOAD\\|BEGIN\\|cho\\(p\\|mp\\)\\|d\\(e\\(fined\\|lete\\)\\|" + "o\\)\\|DESTROY\\|e\\(ach\\|val\\|xists\\|ls\\(e\\|if\\)\\)\\|" + "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|if\\|keys\\|" + "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|" + "p\\(ackage\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|" + "q\\(\\|q\\|w\\|x\\)\\|re\\(turn\\|do\\)\\|s\\(pli\\(ce\\|t\\)\\|" + "calar\\|tudy\\|ub\\|hift\\|ort\\)\\|t\\(r\\|ie\\)\\|" + "u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|" + "while\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually + "\\|[sm]" ; Added manually + "\\)\\>") 2 'font-lock-other-type-face) + ;; (mapconcat 'identity + ;; '("#endif" "#else" "#ifdef" "#ifndef" "#if" + ;; "#include" "#define" "#undef") + ;; "\\|") + '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0 + font-lock-function-name-face) ; Not very good, triggers at "[a-z]" + '("\\*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\([a-zA-Z0-9_:]+\\)[ \t]*}" + (2 font-lock-string-face t) + (0 '(restart 2 t))) ; To highlight $a{bc}{ef} + '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\([a-zA-Z0-9_:]+\\)[ \t]*}" + 2 font-lock-string-face t)) + '("[ \t{,(]\\([a-zA-Z0-9_:]+\\)[ \t]*=>" 1 + font-lock-string-face t) + '("^[ \t]*\\([a-zA-Z0-9_]+[ \t]*:\\)[ \t]*\\($\\|{\\|\\<\\(until\\|while\\|for\\(each\\)?\\|do\\)\\>\\)" 1 + font-lock-reference-face) ; labels + '("\\<\\(continue\\|next\\|last\\|redo\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets + 2 font-lock-reference-face) + (if (featurep 'font-lock-extra) + '("^[ \t]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%][a-zA-Z0-9_]+\\)\\([ \t]*,\\)?" + (3 font-lock-variable-name-face) + (4 '(another 4 nil + ("[ \t]*,[ \t]*\\([$@%][a-zA-Z0-9_]+\\)\\([ \t]*,\\)?" + (1 font-lock-variable-name-face) + (2 '(restart 2 nil) nil t))) + nil t)) ; local variables, multiple + '("^[ \t]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%][a-zA-Z0-9_]+\\)" + 3 font-lock-variable-name-face)) + '("\\= 19.12 + ((fboundp 'valid-color-name-p) 'valid-color-name-p) + ;; XEmacs 19.11 + (t 'x-valid-color-name-p)))) + (defvar font-lock-reference-face 'font-lock-reference-face) + (defvar font-lock-variable-name-face 'font-lock-variable-name-face) + (or (boundp 'font-lock-type-face) + (defconst font-lock-type-face + 'font-lock-type-face + "Face to use for data types.") + ) + (or (boundp 'font-lock-other-type-face) + (defconst font-lock-other-type-face + 'font-lock-other-type-face + "Face to use for data types from another group.") + ) + (if (not (cperl-xemacs-p)) nil + (or (boundp 'font-lock-comment-face) + (defconst font-lock-comment-face + 'font-lock-comment-face + "Face to use for comments.") + ) + (or (boundp 'font-lock-keyword-face) + (defconst font-lock-keyword-face + 'font-lock-keyword-face + "Face to use for keywords.") + ) + (or (boundp 'font-lock-function-name-face) + (defconst font-lock-function-name-face + 'font-lock-function-name-face + "Face to use for function names.") + ) + ) + ;;(if (featurep 'font-lock) + (if (face-equal font-lock-type-face font-lock-comment-face) + (defconst font-lock-type-face + 'font-lock-type-face + "Face to use for basic data types.") + ) +;;; (if (fboundp 'eval-after-load) +;;; (eval-after-load "font-lock" +;;; '(if (face-equal font-lock-type-face +;;; font-lock-comment-face) +;;; (defconst font-lock-type-face +;;; 'font-lock-type-face +;;; "Face to use for basic data types.") +;;; ))) ; This does not work :-( Why?! +;;; ; Workaround: added to font-lock-m-h +;;; ) + (or (boundp 'font-lock-other-emphasized-face) + (defconst font-lock-other-emphasized-face + 'font-lock-other-emphasized-face + "Face to use for another type of emphasizing.") + ) + (or (boundp 'font-lock-emphasized-face) + (defconst font-lock-emphasized-face + 'font-lock-emphasized-face + "Face to use for emphasizing.") + ) + ;; Here we try to guess background + (let ((background + (if (boundp 'font-lock-background-mode) + font-lock-background-mode + 'light)) + (face-list (and (fboundp 'face-list) (face-list))) + is-face) + (fset 'is-face + (cond ((fboundp 'find-face) + (symbol-function 'find-face)) + (face-list + (function (lambda (face) (member face face-list)))) + (t + (function (lambda (face) (boundp face)))))) + (defvar cperl-guessed-background + (if (and (boundp 'font-lock-display-type) + (eq font-lock-display-type 'grayscale)) + 'gray + background) + "Background as guessed by CPerl mode") + (if (is-face 'font-lock-type-face) nil + (copy-face 'default 'font-lock-type-face) + (cond + ((eq background 'light) + (set-face-foreground 'font-lock-type-face + (if (x-color-defined-p "seagreen") + "seagreen" + "sea green"))) + ((eq background 'dark) + (set-face-foreground 'font-lock-type-face + (if (x-color-defined-p "os2pink") + "os2pink" + "pink"))) + (t + (set-face-background 'font-lock-type-face "gray90")))) + (if (is-face 'font-lock-other-type-face) + nil + (copy-face 'font-lock-type-face 'font-lock-other-type-face) + (cond + ((eq background 'light) + (set-face-foreground 'font-lock-other-type-face + (if (x-color-defined-p "chartreuse3") + "chartreuse3" + "chartreuse"))) + ((eq background 'dark) + (set-face-foreground 'font-lock-other-type-face + (if (x-color-defined-p "orchid1") + "orchid1" + "orange"))))) + (if (is-face 'font-lock-other-emphasized-face) nil + (copy-face 'bold-italic 'font-lock-other-emphasized-face) + (cond + ((eq background 'light) + (set-face-background 'font-lock-other-emphasized-face + (if (x-color-defined-p "lightyellow2") + "lightyellow2" + (if (x-color-defined-p "lightyellow") + "lightyellow" + "light yellow")))) + ((eq background 'dark) + (set-face-background 'font-lock-other-emphasized-face + (if (x-color-defined-p "navy") + "navy" + (if (x-color-defined-p "darkgreen") + "darkgreen" + "dark green")))) + (t (set-face-background 'font-lock-other-emphasized-face "gray90")))) + (if (is-face 'font-lock-emphasized-face) nil + (copy-face 'bold 'font-lock-emphasized-face) + (cond + ((eq background 'light) + (set-face-background 'font-lock-emphasized-face + (if (x-color-defined-p "lightyellow2") + "lightyellow2" + "lightyellow"))) + ((eq background 'dark) + (set-face-background 'font-lock-emphasized-face + (if (x-color-defined-p "navy") + "navy" + (if (x-color-defined-p "darkgreen") + "darkgreen" + "dark green")))) + (t (set-face-background 'font-lock-emphasized-face "gray90")))) + (if (is-face 'font-lock-variable-name-face) nil + (copy-face 'italic 'font-lock-variable-name-face)) + (if (is-face 'font-lock-reference-face) nil + (copy-face 'italic 'font-lock-reference-face))))) + (error nil))) + + +(defun cperl-ps-print-init () + "Initialization of `ps-print' components for faces used in CPerl." + ;; Guard against old versions + (defvar ps-underlined-faces nil) + (defvar ps-bold-faces nil) + (defvar ps-italic-faces nil) + (setq ps-bold-faces + (append '(font-lock-emphasized-face + font-lock-keyword-face + font-lock-variable-name-face + font-lock-reference-face + font-lock-other-emphasized-face) + ps-bold-faces)) + (setq ps-italic-faces + (append '(font-lock-other-type-face + font-lock-reference-face + font-lock-other-emphasized-face) + ps-italic-faces)) + (setq ps-underlined-faces + (append '(font-lock-emphasized-face + font-lock-other-emphasized-face + font-lock-other-type-face font-lock-type-face) + ps-underlined-faces)) + (cons 'font-lock-type-face ps-underlined-faces)) + + +(if (cperl-enable-font-lock) (cperl-windowed-init)) + +(defun cperl-set-style (style) + "Set CPerl-mode variables to use one of several different indentation styles. +The arguments are a string representing the desired style. +Available styles are GNU, K&R, BSD and Whitesmith." + (interactive + (let ((list (mapcar (function (lambda (elt) (list (car elt)))) + c-style-alist))) + (list (completing-read "Enter style: " list nil 'insist)))) + (let ((style (cdr (assoc style c-style-alist))) setting str sym) + (while style + (setq setting (car style) style (cdr style)) + (setq str (symbol-name (car setting))) + (and (string-match "^c-" str) + (setq str (concat "cperl-" (substring str 2))) + (setq sym (intern-soft str)) + (boundp sym) + (set sym (cdr setting)))))) + +(defun cperl-check-syntax () + (interactive) + (require 'mode-compile) + (let ((perl-dbg-flags "-wc")) + (mode-compile))) + +(defun cperl-info-buffer () + ;; Returns buffer with documentation. Creats if missing + (let ((info (get-buffer "*info-perl*"))) + (if info info + (save-window-excursion + ;; Get Info running + (require 'info) + (save-window-excursion + (info)) + (Info-find-node "perl5" "perlfunc") + (set-buffer "*info*") + (rename-buffer "*info-perl*") + (current-buffer))))) + +(defun cperl-word-at-point (&optional p) + ;; Returns the word at point or at P. + (save-excursion + (if p (goto-char p)) + (require 'etags) + (funcall (or (and (boundp 'find-tag-default-function) + find-tag-default-function) + (get major-mode 'find-tag-default-function) + ;; XEmacs 19.12 has `find-tag-default-hook'; it is + ;; automatically used within `find-tag-default': + 'find-tag-default)))) + +(defun cperl-info-on-command (command) + "Shows documentation for Perl command in other window." + (interactive + (let* ((default (cperl-word-at-point)) + (read (read-string + (format "Find doc for Perl function (default %s): " + default)))) + (list (if (equal read "") + default + read)))) + + (let ((buffer (current-buffer)) + (cmd-desc (concat "^" (regexp-quote command) "[ \t\n]")) + pos) + (if (string-match "^-[a-zA-Z]$" command) + (setq cmd-desc "^-X[ \t\n]")) + (set-buffer (cperl-info-buffer)) + (beginning-of-buffer) + (re-search-forward "^-X[ \t\n]") + (forward-line -1) + (if (re-search-forward cmd-desc nil t) + (progn + (setq pos (progn (beginning-of-line) + (point))) + (pop-to-buffer (cperl-info-buffer)) + (set-window-start (selected-window) pos)) + (message "No entry for %s found." command)) + (pop-to-buffer buffer))) + +(defun cperl-info-on-current-command () + "Shows documentation for Perl command at point in other window." + (interactive) + (cperl-info-on-command (cperl-word-at-point))) + +(defun cperl-imenu-info-imenu-search () + (if (looking-at "^-X[ \t\n]") nil + (re-search-backward + "^\n\\([-a-zA-Z]+\\)[ \t\n]") + (forward-line 1))) + +(defun cperl-imenu-info-imenu-name () + (buffer-substring + (match-beginning 1) (match-end 1))) + +(defun cperl-imenu-on-info () + (interactive) + (let* ((buffer (current-buffer)) + imenu-create-index-function + imenu-prev-index-position-function + imenu-extract-index-name-function + (index-item (save-restriction + (save-window-excursion + (set-buffer (cperl-info-buffer)) + (setq imenu-create-index-function + 'imenu-default-create-index-function + imenu-prev-index-position-function + 'cperl-imenu-info-imenu-search + imenu-extract-index-name-function + 'cperl-imenu-info-imenu-name) + (imenu-choose-buffer-index))))) + (and index-item + (progn + (push-mark) + (pop-to-buffer "*info-perl*") + (cond + ((markerp (cdr index-item)) + (goto-char (marker-position (cdr index-item)))) + (t + (goto-char (cdr index-item)))) + (set-window-start (selected-window) (point)) + (pop-to-buffer buffer))))) + +(defun cperl-lineup (beg end &optional step minshift) + "Lineup construction in a region. +Beginning of region should be at the start of a construction. +All first occurences of this construction in the lines that are +partially contained in the region are lined up at the same column. + +MINSHIFT is the minimal amount of space to insert before the construction. +STEP is the tabwidth to position constructions. +If STEP is `nil', `cperl-lineup-step' will be used +\(or `cperl-indent-level', if `cperl-lineup-step' is `nil'). +Will not move the position at the start to the left." + (interactive "r") + (let (search col tcol seen b e) + (save-excursion + (goto-char end) + (end-of-line) + (setq end (point-marker)) + (goto-char beg) + (skip-chars-forward " \t\f") + (setq beg (point-marker)) + (indent-region beg end nil) + (goto-char beg) + (setq col (current-column)) + (if (looking-at "\\sw") + (if (looking-at "\\<\\sw+\\>") + (setq search + (concat "\\<" + (regexp-quote + (buffer-substring (match-beginning 0) + (match-end 0))) "\\>")) + (error "Cannot line up in a middle of the word")) + (if (looking-at "$") + (error "Cannot line up end of line")) + (setq search (regexp-quote (char-to-string (following-char))))) + (setq step (or step cperl-lineup-step cperl-indent-level)) + (or minshift (setq minshift 1)) + (while (progn + (beginning-of-line 2) + (and (< (point) end) + (re-search-forward search end t) + (goto-char (match-beginning 0)))) + (setq tcol (current-column) seen t) + (if (> tcol col) (setq col tcol))) + (or seen + (error "The construction to line up occured only once")) + (goto-char beg) + (setq col (+ col minshift)) + (if (/= (% col step) 0) (setq step (* step (1+ (/ col step))))) + (while + (progn + (setq e (point)) + (skip-chars-backward " \t") + (delete-region (point) e) + (indent-to-column col); (make-string (- col (current-column)) ?\ )) + (beginning-of-line 2) + (and (< (point) end) + (re-search-forward search end t) + (goto-char (match-beginning 0)))))))) ; No body + +(defun cperl-etags (&optional add all files) + "Run etags with appropriate options for Perl files. +If optional argument ALL is `recursive', will process Perl files +in subdirectories too." + (interactive) + (let ((cmd "etags") + (args '("-l" "none" "-r" "/\\<\\(package\\|sub\\)[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)[ \\t]*\\([{#]\\|$\\)\\)/\\4/")) + res) + (if add (setq args (cons "-a" args))) + (or files (setq files (list buffer-file-name))) + (cond + ((eq all 'recursive) + ;;(error "Not implemented: recursive") + (setq args (append (list "-e" + "sub wanted {push @ARGV, $File::Find::name if /\\.[Pp][Llm]$/} + use File::Find; + find(\\&wanted, '.'); + exec @ARGV;" + cmd) args) + cmd "perl")) + (all + ;;(error "Not implemented: all") + (setq args (append (list "-e" + "push @ARGV, <*.PL *.pl *.pm>; + exec @ARGV;" + cmd) args) + cmd "perl")) + (t + (setq args (append args files)))) + (setq res (apply 'call-process cmd nil nil nil args)) + (or (eq res 0) + (message "etags returned \"%s\"" res)))) diff --git a/emacs/emacs19 b/emacs/emacs19 deleted file mode 100644 index c3bb070a64..0000000000 --- a/emacs/emacs19 +++ /dev/null @@ -1,312 +0,0 @@ -Article 15041 of comp.lang.perl: -Path: netlabs!news.cerf.net!usc!sol.ctr.columbia.edu!news.kei.com!bloom-beacon.mit.edu!paperboy.osf.org!meissner -From: meissner@osf.org (Michael Meissner) -Newsgroups: comp.lang.perl -Subject: Re: question on using perldb.el with emacs -Date: 17 Oct 1993 21:10:21 GMT -Organization: Open Software Foundation -Lines: 297 -Message-ID: -References: -NNTP-Posting-Host: pasta.osf.org -In-reply-to: bshaw@bobasun.spdc.ti.com's message of Sun, 17 Oct 1993 19:35:24 GMT - -In article bshaw@bobasun.spdc.ti.com -(Bob Shaw) writes: - -| Hi folks -| -| Say, I'm trying to use perldb with emacs. I can invoke perldb -| within emacs ok and get the window *perldb-foo* but when it asks -| for "additional command line arguments" , no matter what I give it -| I get the error message Symbol's function definition is void: make- -| shell. -| -| The debugger , by itself, works fine but wanted to try out perldb in -| emacs. - -This is a symptom of using Emacs 19.xx with perldb.el which was originally made -for emacs version 18.xx. You can either install the emacs19 replacement for -perldb that hooks it in with GUD (grand unified debugger), or apply the patches -that I picked off of the net (I use the perldb replacement that uses GUD -myself): - -#!/bin/sh -# This is a shell archive (produced by shar 3.49) -# To extract the files from this archive, save it to a file, remove -# everything above the "!/bin/sh" line above, and type "sh file_name". -# -# made 10/17/1993 21:07 UTC by meissner@pasta.osf.org -# Source directory /usr/users/meissner/elisp -# -# existing files will NOT be overwritten unless -c is specified -# -# This shar contains: -# length mode name -# ------ ---------- ------------------------------------------ -# 4761 -rw-r--r-- emacs19-perldb.el -# 3845 -rw-rw-r-- emacs19-perldb.patches -# -# ============= emacs19-perldb.el ============== -if test -f 'emacs19-perldb.el' -a X"$1" != X"-c"; then - echo 'x - skipping emacs19-perldb.el (File already exists)' -else -echo 'x - extracting emacs19-perldb.el (Text)' -sed 's/^X//' << 'SHAR_EOF' > 'emacs19-perldb.el' && -X;; Author : Stephane Boucher -X;; Note : This is an add on for gud (Part of GNU Emacs 19). It is -X;; derived from the gdb section that is part of gud. -X -X;; Copyright (C) 1993 Stephane Boucher. -X -X;; Perldb is free software; you can redistribute it and/or modify -X;; it under the terms of the GNU General Public License as published by -X;; the Free Software Foundation; either version 2, or (at your option) -X;; any later version. -X -X;; Perldb Emacs is distributed in the hope that it will be useful, -X;; but WITHOUT ANY WARRANTY; without even the implied warranty of -X;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -X;; GNU General Public License for more details. -X -X;; You should have received a copy of the GNU General Public License -X;; along with GNU Emacs; see the file COPYING. If not, write to -X;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -X -X(require 'gud) -X -X;; ====================================================================== -X;; perldb functions -X -X;;; History of argument lists passed to perldb. -X(defvar gud-perldb-history nil) -X -X(defun gud-perldb-massage-args (file args) -X (cons "-d" (cons file (cons "-emacs" args)))) -X -X;; There's no guarantee that Emacs will hand the filter the entire -X;; marker at once; it could be broken up across several strings. We -X;; might even receive a big chunk with several markers in it. If we -X;; receive a chunk of text which looks like it might contain the -X;; beginning of a marker, we save it here between calls to the -X;; filter. -X(defvar gud-perldb-marker-acc "") -X -X(defun gud-perldb-marker-filter (string) -X (save-match-data -X (setq gud-perldb-marker-acc (concat gud-perldb-marker-acc string)) -X (let ((output "")) -X -X ;; Process all the complete markers in this chunk. -X (while (string-match "^\032\032\\([^:\n]*\\):\\([0-9]*\\):.*\n" -X gud-perldb-marker-acc) -X (setq -X -X ;; Extract the frame position from the marker. -X gud-last-frame -X (cons (substring gud-perldb-marker-acc (match-beginning 1) (match-end 1)) -X (string-to-int (substring gud-perldb-marker-acc -X (match-beginning 2) -X (match-end 2)))) -X -X ;; Append any text before the marker to the output we're going -X ;; to return - we don't include the marker in this text. -X output (concat output -X (substring gud-perldb-marker-acc 0 (match-beginning 0))) -X -X ;; Set the accumulator to the remaining text. -X gud-perldb-marker-acc (substring gud-perldb-marker-acc (match-end 0)))) -X -X ;; Does the remaining text look like it might end with the -X ;; beginning of another marker? If it does, then keep it in -X ;; gud-perldb-marker-acc until we receive the rest of it. Since we -X ;; know the full marker regexp above failed, it's pretty simple to -X ;; test for marker starts. -X (if (string-match "^\032.*\\'" gud-perldb-marker-acc) -X (progn -X ;; Everything before the potential marker start can be output. -X (setq output (concat output (substring gud-perldb-marker-acc -X 0 (match-beginning 0)))) -X -X ;; Everything after, we save, to combine with later input. -X (setq gud-perldb-marker-acc -X (substring gud-perldb-marker-acc (match-beginning 0)))) -X -X (setq output (concat output gud-perldb-marker-acc) -X gud-perldb-marker-acc "")) -X -X output))) -X -X(defun gud-perldb-find-file (f) -X (find-file-noselect f)) -X -X;;;###autoload -X(defun perldb (command-line) -X "Run perldb on program FILE in buffer *gud-FILE*. -XThe directory containing FILE becomes the initial working directory -Xand source-file directory for your debugger." -X (interactive -X (list (read-from-minibuffer "Run perldb (like this): " -X (if (consp gud-perldb-history) -X (car gud-perldb-history) -X "perl ") -X nil nil -X '(gud-perldb-history . 1)))) -X (gud-overload-functions '((gud-massage-args . gud-perldb-massage-args) -X (gud-marker-filter . gud-perldb-marker-filter) -X (gud-find-file . gud-perldb-find-file) -X )) -X -X (gud-common-init command-line) -X -X (gud-def gud-break "b %l" "\C-b" "Set breakpoint at current line.") -X (gud-def gud-remove "d %l" "\C-d" "Remove breakpoint at current line") -X (gud-def gud-step "s" "\C-s" "Step one source line with display.") -X (gud-def gud-next "n" "\C-n" "Step one line (skip functions).") -X (gud-def gud-cont "c" "\C-r" "Continue with display.") -X; (gud-def gud-finish "finish" "\C-f" "Finish executing current function.") -X; (gud-def gud-up "up %p" "<" "Up N stack frames (numeric arg).") -X; (gud-def gud-down "down %p" ">" "Down N stack frames (numeric arg).") -X (gud-def gud-print "%e" "\C-p" "Evaluate perl expression at point.") -X -X (setq comint-prompt-regexp "^ DB<[0-9]+> ") -X (run-hooks 'perldb-mode-hook) -X ) -SHAR_EOF -chmod 0644 emacs19-perldb.el || -echo 'restore of emacs19-perldb.el failed' -Wc_c="`wc -c < 'emacs19-perldb.el'`" -test 4761 -eq "$Wc_c" || - echo 'emacs19-perldb.el: original size 4761, current size' "$Wc_c" -fi -# ============= emacs19-perldb.patches ============== -if test -f 'emacs19-perldb.patches' -a X"$1" != X"-c"; then - echo 'x - skipping emacs19-perldb.patches (File already exists)' -else -echo 'x - extracting emacs19-perldb.patches (Text)' -sed 's/^X//' << 'SHAR_EOF' > 'emacs19-perldb.patches' && -XFrom dmm0t@rincewind.mech.virginia.edu Fri Jul 16 23:17:10 1993 -XPath: paperboy.osf.org!bloom-beacon.mit.edu!biosci!uwm.edu!ux1.cso.uiuc.edu!howland.reston.ans.net!darwin.sura.net!news-feed-2.peachnet.edu!concert!uvaarpa!murdoch!rincewind.mech.virginia.edu!dmm0t -XFrom: dmm0t@rincewind.mech.virginia.edu (David Meyer) -XNewsgroups: gnu.emacs.sources -XSubject: patches to perldb.el for emacs-19 -XMessage-ID: -XDate: 15 Jul 93 17:18:07 GMT -XSender: usenet@murdoch.acc.Virginia.EDU -XOrganization: University of Virginia -XLines: 97 -X -X -XHere are my patches to perldb.el (the perl debugger mode that comes -Xwith perl 4.0xx). Basically, all I've done is to hack perldb.el to -Xuse comint.el stuff rather than the old shell.el stuff (i.e. change -Xshell-mode-map to comint-mode-map). -X -XI've been using my patched version without problem, but if anyone sees -Xsomething I've missed, please post or send e-mail. -X -X Thanks, -X Dave -X -X -X*** /Users/dmm0t/perldb.el Thu Jul 15 13:06:59 1993 -X--- perldb.el Tue Jul 6 22:24:41 1993 -X*************** -X*** 65,71 **** -X -X (if perldb-mode-map -X nil -X! (setq perldb-mode-map (copy-keymap shell-mode-map)) -X (define-key perldb-mode-map "\C-l" 'perldb-refresh)) -X -X (define-key ctl-x-map " " 'perldb-break) -X--- 65,71 ---- -X -X (if perldb-mode-map -X nil -X! (setq perldb-mode-map (copy-keymap comint-mode-map)) -X (define-key perldb-mode-map "\C-l" 'perldb-refresh)) -X -X (define-key ctl-x-map " " 'perldb-break) -X*************** -X*** 122,131 **** -X (setq mode-name "Inferior Perl") -X (setq mode-line-process '(": %s")) -X (use-local-map perldb-mode-map) -X! (make-local-variable 'last-input-start) -X! (setq last-input-start (make-marker)) -X! (make-local-variable 'last-input-end) -X! (setq last-input-end (make-marker)) -X (make-local-variable 'perldb-last-frame) -X (setq perldb-last-frame nil) -X (make-local-variable 'perldb-last-frame-displayed-p) -X--- 122,131 ---- -X (setq mode-name "Inferior Perl") -X (setq mode-line-process '(": %s")) -X (use-local-map perldb-mode-map) -X! (make-local-variable 'comint-last-input-start) -X! (setq comint-last-input-start (make-marker)) -X! (make-local-variable 'comint-last-input-end) -X! (setq comint-last-input-end (make-marker)) -X (make-local-variable 'perldb-last-frame) -X (setq perldb-last-frame nil) -X (make-local-variable 'perldb-last-frame-displayed-p) -X*************** -X*** 134,142 **** -X (setq perldb-delete-prompt-marker nil) -X (make-local-variable 'perldb-filter-accumulator) -X (setq perldb-filter-accumulator nil) -X! (make-local-variable 'shell-prompt-pattern) -X! (setq shell-prompt-pattern perldb-prompt-pattern) -X! (run-hooks 'shell-mode-hook 'perldb-mode-hook)) -X -X (defvar current-perldb-buffer nil) -X -X--- 134,142 ---- -X (setq perldb-delete-prompt-marker nil) -X (make-local-variable 'perldb-filter-accumulator) -X (setq perldb-filter-accumulator nil) -X! (make-local-variable 'comint-prompt-regexp) -X! (setq comint-prompt-regexp perldb-prompt-pattern) -X! (run-hooks 'comint-mode-hook 'perldb-mode-hook)) -X -X (defvar current-perldb-buffer nil) -X -X*************** -X*** 189,195 **** -X (setq default-directory dir) -X (or (bolp) (newline)) -X (insert "Current directory is " default-directory "\n") -X! (apply 'make-shell -X (concat "perldb-" file) perldb-command-name nil "-d" path "-emacs" -X (parse-args args)) -X (perldb-mode) -X--- 189,195 ---- -X (setq default-directory dir) -X (or (bolp) (newline)) -X (insert "Current directory is " default-directory "\n") -X! (apply 'make-comint -X (concat "perldb-" file) perldb-command-name nil "-d" path "-emacs" -X (parse-args args)) -X (perldb-mode) -X-- -XDavid M. Meyer Mechanical & Aerospace Engineering -Xdmm0t@rincewind.mech.virginia.edu University of Virginia -XNeXTmail ok -X -SHAR_EOF -chmod 0664 emacs19-perldb.patches || -echo 'restore of emacs19-perldb.patches failed' -Wc_c="`wc -c < 'emacs19-perldb.patches'`" -test 3845 -eq "$Wc_c" || - echo 'emacs19-perldb.patches: original size 3845, current size' "$Wc_c" -fi -exit 0 - --- -Michael Meissner email: meissner@osf.org phone: 617-621-8861 -Open Software Foundation, 11 Cambridge Center, Cambridge, MA, 02142 - -Old hackers never die, their bugs just increase. - - diff --git a/emacs/perl-mode.el b/emacs/perl-mode.el deleted file mode 100644 index cb6195dec3..0000000000 --- a/emacs/perl-mode.el +++ /dev/null @@ -1,631 +0,0 @@ -;; Perl code editing commands for GNU Emacs -;; Copyright (C) 1990 William F. Mann -;; Adapted from C code editing commands 'c-mode.el', Copyright 1987 by the -;; Free Software Foundation, under terms of its General Public License. - -;; This file may be made part of GNU Emacs at the option of the FSF, or -;; of the perl distribution at the option of Larry Wall. - -;; This code is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor -;; accepts responsibility to anyone for the consequences of using it -;; or for whether it serves any particular purpose or works at all, -;; unless he says so in writing. Refer to the GNU Emacs General Public -;; License for full details. - -;; Everyone is granted permission to copy, modify and redistribute -;; this code, but only under the conditions described in the -;; GNU Emacs General Public License. A copy of this license is -;; supposed to have been given to you along with GNU Emacs so you -;; can know your rights and responsibilities. It should be in a -;; file named COPYING. Among other things, the copyright notice -;; and this notice must be preserved on all copies. - -;; To enter perl-mode automatically, add (autoload 'perl-mode "perl-mode") -;; to your .emacs file and change the first line of your perl script to: -;; #!/usr/bin/perl -- # -*-Perl-*- -;; With argments to perl: -;; #!/usr/bin/perl -P- # -*-Perl-*- -;; To handle files included with do 'filename.pl';, add something like -;; (setq auto-mode-alist (append (list (cons "\\.pl$" 'perl-mode)) -;; auto-mode-alist)) -;; to your .emacs file; otherwise the .pl suffix defaults to prolog-mode. - -;; This code is based on the 18.53 version c-mode.el, with extensive -;; rewriting. Most of the features of c-mode survived intact. - -;; I added a new feature which adds functionality to TAB; it is controlled -;; by the variable perl-tab-to-comment. With it enabled, TAB does the -;; first thing it can from the following list: change the indentation; -;; move past leading white space; delete an empty comment; reindent a -;; comment; move to end of line; create an empty comment; tell you that -;; the line ends in a quoted string, or has a # which should be a \#. - -;; If your machine is slow, you may want to remove some of the bindings -;; to electric-perl-terminator. I changed the indenting defaults to be -;; what Larry Wall uses in perl/lib, but left in all the options. - -;; I also tuned a few things: comments and labels starting in column -;; zero are left there by indent-perl-exp; perl-beginning-of-function -;; goes back to the first open brace/paren in column zero, the open brace -;; in 'sub ... {', or the equal sign in 'format ... ='; indent-perl-exp -;; (meta-^q) indents from the current line through the close of the next -;; brace/paren, so you don't need to start exactly at a brace or paren. - -;; It may be good style to put a set of redundant braces around your -;; main program. This will let you reindent it with meta-^q. - -;; Known problems (these are all caused by limitations in the elisp -;; parsing routine (parse-partial-sexp), which was not designed for such -;; a rich language; writing a more suitable parser would be a big job): -;; 1) Regular expression delimitors do not act as quotes, so special -;; characters such as `'"#:;[](){} may need to be backslashed -;; in regular expressions and in both parts of s/// and tr///. -;; 2) The globbing syntax is not recognized, so special -;; characters in the pattern string must be backslashed. -;; 3) The q, qq, and << quoting operators are not recognized; see below. -;; 4) \ (backslash) always quotes the next character, so '\' is -;; treated as the start of a string. Use "\\" as a work-around. -;; 5) To make variables such a $' and $#array work, perl-mode treats -;; $ just like backslash, so '$' is the same as problem 5. -;; 6) Unfortunately, treating $ like \ makes ${var} be treated as an -;; unmatched }. See below. -;; 7) When ' (quote) is used as a package name separator, perl-mode -;; doesn't understand, and thinks it is seeing a quoted string. - -;; Here are some ugly tricks to bypass some of these problems: the perl -;; expression /`/ (that's a back-tick) usually evaluates harmlessly, -;; but will trick perl-mode into starting a quoted string, which -;; can be ended with another /`/. Assuming you have no embedded -;; back-ticks, this can used to help solve problem 3: -;; -;; /`/; $ugly = q?"'$?; /`/; -;; -;; To solve problem 6, add a /{/; before each use of ${var}: -;; /{/; while (<${glob_me}>) ... -;; -;; Problem 7 is even worse, but this 'fix' does work :-( -;; $DB'stop#' -;; [$DB'line#' -;; ] =~ s/;9$//; - - -(defvar perl-mode-abbrev-table nil - "Abbrev table in use in perl-mode buffers.") -(define-abbrev-table 'perl-mode-abbrev-table ()) - -(defvar perl-mode-map () - "Keymap used in Perl mode.") -(if perl-mode-map - () - (setq perl-mode-map (make-sparse-keymap)) - (define-key perl-mode-map "{" 'electric-perl-terminator) - (define-key perl-mode-map "}" 'electric-perl-terminator) - (define-key perl-mode-map ";" 'electric-perl-terminator) - (define-key perl-mode-map ":" 'electric-perl-terminator) - (define-key perl-mode-map "\e\C-a" 'perl-beginning-of-function) - (define-key perl-mode-map "\e\C-e" 'perl-end-of-function) - (define-key perl-mode-map "\e\C-h" 'mark-perl-function) - (define-key perl-mode-map "\e\C-q" 'indent-perl-exp) - (define-key perl-mode-map "\177" 'backward-delete-char-untabify) - (define-key perl-mode-map "\t" 'perl-indent-command)) - -(autoload 'c-macro-expand "cmacexp" - "Display the result of expanding all C macros occurring in the region. -The expansion is entirely correct because it uses the C preprocessor." - t) - -(defvar perl-mode-syntax-table nil - "Syntax table in use in perl-mode buffers.") - -(if perl-mode-syntax-table - () - (setq perl-mode-syntax-table (make-syntax-table (standard-syntax-table))) - (modify-syntax-entry ?\n ">" perl-mode-syntax-table) - (modify-syntax-entry ?# "<" perl-mode-syntax-table) - (modify-syntax-entry ?$ "/" perl-mode-syntax-table) - (modify-syntax-entry ?% "." perl-mode-syntax-table) - (modify-syntax-entry ?& "." perl-mode-syntax-table) - (modify-syntax-entry ?\' "\"" perl-mode-syntax-table) - (modify-syntax-entry ?* "." perl-mode-syntax-table) - (modify-syntax-entry ?+ "." perl-mode-syntax-table) - (modify-syntax-entry ?- "." perl-mode-syntax-table) - (modify-syntax-entry ?/ "." perl-mode-syntax-table) - (modify-syntax-entry ?< "." perl-mode-syntax-table) - (modify-syntax-entry ?= "." perl-mode-syntax-table) - (modify-syntax-entry ?> "." perl-mode-syntax-table) - (modify-syntax-entry ?\\ "\\" perl-mode-syntax-table) - (modify-syntax-entry ?` "\"" perl-mode-syntax-table) - (modify-syntax-entry ?| "." perl-mode-syntax-table) -) - -(defconst perl-indent-level 4 - "*Indentation of Perl statements with respect to containing block.") -(defconst perl-continued-statement-offset 4 - "*Extra indent for lines not starting new statements.") -(defconst perl-continued-brace-offset -4 - "*Extra indent for substatements that start with open-braces. -This is in addition to perl-continued-statement-offset.") -(defconst perl-brace-offset 0 - "*Extra indentation for braces, compared with other text in same context.") -(defconst perl-brace-imaginary-offset 0 - "*Imagined indentation of an open brace that actually follows a statement.") -(defconst perl-label-offset -2 - "*Offset of Perl label lines relative to usual indentation.") - -(defconst perl-tab-always-indent t - "*Non-nil means TAB in Perl mode should always indent the current line, -regardless of where in the line point is when the TAB command is used.") - -(defconst perl-tab-to-comment t - "*Non-nil means that for lines which don't need indenting, TAB will -either indent an existing comment, move to end-of-line, or if at end-of-line -already, create a new comment.") - -(defconst perl-nochange ";?#\\|\f\\|\\s(\\|\\(\\w\\|\\s_\\)+:" - "*Lines starting with this regular expression will not be auto-indented.") - -(defun perl-mode () - "Major mode for editing Perl code. -Expression and list commands understand all Perl brackets. -Tab indents for Perl code. -Comments are delimited with # ... \\n. -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. -\\{perl-mode-map} -Variables controlling indentation style: - perl-tab-always-indent - Non-nil means TAB in Perl mode should always indent the current line, - regardless of where in the line point is when the TAB command is used. - perl-tab-to-comment - Non-nil means that for lines which don't need indenting, TAB will - either delete an empty comment, indent an existing comment, move - to end-of-line, or if at end-of-line already, create a new comment. - perl-nochange - Lines starting with this regular expression will not be auto-indented. - perl-indent-level - Indentation of Perl statements within surrounding block. - The surrounding block's indentation is the indentation - of the line on which the open-brace appears. - perl-continued-statement-offset - Extra indentation given to a substatement, such as the - then-clause of an if or body of a while. - perl-continued-brace-offset - Extra indentation given to a brace that starts a substatement. - This is in addition to perl-continued-statement-offset. - perl-brace-offset - Extra indentation for line if it starts with an open brace. - perl-brace-imaginary-offset - An open brace following other text is treated as if it were - this far to the right of the start of its line. - perl-label-offset - Extra indentation for line that is a label. - -Various indentation styles: K&R BSD BLK GNU LW - perl-indent-level 5 8 0 2 4 - perl-continued-statement-offset 5 8 4 2 4 - perl-continued-brace-offset 0 0 0 0 -4 - perl-brace-offset -5 -8 0 0 0 - perl-brace-imaginary-offset 0 0 4 0 0 - perl-label-offset -5 -8 -2 -2 -2 - -Turning on Perl mode calls the value of the variable perl-mode-hook with no -args, if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map perl-mode-map) - (setq major-mode 'perl-mode) - (setq mode-name "Perl") - (setq local-abbrev-table perl-mode-abbrev-table) - (set-syntax-table perl-mode-syntax-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "^$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'perl-indent-line) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'comment-start) - (setq comment-start "# ") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column 32) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "\\(^\\|\\s-\\);?#+ *") - (make-local-variable 'comment-indent-hook) - (setq comment-indent-hook 'perl-comment-indent) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments nil) - (run-hooks 'perl-mode-hook)) - -;; This is used by indent-for-comment -;; to decide how much to indent a comment in Perl code -;; based on its context. -(defun perl-comment-indent () - (if (and (bolp) (not (eolp))) - 0 ;Existing comment at bol stays there. - (save-excursion - (skip-chars-backward " \t") - (max (1+ (current-column)) ;Else indent at comment column - comment-column)))) ; except leave at least one space. - -(defun electric-perl-terminator (arg) - "Insert character. If at end-of-line, and not in a comment or a quote, -correct the line's indentation." - (interactive "P") - (let ((insertpos (point))) - (and (not arg) ; decide whether to indent - (eolp) - (save-excursion - (beginning-of-line) - (and (not ; eliminate comments quickly - (re-search-forward comment-start-skip insertpos t)) - (or (/= last-command-char ?:) - ;; Colon is special only after a label .... - (looking-at "\\s-*\\(\\w\\|\\s_\\)+$")) - (let ((pps (parse-partial-sexp - (perl-beginning-of-function) insertpos))) - (not (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))) - (progn ; must insert, indent, delete - (insert-char last-command-char 1) - (perl-indent-line) - (delete-char -1)))) - (self-insert-command (prefix-numeric-value arg))) - -;; not used anymore, but may be useful someday: -;;(defun perl-inside-parens-p () -;; (condition-case () -;; (save-excursion -;; (save-restriction -;; (narrow-to-region (point) -;; (perl-beginning-of-function)) -;; (goto-char (point-max)) -;; (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\())) -;; (error nil))) - -(defun perl-indent-command (&optional arg) - "Indent current line as Perl code, or optionally, insert a tab character. - -With an argument, indent the current line, regardless of other options. - -If perl-tab-always-indent is nil and point is not in the indentation -area at the beginning of the line, simply insert a tab. - -Otherwise, indent the current line. If point was within the indentation -area it is moved to the end of the indentation area. If the line was -already indented properly and point was not within the indentation area, -and if perl-tab-to-comment is non-nil (the default), then do the first -possible action from the following list: - - 1) delete an empty comment - 2) move forward to start of comment, indenting if necessary - 3) move forward to end of line - 4) create an empty comment - 5) move backward to start of comment, indenting if necessary." - (interactive "P") - (if arg ; If arg, just indent this line - (perl-indent-line "\f") - (if (and (not perl-tab-always-indent) - (<= (current-column) (current-indentation))) - (insert-tab) - (let (bof lsexp delta (oldpnt (point))) - (beginning-of-line) - (setq lsexp (point)) - (setq bof (perl-beginning-of-function)) - (goto-char oldpnt) - (setq delta (perl-indent-line "\f\\|;?#" bof)) - (and perl-tab-to-comment - (= oldpnt (point)) ; done if point moved - (if (listp delta) ; if line starts in a quoted string - (setq lsexp (or (nth 2 delta) bof)) - (= delta 0)) ; done if indenting occurred - (let (eol state) - (end-of-line) - (setq eol (point)) - (if (= (char-after bof) ?=) - (if (= oldpnt eol) - (message "In a format statement")) - (setq state (parse-partial-sexp lsexp eol)) - (if (nth 3 state) - (if (= oldpnt eol) ; already at eol in a string - (message "In a string which starts with a %c." - (nth 3 state))) - (if (not (nth 4 state)) - (if (= oldpnt eol) ; no comment, create one? - (indent-for-comment)) - (beginning-of-line) - (if (re-search-forward comment-start-skip eol 'move) - (if (eolp) - (progn ; kill existing comment - (goto-char (match-beginning 0)) - (skip-chars-backward " \t") - (kill-region (point) eol)) - (if (or (< oldpnt (point)) (= oldpnt eol)) - (indent-for-comment) ; indent existing comment - (end-of-line))) - (if (/= oldpnt eol) - (end-of-line) - (message "Use backslash to quote # characters.") - (ding t)))))))))))) - -(defun perl-indent-line (&optional nochange parse-start) - "Indent current line as Perl code. Return the amount the indentation -changed by, or (parse-state) if line starts in a quoted string." - (let ((case-fold-search nil) - (pos (- (point-max) (point))) - (bof (or parse-start (save-excursion (perl-beginning-of-function)))) - beg indent shift-amt) - (beginning-of-line) - (setq beg (point)) - (setq shift-amt - (cond ((= (char-after bof) ?=) 0) - ((listp (setq indent (calculate-perl-indent bof))) indent) - ((looking-at (or nochange perl-nochange)) 0) - (t - (skip-chars-forward " \t\f") - (cond ((looking-at "\\(\\w\\|\\s_\\)+:") - (setq indent (max 1 (+ indent perl-label-offset)))) - ((= (following-char) ?}) - (setq indent (- indent perl-indent-level))) - ((= (following-char) ?{) - (setq indent (+ indent perl-brace-offset)))) - (- indent (current-column))))) - (skip-chars-forward " \t\f") - (if (and (numberp shift-amt) (/= 0 shift-amt)) - (progn (delete-region beg (point)) - (indent-to indent))) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - shift-amt)) - -(defun calculate-perl-indent (&optional parse-start) - "Return appropriate indentation for current line as Perl code. -In usual case returns an integer: the column to indent to. -Returns (parse-state) if line starts inside a string." - (save-excursion - (beginning-of-line) - (let ((indent-point (point)) - (case-fold-search nil) - (colon-line-end 0) - state containing-sexp) - (if parse-start ;used to avoid searching - (goto-char parse-start) - (perl-beginning-of-function)) - (while (< (point) indent-point) ;repeat until right sexp - (setq parse-start (point)) - (setq state (parse-partial-sexp (point) indent-point 0)) -; state = (depth_in_parens innermost_containing_list last_complete_sexp -; string_terminator_or_nil inside_commentp following_quotep -; minimum_paren-depth_this_scan) -; Parsing stops if depth in parentheses becomes equal to third arg. - (setq containing-sexp (nth 1 state))) - (cond ((nth 3 state) state) ; In a quoted string? - ((null containing-sexp) ; Line is at top level. - (skip-chars-forward " \t\f") - (if (= (following-char) ?{) - 0 ; move to beginning of line if it starts a function body - ;; indent a little if this is a continuation line - (perl-backward-to-noncomment) - (if (or (bobp) - (memq (preceding-char) '(?\; ?\}))) - 0 perl-continued-statement-offset))) - ((/= (char-after containing-sexp) ?{) - ;; line is expression, not statement: - ;; indent to just after the surrounding open. - (goto-char (1+ containing-sexp)) - (current-column)) - (t - ;; Statement level. Is it a continuation or a new statement? - ;; Find previous non-comment character. - (perl-backward-to-noncomment) - ;; Back up over label lines, since they don't - ;; affect whether our line is a continuation. - (while (or (eq (preceding-char) ?\,) - (and (eq (preceding-char) ?:) - (memq (char-syntax (char-after (- (point) 2))) - '(?w ?_)))) - (if (eq (preceding-char) ?\,) - (perl-backward-to-start-of-continued-exp containing-sexp)) - (beginning-of-line) - (perl-backward-to-noncomment)) - ;; Now we get the answer. - (if (not (memq (preceding-char) '(?\; ?\} ?\{))) - ;; This line is continuation of preceding line's statement; - ;; indent perl-continued-statement-offset more than the - ;; previous line of the statement. - (progn - (perl-backward-to-start-of-continued-exp containing-sexp) - (+ perl-continued-statement-offset (current-column) - (if (save-excursion (goto-char indent-point) - (looking-at "[ \t]*{")) - perl-continued-brace-offset 0))) - ;; This line starts a new statement. - ;; Position at last unclosed open. - (goto-char containing-sexp) - (or - ;; If open paren is in col 0, close brace is special - (and (bolp) - (save-excursion (goto-char indent-point) - (looking-at "[ \t]*}")) - perl-indent-level) - ;; Is line first statement after an open-brace? - ;; If no, find that first statement and indent like it. - (save-excursion - (forward-char 1) - ;; Skip over comments and labels following openbrace. - (while (progn - (skip-chars-forward " \t\f\n") - (cond ((looking-at ";?#") - (forward-line 1) t) - ((looking-at "\\(\\w\\|\\s_\\)+:") - (save-excursion - (end-of-line) - (setq colon-line-end (point))) - (search-forward ":"))))) - ;; The first following code counts - ;; if it is before the line we want to indent. - (and (< (point) indent-point) - (if (> colon-line-end (point)) - (- (current-indentation) perl-label-offset) - (current-column)))) - ;; If no previous statement, - ;; indent it relative to line brace is on. - ;; For open paren in column zero, don't let statement - ;; start there too. If perl-indent-level is zero, - ;; use perl-brace-offset + perl-continued-statement-offset - ;; For open-braces not the first thing in a line, - ;; add in perl-brace-imaginary-offset. - (+ (if (and (bolp) (zerop perl-indent-level)) - (+ perl-brace-offset perl-continued-statement-offset) - perl-indent-level) - ;; Move back over whitespace before the openbrace. - ;; If openbrace is not first nonwhite thing on the line, - ;; add the perl-brace-imaginary-offset. - (progn (skip-chars-backward " \t") - (if (bolp) 0 perl-brace-imaginary-offset)) - ;; If the openbrace is preceded by a parenthesized exp, - ;; move to the beginning of that; - ;; possibly a different line - (progn - (if (eq (preceding-char) ?\)) - (forward-sexp -1)) - ;; Get initial indentation of the line we are on. - (current-indentation)))))))))) - -(defun perl-backward-to-noncomment () - "Move point backward to after the first non-white-space, skipping comments." - (interactive) - (let (opoint stop) - (while (not stop) - (setq opoint (point)) - (beginning-of-line) - (if (re-search-forward comment-start-skip opoint 'move 1) - (progn (goto-char (match-end 1)) - (skip-chars-forward ";"))) - (skip-chars-backward " \t\f") - (setq stop (or (bobp) - (not (bolp)) - (forward-char -1)))))) - -(defun perl-backward-to-start-of-continued-exp (lim) - (if (= (preceding-char) ?\)) - (forward-sexp -1)) - (beginning-of-line) - (if (<= (point) lim) - (goto-char (1+ lim))) - (skip-chars-forward " \t\f")) - -;; note: this may be slower than the c-mode version, but I can understand it. -(defun indent-perl-exp () - "Indent each line of the Perl grouping following point." - (interactive) - (let* ((case-fold-search nil) - (oldpnt (point-marker)) - (bof-mark (save-excursion - (end-of-line 2) - (perl-beginning-of-function) - (point-marker))) - eol last-mark lsexp-mark delta) - (if (= (char-after (marker-position bof-mark)) ?=) - (message "Can't indent a format statement") - (message "Indenting Perl expression...") - (save-excursion (end-of-line) (setq eol (point))) - (save-excursion ; locate matching close paren - (while (and (not (eobp)) (<= (point) eol)) - (parse-partial-sexp (point) (point-max) 0)) - (setq last-mark (point-marker))) - (setq lsexp-mark bof-mark) - (beginning-of-line) - (while (< (point) (marker-position last-mark)) - (setq delta (perl-indent-line nil (marker-position bof-mark))) - (if (numberp delta) ; unquoted start-of-line? - (progn - (if (eolp) - (delete-horizontal-space)) - (setq lsexp-mark (point-marker)))) - (end-of-line) - (setq eol (point)) - (if (nth 4 (parse-partial-sexp (marker-position lsexp-mark) eol)) - (progn ; line ends in a comment - (beginning-of-line) - (if (or (not (looking-at "\\s-*;?#")) - (listp delta) - (and (/= 0 delta) - (= (- (current-indentation) delta) comment-column))) - (if (re-search-forward comment-start-skip eol t) - (indent-for-comment))))) ; indent existing comment - (forward-line 1)) - (goto-char (marker-position oldpnt)) - (message "Indenting Perl expression...done")))) - -(defun perl-beginning-of-function (&optional arg) - "Move backward to next beginning-of-function, or as far as possible. -With argument, repeat that many times; negative args move forward. -Returns new value of point in all cases." - (interactive "p") - (or arg (setq arg 1)) - (if (< arg 0) (forward-char 1)) - (and (/= arg 0) - (re-search-backward "^\\s(\\|^\\s-*sub\\b[^{]+{\\|^\\s-*format\\b[^=]*=\\|^\\." - nil 'move arg) - (goto-char (1- (match-end 0)))) - (point)) - -;; note: this routine is adapted directly from emacs lisp.el, end-of-defun; -;; no bugs have been removed :-) -(defun perl-end-of-function (&optional arg) - "Move forward to next end-of-function. -The end of a function is found by moving forward from the beginning of one. -With argument, repeat that many times; negative args move backward." - (interactive "p") - (or arg (setq arg 1)) - (let ((first t)) - (while (and (> arg 0) (< (point) (point-max))) - (let ((pos (point)) npos) - (while (progn - (if (and first - (progn - (forward-char 1) - (perl-beginning-of-function 1) - (not (bobp)))) - nil - (or (bobp) (forward-char -1)) - (perl-beginning-of-function -1)) - (setq first nil) - (forward-list 1) - (skip-chars-forward " \t") - (if (looking-at "[#\n]") - (forward-line 1)) - (<= (point) pos)))) - (setq arg (1- arg))) - (while (< arg 0) - (let ((pos (point))) - (perl-beginning-of-function 1) - (forward-sexp 1) - (forward-line 1) - (if (>= (point) pos) - (if (progn (perl-beginning-of-function 2) (not (bobp))) - (progn - (forward-list 1) - (skip-chars-forward " \t") - (if (looking-at "[#\n]") - (forward-line 1))) - (goto-char (point-min))))) - (setq arg (1+ arg))))) - -(defun mark-perl-function () - "Put mark at end of Perl function, point at beginning." - (interactive) - (push-mark (point)) - (perl-end-of-function) - (push-mark (point)) - (perl-beginning-of-function) - (backward-paragraph)) - -;;;;;;;; That's all, folks! ;;;;;;;;; diff --git a/emacs/perldb.el b/emacs/perldb.el deleted file mode 100644 index 66951be26d..0000000000 --- a/emacs/perldb.el +++ /dev/null @@ -1,423 +0,0 @@ -;; Run perl -d under Emacs -;; Based on gdb.el, as written by W. Schelter, and modified by rms. -;; Modified for Perl by Ray Lischner (uunet!mntgfx!lisch), Nov 1990. - -;; This file is part of GNU Emacs. -;; Copyright (C) 1988,1990 Free Software Foundation, Inc. - -;; GNU Emacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY. No author or distributor accepts responsibility -;; to anyone for the consequences of using it or for whether it serves -;; any particular purpose or works at all, unless he says so in writing. -;; Refer to the GNU Emacs General Public License for full details. - -;; Everyone is granted permission to copy, modify and redistribute GNU -;; Emacs, but only under the conditions described in the GNU Emacs -;; General Public License. A copy of this license is supposed to have -;; been given to you along with GNU Emacs so you can know your rights and -;; responsibilities. It should be in a file named COPYING. Among other -;; things, the copyright notice and this notice must be preserved on all -;; copies. - -;; Description of perl -d interface: - -;; A facility is provided for the simultaneous display of the source code -;; in one window, while using perldb to step through a function in the -;; other. A small arrow in the source window, indicates the current -;; line. - -;; Starting up: - -;; In order to use this facility, invoke the command PERLDB to obtain a -;; shell window with the appropriate command bindings. You will be asked -;; for the name of a file to run and additional command line arguments. -;; Perldb will be invoked on this file, in a window named *perldb-foo* -;; if the file is foo. - -;; M-s steps by one line, and redisplays the source file and line. - -;; You may easily create additional commands and bindings to interact -;; with the display. For example to put the perl debugger command n on \M-n -;; (def-perldb n "\M-n") - -;; This causes the emacs command perldb-next to be defined, and runs -;; perldb-display-frame after the command. - -;; perldb-display-frame is the basic display function. It tries to display -;; in the other window, the file and line corresponding to the current -;; position in the perldb window. For example after a perldb-step, it would -;; display the line corresponding to the position for the last step. Or -;; if you have done a backtrace in the perldb buffer, and move the cursor -;; into one of the frames, it would display the position corresponding to -;; that frame. - -;; perldb-display-frame is invoked automatically when a filename-and-line-number -;; appears in the output. - - -(require 'shell) - -(defvar perldb-prompt-pattern "^ DB<[0-9]+> " - "A regexp to recognize the prompt for perldb.") - -(defvar perldb-mode-map nil - "Keymap for perldb-mode.") - -(if perldb-mode-map - nil - (setq perldb-mode-map (copy-keymap shell-mode-map)) - (define-key perldb-mode-map "\C-l" 'perldb-refresh)) - -(define-key ctl-x-map " " 'perldb-break) -(define-key ctl-x-map "&" 'send-perldb-command) - -;;Of course you may use `def-perldb' with any other perldb command, including -;;user defined ones. - -(defmacro def-perldb (name key &optional doc) - (let* ((fun (intern (concat "perldb-" name)))) - (` (progn - (defun (, fun) (arg) - (, (or doc "")) - (interactive "p") - (perldb-call (if (not (= 1 arg)) - (concat (, name) arg) - (, name)))) - (define-key perldb-mode-map (, key) (quote (, fun))))))) - -(def-perldb "s" "\M-s" "Step one source line with display") -(def-perldb "n" "\M-n" "Step one source line (skip functions)") -(def-perldb "c" "\M-c" "Continue with display") -(def-perldb "r" "\C-c\C-r" "Return from current subroutine") -(def-perldb "A" "\C-c\C-a" "Delete all actions") - -(defun perldb-mode () - "Major mode for interacting with an inferior Perl debugger process. -The following commands are available: - -\\{perldb-mode-map} - -\\[perldb-display-frame] displays in the other window -the last line referred to in the perldb buffer. - -\\[perldb-s],\\[perldb-n], and \\[perldb-n] in the perldb window, -call perldb to step, next or continue and then update the other window -with the current file and position. - -If you are in a source file, you may select a point to break -at, by doing \\[perldb-break]. - -Commands: -Many commands are inherited from shell mode. -Additionally we have: - -\\[perldb-display-frame] display frames file in other window -\\[perldb-s] advance one line in program -\\[perldb-n] advance one line in program (skip over calls). -\\[send-perldb-command] used for special printing of an arg at the current point. -C-x SPACE sets break point at current line." - (interactive) - (kill-all-local-variables) - (setq major-mode 'perldb-mode) - (setq mode-name "Inferior Perl") - (setq mode-line-process '(": %s")) - (use-local-map perldb-mode-map) - (make-local-variable 'last-input-start) - (setq last-input-start (make-marker)) - (make-local-variable 'last-input-end) - (setq last-input-end (make-marker)) - (make-local-variable 'perldb-last-frame) - (setq perldb-last-frame nil) - (make-local-variable 'perldb-last-frame-displayed-p) - (setq perldb-last-frame-displayed-p t) - (make-local-variable 'perldb-delete-prompt-marker) - (setq perldb-delete-prompt-marker nil) - (make-local-variable 'perldb-filter-accumulator) - (setq perldb-filter-accumulator nil) - (make-local-variable 'shell-prompt-pattern) - (setq shell-prompt-pattern perldb-prompt-pattern) - (run-hooks 'shell-mode-hook 'perldb-mode-hook)) - -(defvar current-perldb-buffer nil) - -(defvar perldb-command-name "perl" - "Pathname for executing perl -d.") - -(defun end-of-quoted-arg (argstr start end) - (let* ((chr (substring argstr start (1+ start))) - (idx (string-match (concat "[^\\]" chr) argstr (1+ start)))) - (and idx (1+ idx)) - ) -) - -(defun parse-args-helper (arglist argstr start end) - (while (and (< start end) (string-match "[ \t\n\f\r\b]" - (substring argstr start (1+ start)))) - (setq start (1+ start))) - (cond - ((= start end) arglist) - ((string-match "[\"']" (substring argstr start (1+ start))) - (let ((next (end-of-quoted-arg argstr start end))) - (parse-args-helper (cons (substring argstr (1+ start) next) arglist) - argstr (1+ next) end))) - (t (let ((next (string-match "[ \t\n\f\b\r]" argstr start))) - (if next - (parse-args-helper (cons (substring argstr start next) arglist) - argstr (1+ next) end) - (cons (substring argstr start) arglist)))) - ) - ) - -(defun parse-args (args) - "Extract arguments from a string ARGS. -White space separates arguments, with single or double quotes -used to protect spaces. A list of strings is returned, e.g., -(parse-args \"foo bar 'two args'\") => (\"foo\" \"bar\" \"two args\")." - (nreverse (parse-args-helper '() args 0 (length args))) -) - -(defun perldb (path args) - "Run perldb on program FILE in buffer *perldb-FILE*. -The default directory for the current buffer becomes the initial -working directory, by analogy with gdb . If you wish to change this, use -the Perl command `chdir(DIR)'." - (interactive "FRun perl -d on file: \nsCommand line arguments: ") - (setq path (expand-file-name path)) - (let ((file (file-name-nondirectory path)) - (dir default-directory)) - (switch-to-buffer (concat "*perldb-" file "*")) - (setq default-directory dir) - (or (bolp) (newline)) - (insert "Current directory is " default-directory "\n") - (apply 'make-shell - (concat "perldb-" file) perldb-command-name nil "-d" path "-emacs" - (parse-args args)) - (perldb-mode) - (set-process-filter (get-buffer-process (current-buffer)) 'perldb-filter) - (set-process-sentinel (get-buffer-process (current-buffer)) 'perldb-sentinel) - (perldb-set-buffer))) - -(defun perldb-set-buffer () - (cond ((eq major-mode 'perldb-mode) - (setq current-perldb-buffer (current-buffer))))) - -;; This function is responsible for inserting output from Perl -;; into the buffer. -;; Aside from inserting the text, it notices and deletes -;; each filename-and-line-number; -;; that Perl prints to identify the selected frame. -;; It records the filename and line number, and maybe displays that file. -(defun perldb-filter (proc string) - (let ((inhibit-quit t)) - (if perldb-filter-accumulator - (perldb-filter-accumulate-marker proc - (concat perldb-filter-accumulator string)) - (perldb-filter-scan-input proc string)))) - -(defun perldb-filter-accumulate-marker (proc string) - (setq perldb-filter-accumulator nil) - (if (> (length string) 1) - (if (= (aref string 1) ?\032) - (let ((end (string-match "\n" string))) - (if end - (progn - (let* ((first-colon (string-match ":" string 2)) - (second-colon - (string-match ":" string (1+ first-colon)))) - (setq perldb-last-frame - (cons (substring string 2 first-colon) - (string-to-int - (substring string (1+ first-colon) - second-colon))))) - (setq perldb-last-frame-displayed-p nil) - (perldb-filter-scan-input proc - (substring string (1+ end)))) - (setq perldb-filter-accumulator string))) - (perldb-filter-insert proc "\032") - (perldb-filter-scan-input proc (substring string 1))) - (setq perldb-filter-accumulator string))) - -(defun perldb-filter-scan-input (proc string) - (if (equal string "") - (setq perldb-filter-accumulator nil) - (let ((start (string-match "\032" string))) - (if start - (progn (perldb-filter-insert proc (substring string 0 start)) - (perldb-filter-accumulate-marker proc - (substring string start))) - (perldb-filter-insert proc string))))) - -(defun perldb-filter-insert (proc string) - (let ((moving (= (point) (process-mark proc))) - (output-after-point (< (point) (process-mark proc))) - (old-buffer (current-buffer)) - start) - (set-buffer (process-buffer proc)) - (unwind-protect - (save-excursion - ;; Insert the text, moving the process-marker. - (goto-char (process-mark proc)) - (setq start (point)) - (insert string) - (set-marker (process-mark proc) (point)) - (perldb-maybe-delete-prompt) - ;; Check for a filename-and-line number. - (perldb-display-frame - ;; Don't display the specified file - ;; unless (1) point is at or after the position where output appears - ;; and (2) this buffer is on the screen. - (or output-after-point - (not (get-buffer-window (current-buffer)))) - ;; Display a file only when a new filename-and-line-number appears. - t)) - (set-buffer old-buffer)) - (if moving (goto-char (process-mark proc))))) - -(defun perldb-sentinel (proc msg) - (cond ((null (buffer-name (process-buffer proc))) - ;; buffer killed - ;; Stop displaying an arrow in a source file. - (setq overlay-arrow-position nil) - (set-process-buffer proc nil)) - ((memq (process-status proc) '(signal exit)) - ;; Stop displaying an arrow in a source file. - (setq overlay-arrow-position nil) - ;; Fix the mode line. - (setq mode-line-process - (concat ": " - (symbol-name (process-status proc)))) - (let* ((obuf (current-buffer))) - ;; save-excursion isn't the right thing if - ;; process-buffer is current-buffer - (unwind-protect - (progn - ;; Write something in *compilation* and hack its mode line, - (set-buffer (process-buffer proc)) - ;; Force mode line redisplay soon - (set-buffer-modified-p (buffer-modified-p)) - (if (eobp) - (insert ?\n mode-name " " msg) - (save-excursion - (goto-char (point-max)) - (insert ?\n mode-name " " msg))) - ;; If buffer and mode line will show that the process - ;; is dead, we can delete it now. Otherwise it - ;; will stay around until M-x list-processes. - (delete-process proc)) - ;; Restore old buffer, but don't restore old point - ;; if obuf is the perldb buffer. - (set-buffer obuf)))))) - - -(defun perldb-refresh () - "Fix up a possibly garbled display, and redraw the arrow." - (interactive) - (redraw-display) - (perldb-display-frame)) - -(defun perldb-display-frame (&optional nodisplay noauto) - "Find, obey and delete the last filename-and-line marker from PERLDB. -The marker looks like \\032\\032FILENAME:LINE:CHARPOS\\n. -Obeying it means displaying in another window the specified file and line." - (interactive) - (perldb-set-buffer) - (and perldb-last-frame (not nodisplay) - (or (not perldb-last-frame-displayed-p) (not noauto)) - (progn (perldb-display-line (car perldb-last-frame) (cdr perldb-last-frame)) - (setq perldb-last-frame-displayed-p t)))) - -;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen -;; and that its line LINE is visible. -;; Put the overlay-arrow on the line LINE in that buffer. - -(defun perldb-display-line (true-file line) - (let* ((buffer (find-file-noselect true-file)) - (window (display-buffer buffer t)) - (pos)) - (save-excursion - (set-buffer buffer) - (save-restriction - (widen) - (goto-line line) - (setq pos (point)) - (setq overlay-arrow-string "=>") - (or overlay-arrow-position - (setq overlay-arrow-position (make-marker))) - (set-marker overlay-arrow-position (point) (current-buffer))) - (cond ((or (< pos (point-min)) (> pos (point-max))) - (widen) - (goto-char pos)))) - (set-window-point window overlay-arrow-position))) - -(defun perldb-call (command) - "Invoke perldb COMMAND displaying source in other window." - (interactive) - (goto-char (point-max)) - (setq perldb-delete-prompt-marker (point-marker)) - (perldb-set-buffer) - (send-string (get-buffer-process current-perldb-buffer) - (concat command "\n"))) - -(defun perldb-maybe-delete-prompt () - (if (and perldb-delete-prompt-marker - (> (point-max) (marker-position perldb-delete-prompt-marker))) - (let (start) - (goto-char perldb-delete-prompt-marker) - (setq start (point)) - (beginning-of-line) - (delete-region (point) start) - (setq perldb-delete-prompt-marker nil)))) - -(defun perldb-break () - "Set PERLDB breakpoint at this source line." - (interactive) - (let ((line (save-restriction - (widen) - (1+ (count-lines 1 (point)))))) - (send-string (get-buffer-process current-perldb-buffer) - (concat "b " line "\n")))) - -(defun perldb-read-token() - "Return a string containing the token found in the buffer at point. -A token can be a number or an identifier. If the token is a name prefaced -by `$', `@', or `%', the leading character is included in the token." - (save-excursion - (let (begin) - (or (looking-at "[$@%]") - (re-search-backward "[^a-zA-Z_0-9]" (point-min) 'move)) - (setq begin (point)) - (or (looking-at "[$@%]") (setq begin (+ begin 1))) - (forward-char 1) - (buffer-substring begin - (if (re-search-forward "[^a-zA-Z_0-9]" - (point-max) 'move) - (- (point) 1) - (point))) -))) - -(defvar perldb-commands nil - "List of strings or functions used by send-perldb-command. -It is for customization by the user.") - -(defun send-perldb-command (arg) - "Issue a Perl debugger command selected by the prefix arg. A numeric -arg selects the ARG'th member COMMAND of the list perldb-commands. -The token under the cursor is passed to the command. If COMMAND is a -string, (format COMMAND TOKEN) is inserted at the end of the perldb -buffer, otherwise (funcall COMMAND TOKEN) is inserted. If there is -no such COMMAND, then the token itself is inserted. For example, -\"p %s\" is a possible string to be a member of perldb-commands, -or \"p $ENV{%s}\"." - (interactive "P") - (let (comm token) - (if arg (setq comm (nth arg perldb-commands))) - (setq token (perldb-read-token)) - (if (eq (current-buffer) current-perldb-buffer) - (set-mark (point))) - (cond (comm - (setq comm - (if (stringp comm) (format comm token) (funcall comm token)))) - (t (setq comm token))) - (switch-to-buffer-other-window current-perldb-buffer) - (goto-char (dot-max)) - (insert-string comm))) diff --git a/emacs/perldb.pl b/emacs/perldb.pl deleted file mode 100644 index 958e58d874..0000000000 --- a/emacs/perldb.pl +++ /dev/null @@ -1,531 +0,0 @@ -package DB; - -# modified Perl debugger, to be run from Emacs in perldb-mode -# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990 - -$header = '$RCSfile: perldb.pl,v $$Revision: 4.1 $$Date: 92/08/07 17:20:59 $'; -# -# This file is automatically included if you do perl -d. -# It's probably not useful to include this yourself. -# -# Perl supplies the values for @line and %sub. It effectively inserts -# a do DB'DB(); in front of every place that can -# have a breakpoint. It also inserts a do 'perldb.pl' before the first line. -# -# $Log: perldb.pl,v $ - -open(IN, "/dev/tty") || open(OUT, ">&STDOUT"); # so we don't dongle stdout -select(OUT); -$| = 1; # for DB'OUT -select(STDOUT); -$| = 1; # for real STDOUT -$sub = ''; - -# Is Perl being run from Emacs? -$emacs = $main'ARGV[$[] eq '-emacs'; -shift(@main'ARGV) if $emacs; - -$header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/; -print OUT "\nLoading DB routines from $header\n\nEnter h for help.\n\n"; - -sub DB { - &save; - ($package, $filename, $line) = caller; - $usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' . - "package $package;"; # this won't let them modify, alas - local(*dbline) = "_<$filename"; - $max = $#dbline; - if (($stop,$action) = split(/\0/,$dbline{$line})) { - if ($stop eq '1') { - $signal |= 1; - } - else { - $evalarg = "\$DB'signal |= do {$stop;}"; &eval; - $dbline{$line} =~ s/;9($|\0)/$1/; - } - } - if ($single || $trace || $signal) { - if ($emacs) { - print OUT "\032\032$filename:$line:0\n"; - } else { - print OUT "$package'" unless $sub =~ /'/; - print OUT "$sub($filename:$line):\t",$dbline[$line]; - for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { - last if $dbline[$i] =~ /^\s*(}|#|\n)/; - print OUT "$sub($filename:$i):\t",$dbline[$i]; - } - } - } - $evalarg = $action, &eval if $action; - if ($single || $signal) { - $evalarg = $pre, &eval if $pre; - print OUT $#stack . " levels deep in subroutine calls!\n" - if $single & 4; - $start = $line; - while ((print OUT " DB<", $#hist+1, "> "), $cmd=&gets) { - $single = 0; - $signal = 0; - $cmd eq '' && exit 0; - chop($cmd); - $cmd =~ s/\\$// && do { - print OUT " cont: "; - $cmd .= &gets; - redo; - }; - $cmd =~ /^q$/ && exit 0; - $cmd =~ /^$/ && ($cmd = $laststep); - push(@hist,$cmd) if length($cmd) > 1; - ($i) = split(/\s+/,$cmd); - eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i}; - $cmd =~ /^h$/ && do { - print OUT " -T Stack trace. -s Single step. -n Next, steps over subroutine calls. -r Return from current subroutine. -c [line] Continue; optionally inserts a one-time-only breakpoint - at the specified line. - Repeat last n or s. -l min+incr List incr+1 lines starting at min. -l min-max List lines. -l line List line; -l List next window. -- List previous window. -w line List window around line. -l subname List subroutine. -f filename Switch to filename. -/pattern/ Search forwards for pattern; final / is optional. -?pattern? Search backwards for pattern. -L List breakpoints and actions. -S List subroutine names. -t Toggle trace mode. -b [line] [condition] - Set breakpoint; line defaults to the current execution line; - condition breaks if it evaluates to true, defaults to \'1\'. -b subname [condition] - Set breakpoint at first line of subroutine. -d [line] Delete breakpoint. -D Delete all breakpoints. -a [line] command - Set an action to be done before the line is executed. - Sequence is: check for breakpoint, print line if necessary, - do action, prompt user if breakpoint or step, evaluate line. -A Delete all actions. -V [pkg [vars]] List some (default all) variables in package (default current). -X [vars] Same as \"V currentpackage [vars]\". -< command Define command before prompt. -| command Define command after prompt. -! number Redo command (default previous command). -! -number Redo number\'th to last command. -H -number Display last number commands (default all). -q or ^D Quit. -p expr Same as \"print DB'OUT expr\" in current package. -= [alias value] Define a command alias, or list current aliases. -command Execute as a perl statement in current package. - -"; - next; }; - $cmd =~ /^t$/ && do { - $trace = !$trace; - print OUT "Trace = ".($trace?"on":"off")."\n"; - next; }; - $cmd =~ /^S$/ && do { - foreach $subname (sort(keys %sub)) { - print OUT $subname,"\n"; - } - next; }; - $cmd =~ s/^X\b/V $package/; - $cmd =~ /^V$/ && do { - $cmd = 'V $package'; }; - $cmd =~ /^V\s*(\S+)\s*(.*)/ && do { - $packname = $1; - @vars = split(' ',$2); - do 'dumpvar.pl' unless defined &main'dumpvar; - if (defined &main'dumpvar) { - &main'dumpvar($packname,@vars); - } - else { - print DB'OUT "dumpvar.pl not available.\n"; - } - next; }; - $cmd =~ /^f\s*(.*)/ && do { - $file = $1; - if (!$file) { - print OUT "The old f command is now the r command.\n"; - print OUT "The new f command switches filenames.\n"; - next; - } - if (!defined $_main{'_<' . $file}) { - if (($try) = grep(m#^_<.*$file#, keys %_main)) { - $file = substr($try,2); - print "\n$file:\n"; - } - } - if (!defined $_main{'_<' . $file}) { - print OUT "There's no code here anything matching $file.\n"; - next; - } - elsif ($file ne $filename) { - *dbline = "_<$file"; - $max = $#dbline; - $filename = $file; - $start = 1; - $cmd = "l"; - } }; - $cmd =~ /^l\s*(['A-Za-z_]['\w]*)/ && do { - $subname = $1; - $subname = "main'" . $subname unless $subname =~ /'/; - $subname = "main" . $subname if substr($subname,0,1) eq "'"; - ($file,$subrange) = split(/:/,$sub{$subname}); - if ($file ne $filename) { - *dbline = "_<$file"; - $max = $#dbline; - $filename = $file; - } - if ($subrange) { - if (eval($subrange) < -$window) { - $subrange =~ s/-.*/+/; - } - $cmd = "l $subrange"; - } else { - print OUT "Subroutine $1 not found.\n"; - next; - } }; - $cmd =~ /^w\s*(\d*)$/ && do { - $incr = $window - 1; - $start = $1 if $1; - $start -= $preview; - $cmd = 'l ' . $start . '-' . ($start + $incr); }; - $cmd =~ /^-$/ && do { - $incr = $window - 1; - $cmd = 'l ' . ($start-$window*2) . '+'; }; - $cmd =~ /^l$/ && do { - $incr = $window - 1; - $cmd = 'l ' . $start . '-' . ($start + $incr); }; - $cmd =~ /^l\s*(\d*)\+(\d*)$/ && do { - $start = $1 if $1; - $incr = $2; - $incr = $window - 1 unless $incr; - $cmd = 'l ' . $start . '-' . ($start + $incr); }; - $cmd =~ /^l\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do { - $end = (!$2) ? $max : ($4 ? $4 : $2); - $end = $max if $end > $max; - $i = $2; - $i = $line if $i eq '.'; - $i = 1 if $i < 1; - if ($emacs) { - print OUT "\032\032$filename:$i:0\n"; - $i = $end; - } else { - for (; $i <= $end; $i++) { - print OUT "$i:\t", $dbline[$i]; - last if $signal; - } - } - $start = $i; # remember in case they want more - $start = $max if $start > $max; - next; }; - $cmd =~ /^D$/ && do { - print OUT "Deleting all breakpoints...\n"; - for ($i = 1; $i <= $max ; $i++) { - if (defined $dbline{$i}) { - $dbline{$i} =~ s/^[^\0]+//; - if ($dbline{$i} =~ s/^\0?$//) { - delete $dbline{$i}; - } - } - } - next; }; - $cmd =~ /^L$/ && do { - for ($i = 1; $i <= $max; $i++) { - if (defined $dbline{$i}) { - print OUT "$i:\t", $dbline[$i]; - ($stop,$action) = split(/\0/, $dbline{$i}); - print OUT " break if (", $stop, ")\n" - if $stop; - print OUT " action: ", $action, "\n" - if $action; - last if $signal; - } - } - next; }; - $cmd =~ /^b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do { - $subname = $1; - $cond = $2 || '1'; - $subname = "$package'" . $subname unless $subname =~ /'/; - $subname = "main" . $subname if substr($subname,0,1) eq "'"; - ($filename,$i) = split(/[:-]/, $sub{$subname}); - if ($i) { - *dbline = "_<$filename"; - ++$i while $dbline[$i] == 0 && $i < $#dbline; - $dbline{$i} =~ s/^[^\0]*/$cond/; - } else { - print OUT "Subroutine $subname not found.\n"; - } - next; }; - $cmd =~ /^b\s*(\d*)\s*(.*)/ && do { - $i = ($1?$1:$line); - $cond = $2 || '1'; - if ($dbline[$i] == 0) { - print OUT "Line $i not breakable.\n"; - } else { - $dbline{$i} =~ s/^[^\0]*/$cond/; - } - next; }; - $cmd =~ /^d\s*(\d+)?/ && do { - $i = ($1?$1:$line); - $dbline{$i} =~ s/^[^\0]*//; - delete $dbline{$i} if $dbline{$i} eq ''; - next; }; - $cmd =~ /^A$/ && do { - for ($i = 1; $i <= $max ; $i++) { - if (defined $dbline{$i}) { - $dbline{$i} =~ s/\0[^\0]*//; - delete $dbline{$i} if $dbline{$i} eq ''; - } - } - next; }; - $cmd =~ /^<\s*(.*)/ && do { - $pre = do action($1); - next; }; - $cmd =~ /^>\s*(.*)/ && do { - $post = do action($1); - next; }; - $cmd =~ /^a\s*(\d+)(\s+(.*))?/ && do { - $i = $1; - if ($dbline[$i] == 0) { - print OUT "Line $i may not have an action.\n"; - } else { - $dbline{$i} =~ s/\0[^\0]*//; - $dbline{$i} .= "\0" . do action($3); - } - next; }; - $cmd =~ /^n$/ && do { - $single = 2; - $laststep = $cmd; - last; }; - $cmd =~ /^s$/ && do { - $single = 1; - $laststep = $cmd; - last; }; - $cmd =~ /^c\s*(\d*)\s*$/ && do { - $i = $1; - if ($i) { - if ($dbline[$i] == 0) { - print OUT "Line $i not breakable.\n"; - next; - } - $dbline{$i} =~ s/(\0|$)/;9$1/; # add one-time-only b.p. - } - for ($i=0; $i <= $#stack; ) { - $stack[$i++] &= ~1; - } - last; }; - $cmd =~ /^r$/ && do { - $stack[$#stack] |= 2; - last; }; - $cmd =~ /^T$/ && do { - local($p,$f,$l,$s,$h,$a,@a,@sub); - for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { - @a = @args; - for (@a) { - if (/^StB\000/ && length($_) == length($_main{'_main'})) { - $_ = sprintf("%s",$_); - } - else { - s/'/\\'/g; - s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; - s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; - s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; - } - } - $w = $w ? '@ = ' : '$ = '; - $a = $h ? '(' . join(', ', @a) . ')' : ''; - push(@sub, "$w&$s$a from file $f line $l\n"); - last if $signal; - } - for ($i=0; $i <= $#sub; $i++) { - last if $signal; - print OUT $sub[$i]; - } - next; }; - $cmd =~ /^\/(.*)$/ && do { - $inpat = $1; - $inpat =~ s:([^\\])/$:$1:; - if ($inpat ne "") { - eval '$inpat =~ m'."\n$inpat\n"; - if ($@ ne "") { - print OUT "$@"; - next; - } - $pat = $inpat; - } - $end = $start; - eval ' - for (;;) { - ++$start; - $start = 1 if ($start > $max); - last if ($start == $end); - if ($dbline[$start] =~ m'."\n$pat\n".'i) { - if ($emacs) { - print OUT "\032\032$filename:$start:0\n"; - } else { - print OUT "$start:\t", $dbline[$start], "\n"; - } - last; - } - } '; - print OUT "/$pat/: not found\n" if ($start == $end); - next; }; - $cmd =~ /^\?(.*)$/ && do { - $inpat = $1; - $inpat =~ s:([^\\])\?$:$1:; - if ($inpat ne "") { - eval '$inpat =~ m'."\n$inpat\n"; - if ($@ ne "") { - print OUT "$@"; - next; - } - $pat = $inpat; - } - $end = $start; - eval ' - for (;;) { - --$start; - $start = $max if ($start <= 0); - last if ($start == $end); - if ($dbline[$start] =~ m'."\n$pat\n".'i) { - if ($emacs) { - print OUT "\032\032$filename:$start:0\n"; - } else { - print OUT "$start:\t", $dbline[$start], "\n"; - } - last; - } - } '; - print OUT "?$pat?: not found\n" if ($start == $end); - next; }; - $cmd =~ /^!+\s*(-)?(\d+)?$/ && do { - pop(@hist) if length($cmd) > 1; - $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist)); - $cmd = $hist[$i] . "\n"; - print OUT $cmd; - redo; }; - $cmd =~ /^!(.+)$/ && do { - $pat = "^$1"; - pop(@hist) if length($cmd) > 1; - for ($i = $#hist; $i; --$i) { - last if $hist[$i] =~ $pat; - } - if (!$i) { - print OUT "No such command!\n\n"; - next; - } - $cmd = $hist[$i] . "\n"; - print OUT $cmd; - redo; }; - $cmd =~ /^H\s*(-(\d+))?/ && do { - $end = $2?($#hist-$2):0; - $hist = 0 if $hist < 0; - for ($i=$#hist; $i>$end; $i--) { - print OUT "$i: ",$hist[$i],"\n" - unless $hist[$i] =~ /^.?$/; - }; - next; }; - $cmd =~ s/^p( .*)?$/print DB'OUT$1/; - $cmd =~ /^=/ && do { - if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) { - $alias{$k}="s~$k~$v~"; - print OUT "$k = $v\n"; - } elsif ($cmd =~ /^=\s*$/) { - foreach $k (sort keys(%alias)) { - if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) { - print OUT "$k = $v\n"; - } else { - print OUT "$k\t$alias{$k}\n"; - }; - }; - }; - next; }; - $evalarg = $cmd; &eval; - print OUT "\n"; - } - if ($post) { - $evalarg = $post; &eval; - } - } - ($@, $!, $[, $,, $/, $\) = @saved; -} - -sub save { - @saved = ($@, $!, $[, $,, $/, $\); - $[ = 0; $, = ""; $/ = "\n"; $\ = ""; -} - -# The following takes its argument via $evalarg to preserve current @_ - -sub eval { - eval "$usercontext $evalarg; &DB'save"; - print OUT $@; -} - -sub action { - local($action) = @_; - while ($action =~ s/\\$//) { - print OUT "+ "; - $action .= &gets; - } - $action; -} - -sub gets { - local($.); - ; -} - -sub catch { - $signal = 1; -} - -sub sub { - push(@stack, $single); - $single &= 1; - $single |= 4 if $#stack == $deep; - if (wantarray) { - @i = &$sub; - $single |= pop(@stack); - @i; - } - else { - $i = &$sub; - $single |= pop(@stack); - $i; - } -} - -$single = 1; # so it stops on first executable statement -@hist = ('?'); -$SIG{'INT'} = "DB'catch"; -$deep = 100; # warning if stack gets this deep -$window = 10; -$preview = 3; - -@stack = (0); -@ARGS = @ARGV; -for (@args) { - s/'/\\'/g; - s/(.*)/'$1'/ unless /^-?[\d.]+$/; -} - -if (-f '.perldb') { - do './.perldb'; -} -elsif (-f "$ENV{'LOGDIR'}/.perldb") { - do "$ENV{'LOGDIR'}/.perldb"; -} -elsif (-f "$ENV{'HOME'}/.perldb") { - do "$ENV{'HOME'}/.perldb"; -} - -1; diff --git a/emacs/tedstuff b/emacs/tedstuff deleted file mode 100644 index 257bbc8553..0000000000 --- a/emacs/tedstuff +++ /dev/null @@ -1,296 +0,0 @@ -Article 4417 of comp.lang.perl: -Path: jpl-devvax!elroy.jpl.nasa.gov!decwrl!mcnc!uvaarpa!mmdf -From: ted@evi.com (Ted Stefanik) -Newsgroups: comp.lang.perl -Subject: Correction to Perl fatal error marking in GNU Emacs -Message-ID: <1991Feb27.065853.15801@uvaarpa.Virginia.EDU> -Date: 27 Feb 91 06:58:53 GMT -Sender: mmdf@uvaarpa.Virginia.EDU (Uvaarpa Mail System) -Reply-To: ted@evi.com (Ted Stefanik) -Organization: The Internet -Lines: 282 - -Reading my own message, it occurred to me that I didn't quite satisfy the -request of stef@zweig.sun (Stephane Payrard): - -| Does anyone has extended perdb/perdb.el to position the -| point to the first syntax error? It would be cool. - -What I posted is a way to use the "M-x compile" command to test perl scripts. -(Needless to say, the script cannot be not interactive; you can't provide input -to a *compilation* buffer). When creating new Perl programs, I use "M-x -compile" until I'm sure that they are syntatically correct; if syntax errors -occur, C-x` takes me to each in sequence. After I'm sure the syntax is -correct, I start worrying about semantics, and switch to "M-x perldb" if -necessary. - -Therefore, the stuff I posted works great with "M-x compile", but not at all -with "M-x perldb". - -Next, let me update what I posted. I found that perl's die() command doesn't -print the same format error message as perl does when it dies with a syntax -error. If you put the following in your ".emacs" file, it causes C-x` to -recognize both kinds of errors: - -(load-library "compile") -(setq compilation-error-regexp - "\\([^ :\n]+\\(: *\\|, line \\|(\\)[0-9]+\\)\\|\\([0-9]+ *of *[^ \n]+\\|[^ \n]+ \\(at \\)*line [0-9]+\\)") - -Last, so I don't look like a total fool, let me propose a way to satisfy -Stephane Payrard's original request (repeated again): - -| Does anyone has extended perdb/perdb.el to position the -| point to the first syntax error? It would be cool. - -I'm not satisfied with just the "first syntax error". Perl's parser is better -than most about not getting out of sync; therefore, if it reports multiple -errors, you can usually be assured they are all real errors. - -So... I hacked in the "next-error" function from "compile.el" to form -"perldb-next-error". You can apply the patches at the end of this message -to add "perldb-next-error" to your "perldb.el". - -Notes: - 1) The patch binds "perldb-next-error" to C-x~ (because ~ is the shift - of ` on my keyboard, and C-x~ is not yet taken in my version of EMACS). - - 2) "next-error" is meant to work on a single *compilation* buffer; any new - "M-x compile" or "M-x grep" command will clear the old *compilation* - buffer and reset the compilation-error parser to start at the top of the - *compilation* buffer. - - "perldb-next-error", on the other hand, has to deal with multiple - *perldb-* buffers, each of which keep growing. "perldb-next-error" - correctly handles the constantly growing *perldb-* buffers by - keeping track of the last reported error in the "current-perldb-buffer". - - Sadly however, when you invoke a new "M-x perldb" on a different Perl - script, "perldb-next-error" will start parsing the new *perldb-* - buffer at the top (even if it was previously parsed), and will completely - lose the marker of the last reported error in *perldb-*. - - 3) "perldb-next-error" still uses "compilation-error-regexp" to find - fatal errors. Therefore, both the "M-x compile"/C-x` scheme and - the "M-x perldb"/C-x~ scheme can be used to find fatal errors that - match the common "compilation-error-regexp". You *will* want to install - that "compilation-error-regexp" stuff into your .emacs file. - - 4) The patch was developed and tested with GNU Emacs 18.55. - - 5) Since the patch was ripped off from compile.el, the code is (of - course) subject to the GNU copyleft. - -*** perldb.el.orig Wed Feb 27 00:44:27 1991 ---- perldb.el Wed Feb 27 00:44:30 1991 -*************** -*** 199,205 **** - - (defun perldb-set-buffer () - (cond ((eq major-mode 'perldb-mode) -! (setq current-perldb-buffer (current-buffer))))) - - ;; This function is responsible for inserting output from Perl - ;; into the buffer. ---- 199,211 ---- - - (defun perldb-set-buffer () - (cond ((eq major-mode 'perldb-mode) -! (cond ((not (eq current-perldb-buffer (current-buffer))) -! (perldb-forget-errors) -! (setq perldb-parsing-end 2)) ;; 2 to defeat grep defeater -! (t -! (if (> perldb-parsing-end (point-max)) -! (setq perldb-parsing-end (max (point-max) 2))))) -! (setq current-perldb-buffer (current-buffer))))) - - ;; This function is responsible for inserting output from Perl - ;; into the buffer. -*************** -*** 291,297 **** - ;; process-buffer is current-buffer - (unwind-protect - (progn -! ;; Write something in *compilation* and hack its mode line, - (set-buffer (process-buffer proc)) - ;; Force mode line redisplay soon - (set-buffer-modified-p (buffer-modified-p)) ---- 297,303 ---- - ;; process-buffer is current-buffer - (unwind-protect - (progn -! ;; Write something in *perldb-* and hack its mode line, - (set-buffer (process-buffer proc)) - ;; Force mode line redisplay soon - (set-buffer-modified-p (buffer-modified-p)) -*************** -*** 421,423 **** ---- 427,593 ---- - (switch-to-buffer-other-window current-perldb-buffer) - (goto-char (dot-max)) - (insert-string comm))) -+ -+ (defvar perldb-error-list nil -+ "List of error message descriptors for visiting erring functions. -+ Each error descriptor is a list of length two. -+ Its car is a marker pointing to an error message. -+ Its cadr is a marker pointing to the text of the line the message is about, -+ or nil if that is not interesting. -+ The value may be t instead of a list; -+ this means that the buffer of error messages should be reparsed -+ the next time the list of errors is wanted.") -+ -+ (defvar perldb-parsing-end nil -+ "Position of end of buffer when last error messages parsed.") -+ -+ (defvar perldb-error-message "No more fatal Perl errors" -+ "Message to print when no more matches for compilation-error-regexp are found") -+ -+ (defun perldb-next-error (&optional argp) -+ "Visit next perldb error message and corresponding source code. -+ This operates on the output from the \\[perldb] command. -+ If all preparsed error messages have been processed, -+ the error message buffer is checked for new ones. -+ A non-nil argument (prefix arg, if interactive) -+ means reparse the error message buffer and start at the first error." -+ (interactive "P") -+ (if (or (eq perldb-error-list t) -+ argp) -+ (progn (perldb-forget-errors) -+ (setq perldb-parsing-end 2))) ;; 2 to defeat grep defeater -+ (if perldb-error-list -+ nil -+ (save-excursion -+ (switch-to-buffer current-perldb-buffer) -+ (perldb-parse-errors))) -+ (let ((next-error (car perldb-error-list))) -+ (if (null next-error) -+ (error (concat perldb-error-message -+ (if (and (get-buffer-process current-perldb-buffer) -+ (eq (process-status -+ (get-buffer-process -+ current-perldb-buffer)) -+ 'run)) -+ " yet" "")))) -+ (setq perldb-error-list (cdr perldb-error-list)) -+ (if (null (car (cdr next-error))) -+ nil -+ (switch-to-buffer (marker-buffer (car (cdr next-error)))) -+ (goto-char (car (cdr next-error))) -+ (set-marker (car (cdr next-error)) nil)) -+ (let* ((pop-up-windows t) -+ (w (display-buffer (marker-buffer (car next-error))))) -+ (set-window-point w (car next-error)) -+ (set-window-start w (car next-error))) -+ (set-marker (car next-error) nil))) -+ -+ ;; Set perldb-error-list to nil, and -+ ;; unchain the markers that point to the error messages and their text, -+ ;; so that they no longer slow down gap motion. -+ ;; This would happen anyway at the next garbage collection, -+ ;; but it is better to do it right away. -+ (defun perldb-forget-errors () -+ (if (eq perldb-error-list t) -+ (setq perldb-error-list nil)) -+ (while perldb-error-list -+ (let ((next-error (car perldb-error-list))) -+ (set-marker (car next-error) nil) -+ (if (car (cdr next-error)) -+ (set-marker (car (cdr next-error)) nil))) -+ (setq perldb-error-list (cdr perldb-error-list)))) -+ -+ (defun perldb-parse-errors () -+ "Parse the current buffer as error messages. -+ This makes a list of error descriptors, perldb-error-list. -+ For each source-file, line-number pair in the buffer, -+ the source file is read in, and the text location is saved in perldb-error-list. -+ The function next-error, assigned to \\[next-error], takes the next error off the list -+ and visits its location." -+ (setq perldb-error-list nil) -+ (message "Parsing error messages...") -+ (let (text-buffer -+ last-filename last-linenum) -+ ;; Don't reparse messages already seen at last parse. -+ (goto-char perldb-parsing-end) -+ ;; Don't parse the first two lines as error messages. -+ ;; This matters for grep. -+ (if (bobp) -+ (forward-line 2)) -+ (while (re-search-forward compilation-error-regexp nil t) -+ (let (linenum filename -+ error-marker text-marker) -+ ;; Extract file name and line number from error message. -+ (save-restriction -+ (narrow-to-region (match-beginning 0) (match-end 0)) -+ (goto-char (point-max)) -+ (skip-chars-backward "[0-9]") -+ ;; If it's a lint message, use the last file(linenum) on the line. -+ ;; Normally we use the first on the line. -+ (if (= (preceding-char) ?\() -+ (progn -+ (narrow-to-region (point-min) (1+ (buffer-size))) -+ (end-of-line) -+ (re-search-backward compilation-error-regexp) -+ (skip-chars-backward "^ \t\n") -+ (narrow-to-region (point) (match-end 0)) -+ (goto-char (point-max)) -+ (skip-chars-backward "[0-9]"))) -+ ;; Are we looking at a "filename-first" or "line-number-first" form? -+ (if (looking-at "[0-9]") -+ (progn -+ (setq linenum (read (current-buffer))) -+ (goto-char (point-min))) -+ ;; Line number at start, file name at end. -+ (progn -+ (goto-char (point-min)) -+ (setq linenum (read (current-buffer))) -+ (goto-char (point-max)) -+ (skip-chars-backward "^ \t\n"))) -+ (setq filename (perldb-grab-filename))) -+ ;; Locate the erring file and line. -+ (if (and (equal filename last-filename) -+ (= linenum last-linenum)) -+ nil -+ (beginning-of-line 1) -+ (setq error-marker (point-marker)) -+ ;; text-buffer gets the buffer containing this error's file. -+ (if (not (equal filename last-filename)) -+ (setq text-buffer -+ (and (file-exists-p (setq last-filename filename)) -+ (find-file-noselect filename)) -+ last-linenum 0)) -+ (if text-buffer -+ ;; Go to that buffer and find the erring line. -+ (save-excursion -+ (set-buffer text-buffer) -+ (if (zerop last-linenum) -+ (progn -+ (goto-char 1) -+ (setq last-linenum 1))) -+ (forward-line (- linenum last-linenum)) -+ (setq last-linenum linenum) -+ (setq text-marker (point-marker)) -+ (setq perldb-error-list -+ (cons (list error-marker text-marker) -+ perldb-error-list))))) -+ (forward-line 1))) -+ (setq perldb-parsing-end (point-max))) -+ (message "Parsing error messages...done") -+ (setq perldb-error-list (nreverse perldb-error-list))) -+ -+ (defun perldb-grab-filename () -+ "Return a string which is a filename, starting at point. -+ Ignore quotes and parentheses around it, as well as trailing colons." -+ (if (eq (following-char) ?\") -+ (save-restriction -+ (narrow-to-region (point) -+ (progn (forward-sexp 1) (point))) -+ (goto-char (point-min)) -+ (read (current-buffer))) -+ (buffer-substring (point) -+ (progn -+ (skip-chars-forward "^ :,\n\t(") -+ (point))))) -+ -+ (define-key ctl-x-map "~" 'perldb-next-error) - - diff --git a/embed.h b/embed.h index 4a517fe17a..d9788f0a78 100644 --- a/embed.h +++ b/embed.h @@ -26,7 +26,6 @@ #define bufptr Perl_bufptr #define bxor_amg Perl_bxor_amg #define check Perl_check -#define coeff Perl_coeff #define compiling Perl_compiling #define compl_amg Perl_compl_amg #define compcv Perl_compcv @@ -392,6 +391,7 @@ #define gv_stashsv Perl_gv_stashsv #define he_delayfree Perl_he_delayfree #define he_free Perl_he_free +#define he_root Perl_he_root #define hoistmust Perl_hoistmust #define hv_clear Perl_hv_clear #define hv_delete Perl_hv_delete @@ -913,6 +913,7 @@ #define scan_word Perl_scan_word #define scope Perl_scope #define screaminstr Perl_screaminstr +#define setdefout Perl_setdefout #define setenv_getix Perl_setenv_getix #define skipspace Perl_skipspace #define stack_grow Perl_stack_grow @@ -926,6 +927,7 @@ #define sv_2mortal Perl_sv_2mortal #define sv_2nv Perl_sv_2nv #define sv_2pv Perl_sv_2pv +#define sv_add_arena Perl_sv_add_arena #define sv_backoff Perl_sv_backoff #define sv_bless Perl_sv_bless #define sv_catpv Perl_sv_catpv @@ -975,7 +977,6 @@ #define warn Perl_warn #define watch Perl_watch #define whichsig Perl_whichsig -#define whichsigname Perl_whichsigname #define xiv_arenaroot Perl_xiv_arenaroot #define xiv_root Perl_xiv_root #define xnv_root Perl_xnv_root @@ -1042,6 +1043,7 @@ #define e_tmpname (curinterp->Ie_tmpname) #define endav (curinterp->Iendav) #define envgv (curinterp->Ienvgv) +#define errgv (curinterp->Ierrgv) #define eval_root (curinterp->Ieval_root) #define eval_start (curinterp->Ieval_start) #define fdpid (curinterp->Ifdpid) @@ -1199,6 +1201,7 @@ #define Ie_tmpname e_tmpname #define Iendav endav #define Ienvgv envgv +#define Ierrgv errgv #define Ieval_root eval_root #define Ieval_start eval_start #define Ifdpid fdpid diff --git a/embed.pl b/embed.pl old mode 100644 new mode 100755 diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm index 0491d6bb42..55e5e9fe7a 100644 --- a/ext/DB_File/DB_File.pm +++ b/ext/DB_File/DB_File.pm @@ -1,8 +1,8 @@ # DB_File.pm -- Perl 5 interface to Berkeley DB # # written by Paul Marquess (pmarquess@bfsec.bt.co.uk) -# last modified 7th October 1995 -# version 1.0 +# last modified 14th November 1995 +# version 1.01 package DB_File::HASHINFO ; use Carp; @@ -170,7 +170,7 @@ sub CLEAR { croak "DB_File::BTREEINFO::CLEAR is not implemented" } package DB_File ; use Carp; -$VERSION = 1.0 ; +$VERSION = 1.01 ; #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; $DB_BTREE = TIEHASH DB_File::BTREEINFO ; @@ -546,7 +546,7 @@ errors to be caught at run time. Thanks to Judith Grass Added prototype support for multiple btree compare callbacks. -=head 1.0 +=head2 1.0 B has been in use for over a year. To reflect that, the version number has been incremented to 1.0. @@ -556,6 +556,13 @@ Added complete support for multiple concurrent callbacks. Using the I method on an empty list didn't work properly. This has been fixed. +=head2 1.01 + +Fixed a core dump problem with SunOS. + +The return value from TIEHASH wasn't set to NULL when dbopen returned +an error. + =head1 WARNINGS If you happen find any other functions defined in the source for this diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs index 8abb230da1..dd9e03d0d0 100644 --- a/ext/DB_File/DB_File.xs +++ b/ext/DB_File/DB_File.xs @@ -3,17 +3,20 @@ DB_File.xs -- Perl 5 interface to Berkeley DB written by Paul Marquess (pmarquess@bfsec.bt.co.uk) - last modified 7th October 1995 - version 1.0 + last modified 14th November 1995 + version 1.01 All comments/suggestions/problems are welcome Changes: - 0.1 - Initial Release - 0.2 - No longer bombs out if dbopen returns an error. - 0.3 - Added some support for multiple btree compares - 1.0 - Complete support for multiple callbacks added. - Fixed a problem with pushing a value onto an empty list. + 0.1 - Initial Release + 0.2 - No longer bombs out if dbopen returns an error. + 0.3 - Added some support for multiple btree compares + 1.0 - Complete support for multiple callbacks added. + Fixed a problem with pushing a value onto an empty list. + 1.01 - Fixed a SunOS core dump problem. + The return value from TIEHASH wasn't set to NULL when + dbopen returned an error. */ #include "EXTERN.h" @@ -44,18 +47,18 @@ union INFO { /* #define TRACE */ -#define db_DESTROY(db) (db->dbp->close)(db->dbp) -#define db_DELETE(db, key, flags) (db->dbp->del)(db->dbp, &key, flags) -#define db_STORE(db, key, value, flags) (db->dbp->put)(db->dbp, &key, &value, flags) -#define db_FETCH(db, key, flags) (db->dbp->get)(db->dbp, &key, &value, flags) +#define db_DESTROY(db) ((db->dbp)->close)(db->dbp) +#define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags) +#define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags) +#define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, &key, &value, flags) -#define db_close(db) (db->dbp->close)(db->dbp) -#define db_del(db, key, flags) (db->dbp->del)(db->dbp, &key, flags) -#define db_fd(db) (db->dbp->fd)(db->dbp) -#define db_put(db, key, value, flags) (db->dbp->put)(db->dbp, &key, &value, flags) -#define db_get(db, key, value, flags) (db->dbp->get)(db->dbp, &key, &value, flags) -#define db_seq(db, key, value, flags) (db->dbp->seq)(db->dbp, &key, &value, flags) -#define db_sync(db, flags) (db->dbp->sync)(db->dbp, flags) +#define db_close(db) ((db->dbp)->close)(db->dbp) +#define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags) +#define db_fd(db) ((db->dbp)->fd)(db->dbp) +#define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags) +#define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, &key, &value, flags) +#define db_seq(db, key, value, flags) ((db->dbp)->seq)(db->dbp, &key, &value, flags) +#define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags) #define OutputValue(arg, name) \ @@ -708,6 +711,8 @@ db_TIEHASH(dbtype, name=undef, flags=O_RDWR, mode=0640, type=DB_HASH) sv = ST(4) ; RETVAL = ParseOpenInfo(name, flags, mode, sv, "new") ; + if (RETVAL->dbp == NULL) + RETVAL = NULL ; } OUTPUT: RETVAL @@ -748,7 +753,7 @@ db_FETCH(db, key, flags=0) DBT value ; CurrentDB = db ; - RETVAL = (db->dbp->get)(db->dbp, &key, &value, flags) ; + RETVAL = ((db->dbp)->get)(db->dbp, &key, &value, flags) ; ST(0) = sv_newmortal(); if (RETVAL == 0) sv_setpvn(ST(0), value.data, value.size); @@ -771,13 +776,14 @@ db_FIRSTKEY(db) { DBTKEY key ; DBT value ; + DB * Db = db->dbp ; CurrentDB = db ; - RETVAL = (db->dbp->seq)(db->dbp, &key, &value, R_FIRST) ; + RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ; ST(0) = sv_newmortal(); if (RETVAL == 0) { - if (db->dbp->type != DB_RECNO) + if (Db->type != DB_RECNO) sv_setpvn(ST(0), key.data, key.size); else sv_setiv(ST(0), (I32)*(I32*)key.data - 1); @@ -791,13 +797,14 @@ db_NEXTKEY(db, key) CODE: { DBT value ; + DB * Db = db->dbp ; CurrentDB = db ; - RETVAL = (db->dbp->seq)(db->dbp, &key, &value, R_NEXT) ; + RETVAL = (Db->seq)(Db, &key, &value, R_NEXT) ; ST(0) = sv_newmortal(); if (RETVAL == 0) { - if (db->dbp->type != DB_RECNO) + if (Db->type != DB_RECNO) sv_setpvn(ST(0), key.data, key.size); else sv_setiv(ST(0), (I32)*(I32*)key.data - 1); @@ -817,6 +824,7 @@ unshift(db, ...) DBT value ; int i ; int One ; + DB * Db = db->dbp ; CurrentDB = db ; RETVAL = -1 ; @@ -827,7 +835,7 @@ unshift(db, ...) One = 1 ; key.data = &One ; key.size = sizeof(int) ; - RETVAL = (db->dbp->put)(db->dbp, &key, &value, R_IBEFORE) ; + RETVAL = (Db->put)(Db, &key, &value, R_IBEFORE) ; if (RETVAL != 0) break; } @@ -842,15 +850,16 @@ pop(db) { DBTKEY key ; DBT value ; + DB * Db = db->dbp ; CurrentDB = db ; /* First get the final value */ - RETVAL = (db->dbp->seq)(db->dbp, &key, &value, R_LAST) ; + RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ; ST(0) = sv_newmortal(); /* Now delete it */ if (RETVAL == 0) { - RETVAL = (db->dbp->del)(db->dbp, &key, R_CURSOR) ; + RETVAL = (Db->del)(Db, &key, R_CURSOR) ; if (RETVAL == 0) sv_setpvn(ST(0), value.data, value.size); } @@ -863,15 +872,16 @@ shift(db) { DBTKEY key ; DBT value ; + DB * Db = db->dbp ; CurrentDB = db ; /* get the first value */ - RETVAL = (db->dbp->seq)(db->dbp, &key, &value, R_FIRST) ; + RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ; ST(0) = sv_newmortal(); /* Now delete it */ if (RETVAL == 0) { - RETVAL = (db->dbp->del)(db->dbp, &key, R_CURSOR) ; + RETVAL = (Db->del)(Db, &key, R_CURSOR) ; if (RETVAL == 0) sv_setpvn(ST(0), value.data, value.size); } @@ -886,11 +896,12 @@ push(db, ...) DBTKEY key ; DBTKEY * keyptr = &key ; DBT value ; + DB * Db = db->dbp ; int i ; CurrentDB = db ; /* Set the Cursor to the Last element */ - RETVAL = (db->dbp->seq)(db->dbp, &key, &value, R_LAST) ; + RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ; if (RETVAL >= 0) { if (RETVAL == 1) @@ -899,7 +910,7 @@ push(db, ...) { value.data = SvPV(ST(i), na) ; value.size = na ; - RETVAL = (db->dbp->put)(db->dbp, keyptr, &value, R_IAFTER) ; + RETVAL = (Db->put)(Db, keyptr, &value, R_IAFTER) ; if (RETVAL != 0) break; } diff --git a/ext/DB_File/Makefile.PL b/ext/DB_File/Makefile.PL index 3ad8015d95..d9218d9d33 100644 --- a/ext/DB_File/Makefile.PL +++ b/ext/DB_File/Makefile.PL @@ -4,6 +4,6 @@ WriteMakefile( NAME => 'DB_File', LIBS => ["-L/usr/local/lib -ldb"], #INC => '-I/usr/local/include', - VERSION => 1.0, + VERSION => 1.01, ); diff --git a/ext/Devel/DProf/DProf.pm b/ext/Devel/DProf/DProf.pm deleted file mode 100644 index 8ec82d04f2..0000000000 --- a/ext/Devel/DProf/DProf.pm +++ /dev/null @@ -1,106 +0,0 @@ -# Devel::DProf - a Perl code profiler -# 5apr95 -# Dean Roehrich -# -# changes/bugs fixed since 01mar95 version: -# - record $pwd and build pathname for tmon.out -# (so the profile doesn't get lost if the process chdir's) -# changes/bugs fixed since 03feb95 version: -# - fixed some doc bugs -# - added require 5.000 -# - added -w note to bugs section of pod -# changes/bugs fixed since 31dec94 version: -# - podified -# - -require 5.000; - -=head1 NAME - -Devel::DProf - a Perl code profiler - -=head1 SYNOPSIS - - PERL5DB="use Devel::DProf;" - export PERL5DB - - perl5 -d test.pl - -=head1 DESCRIPTION - -The Devel::DProf package is a Perl code profiler. This will collect -information on the execution time of a Perl script and of the subs in that -script. This information can be used to determine which subroutines are -using the most time and which subroutines are being called most often. This -information can also be used to create an execution graph of the script, -showing subroutine relationships. - -To use this package the PERL5DB environment variable must be set to the -following value: - - PERL5DB="use Devel::DProf;" - export PERL5DB - -To profile a Perl script run the perl interpreter with the B<-d> debugging -switch. The profiler uses the debugging hooks. So to profile script -"test.pl" the following command should be used: - - perl5 -d test.pl - -When the script terminates the profiler will dump the profile information -to a file called I. The supplied I tool can be used to -interpret the information which is in that profile. The following command -will print the top 15 subroutines which used the most time: - - dprofpp - -To print an execution graph of the subroutines in the script use the -following command: - - dprofpp -T - -Consult the "dprofpp" manpage for other options. - -=head1 BUGS - -If perl5 is invoked with the B<-w> (warnings) flag then Devel::DProf will -cause a large quantity of warnings to be printed. - -=head1 SEE ALSO - -L, L, times(2) - -=cut - -package DB; - -# So Devel::DProf knows where to drop tmon.out. -chop($pwd = `pwd`); -$tmon = "$pwd/tmon.out"; - -# This sub is replaced by an XS version after the profiler is bootstrapped. -sub sub { -# print "nonXS DBsub($sub)\n"; - $single = 0; # disable DB single-stepping - if( wantarray ){ - @a = &$sub; - @a; - } - else{ - $a = &$sub; - $a; - } -} - -# This sub is needed during startup. -sub DB { -# print "nonXS DBDB\n"; -} - - -require DynaLoader; -@Devel::DProf::ISA = qw(DynaLoader); - -bootstrap Devel::DProf; - -1; diff --git a/ext/Devel/DProf/DProf.xs b/ext/Devel/DProf/DProf.xs deleted file mode 100644 index 8670481a35..0000000000 --- a/ext/Devel/DProf/DProf.xs +++ /dev/null @@ -1,247 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -/* -# Devel::DProf - a Perl code profiler -# 5apr95 -# Dean Roehrich -# -# changes/bugs fixed since 2apr95 version: -# -now mallocing an extra byte for the \0 :) -# changes/bugs fixed since 01mar95 version: -# -stringified code ref is used for name of anonymous sub. -# -include stash name with stringified code ref. -# -use perl.c's DBsingle and DBsub. -# -now using croak() and warn(). -# -print "timer is on" before turning timer on. -# -use safefree() instead of free(). -# -rely on PM to provide full path name to tmon.out. -# -print errno if unable to write tmon.out. -# changes/bugs fixed since 03feb95 version: -# -comments -# changes/bugs fixed since 31dec94 version: -# -added patches from Andy. -# -*/ - -/*#define DBG_SUB 1 /* */ -/*#define DBG_TIMER 1 /* */ - -#ifdef DBG_SUB -# define DBG_SUB_NOTIFY(A,B) warn( A, B ) -#else -# define DBG_SUB_NOTIFY(A,B) /* nothing */ -#endif - -#ifdef DBG_TIMER -# define DBG_TIMER_NOTIFY(A) warn( A ) -#else -# define DBG_TIMER_NOTIFY(A) /* nothing */ -#endif - -/* HZ == clock ticks per second */ -#ifndef HZ -#define HZ 60 -#endif - -static SV * Sub; /* pointer to $DB::sub */ -static char *Tmon; /* name of tmon.out */ - -/* Everything is built on times(2). See its manpage for a description - * of the timings. - */ - -static -struct tms prof_start, - prof_end; - -static -clock_t rprof_start, /* elapsed real time, in ticks */ - rprof_end; - -union prof_any { - clock_t tms_utime; /* cpu time spent in user space */ - clock_t tms_stime; /* cpu time spent in system */ - clock_t realtime; /* elapsed real time, in ticks */ - char *name; - opcode ptype; -}; - -typedef union prof_any PROFANY; - -static PROFANY *profstack; -static int profstack_max = 128; -static int profstack_ix = 0; - - -static void -prof_mark( ptype ) -opcode ptype; -{ - struct tms t; - clock_t realtime; - char *name, *pv; - char *hvname; - STRLEN len; - SV *sv; - - if( profstack_ix + 5 > profstack_max ){ - profstack_max = profstack_max * 3 / 2; - Renew( profstack, profstack_max, PROFANY ); - } - - realtime = times(&t); - pv = SvPV( Sub, len ); - - if( SvROK(Sub) ){ - /* Attempt to make CODE refs identifiable by - * including their package name. - */ - sv = (SV*)SvRV(Sub); - if( sv && SvTYPE(sv) == SVt_PVCV ){ - hvname = HvNAME(CvSTASH(sv)); - len += strlen( hvname ) + 2; /* +2 for more ::'s */ - - } - else { - croak( "DProf prof_mark() lost on supposed CODE ref %s.\n", pv ); - } - name = (char *)safemalloc( len * sizeof(char) + 1 ); - strcpy( name, hvname ); - strcat( name, "::" ); - strcat( name, pv ); - } - else{ - name = (char *)safemalloc( len * sizeof(char) + 1 ); - strcpy( name, pv ); - } - - profstack[profstack_ix++].ptype = ptype; - profstack[profstack_ix++].tms_utime = t.tms_utime; - profstack[profstack_ix++].tms_stime = t.tms_stime; - profstack[profstack_ix++].realtime = realtime; - profstack[profstack_ix++].name = name; -} - -static void -prof_record(){ - FILE *fp; - char *name; - int base = 0; - opcode ptype; - clock_t tms_utime; - clock_t tms_stime; - clock_t realtime; - - if( (fp = fopen( Tmon, "w" )) == NULL ){ - warn("DProf: unable to write %s, errno = %d\n", Tmon, errno ); - return; - } - - fprintf(fp, "#fOrTyTwO\n" ); - fprintf(fp, "$hz=%d;\n", HZ ); - fprintf(fp, "# All values are given in HZ\n" ); - fprintf(fp, "$rrun_utime=%ld; $rrun_stime=%ld; $rrun_rtime=%ld\n", - prof_end.tms_utime - prof_start.tms_utime, - prof_end.tms_stime - prof_start.tms_stime, - rprof_end - rprof_start ); - fprintf(fp, "PART2\n" ); - - while( base < profstack_ix ){ - ptype = profstack[base++].ptype; - tms_utime = profstack[base++].tms_utime; - tms_stime = profstack[base++].tms_stime; - realtime = profstack[base++].realtime; - name = profstack[base++].name; - - switch( ptype ){ - case OP_LEAVESUB: - fprintf(fp,"- %ld %ld %ld %s\n", - tms_utime, tms_stime, realtime, name ); - break; - case OP_ENTERSUB: - fprintf(fp,"+ %ld %ld %ld %s\n", - tms_utime, tms_stime, realtime, name ); - break; - default: - fprintf(fp,"Profiler unknown prof code %d\n", ptype); - } - } - fclose( fp ); -} - -#define for_real -#ifdef for_real - -XS(XS_DB_sub) -{ - dXSARGS; - dORIGMARK; - SP -= items; - - DBG_SUB_NOTIFY( "XS DBsub(%s)\n", SvPV(Sub, na) ); - - sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */ - - prof_mark( OP_ENTERSUB ); - PUSHMARK( ORIGMARK ); - - perl_call_sv( Sub, GIMME ); - - prof_mark( OP_LEAVESUB ); - SPAGAIN; - PUTBACK; - return; -} - -#endif /* for_real */ - -#ifdef testing - - MODULE = Devel::DProf PACKAGE = DB - - void - sub(...) - PPCODE: - - dORIGMARK; - /* SP -= items; added by xsubpp */ - DBG_SUB_NOTIFY( "XS DBsub(%s)\n", SvPV(Sub, na) ); - - sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */ - - prof_mark( OP_ENTERSUB ); - PUSHMARK( ORIGMARK ); - - perl_call_sv( Sub, GIMME ); - - prof_mark( OP_LEAVESUB ); - SPAGAIN; - /* PUTBACK; added by xsubpp */ - -#endif /* testing */ - - -MODULE = Devel::DProf PACKAGE = Devel::DProf - -void -END() - PPCODE: - rprof_end = times(&prof_end); - DBG_TIMER_NOTIFY("Profiler timer is off.\n"); - prof_record(); - -BOOT: - newXS("DB::sub", XS_DB_sub, file); - Sub = GvSV(DBsub); /* name of current sub */ - sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */ - { /* obtain name of tmon.out file */ - SV *sv; - sv = perl_get_sv( "DB::tmon", FALSE ); - Tmon = (char *)safemalloc( SvCUR(sv) * sizeof(char) ); - strcpy( Tmon, SvPVX(sv) ); - } - New( 0, profstack, profstack_max, PROFANY ); - DBG_TIMER_NOTIFY("Profiler timer is on.\n"); - rprof_start = times(&prof_start); diff --git a/ext/Devel/DProf/Makefile.PL b/ext/Devel/DProf/Makefile.PL deleted file mode 100644 index a1d7b0774d..0000000000 --- a/ext/Devel/DProf/Makefile.PL +++ /dev/null @@ -1,8 +0,0 @@ -use ExtUtils::MakeMaker; -WriteMakefile( - 'NAME' => 'Devel::DProf', - 'VERSION' => 'Apr5,1995', - 'clean' => {'FILES' => "tmon.out"}, - 'EXE_FILES' => ['dprofpp'], - -); diff --git a/ext/Devel/DProf/README b/ext/Devel/DProf/README deleted file mode 100644 index 970e26b46e..0000000000 --- a/ext/Devel/DProf/README +++ /dev/null @@ -1,3 +0,0 @@ -Please consult the pod in DProf.pm. - -Dean Roehrich diff --git a/ext/Devel/DProf/dprofpp b/ext/Devel/DProf/dprofpp deleted file mode 100644 index 6b6c0e70f2..0000000000 --- a/ext/Devel/DProf/dprofpp +++ /dev/null @@ -1,394 +0,0 @@ -#!/usr/local/bin/perl - -require 5.000; - - -# dprofpp - display perl profile data -# 5apr95 -# Dean Roehrich -# -# changes/bugs fixed since 10feb95 version: -# - summary info is printed by default, opt_c is gone. -# - fixed some doc bugs -# - changed name to dprofpp -# changes/bugs fixed since 03feb95 version: -# - fixed division by zero. -# - replace many local()s with my(). -# - now prints user+system times by default -# now -u prints user time, -U prints unsorted. -# - fixed documentation -# - fixed output, to clarify that times are given in seconds. -# - can now fake exit timestamps if the profile is garbled. -# changes/bugs fixed since 17jun94 version: -# - podified. -# - correct old documentation flaws. -# - added Andy's patches. -# - - -=head1 NAME - -dprofpp - display perl profile data - -=head1 SYNOPSIS - -dprofpp [B<-a|-t|-l|-v|-U|-T>] [B<-s|-r|-u>] [B<-q>] [B<-F>] [B<-O cnt>] [profile] - -=head1 DESCRIPTION - -The I command interprets a profile file produced by the Devel::DProf -profiler. By default dprofpp will read the file I and will display -the 15 subroutines which are using the most time. - -=head1 OPTIONS - -=over 5 - -=item B<-a> - -Sort alphabetically by subroutine names. - -=item B<-t> - -(default) Sort by amount of user+system time used. The first few lines -should show you which subroutines are using the most time. - -=item B<-l> - -Sort by number of calls to the subroutines. This may help identify -candidates for inlining. - -=item B<-v> - -Sort by average time spent in subroutines during each call. This may help -identify candidates for inlining. - -=item B<-U> - -Do not sort. Display in the order found in the raw profile. - -=item B<-F> - -Force the generation of fake exit timestamps if dprofpp reports that the -profile is garbled. This is only useful if dprofpp determines that the -profile is garbled due to missing exit timestamps. You're on your own if -you do this. Consult the BUGS section. - -=item B<-T> - -Display subroutine call tree to stdout. Subroutine statistics are -not displayed. - -=item B<-q> - -Do not display column headers. Does nothing if B<-T> is used. - -=item B<-O cnt> - -Show only I subroutines. The default is 15. Does nothing if B<-T> -is used. - -=item B<-r> - -Display elapsed real times rather than user+system times. - -=item B<-s> - -Display system times rather than user+system times. - -=item B<-u> - -Display user times rather than user+system times. - -=back - -=head1 BUGS - -Applications which call I from within an eval for exception handling -(catch/throw) or for setjmp/longjmp may not generate a readable profile. - -Applications which call I from within a subroutine will leave an -incomplete profile. - -=head1 FILES - - dprofpp - profile processor - tmon.out - raw profile - -=head1 SEE ALSO - -L, L, times(2) - -=cut - -use Getopt::Std 'getopts'; - -Setup: { - getopts('O:ltavuTqrsUF'); - -# -O cnt Specifies maximum number of subroutines to display. -# -a Sort by alphabetic name of subroutines. -# -t Sort by user+system time spent in subroutines. (default) -# -l Sort by number of calls to subroutines. -# -v Sort by average amount of time spent in subroutines. -# -T Show call tree. -# -q Do not print column headers. -# -u Use user time rather than user+system time. -# -s Use system time rather than user+system time. -# -r Use real elapsed time rather than user+system time. -# -U Do not sort subroutines. - - $cnt = $opt_O || 15; - $sort = 'by_time'; - $sort = 'by_calls' if defined $opt_l; - $sort = 'by_alpha' if defined $opt_a; - $sort = 'by_avgcpu' if defined $opt_v; - $whichtime = "User+System"; - $whichtime = "System" if defined $opt_s; - $whichtime = "Real" if defined $opt_r; - $whichtime = "User" if defined $opt_u; -} - -Main: { - my $monout = shift || "tmon.out"; - my $fh = "main::fh"; - local $names = {}; - local $times = {}; # times in hz - local $calls = {}; - local $persecs = {}; # times in seconds - local $idkeys = []; - local $runtime; # runtime in seconds - my @a = (); - my $a; - local $rrun_utime = 0; # user time in hz - local $rrun_stime = 0; # system time in hz - local $rrun_rtime = 0; # elapsed run time in hz - local $rrun_ustime = 0; # user+system time in hz - local $hz = 0; - - open( $fh, "<$monout" ) || die "Unable to open $monout\n"; - - header($fh); - - $rrun_ustime = $rrun_utime + $rrun_stime; - - settime( \$runtime, $hz ); - - $~ = 'STAT'; - if( ! $opt_q ){ - $^ = 'CSTAT_top'; - } - - parsestack( $fh, $names, $calls, $times, $idkeys ); - - exit(0) if $opt_T; - - if( $opt_v ){ - percalc( $calls, $times, $persecs, $idkeys ); - } - if( ! $opt_U ){ - @a = sort $sort @$idkeys; - $a = \@a; - } - else { - $a = $idkeys; - } - display( $runtime, $hz, $names, $calls, $times, $cnt, $a ); -} - - -# Sets $runtime to user, system, real, or user+system time. The -# result is given in seconds. -# -sub settime { - my( $runtime, $hz ) = @_; - - if( $opt_r ){ - $$runtime = $rrun_rtime/$hz; - } - elsif( $opt_s ){ - $$runtime = $rrun_stime/$hz; - } - elsif( $opt_u ){ - $$runtime = $rrun_utime/$hz; - } - else{ - $$runtime = $rrun_ustime/$hz; - } -} - - -# Report the times in seconds. -sub display { - my( $runtime, $hz, $names, $calls , $times, $cnt, $idkeys ) = @_; - my( $x, $key, $s ); - #format: $ncalls, $name, $secs, $percall, $pcnt - - for( $x = 0; $x < @$idkeys; ++$x ){ - $key = $idkeys->[$x]; - $ncalls = $calls->{$key}; - $name = $names->{$key}; - $s = $times->{$key}/$hz; - $secs = sprintf("%.3f", $s ); - $percall = sprintf("%.4f", $s/$ncalls ); - $pcnt = sprintf("%.2f", - $runtime ? - (($secs / $runtime) * 100.0) : - 0 ); - write; - $pcnt = $secs = $ncalls = $percall = ""; - write while( length $name ); - last unless --$cnt; - } -} - - -sub parsestack { - my( $fh, $names, $calls, $times, $idkeys ) = @_; - my( $dir, $name ); - my( $t, $syst, $realt, $usert ); - my( $x, $z, $c ); - my @stack = (); - my @tstack = (); - my $tab = 3; - my $in = 0; - - while(<$fh>){ - next if /^#/o; - last if /^PART/o; - chop; - ($dir, $usert, $syst, $realt, $name) = split; - - if ( $opt_u ) { $t = $usert } - elsif( $opt_s ) { $t = $syst } - elsif( $opt_r ) { $t = $realt } - else { $t = $usert + $syst } - - if( $dir eq '+' ){ - if( $opt_T ){ - print " " x $in, "$name\n"; - $in += $tab; - } - if(! defined $names->{$name} ){ - $names->{$name} = $name; - $times->{$name} = 0; - push( @$idkeys, $name ); - } - $calls->{$name}++; - $x = [ $name, $t ]; - push( @stack, $x ); - - # my children will put their time here - push( @tstack, 0 ); - - next; - } - if( $dir eq '-' ){ - exitstamp( \@stack, \@tstack, $t, $times, - $name, \$in, $tab ); - next; - } - die "Bad profile: $_"; - } - if( @stack ){ - my @astack; - - warn "Garbled profile is missing some exit time stamps:\n"; - foreach (@stack) { - printf "${$_}[0]\n"; - push( @astack, @stack ); - } - if( ! $opt_F ){ - die "Garbled profile"; - } - else{ - warn( "Faking " . scalar( @astack ) . " exit timestamp(s) . . .\n"); - - foreach $x ( @astack ){ - $name = $x->[0]; - exitstamp( \@stack, \@tstack, $t, $times, - $name, \$in, $tab ); - } - } - } -} - -sub exitstamp { - my( $stack, $tstack, $t, $times, $name, $in, $tab ) = @_; - - my( $x, $c, $z ); - - $x = pop( @$stack ); - if( ! defined $x ){ - die "Garbled profile, missing an enter time stamp"; - } - if( $x->[0] ne $name ){ - die "Garbled profile, unexpected exit time stamp"; - } - if( $opt_T ){ - $$in -= $tab; - } - # collect childtime - $c = pop( @$tstack ); - # total time this func has been active - $z = $t - $x->[1]; - # less time spent in child funcs. - # prepare to accept that the children may account - # for all my time. - $times->{$name} += ($z > $c)? $z - $c: $c - $z; - - # pass my time to my parent - if( @$tstack ){ - $c = pop( @$tstack ); - push( @$tstack, $c + $z ); - } -} - - -sub header { - my $fh = shift; - chop($_ = <$fh>); - if( ! /^#fOrTyTwO$/ ){ - die "Not a perl profile"; - } - while(<$fh>){ - next if /^#/o; - last if /^PART/o; - eval; - } -} - - -# Report avg time-per-function in seconds -sub percalc { - my( $calls, $times, $persecs, $idkeys ) = @_; - my( $x, $t, $n, $key ); - - for( $x = 0; $x < @$idkeys; ++$x ){ - $key = $idkeys->[$x]; - $n = $calls->{$key}; - $t = $times->{$key} / $hz; - $persecs->{$key} = $t ? $t / $n : 0; - } -} - - -sub by_time { $times->{$b} <=> $times->{$a} } -sub by_calls { $calls->{$b} <=> $calls->{$a} } -sub by_alpha { $names->{$a} cmp $names->{$b} } -sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} } - - -format CSTAT_top = -Total Elapsed Time = @>>>>>> Seconds -($rrun_rtime / $hz) - @>>>>>>>>>> Time = @>>>>>> Seconds -$whichtime, $runtime -%Time Seconds #Calls sec/call Name -. - -format STAT = - ^>>> ^>>>> ^>>>>>>>>> ^>>>>> ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< -$pcnt, $secs, $ncalls, $percall, $name -. - diff --git a/ext/Devel/DProf/test.pl b/ext/Devel/DProf/test.pl deleted file mode 100644 index 8fa0f41043..0000000000 --- a/ext/Devel/DProf/test.pl +++ /dev/null @@ -1,20 +0,0 @@ -#!./perl - -sub foo { - print "in sub foo\n"; - bar(); -} - -sub bar { - print "in sub bar\n"; -} - -sub baz { - print "in sub baz\n"; - bar(); - foo(); -} - -bar(); -baz(); -foo(); diff --git a/ext/DynaLoader/DynaLoader.pm b/ext/DynaLoader/DynaLoader.pm index 05053b849e..11051c090a 100644 --- a/ext/DynaLoader/DynaLoader.pm +++ b/ext/DynaLoader/DynaLoader.pm @@ -73,7 +73,7 @@ sub bootstrap { local($module) = $args[0]; local(@dirs, $file); - Carp::confess "Usage: DynaLoader::bootstrap(module)" unless $module; + Carp::confess("Usage: DynaLoader::bootstrap(module)") unless $module; # A common error on platforms which don't support dynamic loading. # Since it's fatal and potentially confusing we give a detailed message. @@ -108,7 +108,7 @@ sub bootstrap { # last resort, let dl_findfile have a go in all known locations $file = dl_findfile(@dirs, map("-L$_",@INC), $modfname) unless $file; - Carp::croak "Can't find loadable object for module $module in \@INC (@INC)" + Carp::croak("Can't find loadable object for module $module in \@INC (@INC)") unless $file; my $bootname = "boot_$module"; @@ -134,14 +134,14 @@ sub bootstrap { # it executed. my $libref = dl_load_file($file) or - Carp::croak "Can't load '$file' for module $module: ".dl_error()."\n"; + Carp::croak("Can't load '$file' for module $module: ".dl_error()."\n"); my @unresolved = dl_undef_symbols(); - Carp::carp "Undefined symbols present after loading $file: @unresolved\n" + Carp::carp("Undefined symbols present after loading $file: @unresolved\n") if @unresolved; my $boot_symbol_ref = dl_find_symbol($libref, $bootname) or - Carp::croak "Can't find '$bootname' symbol in $file\n"; + Carp::croak("Can't find '$bootname' symbol in $file\n"); my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file); @@ -250,7 +250,7 @@ sub dl_expandspec { my $file = $spec; # default output to input if ($osname eq 'VMS') { # dl_expandspec should be defined in dl_vms.xs - Carp::croak "dl_expandspec: should be defined in XS file!\n"; + Carp::croak("dl_expandspec: should be defined in XS file!\n"); } else { return undef unless -f $file; } diff --git a/ext/DynaLoader/dl_os2.xs b/ext/DynaLoader/dl_os2.xs new file mode 100644 index 0000000000..5ca213b985 --- /dev/null +++ b/ext/DynaLoader/dl_os2.xs @@ -0,0 +1,187 @@ +/* dl_os2.xs + * + * Platform: OS/2. + * Author: Andreas Kaiser (ak@ananke.s.bawue.de) + * Created: 08th December 1994 + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define INCL_BASE +#include + +#include "dlutils.c" /* SaveError() etc */ + +static ULONG retcode; + +static void * +dlopen(char *path, int mode) +{ + HMODULE handle; + char tmp[260], *beg, *dot; + char fail[300]; + ULONG rc; + + if ((rc = DosLoadModule(fail, sizeof fail, path, &handle)) == 0) + return (void *)handle; + + /* Not found. Check for non-FAT name and try truncated name. */ + /* Don't know if this helps though... */ + for (beg = dot = path + strlen(path); + beg > path && !strchr(":/\\", *(beg-1)); + beg--) + if (*beg == '.') + dot = beg; + if (dot - beg > 8) { + int n = beg+8-path; + memmove(tmp, path, n); + memmove(tmp+n, dot, strlen(dot)+1); + if (DosLoadModule(fail, sizeof fail, tmp, &handle) == 0) + return (void *)handle; + } + + retcode = rc; + return NULL; +} + +static void * +dlsym(void *handle, char *symbol) +{ + ULONG rc, type; + PFN addr; + + rc = DosQueryProcAddr((HMODULE)handle, 0, symbol, &addr); + if (rc == 0) { + rc = DosQueryProcType((HMODULE)handle, 0, symbol, &type); + if (rc == 0 && type == PT_32BIT) + return (void *)addr; + rc = ERROR_CALL_NOT_IMPLEMENTED; + } + retcode = rc; + return NULL; +} + +static char * +dlerror(void) +{ + static char buf[300]; + ULONG len; + + if (retcode == 0) + return NULL; + if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, retcode, "OSO001.MSG", &len)) + sprintf(buf, "OS/2 system error code %d", retcode); + else + buf[len] = '\0'; + retcode = 0; + return buf; +} + + +static void +dl_private_init() +{ + (void)dl_generic_private_init(); +} + +static char * +mod2fname(sv) + SV *sv; +{ + static char fname[9]; + int pos = 7; + int len; + AV *av; + SV *svp; + char *s; + + if (!SvROK(sv)) croak("Not a reference given to mod2fname"); + sv = SvRV(sv); + if (SvTYPE(sv) != SVt_PVAV) + croak("Not array reference given to mod2fname"); + if (av_len((AV*)sv) < 0) + croak("Empty array reference given to mod2fname"); + s = SvPV(*av_fetch((AV*)sv, av_len((AV*)sv), FALSE), na); + strncpy(fname, s, 8); + if ((len=strlen(s)) < 7) pos = len; + fname[pos] = '_'; + fname[pos + 1] = '\0'; + return (char *)fname; +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + + +void * +dl_load_file(filename) + char * filename + CODE: + int mode = 1; /* Solaris 1 */ +#ifdef RTLD_LAZY + mode = RTLD_LAZY; /* Solaris 2 */ +#endif + DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + RETVAL = dlopen(filename, mode) ; + DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%s",dlerror()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: +#ifdef DLSYM_NEEDS_UNDERSCORE + char symbolname_buf[1024]; + symbolname = dl_add_underscore(symbolname, symbolname_buf); +#endif + DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + libhandle, symbolname)); + RETVAL = dlsym(libhandle, symbolname); + DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%s",dlerror()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void +dl_undef_symbols() + PPCODE: + +char * +mod2fname(sv) + SV *sv; + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/ext/Fcntl/Fcntl.xs b/ext/Fcntl/Fcntl.xs index b505239629..dfdf099762 100644 --- a/ext/Fcntl/Fcntl.xs +++ b/ext/Fcntl/Fcntl.xs @@ -172,6 +172,12 @@ int arg; return O_WRONLY; #else goto not_there; +#endif + if (strEQ(name, "O_BINARY")) +#ifdef O_BINARY + return O_BINARY; +#else + goto not_there; #endif } else goto not_there; diff --git a/ext/GDBM_File/GDBM_File.pm b/ext/GDBM_File/GDBM_File.pm index 73bcdbeb24..d612add948 100644 --- a/ext/GDBM_File/GDBM_File.pm +++ b/ext/GDBM_File/GDBM_File.pm @@ -1,3 +1,41 @@ +# GDBM_File.pm -- Perl 5 interface to GNU gdbm library. +=head1 NAME + +GDBM_File - Perl5 access to the gdbm library. + +=head1 SYNOPSIS + + use GDBM_File ; + tie %hash, GDBM_File, $filename, &GDBM_WRCREAT, 0640); + # Use the %hash array. + untie %hash ; + +=head1 DESCRIPTION + +B is a module which allows Perl programs to make use of the +facilities provided by the GNU gdbm library. If you intend to use this +module you should really have a copy of the gdbm manualpage at hand. + +Most of the libgdbm.a functions are available through the GDBM_File +interface. + +=head1 AVAILABILITY + +Gdbm is available from any GNU archive. The master site is +C, but your are strongly urged to use one of the many +mirrors. You can obtain a list of mirror sites by issuing the +command C. + +=head1 BUGS + +The available functions and the gdbm/perl interface need to be documented. + +=head1 SEE ALSO + +L, L. + +=cut + package GDBM_File; require Carp; diff --git a/ext/GDBM_File/GDBM_File.xs b/ext/GDBM_File/GDBM_File.xs index 81b42d8824..5567020391 100644 --- a/ext/GDBM_File/GDBM_File.xs +++ b/ext/GDBM_File/GDBM_File.xs @@ -16,6 +16,7 @@ typedef GDBM_FILE GDBM_File; #define gdbm_DELETE(db,key) gdbm_delete(db,key) #define gdbm_FIRSTKEY(db) gdbm_firstkey(db) #define gdbm_NEXTKEY(db,key) gdbm_nextkey(db,key) +#define gdbm_EXISTS(db,key) gdbm_exists(db,key) typedef datum gdatum; diff --git a/ext/NDBM_File/hints/solaris.pl b/ext/NDBM_File/hints/solaris.pl index 8d2fe1289e..11310a972f 100644 --- a/ext/NDBM_File/hints/solaris.pl +++ b/ext/NDBM_File/hints/solaris.pl @@ -1,3 +1,3 @@ # -lucb has been reported to be fatal for perl5 on Solaris. # Thus we deliberately don't include it here. -$att{LIBS} = ["-L/usr/local/lib -lndbm", "-ldbm"]; +$self->{LIBS} = ["-lndbm", "-ldbm"]; diff --git a/ext/ODBM_File/hints/sco.pl b/ext/ODBM_File/hints/sco.pl index 42a4d99171..4664f2bee0 100644 --- a/ext/ODBM_File/hints/sco.pl +++ b/ext/ODBM_File/hints/sco.pl @@ -1,4 +1,4 @@ # Some versions of SCO contain a broken -ldbm library that is missing # dbmclose. Some of those might have a fixed library installed as # -ldbm.nfs. -$att{LIBS} = ['-ldbm.nfs', '-ldbm']; +$self->{LIBS} = ['-ldbm.nfs', '-ldbm']; diff --git a/ext/ODBM_File/hints/solaris.pl b/ext/ODBM_File/hints/solaris.pl index 0dd124021f..ac573932cc 100644 --- a/ext/ODBM_File/hints/solaris.pl +++ b/ext/ODBM_File/hints/solaris.pl @@ -1,3 +1,3 @@ # -lucb has been reported to be fatal for perl5 on Solaris. # Thus we deliberately don't include it here. -$att{LIBS} = ['-ldbm']; +$self->{LIBS} = ['-ldbm']; diff --git a/ext/ODBM_File/hints/svr4.pl b/ext/ODBM_File/hints/svr4.pl index 04d40e045a..3285d9a685 100644 --- a/ext/ODBM_File/hints/svr4.pl +++ b/ext/ODBM_File/hints/svr4.pl @@ -1,4 +1,4 @@ # Some SVR4 systems may need to link against routines in -lucb for # odbm. Some may also need to link against -lc to pick up things like # ecvt. -$att{LIBS} = ['-ldbm -lucb -lc']; +$self->{LIBS} = ['-ldbm -lucb -lc']; diff --git a/ext/POSIX/POSIX.pm b/ext/POSIX/POSIX.pm index 10a67cb630..0a3eb82f8e 100644 --- a/ext/POSIX/POSIX.pm +++ b/ext/POSIX/POSIX.pm @@ -230,32 +230,37 @@ sub import { Exporter::import($this,@list); } + +bootstrap POSIX; + +my $EINVAL = constant("EINVAL", 0); +my $EAGAIN = constant("EAGAIN", 0); + sub AUTOLOAD { if ($AUTOLOAD =~ /::(_?[a-z])/) { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD } - local $constname = $AUTOLOAD; + local $! = 0; + my $constname = $AUTOLOAD; $constname =~ s/.*:://; - $val = constant($constname, $_[0]); - if ($! != 0) { - if ($! =~ /Invalid/) { - croak "$constname is not a valid POSIX macro"; - } - else { - croak "Your vendor has not defined POSIX macro $constname, used"; - } + my $val = constant($constname, $_[0]); + if ($! == 0) { + *$AUTOLOAD = sub { $val }; + } + elsif ($! == $EAGAIN) { # Not really a constant, so always call. + *$AUTOLOAD = sub { constant($constname, $_[0]) }; + } + elsif ($! == $EINVAL) { + croak "$constname is not a valid POSIX macro"; } - eval "sub $AUTOLOAD { $val }"; + else { + croak "Your vendor has not defined POSIX macro $constname, used"; + } + goto &$AUTOLOAD; } - -@liblist = (); -@liblist = split ' ', $Config::Config{"POSIX_loadlibs"} - if defined $Config::Config{"POSIX_loadlibs"}; -bootstrap POSIX @liblist; - sub usage { local ($mess) = @_; croak "Usage: POSIX::$mess"; @@ -272,16 +277,13 @@ sub unimpl { croak "Unimplemented: POSIX::$mess"; } -$gensym = "SYM000"; - sub gensym { - *{"POSIX::" . $gensym++}; + my $pkg = @_ ? ref($_[0]) || $_[0] : ""; + local *{$pkg . "::GLOB" . ++$seq}; + \delete ${$pkg . "::"}{'GLOB' . $seq}; } sub ungensym { - local($x) = shift; - $x =~ s/.*:://; - delete $POSIX::{$x}; } ############################ @@ -297,23 +299,23 @@ package FileHandle; sub new { POSIX::usage "FileHandle->new(filename, posixmode)" if @_ != 3; local($class,$filename,$mode) = @_; - local($glob) = &POSIX::gensym; + local($sym) = $class->POSIX::gensym; $mode =~ s/a.*/>>/ || $mode =~ s/w.*/>/ || ($mode = '<'); - open($glob, "$mode $filename") and - bless \$glob; + open($sym, "$mode $filename") and + bless $sym => $class; } sub new_from_fd { POSIX::usage "FileHandle->new_from_fd(fd,mode)" if @_ != 3; local($class,$fd,$mode) = @_; - local($glob) = &POSIX::gensym; + local($sym) = $class->POSIX::gensym; $mode =~ s/a.*/>>/ || $mode =~ s/w.*/>/ || ($mode = '<'); - open($glob, "$mode&=$fd") and - bless \$glob; + open($sym, "$mode&=$fd") and + bless $sym => $class; } sub clearerr { @@ -328,7 +330,6 @@ sub close { sub DESTROY { close($_[0]); - ungensym($_[0]); } sub eof { @@ -386,15 +387,14 @@ sub toupper { sub closedir { usage "closedir(dirhandle)" if @_ != 1; closedir($_[0]); - ungensym($_[0]); } sub opendir { usage "opendir(directory)" if @_ != 1; - local($dirhandle) = &gensym; + local($dirhandle) = POSIX->gensym; opendir($dirhandle, $_[0]) ? $dirhandle - : (ungensym($dirhandle), undef); + : undef; } sub readdir { diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index 2a1338200d..a303f57e32 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -1483,21 +1483,6 @@ int arg; break; } if (name[1] == '_') { -#ifdef S_ISBLK - if (strEQ(name, "S_ISBLK")) return S_ISBLK(arg); -#endif -#ifdef S_ISCHR - if (strEQ(name, "S_ISCHR")) return S_ISCHR(arg); -#endif -#ifdef S_ISDIR - if (strEQ(name, "S_ISDIR")) return S_ISDIR(arg); -#endif -#ifdef S_ISFIFO - if (strEQ(name, "S_ISFIFO")) return S_ISFIFO(arg); -#endif -#ifdef S_ISREG - if (strEQ(name, "S_ISREG")) return S_ISREG(arg); -#endif if (strEQ(name, "S_ISGID")) #ifdef S_ISGID return S_ISGID; @@ -1581,6 +1566,22 @@ int arg; return S_IXUSR; #else goto not_there; +#endif + errno = EAGAIN; /* the following aren't constants */ +#ifdef S_ISBLK + if (strEQ(name, "S_ISBLK")) return S_ISBLK(arg); +#endif +#ifdef S_ISCHR + if (strEQ(name, "S_ISCHR")) return S_ISCHR(arg); +#endif +#ifdef S_ISDIR + if (strEQ(name, "S_ISDIR")) return S_ISDIR(arg); +#endif +#ifdef S_ISFIFO + if (strEQ(name, "S_ISFIFO")) return S_ISFIFO(arg); +#endif +#ifdef S_ISREG + if (strEQ(name, "S_ISREG")) return S_ISREG(arg); #endif break; } @@ -1844,6 +1845,19 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "WNOHANG")) +#ifdef WNOHANG + return WNOHANG; +#else + goto not_there; +#endif + if (strEQ(name, "WUNTRACED")) +#ifdef WUNTRACED + return WUNTRACED; +#else + goto not_there; +#endif + errno = EAGAIN; /* the following aren't constants */ #ifdef WEXITSTATUS if (strEQ(name, "WEXITSTATUS")) return WEXITSTATUS(arg); #endif @@ -1855,24 +1869,12 @@ int arg; #endif #ifdef WIFSTOPPED if (strEQ(name, "WIFSTOPPED")) return WIFSTOPPED(arg); -#endif - if (strEQ(name, "WNOHANG")) -#ifdef WNOHANG - return WNOHANG; -#else - goto not_there; #endif #ifdef WSTOPSIG if (strEQ(name, "WSTOPSIG")) return WSTOPSIG(arg); #endif #ifdef WTERMSIG if (strEQ(name, "WTERMSIG")) return WTERMSIG(arg); -#endif - if (strEQ(name, "WUNTRACED")) -#ifdef WUNTRACED - return WUNTRACED; -#else - goto not_there; #endif break; case 'X': @@ -2753,8 +2755,8 @@ sigaction(sig, action, oldaction = 0) POSIX__SigSet sigset; SV** svp; SV** sigsvp = hv_fetch(GvHVn(siggv), - whichsigname(sig), - strlen(whichsigname(sig)), + sig_name[sig], + strlen(sig_name[sig]), TRUE); /* Remember old handler name if desired. */ diff --git a/ext/SDBM_File/Makefile.PL b/ext/SDBM_File/Makefile.PL index 17c16b104b..911870ce35 100644 --- a/ext/SDBM_File/Makefile.PL +++ b/ext/SDBM_File/Makefile.PL @@ -6,7 +6,7 @@ use ExtUtils::MakeMaker; # which perform the corresponding actions in the subdirectory. WriteMakefile( - 'MYEXTLIB' => 'sdbm/libsdbm.a', + 'MYEXTLIB' => 'sdbm/libsdbm$(LIB_EXT)', ); diff --git a/ext/SDBM_File/sdbm/Makefile.PL b/ext/SDBM_File/sdbm/Makefile.PL index f42a1651aa..b4cc8d7545 100644 --- a/ext/SDBM_File/sdbm/Makefile.PL +++ b/ext/SDBM_File/sdbm/Makefile.PL @@ -14,13 +14,13 @@ sub MY::top_targets { ' all :: static -static :: libsdbm.a +static :: libsdbm$(LIB_EXT) config :: -libsdbm.a: $(O_FILES) - ar cr libsdbm.a $(O_FILES) - $(RANLIB) libsdbm.a +libsdbm$(LIB_EXT): $(O_FILES) + $(AR) cr libsdbm$(LIB_EXT) $(O_FILES) + $(RANLIB) libsdbm$(LIB_EXT) lint: lint -abchx $(LIBSRCS) diff --git a/ext/SDBM_File/sdbm/sdbm.c b/ext/SDBM_File/sdbm/sdbm.c index d7014a6769..0c4e5914cd 100644 --- a/ext/SDBM_File/sdbm/sdbm.c +++ b/ext/SDBM_File/sdbm/sdbm.c @@ -135,6 +135,9 @@ int mode; * open the files in sequence, and stat the dirfile. * If we fail anywhere, undo everything, return NULL. */ +# ifdef OS2 + flags |= O_BINARY; +# endif if ((db->pagf = open(pagname, flags, mode)) > -1) { if ((db->dirf = open(dirname, flags, mode)) > -1) { /* diff --git a/ext/Socket/Makefile.PL b/ext/Socket/Makefile.PL index 414df14f22..2b3b08305a 100644 --- a/ext/Socket/Makefile.PL +++ b/ext/Socket/Makefile.PL @@ -1,2 +1,2 @@ use ExtUtils::MakeMaker; -WriteMakefile(); +WriteMakefile(VERSION => 1.3); diff --git a/ext/Socket/Socket.pm b/ext/Socket/Socket.pm index 5a4b486a22..9c0f04ba0a 100644 --- a/ext/Socket/Socket.pm +++ b/ext/Socket/Socket.pm @@ -1,20 +1,39 @@ package Socket; +$VERSION = 1.3; =head1 NAME -Socket - load the C socket.h defines and structure manipulators +Socket, sockaddr_in, sockaddr_un, inet_aton, inet_ntoa - load the C + socket.h defines and structure manipulators =head1 SYNOPSIS use Socket; - $proto = (getprotobyname('udp'))[2]; + $proto = getprotobyname('udp'); socket(Socket_Handle, PF_INET, SOCK_DGRAM, $proto); - $sockaddr_in = pack_sockaddr_in(AF_INET,7,inet_aton("localhost")); - $sockaddr_in = pack_sockaddr_in(AF_INET,7,INADDR_LOOPBACK); - connect(Socket_Handle,$sockaddr_in); - $peer = inet_ntoa((unpack_sockaddr_in(getpeername(Socket_Handle)))[2]); - + $iaddr = gethostbyname('hishost.com'); + $port = getservbyname('time', 'udp'); + $sin = sockaddr_in($port, $iaddr); + send(Socket_Handle, 0, 0, $sin); + + $proto = getprotobyname('tcp'); + socket(Socket_Handle, PF_INET, SOCK_STREAM, $proto); + $port = getservbyname('smtp'); + $sin = sockaddr_in($port,inet_aton("127.1")); + $sin = sockaddr_in(7,inet_aton("localhost")); + $sin = sockaddr_in(7,INADDR_LOOPBACK); + connect(Socket_Handle,$sin); + + ($port, $iaddr) = sockaddr_in(getpeername(Socket_Handle)); + $peer_host = gethostbyaddr($iaddr, AF_INET); + $peer_addr = inet_ntoa($iaddr); + + $proto = getprotobyname('tcp'); + socket(Socket_Handle, PF_UNIX, SOCK_STREAM, $proto); + unlink('/tmp/usock'); + $sun = sockaddr_un('/tmp/usock'); + connect(Socket_Handle,$sun); =head1 DESCRIPTION @@ -22,7 +41,8 @@ This module is just a translation of the C F file. Unlike the old mechanism of requiring a translated F file, this uses the B program (see the Perl source distribution) and your native C compiler. This means that it has a -far more likely chance of getting the numbers right. +far more likely chance of getting the numbers right. This includes +all of the commonly used pound-defines like AF_INET, SOCK_STREAM, etc. In addition, some structure manipulation functions are available: @@ -42,7 +62,7 @@ readable four dotted number notation for internet addresses). =item INADDR_ANY -Note - does not return a number. +Note: does not return a number, but a packed string. Returns the 4-byte wildcard ip address which specifies any of the hosts ip addresses. (A particular machine can have @@ -65,21 +85,52 @@ Note - does not return a number. Returns the 4-byte invalid ip address. Normally equivalent to inet_aton('255.255.255.255'). -=item pack_sockaddr_in FAMILY, PORT, IP_ADDRESS +=item sockaddr_in PORT, ADDRESS + +=item sockaddr_in SOCKADDR_IN + +In an array context, unpacks its SOCKADDR_IN argument and returns an array +consisting of (PORT, ADDRESS). In a scalar context, packs its (PORT, +ADDRESS) arguments as a SOCKADDR_IN and returns it. If this is confusing, +use pack_sockaddr_in() and unpack_sockaddr_in() explicitly. + +=item pack_sockaddr_in PORT, IP_ADDRESS -Takes three arguments, an address family (normally AF_INET), -a port number, and a 4 byte IP_ADDRESS (as returned by -inet_aton()). Returns the sockaddr_in structure with those -arguments packed in. For internet domain sockets, this structure -is normally what you need for the arguments in bind(), connect(), -and send(), and is also returned by getpeername(), getsockname() -and recv(). +Takes two arguments, a port number and a 4 byte IP_ADDRESS (as returned by +inet_aton()). Returns the sockaddr_in structure with those arguments +packed in with AF_INET filled in. For internet domain sockets, this +structure is normally what you need for the arguments in bind(), +connect(), and send(), and is also returned by getpeername(), +getsockname() and recv(). =item unpack_sockaddr_in SOCKADDR_IN -Takes a sockaddr_in structure (as returned by pack_sockaddr_in()) -and returns an array of three elements: the address family, -the port, and the 4-byte ip-address. +Takes a sockaddr_in structure (as returned by pack_sockaddr_in()) and +returns an array of two elements: the port and the 4-byte ip-address. +Will croak if the structure does not have AF_INET in the right place. + +=item sockaddr_un PATHNAME + +=item sockaddr_un SOCKADDR_UN + +In an array context, unpacks its SOCKADDR_UN argument and returns an array +consisting of (PATHNAME). In a scalar context, packs its PATHANE +arguments as a SOCKADDR_UN and returns it. If this is confusing, use +pack_sockaddr_un() and unpack_sockaddr_un() explicitly. + +=item pack_sockaddr_un PATH + +Takes one argument, a pathname. Returns the sockaddr_un structure with +that path packed in with AF_UNIX filled in. For unix domain sockets, this +structure is normally what you need for the arguments in bind(), +connect(), and send(), and is also returned by getpeername(), +getsockname() and recv(). + +=item unpack_sockaddr_un SOCKADDR_UN + +Takes a sockaddr_un structure (as returned by pack_sockaddr_un()) +and returns the pathname. Will croak if the structure does not +have AF_UNIX in the right place. =cut @@ -91,6 +142,8 @@ require DynaLoader; @ISA = qw(Exporter DynaLoader); @EXPORT = qw( inet_aton inet_ntoa pack_sockaddr_in unpack_sockaddr_in + pack_sockaddr_un unpack_sockaddr_un + sockaddr_in sockaddr_un INADDR_ANY INADDR_LOOPBACK INADDR_NONE AF_802 AF_APPLETALK @@ -171,6 +224,31 @@ require DynaLoader; SO_USELOOPBACK ); +sub sockaddr_in { + if (@_ == 6 && !wantarray) { # perl5.001m compat; use this && die + my($af, $port, @quad) = @_; + carp "6-ARG sockaddr_in call is deprecated" if $^W; + pack_sockaddr_in($port, inet_aton(join('.', @quad))); + } elsif (wantarray) { + croak "usage: (port,iaddr) = sockaddr_in(sin_sv)" unless @_ == 1; + unpack_sockaddr_in(@_); + } else { + croak "usage: sin_sv = sockaddr_in(port,iaddr))" unless @_ == 2; + pack_sockaddr_in(@_); + } +} + +sub sockaddr_un { + if (wantarray) { + croak "usage: (filename) = sockaddr_un(sun_sv)" unless @_ == 1; + unpack_sockaddr_un(@_); + } else { + croak "usage: sun_sv = sockaddr_un(filename))" unless @_ == 1; + pack_sockaddr_in(@_); + } +} + + sub AUTOLOAD { local($constname); ($constname = $AUTOLOAD) =~ s/.*:://; diff --git a/ext/Socket/Socket.xs b/ext/Socket/Socket.xs index 1f32dab79c..e799c81e89 100644 --- a/ext/Socket/Socket.xs +++ b/ext/Socket/Socket.xs @@ -7,6 +7,7 @@ # include # endif #include +#include # ifdef I_NETINET_IN # include # endif @@ -627,8 +628,45 @@ inet_ntoa(ip_address_sv) } void -pack_sockaddr_in(family,port,ip_address) - short family +pack_sockaddr_un(pathname) + char * pathname + CODE: + { + struct sockaddr_un sun_ad; /* fear using sun */ + Zero( &sun_ad, sizeof sun_ad, char ); + sun_ad.sun_family = AF_UNIX; + Copy( pathname, sun_ad.sun_path, sizeof sun_ad.sun_path, char ); + ST(0) = sv_2mortal(newSVpv((char *)&sun_ad, sizeof sun_ad)); + } + +void +unpack_sockaddr_un(sun_sv) + SV * sun_sv + PPCODE: + { + STRLEN sockaddrlen; + struct sockaddr_un addr; + char * sun_ad = SvPV(sun_sv,sockaddrlen); + + if (sockaddrlen != sizeof(addr)) { + croak("Bad arg length for %s, length is %d, should be %d", + "Socket::unpack_sockaddr_un", + sockaddrlen, sizeof(addr)); + } + + Copy( sun_ad, &addr, sizeof addr, char ); + + if ( addr.sun_family != AF_UNIX ) { + croak("Bad address family for %s, got %d, should be %d", + "Socket::unpack_sockaddr_un", + addr.sun_family, + AF_UNIX); + } + ST(0) = sv_2mortal(newSVpv(addr.sun_path, strlen(addr.sun_path))); + } + +void +pack_sockaddr_in(port,ip_address) short port char * ip_address CODE: @@ -636,7 +674,7 @@ pack_sockaddr_in(family,port,ip_address) struct sockaddr_in sin; Zero( &sin, sizeof sin, char ); - sin.sin_family = family; + sin.sin_family = AF_INET; sin.sin_port = htons(port); Copy( ip_address, &sin.sin_addr, sizeof sin.sin_addr, char ); @@ -650,7 +688,6 @@ unpack_sockaddr_in(sin_sv) { STRLEN sockaddrlen; struct sockaddr_in addr; - short family; short port; struct in_addr ip_address; char * sin = SvPV(sin_sv,sockaddrlen); @@ -659,14 +696,17 @@ unpack_sockaddr_in(sin_sv) "Socket::unpack_sockaddr_in", sockaddrlen, sizeof(addr)); } - Copy( sin, &addr,sizeof addr, char ); - family = addr.sin_family; + if ( addr.sin_family != AF_INET ) { + croak("Bad address family for %s, got %d, should be %d", + "Socket::unpack_sockaddr_in", + addr.sin_family, + AF_INET); + } port = ntohs(addr.sin_port); ip_address = addr.sin_addr; - EXTEND(sp, 3); - PUSHs(sv_2mortal(newSViv(family))); + EXTEND(sp, 2); PUSHs(sv_2mortal(newSViv(port))); PUSHs(sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address))); } diff --git a/global.sym b/global.sym index 304db489f9..b287bc0cc6 100644 --- a/global.sym +++ b/global.sym @@ -23,7 +23,6 @@ bufend bufptr bxor_amg check -coeff compiling compl_amg compcv @@ -392,6 +391,7 @@ gv_stashpv gv_stashsv he_delayfree he_free +he_root hoistmust hv_clear hv_delete @@ -913,6 +913,7 @@ scan_trans scan_word scope screaminstr +setdefout setenv_getix skipspace stack_grow @@ -926,6 +927,7 @@ sv_2iv sv_2mortal sv_2nv sv_2pv +sv_add_arena sv_backoff sv_bless sv_catpv @@ -975,7 +977,6 @@ wait4pid warn watch whichsig -whichsigname xiv_arenaroot xiv_root xnv_root diff --git a/gv.c b/gv.c index 5eee9b6a5e..f4d03d22e3 100644 --- a/gv.c +++ b/gv.c @@ -223,10 +223,55 @@ char* name; if (*nsplit == ':') --nsplit; *nsplit = '\0'; - stash = gv_stashpv(origname,TRUE); - *nsplit = ch; + if (strEQ(origname,"SUPER")) { + /* Degenerate case ->SUPER::method should really lookup in original stash */ + SV *tmpstr = sv_2mortal(newSVpv(HvNAME(stash),0)); + sv_catpvn(tmpstr, "::SUPER", 7); + stash = gv_stashpv(SvPV(tmpstr,na),TRUE); + *nsplit = ch; + DEBUG_o( deb("Treating %s as %s::%s\n",origname,HvNAME(stash),name) ); + } else { + stash = gv_stashpv(origname,TRUE); + *nsplit = ch; + } } gv = gv_fetchmeth(stash, name, nend - name, 0); + + if (!gv) { + /* Failed obvious case - look for SUPER as last element of stash's name */ + char *packname = HvNAME(stash); + STRLEN len = strlen(packname); + if (len >= 7 && strEQ(packname+len-7,"::SUPER")) { + /* Now look for @.*::SUPER::ISA */ + GV** gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); + if (!gvp || (gv = *gvp) == (GV*)&sv_undef || !GvAV(gv)) { + /* No @ISA in package ending in ::SUPER - drop suffix + and see if there is an @ISA there + */ + HV *basestash; + char ch = packname[len-7]; + AV *av; + packname[len-7] = '\0'; + basestash = gv_stashpv(packname, TRUE); + packname[len-7] = ch; + gvp = (GV**)hv_fetch(basestash,"ISA",3,FALSE); + if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) { + /* Okay found @ISA after dropping the SUPER, alias it */ + SV *tmpstr = sv_2mortal(newSVpv(HvNAME(stash),0)); + sv_catpvn(tmpstr, "::ISA", 5); + gv = gv_fetchpv(SvPV(tmpstr,na),TRUE,SVt_PVGV); + if (gv) { + GvAV(gv) = (AV*)SvREFCNT_inc(av); + /* ... and re-try lookup */ + gv = gv_fetchmeth(stash, name, nend - name, 0); + } else { + croak("Cannot create %s::ISA",HvNAME(stash)); + } + } + } + } + } + if (!gv) { CV* cv; @@ -372,9 +417,30 @@ I32 sv_type; if (add && (hints & HINT_STRICT_VARS) && sv_type != SVt_PVCV && sv_type != SVt_PVGV && + sv_type != SVt_PVFM && sv_type != SVt_PVIO) { + gvp = (GV**)hv_fetch(stash,name,len,0); + if (!gvp || + *gvp == (GV*)&sv_undef || + SvTYPE(*gvp) != SVt_PVGV || + !(GvFLAGS(*gvp) & GVf_IMPORTED)) + stash = 0; + else if (sv_type == SVt_PVAV && !GvAV(*gvp) || + sv_type == SVt_PVHV && !GvHV(*gvp) || + sv_type == SVt_PV && + (!GvSV(*gvp) || + (!SvTYPE(GvSV(*gvp)) && + SvREFCNT(GvSV(*gvp)) == 1) )) + { + warn("Variable \"%c%s\" is not exported", + sv_type == SVt_PVAV ? '@' : + sv_type == SVt_PVHV ? '%' : '$', + name); + if (GvCV(*gvp)) + warn("(Did you mean &%s instead?)\n", name); stash = 0; + } } } else @@ -964,7 +1030,7 @@ int flags; * argument found */ lr=1; } else if (((ocvp && oamtp->fallback > AMGfallNEVER - && (cvp=ocvp) && (lr=-1)) + && (cvp=ocvp) && (lr = -1)) || (cvp && amtp->fallback > AMGfallNEVER && (lr=1))) && !(flags & AMGf_unary)) { /* We look for substitution for diff --git a/h2ph.PL b/h2ph.PL new file mode 100644 index 0000000000..115afe09ab --- /dev/null +++ b/h2ph.PL @@ -0,0 +1,306 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. +# Wanted: $archlibexp + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir(dirname($0)); +($file = basename($0)) =~ s/\.PL$//; +$file =~ s/\.pl$// + if ($Config{'osname'} eq 'VMS' or + $Config{'osname'} eq 'OS2'); # "case-forgiving" + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{'startperl'} + eval 'exec perl -S \$0 "\$@"' + if 0; + +'di '; +'ds 00 \"'; +'ig 00 '; + +\$perlincl = $Config{archlibexp}; + +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; + +chdir '/usr/include' || die "Can't cd /usr/include"; + +@isatype = split(' ',<-"); + } + else { + ($outfile = $file) =~ s/\.h$/.ph/ || next; + print "$file -> $outfile\n"; + if ($file =~ m|^(.*)/|) { + $dir = $1; + if (!-d "$perlincl/$dir") { + mkdir("$perlincl/$dir",0777); + } + } + open(IN,"$file") || ((warn "Can't open $file: $!\n"),next); + open(OUT,">$perlincl/$outfile") || die "Can't create $outfile: $!\n"; + } + while () { + chop; + while (/\\$/) { + chop; + $_ .= ; + chop; + } + if (s:/\*:\200:g) { + s:\*/:\201:g; + s/\200[^\201]*\201//g; # delete single line comments + if (s/\200.*//) { # begin multi-line comment? + $_ .= '/*'; + $_ .= ; + redo; + } + } + if (s/^#\s*//) { + if (s/^define\s+(\w+)//) { + $name = $1; + $new = ''; + s/\s+$//; + if (s/^\(([\w,\s]*)\)//) { + $args = $1; + if ($args ne '') { + foreach $arg (split(/,\s*/,$args)) { + $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/; + $curargs{$arg} = 1; + } + $args =~ s/\b(\w)/\$$1/g; + $args = "local($args) = \@_;\n$t "; + } + s/^\s+//; + do expr(); + $new =~ s/(["\\])/\\$1/g; + if ($t ne '') { + $new =~ s/(['\\])/\\$1/g; + print OUT $t, + "eval 'sub $name {\n$t ${args}eval \"$new\";\n$t}';\n"; + } + else { + print OUT "sub $name {\n ${args}eval \"$new\";\n}\n"; + } + %curargs = (); + } + else { + s/^\s+//; + do expr(); + $new = 1 if $new eq ''; + if ($t ne '') { + $new =~ s/(['\\])/\\$1/g; + print OUT $t,"eval 'sub $name {",$new,";}';\n"; + } + else { + print OUT $t,"sub $name {",$new,";}\n"; + } + } + } + elsif (/^include\s+<(.*)>/) { + ($incl = $1) =~ s/\.h$/.ph/; + print OUT $t,"require '$incl';\n"; + } + elsif (/^ifdef\s+(\w+)/) { + print OUT $t,"if (defined &$1) {\n"; + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + } + elsif (/^ifndef\s+(\w+)/) { + print OUT $t,"if (!defined &$1) {\n"; + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + } + elsif (s/^if\s+//) { + $new = ''; + $inif = 1; + do expr(); + $inif = 0; + print OUT $t,"if ($new) {\n"; + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + } + elsif (s/^elif\s+//) { + $new = ''; + $inif = 1; + do expr(); + $inif = 0; + $tab -= 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + print OUT $t,"}\n${t}elsif ($new) {\n"; + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + } + elsif (/^else/) { + $tab -= 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + print OUT $t,"}\n${t}else {\n"; + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + } + elsif (/^endif/) { + $tab -= 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + print OUT $t,"}\n"; + } + } + } + print OUT "1;\n"; +} + +sub expr { + while ($_ ne '') { + s/^(\s+)// && do {$new .= ' '; next;}; + s/^(0x[0-9a-fA-F]+)// && do {$new .= $1; next;}; + s/^(\d+)// && do {$new .= $1; next;}; + s/^("(\\"|[^"])*")// && do {$new .= $1; next;}; + s/^'((\\"|[^"])*)'// && do { + if ($curargs{$1}) { + $new .= "ord('\$$1')"; + } + else { + $new .= "ord('$1')"; + } + next; + }; + s/^sizeof\s*\(([^)]+)\)/{$1}/ && do { + $new .= '$sizeof'; + next; + }; + s/^([_a-zA-Z]\w*)// && do { + $id = $1; + if ($id eq 'struct') { + s/^\s+(\w+)//; + $id .= ' ' . $1; + $isatype{$id} = 1; + } + elsif ($id eq 'unsigned') { + s/^\s+(\w+)//; + $id .= ' ' . $1; + $isatype{$id} = 1; + } + if ($curargs{$id}) { + $new .= '$' . $id; + } + elsif ($id eq 'defined') { + $new .= 'defined'; + } + elsif (/^\(/) { + s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat + $new .= " &$id"; + } + elsif ($isatype{$id}) { + if ($new =~ /{\s*$/) { + $new .= "'$id'"; + } + elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) { + $new =~ s/\(\s*$//; + s/^[\s*]*\)//; + } + else { + $new .= $id; + } + } + else { + if ($inif && $new !~ /defined\($/) { + $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)'; + } else { + $new .= ' &' . $id; + } + } + next; + }; + s/^(.)// && do {$new .= $1; next;}; + } +} +############################################################################## + + # These next few lines are legal in both Perl and nroff. + +.00 ; # finish .ig + +'di \" finish diversion--previous line must be blank +.nr nl 0-1 \" fake up transition to first page again +.nr % 0 \" start at page 1 +'; __END__ ############# From here on it's a standard manual page ############ +.TH H2PH 1 "August 8, 1990" +.AT 3 +.SH NAME +h2ph \- convert .h C header files to .ph Perl header files +.SH SYNOPSIS +.B h2ph [headerfiles] +.SH DESCRIPTION +.I h2ph +converts any C header files specified to the corresponding Perl header file +format. +It is most easily run while in /usr/include: +.nf + + cd /usr/include; h2ph * sys/* + +.fi +If run with no arguments, filters standard input to standard output. +.SH ENVIRONMENT +No environment variables are used. +.SH FILES +/usr/include/*.h +.br +/usr/include/sys/*.h +.br +etc. +.SH AUTHOR +Larry Wall +.SH "SEE ALSO" +perl(1) +.SH DIAGNOSTICS +The usual warnings if it can't read or write the files involved. +.SH BUGS +Doesn't construct the %sizeof array for you. +.PP +It doesn't handle all C constructs, but it does attempt to isolate +definitions inside evals so that you can get at the definitions +that it can translate. +.PP +It's only intended as a rough tool. +You may need to dicker with the files produced. +.ex +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; diff --git a/h2ph.SH b/h2ph.SH deleted file mode 100755 index cb36adad80..0000000000 --- a/h2ph.SH +++ /dev/null @@ -1,295 +0,0 @@ -case $CONFIG in -'') - if test ! -f config.sh; then - ln ../config.sh . || \ - ln ../../config.sh . || \ - ln ../../../config.sh . || \ - (echo "Can't find config.sh."; exit 1) - fi 2>/dev/null - . ./config.sh - ;; -esac -: This forces SH files to create target in same directory as SH file. -: This is so that make depend always knows where to find SH derivatives. -case "$0" in -*/*) cd `expr X$0 : 'X\(.*\)/'` ;; -esac -echo "Extracting h2ph (with variable substitutions)" -: This section of the file will have variable substitutions done on it. -: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. -: Protect any dollar signs and backticks that you do not want interpreted -: by putting a backslash in front. You may delete these comments. -rm -f h2ph -$spitshell >h2ph <>h2ph <<'!NO!SUBS!' - -chdir '/usr/include' || die "Can't cd /usr/include"; - -@isatype = split(' ',<-"); - } - else { - ($outfile = $file) =~ s/\.h$/.ph/ || next; - print "$file -> $outfile\n"; - if ($file =~ m|^(.*)/|) { - $dir = $1; - if (!-d "$perlincl/$dir") { - mkdir("$perlincl/$dir",0777); - } - } - open(IN,"$file") || ((warn "Can't open $file: $!\n"),next); - open(OUT,">$perlincl/$outfile") || die "Can't create $outfile: $!\n"; - } - while () { - chop; - while (/\\$/) { - chop; - $_ .= ; - chop; - } - if (s:/\*:\200:g) { - s:\*/:\201:g; - s/\200[^\201]*\201//g; # delete single line comments - if (s/\200.*//) { # begin multi-line comment? - $_ .= '/*'; - $_ .= ; - redo; - } - } - if (s/^#\s*//) { - if (s/^define\s+(\w+)//) { - $name = $1; - $new = ''; - s/\s+$//; - if (s/^\(([\w,\s]*)\)//) { - $args = $1; - if ($args ne '') { - foreach $arg (split(/,\s*/,$args)) { - $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/; - $curargs{$arg} = 1; - } - $args =~ s/\b(\w)/\$$1/g; - $args = "local($args) = \@_;\n$t "; - } - s/^\s+//; - do expr(); - $new =~ s/(["\\])/\\$1/g; - if ($t ne '') { - $new =~ s/(['\\])/\\$1/g; - print OUT $t, - "eval 'sub $name {\n$t ${args}eval \"$new\";\n$t}';\n"; - } - else { - print OUT "sub $name {\n ${args}eval \"$new\";\n}\n"; - } - %curargs = (); - } - else { - s/^\s+//; - do expr(); - $new = 1 if $new eq ''; - if ($t ne '') { - $new =~ s/(['\\])/\\$1/g; - print OUT $t,"eval 'sub $name {",$new,";}';\n"; - } - else { - print OUT $t,"sub $name {",$new,";}\n"; - } - } - } - elsif (/^include\s+<(.*)>/) { - ($incl = $1) =~ s/\.h$/.ph/; - print OUT $t,"require '$incl';\n"; - } - elsif (/^ifdef\s+(\w+)/) { - print OUT $t,"if (defined &$1) {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (/^ifndef\s+(\w+)/) { - print OUT $t,"if (!defined &$1) {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (s/^if\s+//) { - $new = ''; - $inif = 1; - do expr(); - $inif = 0; - print OUT $t,"if ($new) {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (s/^elif\s+//) { - $new = ''; - $inif = 1; - do expr(); - $inif = 0; - $tab -= 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT $t,"}\n${t}elsif ($new) {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (/^else/) { - $tab -= 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT $t,"}\n${t}else {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (/^endif/) { - $tab -= 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT $t,"}\n"; - } - } - } - print OUT "1;\n"; -} - -sub expr { - while ($_ ne '') { - s/^(\s+)// && do {$new .= ' '; next;}; - s/^(0x[0-9a-fA-F]+)// && do {$new .= $1; next;}; - s/^(\d+)// && do {$new .= $1; next;}; - s/^("(\\"|[^"])*")// && do {$new .= $1; next;}; - s/^'((\\"|[^"])*)'// && do { - if ($curargs{$1}) { - $new .= "ord('\$$1')"; - } - else { - $new .= "ord('$1')"; - } - next; - }; - s/^sizeof\s*\(([^)]+)\)/{$1}/ && do { - $new .= '$sizeof'; - next; - }; - s/^([_a-zA-Z]\w*)// && do { - $id = $1; - if ($id eq 'struct') { - s/^\s+(\w+)//; - $id .= ' ' . $1; - $isatype{$id} = 1; - } - elsif ($id eq 'unsigned') { - s/^\s+(\w+)//; - $id .= ' ' . $1; - $isatype{$id} = 1; - } - if ($curargs{$id}) { - $new .= '$' . $id; - } - elsif ($id eq 'defined') { - $new .= 'defined'; - } - elsif (/^\(/) { - s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat - $new .= " &$id"; - } - elsif ($isatype{$id}) { - if ($new =~ /{\s*$/) { - $new .= "'$id'"; - } - elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) { - $new =~ s/\(\s*$//; - s/^[\s*]*\)//; - } - else { - $new .= $id; - } - } - else { - if ($inif && $new !~ /defined\($/) { - $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)'; - } else { - $new .= ' &' . $id; - } - } - next; - }; - s/^(.)// && do {$new .= $1; next;}; - } -} -############################################################################## - - # These next few lines are legal in both Perl and nroff. - -.00 ; # finish .ig - -'di \" finish diversion--previous line must be blank -.nr nl 0-1 \" fake up transition to first page again -.nr % 0 \" start at page 1 -'; __END__ ############# From here on it's a standard manual page ############ -.TH H2PH 1 "August 8, 1990" -.AT 3 -.SH NAME -h2ph \- convert .h C header files to .ph Perl header files -.SH SYNOPSIS -.B h2ph [headerfiles] -.SH DESCRIPTION -.I h2ph -converts any C header files specified to the corresponding Perl header file -format. -It is most easily run while in /usr/include: -.nf - - cd /usr/include; h2ph * sys/* - -.fi -If run with no arguments, filters standard input to standard output. -.SH ENVIRONMENT -No environment variables are used. -.SH FILES -/usr/include/*.h -.br -/usr/include/sys/*.h -.br -etc. -.SH AUTHOR -Larry Wall -.SH "SEE ALSO" -perl(1) -.SH DIAGNOSTICS -The usual warnings if it can't read or write the files involved. -.SH BUGS -Doesn't construct the %sizeof array for you. -.PP -It doesn't handle all C constructs, but it does attempt to isolate -definitions inside evals so that you can get at the definitions -that it can translate. -.PP -It's only intended as a rough tool. -You may need to dicker with the files produced. -.ex -!NO!SUBS! -chmod 755 h2ph -$eunicefix h2ph -rm -f h2ph.man -ln h2ph h2ph.man diff --git a/h2xs.PL b/h2xs.PL new file mode 100644 index 0000000000..b7bf49654d --- /dev/null +++ b/h2xs.PL @@ -0,0 +1,433 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir(dirname($0)); +($file = basename($0)) =~ s/\.PL$//; +$file =~ s/\.pl$// + if ($Config{'osname'} eq 'VMS' or + $Config{'osname'} eq 'OS2'); # "case-forgiving" + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{'startperl'} + eval 'exec perl -S \$0 "\$@"' + if 0; +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; + +=head1 NAME + +h2xs - convert .h C header files to Perl extensions + +=head1 SYNOPSIS + +B [B<-Acfh>] [B<-n> module_name] [headerfile [extra_libraries]] + +=head1 DESCRIPTION + +I builds a Perl extension from any C header file. The extension will +include functions which can be used to retrieve the value of any #define +statement which was in the C header. + +The I will be used for the name of the extension. If +module_name is not supplied then the name of the header file will be used, +with the first character capitalized. + +If the extension might need extra libraries, they should be included +here. The extension Makefile.PL will take care of checking whether +the libraries actually exist and how they should be loaded. +The extra libraries should be specified in the form -lm -lposix, etc, +just as on the cc command line. By default, the Makefile.PL will +search through the library path determined by Configure. That path +can be augmented by including arguments of the form B<-L/another/library/path> +in the extra-libraries argument. + +=head1 OPTIONS + +=over 5 + +=item B<-n> I + +Specifies a name to be used for the extension, e.g., S<-n RPC::DCE> + +=item B<-f> + +Allows an extension to be created for a header even if that header is +not found in /usr/include. + +=item B<-c> + +Omit C from the .xs file and corresponding specialised +C from the .pm file. + +=item B<-A> + +Omit all autoload facilities. This is the same as B<-c> but also removes the +S> statement from the .pm file. + +=back + +=head1 EXAMPLES + + + # Default behavior, extension is Rusers + h2xs rpcsvc/rusers + + # Same, but extension is RUSERS + h2xs -n RUSERS rpcsvc/rusers + + # Extension is rpcsvc::rusers. Still finds + h2xs rpcsvc::rusers + + # Extension is ONC::RPC. Still finds + h2xs -n ONC::RPC rpcsvc/rusers + + # Without constant() or AUTOLOAD + h2xs -c rpcsvc/rusers + + # Creates templates for an extension named RPC + h2xs -cfn RPC + + # Extension is ONC::RPC. + h2xs -cfn ONC::RPC + + # Makefile.PL will look for library -lrpc in + # additional directory /opt/net/lib + h2xs rpcsvc/rusers -L/opt/net/lib -lrpc + + +=head1 ENVIRONMENT + +No environment variables are used. + +=head1 AUTHOR + +Larry Wall and others + +=head1 SEE ALSO + +L, L, L + +=head1 DIAGNOSTICS + +The usual warnings if it can't read or write the files involved. + +=cut + + +use Getopt::Std; + +sub usage{ + warn "@_\n" if @_; + die 'h2xs [-Acfh] [-n module_name] [headerfile [extra_libraries]] + -f Force creation of the extension even if the C header does not exist. + -n Specify a name to use for the extension (recommended). + -c Omit the constant() function and specialised AUTOLOAD from the XS file. + -A Omit all autoloading facilities (implies -c). + -h Display this help message +extra_libraries + are any libraries that might be needed for loading the + extension, e.g. -lm would try to link in the math library. +'; +} + + +getopts("Acfhn:") || usage; + +usage if $opt_h; +$opt_c = 1 if $opt_A; + +$path_h = shift; +$extralibs = "@ARGV"; + +usage "Must supply header file or module name\n" + unless ($path_h or $opt_n); + + +if( $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$/; + $path_h = "/usr/include/$path_h" unless $path_h =~ m#^[./]#; + die "Can't find $path_h\n" if ( ! $opt_f && ! -f $path_h ); + + # Scan the header file (we should deal with nested header files) + # Record the names of simple #define constants into const_names + # Function prototypes are not (currently) processed. + open(CH, "<$path_h") || die "Can't open $path_h: $!\n"; + while () { + if (/^#[ \t]*define\s+(\w+)\b\s*[^("]/) { + $_ = $1; + next if /^_.*_h_*$/i; # special case, but for what? + $const_names{$_}++; + } + } + close(CH); + @const_names = sort keys %const_names; +} + + +$module = $opt_n || do { + $name =~ s/\.h$//; + if( $name !~ /::/ ){ + $name =~ s#^.*/##; + $name = "\u$name"; + } + $name; +}; + +(chdir 'ext', $ext = 'ext/') if -d 'ext'; + +if( $module =~ /::/ ){ + $nested = 1; + @modparts = split(/::/,$module); + $modfname = $modparts[-1]; + $modpname = join('/',@modparts); +} +else { + $nested = 0; + @modparts = (); + $modfname = $modpname = $module; +} + + +die "Won't overwrite existing $ext$modpname\n" if -e $modpname; +# quick hack, should really loop over @modparts +mkdir($modparts[0], 0777) if $nested; +mkdir($modpname, 0777); +chdir($modpname) || die "Can't chdir $ext$modpname: $!\n"; + +open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n"; +open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n"; + +$" = "\n\t"; +warn "Writing $ext$modpname/$modfname.pm\n"; + +print PM <<"END"; +package $module; + +require Exporter; +require DynaLoader; +END + +if( ! $opt_A ){ + print PM <<"END"; +require AutoLoader; +END +} + +if( $opt_c && ! $opt_A ){ + # we won't have our own AUTOLOAD(), so we'll inherit it. + print PM <<"END"; + +\@ISA = qw(Exporter AutoLoader DynaLoader); +END +} +else{ + # 1) we have our own AUTOLOAD(), so don't need to inherit it. + # or + # 2) we don't want autoloading mentioned. + print PM <<"END"; + +\@ISA = qw(Exporter DynaLoader); +END +} + +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( + @const_names +); +END + +print PM <<"END" unless $opt_c; +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. If a constant is not found then control is passed + # to the AUTOLOAD in AutoLoader. + + local(\$constname); + (\$constname = \$AUTOLOAD) =~ s/.*:://; + \$val = constant(\$constname, \@_ ? \$_[0] : 0); + if (\$! != 0) { + if (\$! =~ /Invalid/) { + \$AutoLoader::AUTOLOAD = \$AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + (\$pack,\$file,\$line) = caller; + die "Your vendor has not defined $module macro \$constname, used at \$file line \$line.\n"; + } + } + eval "sub \$AUTOLOAD { \$val }"; + goto &\$AUTOLOAD; +} + +END + +print PM <<"END"; +bootstrap $module; + +# Preloaded methods go here. + +# Autoload methods go after __END__, and are processed by the autosplit program. + +1; +__END__ +END + +close PM; + + +warn "Writing $ext$modpname/$modfname.xs\n"; + +print XS <<"END"; +#ifdef __cplusplus +extern "C" { +#endif +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#ifdef __cplusplus +} +#endif + +END +if( $path_h ){ + my($h) = $path_h; + $h =~ s#^/usr/include/##; +print XS <<"END"; +#include <$h> + +END +} + +if( ! $opt_c ){ +print XS <<"END"; +static int +not_here(s) +char *s; +{ + croak("$module::%s not implemented on this architecture", s); + return -1; +} + +static double +constant(name, arg) +char *name; +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 && /^_/; +} + +foreach $letter (@AZ, @az, @under) { + + last if $letter eq 'a' && !@const_names; + + print XS " case '$letter':\n"; + my($name); + while (substr($const_names[0],0,1) eq $letter) { + $name = shift(@const_names); + print XS <<"END"; + if (strEQ(name, "$name")) +#ifdef $name + return $name; +#else + goto not_there; +#endif +END + } + print XS <<"END"; + break; +END +} +print XS <<"END"; + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +END +} + +# Now switch from C to XS by issuing the first MODULE declaration: +print XS <<"END"; + +MODULE = $module PACKAGE = $module + +END + +# If a constant() function was written then output a corresponding +# XS declaration: +print XS <<"END" unless $opt_c; + +double +constant(name,arg) + char * name + int arg + +END + +close XS; + + +warn "Writing $ext$modpname/Makefile.PL\n"; +open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n"; + +print PL <<'END'; +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +END +print PL "WriteMakefile(\n"; +print PL " 'NAME' => '$module',\n"; +print PL " 'VERSION' => '0.1',\n"; +print PL " 'LIBS' => ['$extralibs'], # e.g., '-lm' \n"; +print PL " 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' \n"; +print PL " 'INC' => '', # e.g., '-I/usr/include/other' \n"; +print PL ");\n"; + + +system '/bin/ls > MANIFEST' or system 'ls > MANIFEST'; +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; diff --git a/h2xs.SH b/h2xs.SH deleted file mode 100755 index 4c83293919..0000000000 --- a/h2xs.SH +++ /dev/null @@ -1,413 +0,0 @@ -case $CONFIG in -'') - if test -f config.sh; then TOP=.; - elif test -f ../config.sh; then TOP=..; - elif test -f ../../config.sh; then TOP=../..; - elif test -f ../../../config.sh; then TOP=../../..; - elif test -f ../../../../config.sh; then TOP=../../../..; - else - echo "Can't find config.sh."; exit 1 - fi - . $TOP/config.sh - ;; -esac -: This forces SH files to create target in same directory as SH file. -: This is so that make depend always knows where to find SH derivatives. -case "$0" in -*/*) cd `expr X$0 : 'X\(.*\)/'` ;; -esac -echo "Extracting h2xs (with variable substitutions)" -$spitshell >h2xs <>h2xs <<'!NO!SUBS!' - -=head1 NAME - -h2xs - convert .h C header files to Perl extensions - -=head1 SYNOPSIS - -B [B<-Acfh>] [B<-n> module_name] [headerfile [extra_libraries]] - -=head1 DESCRIPTION - -I builds a Perl extension from any C header file. The extension will -include functions which can be used to retrieve the value of any #define -statement which was in the C header. - -The I will be used for the name of the extension. If -module_name is not supplied then the name of the header file will be used, -with the first character capitalized. - -If the extension might need extra libraries, they should be included -here. The extension Makefile.PL will take care of checking whether -the libraries actually exist and how they should be loaded. -The extra libraries should be specified in the form -lm -lposix, etc, -just as on the cc command line. By default, the Makefile.PL will -search through the library path determined by Configure. That path -can be augmented by including arguments of the form B<-L/another/library/path> -in the extra-libraries argument. - -=head1 OPTIONS - -=over 5 - -=item B<-n> I - -Specifies a name to be used for the extension, e.g., S<-n RPC::DCE> - -=item B<-f> - -Allows an extension to be created for a header even if that header is -not found in /usr/include. - -=item B<-c> - -Omit C from the .xs file and corresponding specialised -C from the .pm file. - -=item B<-A> - -Omit all autoload facilities. This is the same as B<-c> but also removes the -S> statement from the .pm file. - -=back - -=head1 EXAMPLES - - - # Default behavior, extension is Rusers - h2xs rpcsvc/rusers - - # Same, but extension is RUSERS - h2xs -n RUSERS rpcsvc/rusers - - # Extension is rpcsvc::rusers. Still finds - h2xs rpcsvc::rusers - - # Extension is ONC::RPC. Still finds - h2xs -n ONC::RPC rpcsvc/rusers - - # Without constant() or AUTOLOAD - h2xs -c rpcsvc/rusers - - # Creates templates for an extension named RPC - h2xs -cfn RPC - - # Extension is ONC::RPC. - h2xs -cfn ONC::RPC - - # Makefile.PL will look for library -lrpc in - # additional directory /opt/net/lib - h2xs rpcsvc/rusers -L/opt/net/lib -lrpc - - -=head1 ENVIRONMENT - -No environment variables are used. - -=head1 AUTHOR - -Larry Wall and others - -=head1 SEE ALSO - -L, L, L - -=head1 DIAGNOSTICS - -The usual warnings if it can't read or write the files involved. - -=cut - - -use Getopt::Std; - -sub usage{ - warn "@_\n" if @_; - die 'h2xs [-Acfh] [-n module_name] [headerfile [extra_libraries]] - -f Force creation of the extension even if the C header does not exist. - -n Specify a name to use for the extension (recommended). - -c Omit the constant() function and specialised AUTOLOAD from the XS file. - -A Omit all autoloading facilities (implies -c). - -h Display this help message -extra_libraries - are any libraries that might be needed for loading the - extension, e.g. -lm would try to link in the math library. -'; -} - - -getopts("Acfhn:") || usage; - -usage if $opt_h; -$opt_c = 1 if $opt_A; - -$path_h = shift; -$extralibs = "@ARGV"; - -usage "Must supply header file or module name\n" - unless ($path_h or $opt_n); - - -if( $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$/; - $path_h = "/usr/include/$path_h" unless $path_h =~ m#^[./]#; - die "Can't find $path_h\n" if ( ! $opt_f && ! -f $path_h ); - - # Scan the header file (we should deal with nested header files) - # Record the names of simple #define constants into const_names - # Function prototypes are not (currently) processed. - open(CH, "<$path_h") || die "Can't open $path_h: $!\n"; - while () { - if (/^#[ \t]*define\s+(\w+)\b\s*[^("]/) { - $_ = $1; - next if /^_.*_h_*$/i; # special case, but for what? - $const_names{$_}++; - } - } - close(CH); - @const_names = sort keys %const_names; -} - - -$module = $opt_n || do { - $name =~ s/\.h$//; - if( $name !~ /::/ ){ - $name =~ s#^.*/##; - $name = "\u$name"; - } - $name; -}; - -(chdir 'ext', $ext = 'ext/') if -d 'ext'; - -if( $module =~ /::/ ){ - $nested = 1; - @modparts = split(/::/,$module); - $modfname = $modparts[-1]; - $modpname = join('/',@modparts); -} -else { - $nested = 0; - @modparts = (); - $modfname = $modpname = $module; -} - - -die "Won't overwrite existing $ext$modpname\n" if -e $modpname; -# quick hack, should really loop over @modparts -mkdir($modparts[0], 0777) if $nested; -mkdir($modpname, 0777); -chdir($modpname) || die "Can't chdir $ext$modpname: $!\n"; - -open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n"; -open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n"; - -$" = "\n\t"; -warn "Writing $ext$modpname/$modfname.pm\n"; - -print PM <<"END"; -package $module; - -require Exporter; -require DynaLoader; -END - -if( ! $opt_A ){ - print PM <<"END"; -require AutoLoader; -END -} - -if( $opt_c && ! $opt_A ){ - # we won't have our own AUTOLOAD(), so we'll inherit it. - print PM <<"END"; - -\@ISA = qw(Exporter AutoLoader DynaLoader); -END -} -else{ - # 1) we have our own AUTOLOAD(), so don't need to inherit it. - # or - # 2) we don't want autoloading mentioned. - print PM <<"END"; - -\@ISA = qw(Exporter DynaLoader); -END -} - -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( - @const_names -); -END - -print PM <<"END" unless $opt_c; -sub AUTOLOAD { - # This AUTOLOAD is used to 'autoload' constants from the constant() - # XS function. If a constant is not found then control is passed - # to the AUTOLOAD in AutoLoader. - - local(\$constname); - (\$constname = \$AUTOLOAD) =~ s/.*:://; - \$val = constant(\$constname, \@_ ? \$_[0] : 0); - if (\$! != 0) { - if (\$! =~ /Invalid/) { - \$AutoLoader::AUTOLOAD = \$AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } - else { - (\$pack,\$file,\$line) = caller; - die "Your vendor has not defined $module macro \$constname, used at \$file line \$line.\n"; - } - } - eval "sub \$AUTOLOAD { \$val }"; - goto &\$AUTOLOAD; -} - -END - -print PM <<"END"; -bootstrap $module; - -# Preloaded methods go here. - -# Autoload methods go after __END__, and are processed by the autosplit program. - -1; -__END__ -END - -close PM; - - -warn "Writing $ext$modpname/$modfname.xs\n"; - -print XS <<"END"; -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -END -if( $path_h ){ - my($h) = $path_h; - $h =~ s#^/usr/include/##; -print XS <<"END"; -#include <$h> - -END -} - -if( ! $opt_c ){ -print XS <<"END"; -static int -not_here(s) -char *s; -{ - croak("$module::%s not implemented on this architecture", s); - return -1; -} - -static double -constant(name, arg) -char *name; -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 && /^_/; -} - -foreach $letter (@AZ, @az, @under) { - - last if $letter eq 'a' && !@const_names; - - print XS " case '$letter':\n"; - my($name); - while (substr($const_names[0],0,1) eq $letter) { - $name = shift(@const_names); - print XS <<"END"; - if (strEQ(name, "$name")) -#ifdef $name - return $name; -#else - goto not_there; -#endif -END - } - print XS <<"END"; - break; -END -} -print XS <<"END"; - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - -END -} - -# Now switch from C to XS by issuing the first MODULE declaration: -print XS <<"END"; - -MODULE = $module PACKAGE = $module - -END - -# If a constant() function was written then output a corresponding -# XS declaration: -print XS <<"END" unless $opt_c; - -double -constant(name,arg) - char * name - int arg - -END - -close XS; - - -warn "Writing $ext$modpname/Makefile.PL\n"; -open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n"; - -print PL <<'END'; -use ExtUtils::MakeMaker; -# See lib/ExtUtils/MakeMaker.pm for details of how to influence -# the contents of the Makefile that is written. -END -print PL "WriteMakefile(\n"; -print PL " 'NAME' => '$module',\n"; -print PL " 'VERSION' => '0.1',\n"; -print PL " 'LIBS' => ['$extralibs'], # e.g., '-lm' \n"; -print PL " 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' \n"; -print PL " 'INC' => '', # e.g., '-I/usr/include/other' \n"; -print PL ");\n"; - - -system '/bin/ls > MANIFEST'; -!NO!SUBS! -chmod 755 h2xs -$eunicefix h2xs diff --git a/hints/aix.sh b/hints/aix.sh index bca6eb7022..35fbb5ec39 100644 --- a/hints/aix.sh +++ b/hints/aix.sh @@ -43,7 +43,10 @@ scope_cflags='case "$osvers" in 4.1*) optimize=" ";; esac' # Changes for dynamic linking by Wayne Scott # # Tell perl which symbols to export for dynamic linking. -ccdlflags='-bE:perl.exp' +case "$cc" in +*gcc*) ccdlflags='-Xlinker -bE:perl.exp' ;; +*) ccdlflags='-bE:perl.exp' ;; +esac # The first 3 options would not be needed if dynamic libs. could be linked # with the compiler instead of ld. diff --git a/hints/dec_osf.sh b/hints/dec_osf.sh index 85de7cb042..bfd235faaf 100644 --- a/hints/dec_osf.sh +++ b/hints/dec_osf.sh @@ -8,4 +8,4 @@ case "$optimize" in ;; esac ccflags="$ccflags -DSTANDARD_C" -lddlflags='-shared -expect_unresolved "*" -s' +lddlflags='-shared -expect_unresolved "*" -s -hidden' diff --git a/hints/freebsd.sh b/hints/freebsd.sh index 756ad78981..e11eb33242 100644 --- a/hints/freebsd.sh +++ b/hints/freebsd.sh @@ -70,3 +70,14 @@ esac # Avoid telldir prototype conflict in pp_sys.c (FreeBSD uses const DIR *) # Configure should test for this. Volunteers? pp_sys_cflags='ccflags="$ccflags -DHAS_TELLDIR_PROTOTYPE"' + +cat <<'EOM' + +Some users have reported that Configure halts when testing for +the O_NONBLOCK symbol with a syntax error. This is apparently a +sh error. Rerunning Configure with ksh apparently fixes the +problem. Try + ksh Configure [your options] + +EOM + diff --git a/hints/hpux.sh b/hints/hpux.sh index 27513ce196..626d069f18 100644 --- a/hints/hpux.sh +++ b/hints/hpux.sh @@ -13,6 +13,9 @@ # Use Configure -Dcc=gcc to use gcc. # Use Configure -Dprefix=/usr/local to install in /usr/local. +# Some users have reported problems with dynamic loading if the +# environment variable LDOPTS='-a archive' . + # Turn on the _HPUX_SOURCE flag to get many of the HP add-ons ccflags="$ccflags -D_HPUX_SOURCE" ldflags="$ldflags" @@ -40,6 +43,45 @@ EOM ;; esac +# Determine the architecture type of this system. +xxuname=`uname -r` +if echo $xxuname | $contains '10' +then + # This system is running 10.0 + xxcontext=`grep $(printf %#x $(getconf CPU_VERSION)) /usr/include/sys/unistd.h` + if echo "$xxcontext" | $contains 'PA-RISC1.1' + then + archname='PA-RISC1.1' + elif echo "$xxcontext" | $contains 'PA-RISC1.0' + then + archname='PA-RISC1.0' + elif echo "$xxcontext" | $contains 'PA-RISC2' + then + archname='PA-RISC2' + else + echo "This 10.0 system is of a PA-RISC type I don't recognize." + echo "Debugging output: $xxcontext" + archname='' + fi +else + # This system is not running 10.0 + xxcontext=`/bin/getcontext` + if echo "$xxcontext" | $contains 'PA-RISC1.1' + then + archname='PA-RISC1.1' + elif echo "$xxcontext" | $contains 'PA-RISC1.0' + then + archname='PA-RISC1.0' + elif echo "$xxcontext" | $contains 'HP-MC' + then + archname='HP-MC68K' + else + echo "I cannot recognize what chip set this system is using." + echo "Debugging output: $xxcontext" + archname='' + fi +fi + # Remove bad libraries that will cause problems # (This doesn't remove libraries that don't actually exist) # -lld is unneeded (and I can't figure out what it's used for anyway) @@ -71,13 +113,8 @@ d_bsdpgrp='define' # If your compile complains about FLT_MIN, uncomment the next line # POSIX_cflags='ccflags="$ccflags -DFLT_MIN=1.17549435E-38"' -# Comment these out if you don't want to follow the SVR4 filesystem layout +# Comment this out if you don't want to follow the SVR4 filesystem layout # that HP-UX 10.0 uses case "$prefix" in -'') prefix='/opt/perl5' - privlib='/opt/perl5/lib' - archlib='/opt/perl5/lib/hpux' - man3dir='/opt/perl5/man/man3' - ;; +'') prefix='/opt/perl5' ;; esac - diff --git a/hints/irix_6_2.sh b/hints/irix_6_2.sh new file mode 100644 index 0000000000..cbb08bbb2a --- /dev/null +++ b/hints/irix_6_2.sh @@ -0,0 +1,25 @@ +# irix_6_2.sh +# from Krishna Sethuraman, krishna@mit.edu +# Date: Tue Aug 22 00:38:26 PDT 1995 +# removed -ansiposix and -D_POSIX_SOURCE cuz it was choking + +# Perl built with this hints file under IRIX 6.2 passes +# all tests (`make test'). + +ld=ld +i_time='define' +cc="cc -32" +ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -Olimit 3000" +#ccflags="$ccflags -Olimit 3000" # this line builds perl but not tk (beta 8) +lddlflags="-32 -shared" + +# We don't want these libraries. Anyone know why? +set `echo X "$libswanted "|sed -e 's/ socket / /' -e 's/ nsl / /' -e 's/ dl / /'` +shift +libswanted="$*" +# Don't need sun crypt bsd PW under 6.2. You *may* need to link +# with these if you want to run perl built under 6.2 on a 5.3 machine +# (I haven't checked) +#set `echo X "$libswanted "|sed -e 's/ sun / /' -e 's/ crypt / /' -e 's/ bsd / /' -e 's/ PW / /'` +#shift +#libswanted="$*" diff --git a/hints/netbsd.sh b/hints/netbsd.sh index 67cd95c2ad..24ffe15f73 100644 --- a/hints/netbsd.sh +++ b/hints/netbsd.sh @@ -1,17 +1,39 @@ # hints/netbsd.sh -# netbsd keeps dynamic loading dl*() functions in /usr/lib/crt0.o, +# +# talk to mrg@eterna.com.au if you want to change this file. +# +# netbsd keeps dynamic loading dl*() functions in /usr/lib/crt0.o, # so Configure doesn't find them (unless you abandon the nm scan). +# this should be *just* 0.9 below as netbsd 0.9a was the first to +# introduce shared libraries. case "$osvers" in -0.9*|0.8*) +0.9|0.8*) usedl="$undef" ;; *) d_dlopen=$define d_dlerror=$define - cccdlflags="-DPIC -fpic $cccdlflags" +# we use -fPIC here because -fpic is *NOT* enough for some of the +# extensions like Tk on some netbsd platforms (the sparc is one) + cccdlflags="-DPIC -fPIC $cccdlflags" lddlflags="-Bforcearchive -Bshareable $lddlflags" +# netbsd has these but they don't really work as advertised. if they +# are defined, then there isn't a way to make perl call setuid() or +# setgid(). if they aren't, then ($<, $>) = ($u, $u); will work (same +# for $(/$)). this is because you can not change the real userid of +# a process under 4.4BSD. + d_setregid="$undef" + d_setreuid="$undef" + d_setrgid="$undef" + d_setruid="$undef" ;; esac # Avoid telldir prototype conflict in pp_sys.c (NetBSD uses const DIR *) # Configure should test for this. Volunteers? pp_sys_cflags='ccflags="$ccflags -DHAS_TELLDIR_PROTOTYPE"' + +case "$archname" in +'') + archname=`uname -m`-${osname} + ;; +esac diff --git a/hints/os2.sh b/hints/os2.sh new file mode 100644 index 0000000000..55766f7482 --- /dev/null +++ b/hints/os2.sh @@ -0,0 +1,192 @@ +# Problems: +# a) warning from fcntl: Third argument is int in emx - patched +# b) gr_password is not a structure in struct group - patched +# c) (gone) +# d) Makefile needs sh before ./makedir +# e) (gone) +# f) (gone) +# g) (gone) +# h) (gone) +# i) (gone) +# j) the rule true in Makefile should become sh -c true +# k) Cwd does not work. ===> the extensions cannot be compiled - patched +# l) TEST expects to get -e 'perl' - patched +# m) (gone) + +# Tests failing with .o compile (this is probably obsolete, but now it is .obj): + +# comp/cpp (because of sed above) +# io/fs.t : (patched) 2..5 7..11 18 (why 11?) +# io/inplace.t ???? (ak works) +# io/tell.t 10 ???? +# op/exec.t 1 ???? 4 ???? +# op/glob.t 1 (bug in sh) +# op/magic.t 4 1/2 (????) adding sleep 5 does not help +# op/readdir.t 3 (same bug in ksh) +# op/stat.t 3 4 9 10 20 >34 + +# Newer results with .obj without i/o optimization, fail: + +# io/fs.t : 2+ +# io/pipe.t : 1+ +# io/tell.t : 8, 10 +# op/exec.t : 4, 6 (ok 1 comes as "ok \1") +# op/fork.t : 1+ +# op/misc.t : 9 +# op/pack.t : 8 +# op/stat.t : 3 4 9 10 20 >34 +# lib/sdbm.t : sdbm store returned -1, errno 0, key "21" at lib/sdbm.t line 112. +# lib/posix.t : coredump on 3 + +# If compiled with i/o optimization, then 15% speedup on input, and +# io/tell.t : 11 only +# no coredump in posix.t + + +# Note that during the .obj compile you need to move the perl.dll file +# to LIBPATH :-( + +#osname="OS/2" +sysman=`../UU/loc . /man/man1 /usr/man/man1 c:/man/man1 c:/usr/man/man1` +cc='gcc' +usrinc='/emx/include' +libpth='/emx/lib/st /emx/lib' + +so='dll' + +# Additional definitions: + +d_shrplib='define' +firstmakefile='GNUmakefile' +obj_ext='.obj' +obj_ext_regexp='\.obj' +lib_ext='.lib' +ar='emxomfar' +plibext='.lib' +exe_ext='.exe' +archobjs="os2$obj_ext" +cldlibs='' + +libc="/emx/lib/st/c_import$lib_ext" + +# otherwise puts -lc ??? + +libs='-lsocket -lm' + +# Run files without extension with sh - feature of patched ksh +NOHASHBANG=sh + +cccdlflags='-Zdll' +dlsrc='dl_os2.xs' +lddlflags='-Zdll -Zomf -Zcrtdll' +ldflags='-Zexe -Zomf -Zcrtdll' +ld='gcc' +usedl='define' +ccflags='-Zomf -DDOSISH -DOS2=2 -DEMBED -I.' +cppflags='-DDOSISH -DOS2=2 -DEMBED -I.' + +# This variables taken from recommended config.sh +alignbytes='8' + +d_fork='undef' + +# for speedup: (some patches to ungetc are also needed): +# Note that without this guy tests 8 and 10 of io/tell.t fail, with it 11 fails + +d_stdstdio='define' +d_stdiobase='define' +d_stdio_ptr_lval='define' +d_stdio_cnt_lval='define' +stdio_ptr='((fp)->ptr)' +stdio_cnt='((fp)->rcount)' +stdio_base='((fp)->buffer)' +stdio_bufsiz='((fp)->rcount + (fp)->ptr - (fp)->buffer)' + + +# I do not have these: +#dynamic_ext='Fcntl GDBM_File SDBM_File POSIX Socket UPM REXXCALL' +dynamic_ext='Fcntl POSIX Socket SDBM_File Devel/DProf' +#extensions='Fcntl GDBM_File SDBM_File POSIX Socket UPM REXXCALL' +extensions='Fcntl SDBM_File POSIX Socket Devel/DProf' + +# To have manpages installed +echo nroff is "'$nroff'" +nroff='nroff.cmd' +_nroff='nroff.cmd' +echo nroff is "'$nroff'" + +# Unknown reasons for: +#cpio='cpio' +#csh='' +#date='' +#byacc='' +#d_charsprf='undef' +#d_drem='undef' +#d_fmod='define' +#d_linuxstd='undef' +#d_socket='define' +#gcc='gcc' +#gidtype='gid_t' +#glibpth='c:/usr/lib/emx h:/emx/lib /emx/lib' +#groupstype='gid_t' +#h_fcntl='true' +#i_time='define' +#line='' +#lseektype='off_t' +#man1ext='1' +#man3ext='3' +#modetype='mode_t' +#more='more' +#mv='mv' +#sleep='sleep' +#socketlib='-lsocket' +#ssizetype='ssize_t' +#tar='tar' +#timetype='time_t' +#uidtype='uid_t' +#uname='' +#uniq='' +#xlibpth='' +#yacc='yacc' +#yaccflags='' +#zcat='zcat' +#orderlib='false' +#pg='pg' +#pr='pr' +#ranlib=':' + +# Misfound by configure: + +#gcc='gcc' +#more='more' +#mv='mv' +#pr='pr' +#sleep='sleep' +#tar='tar' + +xlibpth='' + +# I cannot stand it, but did not test with: +# d_dirnamlen='undef' + +# I try to do without these: + +#d_pwage='undef' +#d_pwcomment='undef' + +ln='cp' +lns='cp' + +# ???? +#mallocobj='' +#mallocsrc='' +#usemymalloc='false' + +nm_opt='-p' + +# The next two are commented. pdksh handles #! +# sharpbang='extproc ' +# shsharp='false' + +# Commented: +#startsh='extproc ksh\\n#! sh' diff --git a/hints/sco.sh b/hints/sco.sh new file mode 100644 index 0000000000..daf3aec008 --- /dev/null +++ b/hints/sco.sh @@ -0,0 +1,45 @@ +# sco_3.sh +# Courtesy of Joel Rosi-Schwartz +# To use gcc, do Configure -Dcc=gcc +# +# Try to use libintl.a since it has strcoll and strxfrm +libswanted="intl $libswanted" +# Try to use libdbm.nfs.a since it has dbmclose. +# +if test -f /usr/lib/libdbm.nfs.a ; then + libswanted=`echo "dbm.nfs $libswanted " | sed -e 's/ dbm / /'` +fi +set X $libswanted +shift +libswanted="$*" +# +# We don't want Xenix cross-development libraries +glibpth=`echo $glibpth | sed -e 's! /usr/lib/386 ! !' -e 's! /lib/386 ! !'` +xlibpth='' +# +case "$cc" in +gcc) + ccflags="$ccflags -U M_XENIX" + optimize="$optimize -O2" + ;; +scocc) ;; + +*) + ccflags="$ccflags -W0 -U M_XENIX" + ;; +esac +i_varargs=undef + +# I have received one report that nm extraction doesn't work if you're +# using the scocc compiler. This system had the following 'myconfig' +# uname='xxx xxx 3.2 2 i386 ' +# cc='scocc', optimize='-O' +usenm='false' + +# If you want to use nm, you'll probably have to use nm -p. The +# following does that for you: +nm_opt='-p' + +# I have received one report that you can't include utime.h in +# pp_sys.c. Uncomment the following line if that happens to you: +# i_utime=undef diff --git a/hints/sco_3.sh b/hints/sco_3.sh deleted file mode 100644 index daf3aec008..0000000000 --- a/hints/sco_3.sh +++ /dev/null @@ -1,45 +0,0 @@ -# sco_3.sh -# Courtesy of Joel Rosi-Schwartz -# To use gcc, do Configure -Dcc=gcc -# -# Try to use libintl.a since it has strcoll and strxfrm -libswanted="intl $libswanted" -# Try to use libdbm.nfs.a since it has dbmclose. -# -if test -f /usr/lib/libdbm.nfs.a ; then - libswanted=`echo "dbm.nfs $libswanted " | sed -e 's/ dbm / /'` -fi -set X $libswanted -shift -libswanted="$*" -# -# We don't want Xenix cross-development libraries -glibpth=`echo $glibpth | sed -e 's! /usr/lib/386 ! !' -e 's! /lib/386 ! !'` -xlibpth='' -# -case "$cc" in -gcc) - ccflags="$ccflags -U M_XENIX" - optimize="$optimize -O2" - ;; -scocc) ;; - -*) - ccflags="$ccflags -W0 -U M_XENIX" - ;; -esac -i_varargs=undef - -# I have received one report that nm extraction doesn't work if you're -# using the scocc compiler. This system had the following 'myconfig' -# uname='xxx xxx 3.2 2 i386 ' -# cc='scocc', optimize='-O' -usenm='false' - -# If you want to use nm, you'll probably have to use nm -p. The -# following does that for you: -nm_opt='-p' - -# I have received one report that you can't include utime.h in -# pp_sys.c. Uncomment the following line if that happens to you: -# i_utime=undef diff --git a/hints/solaris_2.sh b/hints/solaris_2.sh index 0193bd4a1c..06abe32d7f 100644 --- a/hints/solaris_2.sh +++ b/hints/solaris_2.sh @@ -128,6 +128,7 @@ case "`${cc:-cc} -v 2>&1`" in # Get gcc to share its secrets. echo 'main() { return 0; }' > try.c verbose=`${cc:-cc} -v -o try try.c 2>&1` + rm -f try try.c tmp=`echo "$verbose" | grep '^Reading' | awk '{print $NF}' | sed 's/specs$/include/'` diff --git a/hints/ultrix_4.sh b/hints/ultrix_4.sh index 3f96a668e1..e00450792d 100644 --- a/hints/ultrix_4.sh +++ b/hints/ultrix_4.sh @@ -9,6 +9,12 @@ case "$optimize" in '') optimize=-g ;; esac +# Some users have reported Configure runs *much* faster if you +# replace all occurences of /bin/sh by /bin/sh5 +# Something like: +# sed 's!/bin/sh!/bin/sh5!g' Configure > Configure.sh5 +# Then run "sh5 Configure.sh5 [your options]" + case "$myuname" in *risc*) cat <hent_next; + return he; + } + return more_he(); +} + +static void +del_he(p) +HE* p; +{ + p->hent_next = (HE*)he_root; + he_root = p; +} + +static HE* +more_he() +{ + register HE* he; + register HE* heend; + he_root = (HE*)safemalloc(1008); + he = he_root; + heend = &he[1008 / sizeof(HE) - 1]; + while (he < heend) { + he->hent_next = (HE*)(he + 1); + he++; + } + he->hent_next = 0; + return new_he(); +} + SV** hv_fetch(hv,key,klen,lval) HV *hv; @@ -142,8 +180,8 @@ register U32 hash; entry->hent_val = val; return &entry->hent_val; } - New(501,entry, 1, HE); + entry = new_he(); entry->hent_klen = klen; entry->hent_key = savepvn(key,klen); entry->hent_val = val; @@ -282,10 +320,33 @@ HV *hv; register HE **b; register HE *entry; register HE **oentry; + I32 tmp; a = (HE**)xhv->xhv_array; nomemok = TRUE; +#ifdef STRANGE_MALLOC Renew(a, newsize, HE*); +#else + i = newsize * sizeof(HE*); +#define MALLOC_OVERHEAD 16 + tmp = MALLOC_OVERHEAD; + while (tmp - MALLOC_OVERHEAD < i) + tmp += tmp; + tmp -= MALLOC_OVERHEAD; + tmp /= sizeof(HE*); + assert(tmp >= newsize); + New(2,a, tmp, HE*); + Copy(xhv->xhv_array, a, oldsize, HE*); + if (oldsize >= 64 && *(char*)&xhv->xnv_nv == 0) { + sv_add_arena((char*)xhv->xhv_array, oldsize * sizeof(HE*), 0); + sv_add_arena(((char*)a) + newsize * sizeof(HE*), + newsize * sizeof(HE*) - MALLOC_OVERHEAD, + SVf_FAKE); + } + else + Safefree(xhv->xhv_array); +#endif + nomemok = FALSE; Zero(&a[oldsize], oldsize, HE*); /* zero 2nd half*/ xhv->xhv_max = --newsize; @@ -326,6 +387,7 @@ newHV() xhv->xhv_max = 7; /* start with 8 buckets */ xhv->xhv_fill = 0; xhv->xhv_pmroot = 0; + *(char*)&xhv->xnv_nv = 0; (void)hv_iterinit(hv); /* so each() will start off right */ return hv; } @@ -338,7 +400,7 @@ register HE *hent; return; SvREFCNT_dec(hent->hent_val); Safefree(hent->hent_key); - Safefree(hent); + del_he(hent); } void @@ -349,7 +411,7 @@ register HE *hent; return; sv_2mortal(hent->hent_val); /* free between statements */ Safefree(hent->hent_key); - Safefree(hent); + del_he(hent); } void @@ -413,7 +475,14 @@ HV *hv; return; xhv = (XPVHV*)SvANY(hv); hfreeentries(hv); +#ifdef STRANGE_MALLOC Safefree(xhv->xhv_array); +#else + if (xhv->xhv_max < 127 || *(char*)&xhv->xnv_nv) + Safefree(xhv->xhv_array); + else /* We used last half, so use first half for SV arena too. */ + sv_add_arena((char*)xhv->xhv_array, (xhv->xhv_max + 1) * sizeof(HE*),0); +#endif if (HvNAME(hv)) { Safefree(HvNAME(hv)); HvNAME(hv) = 0; @@ -422,6 +491,7 @@ HV *hv; xhv->xhv_max = 7; /* it's a normal associative array */ xhv->xhv_fill = 0; xhv->xhv_keys = 0; + *(char*)&xhv->xnv_nv = 1; if (SvRMAGICAL(hv)) mg_clear((SV*)hv); @@ -461,8 +531,8 @@ HV *hv; entry->hent_key = 0; } else { - Newz(504,entry, 1, HE); - xhv->xhv_eiter = entry; + xhv->xhv_eiter = entry = new_he(); + Zero(entry, 1, HE); } magic_nextpack((SV*) hv,mg,key); if (SvOK(key)) { @@ -475,14 +545,13 @@ HV *hv; } if (entry->hent_val) SvREFCNT_dec(entry->hent_val); - Safefree(entry); + del_he(entry); xhv->xhv_eiter = Null(HE*); return Null(HE*); } if (!xhv->xhv_array) - entry = Null(HE*); - else + Newz(506,xhv->xhv_array, sizeof(HE*) * (xhv->xhv_max + 1), char); do { if (entry) entry = entry->hent_next; diff --git a/installman b/installman old mode 100644 new mode 100755 index b6765632fe..bc36ca6ac1 --- a/installman +++ b/installman @@ -27,6 +27,7 @@ $usage = GetOptions( qw( man1dir=s man1ext=s man3dir=s man3ext=s notify help)) || die $usage; +die $usage if $opt_help; # These are written funny to avoid -w typo warnings. $man1dir = defined($opt_man1dir) ? $opt_man1dir : $Config{'installman1dir'}; diff --git a/installperl b/installperl index 87b81ac2f1..45f9c7efd1 100755 --- a/installperl +++ b/installperl @@ -1,6 +1,7 @@ #!./perl BEGIN { @INC=('./lib', '../lib') } use File::Find; +use Config; $mainperldir = "/usr/bin"; @@ -12,8 +13,10 @@ while (@ARGV) { umask 022; -@scripts = ('cppstdin', 'c2ph', 'h2xs', 'pstruct', 'x2p/s2p', 'x2p/find2perl', - 'perldoc', 'pod/pod2man', 'pod/pod2html', 'pod/pod2latex' ); +@scripts = ('cppstdin', 'c2ph', 'h2ph', 'h2xs', 'pstruct', + 'x2p/s2p', 'x2p/find2perl', + 'perldoc', + 'pod/pod2man', 'pod/pod2html', 'pod/pod2latex' ); # pod documentation now handled by separate installman script. # These two are archaic leftovers. @@ -21,31 +24,39 @@ umask 022; @pods = (); -# Read in the config file. - -open(CONFIG, "config.sh") || die "You haven't run Configure yet!\n"; -while () { - if (s/^(\w+=)/\$$1/) { - $accum =~ s/'undef'/undef/g; - eval $accum; - $accum = ''; - } - $accum .= $_; -} -close CONFIG; - $ver = $]; -$release = substr($ver,0,3); +$release = substr($ver,0,3); # Not used presently. $patchlevel = substr($ver,3,2); die "Patchlevel of perl ($patchlevel)", - "and patchlevel of config.sh ($PATCHLEVEL) don't match\n" - if $patchlevel != $PATCHLEVEL; + "and patchlevel of config.sh ($Config{'PATCHLEVEL'}) don't match\n" + if $patchlevel != $Config{'PATCHLEVEL'}; + +# Fetch some frequently-used items from %Config +$installbin = $Config{installbin}; +$installscript = $Config{installscript}; +$installprivlib = $Config{installprivlib}; +$installarchlib = $Config{installarchlib}; +$installsitelib = $Config{installsitelib}; +$installsitearch = $Config{installsitearch}; +$installman1dir = $Config{installman1dir}; +$man1ext = $Config{man1ext}; +# Did we build libperl as a shared library? +$d_shrplib = $Config{d_shrplib}; +$shrpdir = $Config{shrpdir}; +# Shared library and dynamic loading suffixes. +$so = $Config{so}; +$dlext = $Config{dlext}; + +$d_dosuid = $Config{d_dosuid}; +$binexp = $Config{binexp}; +$osname = $Config{osname}; # Do some quick sanity checks. if ($d_dosuid && $>) { die "You must run as root to install suidperl\n"; } $installbin || die "No installbin directory in config.sh\n"; +-d $installbin || makedir($installbin); -d $installbin || die "$installbin is not a directory\n"; -w $installbin || die "$installbin is not writable by you\n" unless $installbin =~ m#^/afs/# || $nonono; @@ -142,6 +153,9 @@ $do_installarchlib = $do_installprivlib = 0; &makedir($installprivlib); &makedir($installarchlib); +&makedir($installsitelib) if ($installsitelib); +&makedir($installsitearch) if ($installsitearch); + if (chdir "lib") { $do_installarchlib = ! &samepath($installarchlib, '.'); $do_installprivlib = ! &samepath($installprivlib, '.'); diff --git a/interp.sym b/interp.sym index 4bd3e72ca6..e6d5c3852d 100644 --- a/interp.sym +++ b/interp.sym @@ -47,6 +47,7 @@ e_fp e_tmpname endav envgv +errgv eval_root eval_start fdpid diff --git a/ioctl.pl b/ioctl.pl deleted file mode 100644 index 0327daee45..0000000000 --- a/ioctl.pl +++ /dev/null @@ -1,169 +0,0 @@ -$TIOCGSIZE = 0x40087468; -$TIOCSSIZE = 0x80087467; -$IOCPARM_MASK = 0x1fff; -$IOCPARM_MAX = 0x200; -$IOC_VOID = 0x20000000; -$IOC_OUT = 0x40000000; -$IOC_IN = 0x80000000; -$IOC_INOUT = 0xC0000000; -$IOC_DIRMASK = 0xe0000000; -$TIOCGETD = 0x40047400; -$TIOCSETD = 0x80047401; -$TIOCHPCL = 0x20007402; -$TIOCMODG = 0x40047403; -$TIOCMODS = 0x80047404; -$TIOCM_LE = 0001; -$TIOCM_DTR = 0002; -$TIOCM_RTS = 0004; -$TIOCM_ST = 0010; -$TIOCM_SR = 0020; -$TIOCM_CTS = 0040; -$TIOCM_CAR = 0100; -$TIOCM_CD = 0x40; -$TIOCM_RNG = 0200; -$TIOCM_RI = 0x80; -$TIOCM_DSR = 0400; -$TIOCGETP = 0x40067408; -$TIOCSETP = 0x80067409; -$TIOCSETN = 0x8006740A; -$TIOCEXCL = 0x2000740D; -$TIOCNXCL = 0x2000740E; -$TIOCFLUSH = 0x80047410; -$TIOCSETC = 0x80067411; -$TIOCGETC = 0x40067412; -$TANDEM = 0x00000001; -$CBREAK = 0x00000002; -$LCASE = 0x00000004; -$ECHO = 0x00000008; -$CRMOD = 0x00000010; -$RAW = 0x00000020; -$ODDP = 0x00000040; -$EVENP = 0x00000080; -$ANYP = 0x000000c0; -$NLDELAY = 0x00000300; -$NL0 = 0x00000000; -$NL1 = 0x00000100; -$NL2 = 0x00000200; -$NL3 = 0x00000300; -$TBDELAY = 0x00000c00; -$TAB0 = 0x00000000; -$TAB1 = 0x00000400; -$TAB2 = 0x00000800; -$XTABS = 0x00000c00; -$CRDELAY = 0x00003000; -$CR0 = 0x00000000; -$CR1 = 0x00001000; -$CR2 = 0x00002000; -$CR3 = 0x00003000; -$VTDELAY = 0x00004000; -$FF0 = 0x00000000; -$FF1 = 0x00004000; -$BSDELAY = 0x00008000; -$BS0 = 0x00000000; -$BS1 = 0x00008000; -$ALLDELAY = 0xFF00; -$CRTBS = 0x00010000; -$PRTERA = 0x00020000; -$CRTERA = 0x00040000; -$TILDE = 0x00080000; -$MDMBUF = 0x00100000; -$LITOUT = 0x00200000; -$TOSTOP = 0x00400000; -$FLUSHO = 0x00800000; -$NOHANG = 0x01000000; -$L001000 = 0x02000000; -$CRTKIL = 0x04000000; -$PASS8 = 0x08000000; -$CTLECH = 0x10000000; -$PENDIN = 0x20000000; -$DECCTQ = 0x40000000; -$NOFLSH = 0x80000000; -$TIOCLBIS = 0x8004747F; -$TIOCLBIC = 0x8004747E; -$TIOCLSET = 0x8004747D; -$TIOCLGET = 0x4004747C; -$LCRTBS = 0x1; -$LPRTERA = 0x2; -$LCRTERA = 0x4; -$LTILDE = 0x8; -$LMDMBUF = 0x10; -$LLITOUT = 0x20; -$LTOSTOP = 0x40; -$LFLUSHO = 0x80; -$LNOHANG = 0x100; -$LCRTKIL = 0x400; -$LPASS8 = 0x800; -$LCTLECH = 0x1000; -$LPENDIN = 0x2000; -$LDECCTQ = 0x4000; -$LNOFLSH = 0xFFFF8000; -$TIOCSBRK = 0x2000747B; -$TIOCCBRK = 0x2000747A; -$TIOCSDTR = 0x20007479; -$TIOCCDTR = 0x20007478; -$TIOCGPGRP = 0x40047477; -$TIOCSPGRP = 0x80047476; -$TIOCSLTC = 0x80067475; -$TIOCGLTC = 0x40067474; -$TIOCOUTQ = 0x40047473; -$TIOCSTI = 0x80017472; -$TIOCNOTTY = 0x20007471; -$TIOCPKT = 0x80047470; -$TIOCPKT_DATA = 0x00; -$TIOCPKT_FLUSHREAD = 0x01; -$TIOCPKT_FLUSHWRITE = 0x02; -$TIOCPKT_STOP = 0x04; -$TIOCPKT_START = 0x08; -$TIOCPKT_NOSTOP = 0x10; -$TIOCPKT_DOSTOP = 0x20; -$TIOCSTOP = 0x2000746F; -$TIOCSTART = 0x2000746E; -$TIOCMSET = 0x8004746D; -$TIOCMBIS = 0x8004746C; -$TIOCMBIC = 0x8004746B; -$TIOCMGET = 0x4004746A; -$TIOCREMOTE = 0x80047469; -$TIOCGWINSZ = 0x40087468; -$TIOCSWINSZ = 0x80087467; -$TIOCUCNTL = 0x80047466; -$TIOCSSOFTC = 0x80047465; -$TIOCGSOFTC = 0x40047464; -$TIOCSCARR = 0x80047463; -$TIOCWCARR = 0x20007462; -$OTTYDISC = 0; -$NETLDISC = 1; -$NTTYDISC = 2; -$TABLDISC = 3; -$SLIPDISC = 4; -$FIOCLEX = 0x20006601; -$FIONCLEX = 0x20006602; -$FIONREAD = 0x4004667F; -$FIONBIO = 0x8004667E; -$FIOASYNC = 0x8004667D; -$FIOSETOWN = 0x8004667C; -$FIOGETOWN = 0x4004667B; -$SIOCSHIWAT = 0x80047300; -$SIOCGHIWAT = 0x40047301; -$SIOCSLOWAT = 0x80047302; -$SIOCGLOWAT = 0x40047303; -$SIOCATMARK = 0x40047307; -$SIOCSPGRP = 0x80047308; -$SIOCGPGRP = 0x40047309; -$SIOCADDRT = 0x8030720A; -$SIOCDELRT = 0x8030720B; -$SIOCSIFADDR = 0x8020690C; -$SIOCGIFADDR = 0xC020690D; -$SIOCSIFDSTADDR = 0x8020690E; -$SIOCGIFDSTADDR = 0xC020690F; -$SIOCSIFFLAGS = 0x80206910; -$SIOCGIFFLAGS = 0xC0206911; -$SIOCGIFBRDADDR = 0xC0206912; -$SIOCSIFBRDADDR = 0x80206913; -$SIOCGIFCONF = 0xC0086914; -$SIOCGIFNETMASK = 0xC0206915; -$SIOCSIFNETMASK = 0x80206916; -$SIOCGIFMETRIC = 0xC0206917; -$SIOCSIFMETRIC = 0x80206918; -$SIOCSARP = 0x8024691E; -$SIOCGARP = 0xC024691F; -$SIOCDARP = 0x80246920; diff --git a/lib/AutoLoader.pm b/lib/AutoLoader.pm index b38915872c..ea19e502a0 100644 --- a/lib/AutoLoader.pm +++ b/lib/AutoLoader.pm @@ -33,7 +33,8 @@ AUTOLOAD { eval {require $name}; } elsif ($AUTOLOAD =~ /::DESTROY$/) { - eval "sub $AUTOLOAD {}"; + # eval "sub $AUTOLOAD {}"; + *$AUTOLOAD = sub {}; } if ($@){ $@ =~ s/ at .*\n//; diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm index 72f897d1b1..46cf68985a 100644 --- a/lib/AutoSplit.pm +++ b/lib/AutoSplit.pm @@ -56,6 +56,7 @@ sub autosplit_lib_modules{ foreach(@modules){ s#::#/#g; # incase specified as ABC::XYZ + s|\\|/|g; # bug in ksh OS/2 s#^lib/##; # incase specified as lib/*.pm if ($vms && /[:>\]]/) { # may need to convert VMS-style filespecs my ($dir,$name) = (/(.*])(.*)/); @@ -77,6 +78,9 @@ sub autosplit_file{ # where to write output files $autodir = "lib/auto" unless $autodir; + if ($Config{'osname'} eq 'VMS') { + ($autodir = VMS::Filespec::unixpath($autodir)) =~ s#/$##; + } unless (-d $autodir){ local($", @p)="/"; foreach(split(/\//,$autodir)){ @@ -107,7 +111,6 @@ sub autosplit_file{ $package = $1 if (m/^\s*package\s+([\w:]+)\s*;/); ++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/; ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/; - ++$autoloader_seen if m/^\s*sub\s+AUTOLOAD\b/; last if /^__END__/; } if ($check_for_autoloader && !$autoloader_seen){ @@ -174,14 +177,15 @@ sub autosplit_file{ # For now both of these produce warnings. open(OUT,">/dev/null") || open(OUT,">nla0:"); # avoid 'not opened' warning - my(@subnames); + my(@subnames, %proto); while () { if (/^package ([\w:]+)\s*;/) { warn "package $1; in AutoSplit section ignored. Not currently supported."; } - if (/^sub ([\w:]+)/) { + if (/^sub\s+([\w:]+)(\s*\(.*?\))?/) { print OUT "1;\n"; - my($subname) = $1; + my $subname = $1; + $proto{$1} = $2 or ''; if ($subname =~ m/::/){ warn "subs with package names not currently supported in AutoSplit section"; } @@ -229,7 +233,7 @@ sub autosplit_file{ carp "AutoSplit: unable to create timestamp file ($al_idx_file): $!"; print TS "# Index created by AutoSplit for $filename (file acts as timestamp)\n"; print TS "package $package;\n"; - print TS map("sub $_ ;\n", @subnames); + print TS map("sub $_$proto{$_} ;\n", @subnames); print TS "1;\n"; close(TS); diff --git a/lib/Cwd.pm b/lib/Cwd.pm index af1167dfc8..6b845108c2 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -1,7 +1,11 @@ package Cwd; require 5.000; require Exporter; -use Config; +require Config; + +# Use osname for portability switches (doubled to cheaply avoid -w warning) +my $osname = $Config::Config{'osname'} || $Config::Config{'osname'}; + =head1 NAME @@ -9,11 +13,14 @@ getcwd - get pathname of current working directory =head1 SYNOPSIS - require Cwd; - $dir = Cwd::getcwd(); + use Cwd; + $dir = cwd; + + use Cwd; + $dir = getcwd; use Cwd; - $dir = getcwd(); + $dir = fastgetcwd; use Cwd 'chdir'; chdir "/tmp"; @@ -22,29 +29,42 @@ getcwd - get pathname of current working directory =head1 DESCRIPTION The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions -in Perl. If you ask to override your chdir() built-in function, then your -PWD environment variable will be kept up to date. (See -L.) +in Perl. The fastgetcwd() function looks the same as getcwd(), but runs faster. It's also more dangerous because you might conceivably chdir() out of a directory that you can't chdir() back into. +The cwd() function looks the same as getcwd and fastgetcwd but is +implemented using the most natural and safe form for the current +architecture. For most systems it is identical to `pwd` (but without +the trailing line terminator). It is recommended that cwd (or another +*cwd() function) is used in I code to ensure portability. + +If you ask to override your chdir() built-in function, then your PWD +environment variable will be kept up to date. (See +L.) Note that it will only be +kept up to date it all packages which use chdir import it from Cwd. + =cut @ISA = qw(Exporter); -@EXPORT = qw(getcwd fastcwd); +@EXPORT = qw(cwd getcwd fastcwd); @EXPORT_OK = qw(chdir); +# use strict; + +sub _backtick_pwd { # The 'natural and safe form' for UNIX (pwd may be setuid root) + my $cwd; + chop($cwd = `pwd`); + $cwd; +} + +# Since some ports may predefine cwd internally (e.g., NT) +# we take care not to override an existing definition for cwd(). + +*cwd = \&_backtick_pwd unless defined &cwd; -# VMS: $ENV{'DEFAULT'} points to default directory at all times -# 08-Dec-1994 Charles Bailey bailey@genetics.upenn.edu -# Note: Use of Cwd::getcwd() or Cwd::chdir() (but not Cwd::fastcwd()) -# causes the logical name PWD to be defined in the process -# logical name table as the default device and directory -# seen by Perl. This may not be the same as the default device -# and directory seen by DCL after Perl exits, since the effects -# the CRTL chdir() function persist only until Perl exits. # By Brandon S. Allbery # @@ -52,8 +72,6 @@ directory that you can't chdir() back into. sub getcwd { - if($Config{'osname'} eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} } - my($dotdots, $cwd, @pst, @cst, $dir, @tst); unless (@cst = stat('.')) @@ -120,8 +138,6 @@ sub getcwd # you might chdir out of a directory that you can't chdir back into. sub fastcwd { - if($Config{'osname'} eq 'VMS') { return $ENV{'DEFAULT'} } - my($odev, $oino, $cdev, $cino, $tdev, $tino); my(@path, $path); local(*DIR); @@ -151,29 +167,25 @@ sub fastcwd { } -# keeps track of current working directory in PWD environment var -# -# $RCSfile: pwd.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:11 $ -# -# $Log: pwd.pl,v $ -# +# Keeps track of current working directory in PWD environment var # Usage: # use Cwd 'chdir'; # chdir $newdir; -$chdir_init = 0; +my $chdir_init = 0; -sub chdir_init{ - if ($ENV{'PWD'}) { +sub chdir_init { + if ($ENV{'PWD'} and $osname ne 'os2') { my($dd,$di) = stat('.'); my($pd,$pi) = stat($ENV{'PWD'}); if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { - chop($ENV{'PWD'} = `pwd`); + $ENV{'PWD'} = cwd(); } } else { - chop($ENV{'PWD'} = `pwd`); + $ENV{'PWD'} = cwd(); } + # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar) if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) { my($pd,$pi) = stat($2); my($dd,$di) = stat($1); @@ -185,17 +197,18 @@ sub chdir_init{ } sub chdir { - my($newdir) = shift; - $newdir =~ s|/{2,}|/|g; + my $newdir = shift || ''; # allow for no arg (chdir to HOME dir) + $newdir =~ s|///*|/|g; chdir_init() unless $chdir_init; - return 0 unless (CORE::chdir $newdir); - if ($Config{'osname'} eq 'VMS') { return $ENV{PWD} = $ENV{DEFAULT} } + return 0 unless CORE::chdir $newdir; + if ($osname eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} } if ($newdir =~ m#^/#) { $ENV{'PWD'} = $newdir; - }else{ - my(@curdir) = split(m#/#,$ENV{'PWD'}); - @curdir = '' unless @curdir; + } else { + my @curdir = split(m#/#,$ENV{'PWD'}); + @curdir = ('') unless @curdir; + my $component; foreach $component (split(m#/#, $newdir)) { next if $component eq '.'; pop(@curdir),next if $component eq '..'; @@ -203,7 +216,60 @@ sub chdir { } $ENV{'PWD'} = join('/',@curdir) || '/'; } + 1; } + +# --- PORTING SECTION --- + +# VMS: $ENV{'DEFAULT'} points to default directory at all times +# 08-Dec-1994 Charles Bailey bailey@genetics.upenn.edu +# Note: Use of Cwd::getcwd() or Cwd::chdir() (but not Cwd::fastcwd()) +# causes the logical name PWD to be defined in the process +# logical name table as the default device and directory +# seen by Perl. This may not be the same as the default device +# and directory seen by DCL after Perl exits, since the effects +# the CRTL chdir() function persist only until Perl exits. +# This does not apply to other systems (where only chdir() sets PWD). + +sub _vms_cwd { + return $ENV{'DEFAULT'} +} +sub _vms_pwd { + return $ENV{'PWD'} = $ENV{'DEFAULT'} +} +sub _os2_cwd { + $ENV{'PWD'} = `cmd /c cd`; + chop $ENV{'PWD'}; + $ENV{'PWD'} =~ s:\\:/:g ; + return $ENV{'PWD'}; +} + +if ($osname eq 'VMS') { + + *cwd = \&_vms_pwd; + *getcwd = \&_vms_pwd; + *fastgetcwd = \&_vms_cwd; +} +elsif ($osname eq 'NT') { + + *getcwd = \&cwd; + *fastgetcwd = \&cwd; +} +elsif ($osname eq 'os2') { + *cwd = \&_os2_cwd; + *getcwd = \&_os2_cwd; + *fastgetcwd = \&_os2_cwd; + *fastcwd = \&_os2_cwd; +} + +# package main; eval join('',) || die $@; # quick test + 1; +__END__ +BEGIN { import Cwd qw(:DEFAULT chdir); } +print join("\n", cwd, getcwd, fastcwd, ""); +chdir('..'); +print join("\n", cwd, getcwd, fastcwd, ""); +print "$ENV{PWD}\n"; diff --git a/lib/Exporter.pm b/lib/Exporter.pm index 0a7abc5286..8c4368c0ef 100644 --- a/lib/Exporter.pm +++ b/lib/Exporter.pm @@ -64,6 +64,10 @@ sub export { local $Carp::CarpLevel = 1; # ignore package calling us too. Carp::carp($text); }; + local $SIG{__DIE__} = sub { + Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT") + if $_[0] =~ /^Unable to create sub named "(.*?)::"/; + }; my $pkg = shift; my $callpkg = shift; diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index 7672f5ef31..d9b1e35b1d 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/lib/ExtUtils/Liblist.pm @@ -4,11 +4,15 @@ package ExtUtils::Liblist; use Config; use Cwd; +use File::Basename; + +my $Config_libext = $Config{lib_ext} || ".a"; + # --- Determine libraries to use and how to use them --- sub ext { my($potential_libs, $Verbose) = @_; - return ("", "", "") unless $potential_libs; + return ("", "", "", "") unless $potential_libs; print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose; my($so) = $Config{'so'}; @@ -21,7 +25,7 @@ sub ext { my(@searchpath); # from "-L/path" entries in $potential_libs my(@libpath) = split " ", $Config{'libpth'}; - my(@ldloadlibs, @bsloadlibs, @extralibs); + my(@ldloadlibs, @bsloadlibs, @extralibs, @ld_run_path, %ld_run_path_seen); my($fullname, $thislib, $thispth, @fullname); my($pwd) = fastcwd(); # from Cwd.pm my($found) = 0; @@ -90,22 +94,24 @@ sub ext { $mb cmp $ma;} @fullname)[0]; } elsif (-f ($fullname="$thispth/lib$thislib.$so") && (($Config{'dlsrc'} ne "dl_dld.xs") || ($thislib eq "m"))){ - } elsif (-f ($fullname="$thispth/lib${thislib}_s.a") + } elsif (-f ($fullname="$thispth/lib${thislib}_s$Config_libext") && ($thislib .= "_s") ){ # we must explicitly use _s version - } elsif (-f ($fullname="$thispth/lib$thislib.a")){ - } elsif (-f ($fullname="$thispth/Slib$thislib.a")){ + } elsif (-f ($fullname="$thispth/lib$thislib$Config_libext")){ + } elsif (-f ($fullname="$thispth/Slib$thislib$Config_libext")){ } else { print STDOUT "$thislib not found in $thispth\n" if $Verbose; next; } print STDOUT "'-l$thislib' found at $fullname\n" if $Verbose; + my($fullnamedir) = dirname($fullname); + push @ld_run_path, $fullnamedir unless $ld_run_path_seen{$fullnamedir}++; $found++; $found_lib++; # Now update library lists # what do we know about this library... - my $is_dyna = ($fullname !~ /\.a$/); + my $is_dyna = ($fullname !~ /\Q$Config_libext\E$/); my $in_perl = ($libs =~ /\B-l${thislib}\b/s); # Do not add it into the list if it is already linked in @@ -142,8 +148,8 @@ sub ext { print STDOUT "Warning (non-fatal): No library found for -l$thislib\n" unless $found_lib>0; } - return ('','','') unless $found; - ("@extralibs", "@bsloadlibs", "@ldloadlibs"); + return ('','','','') unless $found; + ("@extralibs", "@bsloadlibs", "@ldloadlibs",join(":",@ld_run_path)); } sub lsdir { #yes, duplicate code seems less hassle than having an diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index a03e4b8a60..feb3cf010c 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -14,21 +14,21 @@ sub TIEHASH { } sub FETCH { - print "Warning (non-fatal): Importing of %att is depreciated [$_[1]] + print "Warning (non-fatal): Importing of %att is deprecated [$_[1]] use \$self instead\n" unless ++$Enough>$Enough_limit; print "Further ExtUtils::MakeMaker::TieAtt warnings suppressed\n" if $Enough==$Enough_limit; $_[0]->{SECRETHASH}->{$_[1]}; } sub STORE { - print "Warning (non-fatal): Importing of %att is depreciated [$_[1]][$_[2]] + print "Warning (non-fatal): Importing of %att is deprecated [$_[1]][$_[2]] use \$self instead\n" unless ++$Enough>$Enough_limit; print "Further ExtUtils::MakeMaker::TieAtt warnings suppressed\n" if $Enough==$Enough_limit; $_[0]->{SECRETHASH}->{$_[1]} = $_[2]; } sub FIRSTKEY { - print "Warning (non-fatal): Importing of %att is depreciated [FIRSTKEY] + print "Warning (non-fatal): Importing of %att is deprecated [FIRSTKEY] use \$self instead\n" unless ++$Enough>$Enough_limit; print "Further ExtUtils::MakeMaker::TieAtt warnings suppressed\n" if $Enough==$Enough_limit; each %{$_[0]->{SECRETHASH}}; @@ -44,38 +44,26 @@ sub DESTROY { sub warndirectuse { my($caller) = @_; return if $Enough>$Enough_limit; - print STDOUT "Warning (non-fatal): Direct use of class methods depreciated; use\n"; + print STDOUT "Warning (non-fatal): Direct use of class methods deprecated; use\n"; my($method) = $caller =~ /.*:(\w+)$/; print STDOUT ' my $self = shift; - local *', $method, '; $self->MM::', $method, "(); instead\n"; print "Further ExtUtils::MakeMaker::TieAtt warnings suppressed\n" if ++$Enough==$Enough_limit; } -package ExtUtils::MakeMaker::TieVersion; -sub TIESCALAR { my $x = "5.00"; bless \$x } -sub FETCH { ${$_[0]} } -sub STORE { warn "You just tried to alter \$ExtUtils::MakeMaker::Version. -Please check your Makefile.PL"; $_[1]; } -sub DESTROY {} - package ExtUtils::MakeMaker; -# Last edited $Date: 1995/10/26 16:24:47 $ by Andreas Koenig +# Last edited $Date: 1995/11/12 10:05:55 $ by Andreas Koenig +# $Id: MakeMaker.pm,v 1.105 1995/11/12 10:05:55 k Exp $ -# The tie will go away again inlater versions -$ExtUtils::MakeMaker::Version = $ExtUtils::MakeMaker::VERSION; -tie $ExtUtils::MakeMaker::Version, ExtUtils::MakeMaker::TieVersion; -tie $ExtUtils::MakeMaker::VERSION, ExtUtils::MakeMaker::TieVersion; +$Version = $VERSION = "5.06"; $ExtUtils::MakeMaker::Version_OK = 4.13; # Makefiles older than $Version_OK will die # (Will be checked from MakeMaker version 4.13 onwards) -# $Id: MakeMaker.pm,v 1.93 1995/10/26 16:24:47 k Exp $ - use Config; use Carp; use Cwd; @@ -96,12 +84,12 @@ eval {require DynaLoader;}; # Get mod2fname, if defined. Will fail @EXPORT = qw(&WriteMakefile &writeMakefile $Verbose &prompt); @EXPORT_OK = qw($Version $VERSION &Version_check &help &neatvalue &mkbootstrap &mksymlists - %att ## Import of %att is depreciated, please use OO features! + %att ## Import of %att is deprecated, please use OO features! ); $Is_VMS = $Config::Config{osname} eq 'VMS'; require ExtUtils::MM_VMS if $Is_VMS; -$Is_OS2 = $Config::Config{'osname'} =~ m|^os/?2$|i ; +$Is_OS2 = $Config::Config{osname} =~ m|^os/?2$|i ; $ENV{EMXSHELL} = 'sh' if $Is_OS2; # to run `commands` $ExtUtils::MakeMaker::Verbose = 0; @@ -119,11 +107,10 @@ unshift(@MY::ISA, qw(MM)); # MY::XYZ->func() can call MM->func() and get the proper # default routine without having to know under what OS # it's running. -#unshift(@MM::ISA, $Is_VMS ? qw(ExtUtils::MM_VMS MM_Unix) : qw(MM_Unix)); -unshift @MM::ISA, 'MM_Unix'; + +@MM::ISA = qw[MM_Unix ExtUtils::MakeMaker]; unshift @MM::ISA, 'ExtUtils::MM_VMS' if $Is_VMS; unshift @MM::ISA, 'ExtUtils::MM_OS2' if $Is_OS2; -push @MM::ISA, qw[ExtUtils::MakeMaker]; @ExtUtils::MakeMaker::MM_Sections_spec = ( @@ -185,6 +172,7 @@ foreach(split(/\n/,attrib_help())){ %ExtUtils::MakeMaker::Prepend_dot_dot = qw( INST_LIB 1 INST_ARCHLIB 1 INST_EXE 1 MAP_TARGET 1 INST_MAN1DIR 1 INST_MAN3DIR 1 +PERL_SRC 1 PERL 1 FULLPERL 1 ); $PACKNAME = "PACK000"; @@ -196,10 +184,12 @@ most probably outdated. We detect that from the fact, that a subroutine "writeMakefile" is called, and this subroutine is not supported anymore since about October 1994. -Please contact the author or ask archie for a more recent version of -the extension. If you're really desperate, you can try to change the -subroutine name from writeMakefile to WriteMakefile and rerun 'perl -akefile.PL', but you're most probably left alone, when you do so. +Please contact the author or look into CPAN (details about CPAN can be +found in the FAQ and at http:/www.perl.com) for a more recent version +of the extension. If you're really desperate, you can try to change +the subroutine name from writeMakefile to WriteMakefile and rerun +'perl Makefile.PL', but you're most probably left alone, when you do +so. The MakeMaker team @@ -221,10 +211,10 @@ sub new { check_manifest(); } - check_hints(); - $self = {} unless (defined $self); + check_hints(); + my(%initial_att) = %$self; # record initial attributes if (defined $self->{CONFIGURE}) { @@ -257,6 +247,7 @@ sub new { $self->{PARENT} = $ExtUtils::MakeMaker::Parent[-2]; my $key; for $key (keys %ExtUtils::MakeMaker::Prepend_dot_dot) { + next unless defined $self->{PARENT}{$key}; $self->{$key} = $self->{PARENT}{$key}; $self->{$key} = $self->catdir("..",$self->{$key}) unless $self->{$key} =~ m!^/!; @@ -319,6 +310,7 @@ END unless ($self->{NORECURS}) { foreach $dir (@{$self->{DIR}}){ chdir $dir; + package main; local *FH; open FH, "Makefile.PL"; eval join "", ; @@ -385,13 +377,14 @@ sub parse_args{ (getpwuid($>))[7] ]ex; } - # This will go away: + # This may go away, in mid 1996 if ($self->{Correct_relativ_directories}){ $value = $self->catdir("..",$value) - if $ExtUtils::MakeMaker::Prepend_dot_dot{$name} &&! $value =~ m!^/!; + if $ExtUtils::MakeMaker::Prepend_dot_dot{$name} && ! $value =~ m!^/!; } $self->{$name} = $value; } + # This may go away, in mid 1996 delete $self->{Correct_relativ_directories}; # catch old-style 'potential_libs' and inform user how to 'upgrade' @@ -419,6 +412,13 @@ sub parse_args{ $self->{LDFROM} = $self->{LDTARGET}; delete $self->{LDTARGET}; } + # Turn a DIR argument on the command line into an array + if (defined $self->{DIR} && ref \$self->{DIR} eq 'SCALAR') { + # So they can choose from the command line, which extensions they want + # the grep enables them to have some colons too much in case they + # have to build a list with the shell + $self->{DIR} = [grep $_, split ":", $self->{DIR}]; + } my $mmkey; foreach $mmkey (sort keys %$self){ print STDOUT " $mmkey => ", neatvalue($self->{$mmkey}), "\n" if $ExtUtils::MakeMaker::Verbose; @@ -449,6 +449,7 @@ sub check_hints { return unless -f "hints/$hint.pl"; # really there # execute the hintsfile: + local *HINTS; open HINTS, "hints/$hint.pl"; @goodhints = ; close HINTS; @@ -462,7 +463,7 @@ sub mv_all_methods { my($method); # no strict; - foreach $method (@ExtUtils::MakeMaker::MM_Sections, qw[ dir_target exescan extliblist + foreach $method (@ExtUtils::MakeMaker::MM_Sections, qw[ dir_target exescan fileparse fileparse_set_fstype init_dirscan init_main init_others installpm_x libscan makeaperl mksymlists needs_linking runsubdirpl subdir_x test_via_harness test_via_script writedoc ]) { @@ -505,13 +506,18 @@ subdir_x test_via_harness test_via_script writedoc ]) { sub prompt { my($mess,$def)=@_; - local $|=1; - die "prompt function called without an argument" unless defined $mess; + BEGIN { my $ISA_TTY = -t STDIN && -t STDOUT } + Carp::confess("prompt function called without an argument") unless defined $mess; $def = "" unless defined $def; my $dispdef = "[$def] "; - print "$mess $dispdef"; - chop(my $ans = ); - $ans || $def; + my $ans; + if ($ISA_TTY) { + local $|=1; + print "$mess $dispdef"; + chop($ans = ); + } + return $ans if defined $ans; + return $def; } sub attrib_help { @@ -587,7 +593,7 @@ Current Version is $ExtUtils::MakeMaker::VERSION. There have been considerable changes in the meantime. Please rerun 'perl Makefile.PL' to regenerate the Makefile.\n" if $checkversion < $ExtUtils::MakeMaker::Version_OK; - printf STDOUT "%s %.2f %s %.2f.\n", "Makefile built with ExtUtils::MakeMaker v", + printf STDOUT "%s %s %s %s.\n", "Makefile built with ExtUtils::MakeMaker v", $checkversion, "Current Version is", $ExtUtils::MakeMaker::VERSION unless $checkversion == $ExtUtils::MakeMaker::VERSION; } @@ -736,7 +742,7 @@ sub init_main { ($self->{ROOTEXT} = $self->{FULLEXT}) =~ s#/?\Q$self->{BASEEXT}\E$## ; #eg. /BSD/Foo - $self->{ROOTEXT} = ($Is_VMS ? '' : '/') . $self->{ROOTEXT} if $self->{ROOTEXT}; + $self->{ROOTEXT} = ($Is_VMS ? '' : '/') . $self->{ROOTEXT} if $self->{ROOTEXT}; # --- Initialize PERL_LIB, INST_LIB, PERL_SRC @@ -749,18 +755,18 @@ sub init_main { # not be the case (e.g., installing into project libraries etc). # Perl Macro: With source No source - # PERL_LIB ../../lib /usr/local/lib/perl5 - # PERL_ARCHLIB ../../lib /usr/local/lib/perl5/sun4-sunos # PERL_SRC ../.. (undefined) + # PERL_LIB PERL_SRC/lib /usr/local/lib/perl5 + # PERL_ARCHLIB PERL_SRC/lib /usr/local/lib/perl5/sun4-sunos # INST Macro: For standard for any other # modules module - # INST_LIB ../../lib ./blib - # INST_ARCHLIB ../../lib ./blib/ + # INST_LIB PERL_SRC/lib ./blib + # INST_ARCHLIB PERL_SRC/lib ./blib/ unless ($self->{PERL_SRC}){ my($dir); - foreach $dir (qw(../.. ../../.. ../../../..)){ + foreach $dir (qw(.. ../.. ../../..)){ if ( -f "$dir/config.sh" && -f "$dir/perl.h" && -f "$dir/lib/Exporter.pm") { @@ -814,6 +820,10 @@ EOM # perl has been built and installed. Setting INST_LIB allows # you to build directly into, say $Config::Config{privlibexp}. unless ($self->{INST_LIB}){ + + + ##### XXXXX We have to change this nonsense + if (defined $self->{PERL_SRC}) { $self->{INST_LIB} = $self->{PERL_LIB}; } else { @@ -845,8 +855,8 @@ EOM if ($self->{PREFIX}){ $self->{INSTALLPRIVLIB} = $self->catdir($self->{PREFIX},"lib","perl5"); $self->{INSTALLBIN} = $self->catdir($self->{PREFIX},"bin"); - $self->{INSTALLMAN1DIR} = $self->catdir($self->{PREFIX},"perl5","man","man1"); - $self->{INSTALLMAN3DIR} = $self->catdir($self->{PREFIX},"perl5","man","man3"); + $self->{INSTALLMAN3DIR} = $self->catdir($self->{PREFIX},"perl5","man","man3") + unless defined $self->{INSTALLMAN3DIR}; } if( $self->{INSTALLPRIVLIB} && ! $self->{INSTALLARCHLIB} ){ @@ -862,25 +872,39 @@ EOM $self->{INSTALLARCHLIB} ||= $Config::Config{installarchlib}; $self->{INSTALLBIN} ||= $Config::Config{installbin}; - $self->{INST_MAN1DIR} ||= $self->catdir('.','blib','man','man1'); - $self->{INSTALLMAN1DIR} ||= $Config::Config{installman1dir}; - $self->{MAN1EXT} ||= $Config::Config{man1ext}; + $self->{INSTALLMAN1DIR} = $Config::Config{installman1dir} + unless defined $self->{INSTALLMAN1DIR}; + unless (defined $self->{INST_MAN1DIR}){ + if ($self->{INSTALLMAN1DIR} =~ /^(none|\s*)$/){ + $self->{INST_MAN1DIR} = $self->{INSTALLMAN1DIR}; + } else { + $self->{INST_MAN1DIR} = $self->catdir('.','blib','man','man1'); + } + } + $self->{MAN1EXT} ||= $Config::Config{man1ext}; - $self->{INST_MAN3DIR} ||= $self->catdir('.','blib','man','man3'); - $self->{INSTALLMAN3DIR} ||= $Config::Config{installman3dir}; - $self->{MAN3EXT} ||= $Config::Config{man3ext}; + $self->{INSTALLMAN3DIR} = $Config::Config{installman3dir} + unless defined $self->{INSTALLMAN3DIR}; + unless (defined $self->{INST_MAN3DIR}){ + if ($self->{INSTALLMAN3DIR} =~ /^(none|\s*)$/){ + $self->{INST_MAN3DIR} = $self->{INSTALLMAN3DIR}; + } else { + $self->{INST_MAN3DIR} = $self->catdir('.','blib','man','man3'); + } + } + $self->{MAN3EXT} ||= $Config::Config{man3ext}; $self->{MAP_TARGET} = "perl" unless $self->{MAP_TARGET}; - $self->{LIB_EXT} = $Config::Config{lib_ext} || "a"; - $self->{OBJ_EXT} = $Config::Config{obj_ext} || "o"; + $self->{LIB_EXT} = $Config::Config{lib_ext} || ".a"; + $self->{OBJ_EXT} = $Config::Config{obj_ext} || ".o"; $self->{AR} = $Config::Config{ar} || "ar"; unless ($self->{LIBPERL_A}){ if ($Is_VMS) { $self->{LIBPERL_A} = 'libperl.olb'; } else { - $self->{LIBPERL_A} = "libperl.$self->{LIB_EXT}"; + $self->{LIBPERL_A} = "libperl$self->{LIB_EXT}"; } } @@ -1015,7 +1039,7 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) $self->{PM} = \%pm unless $self->{PM}; $self->{C} = [sort keys %c] unless $self->{C}; my(@o_files) = @{$self->{C}}; - $self->{O_FILES} = [grep s/\.c$/\.$self->{OBJ_EXT}/, @o_files] ; + $self->{O_FILES} = [grep s/\.c$/$self->{OBJ_EXT}/, @o_files] ; $self->{H} = [sort keys %h] unless $self->{H}; $self->{PL_FILES} = \%pl_files unless $self->{PL_FILES}; @@ -1115,15 +1139,8 @@ sub init_others { # --- Initialize Other Attributes $libs =~ s/^\s*(.*\S)\s*$/$1/; # remove leading and trailing whitespace my(@libs) = $self->extliblist($libs); if ($libs[0] or $libs[1] or $libs[2]){ - ($self->{EXTRALIBS}, $self->{BSLOADLIBS}, $self->{LDLOADLIBS}) = @libs; - if ($libs[2]) { - my @splitted = split(" ", $libs[2]); - my $splitted; - foreach $splitted (@splitted) { - $splitted =~ s/^-L//; - } - $self->{LD_RUN_PATH} = join ":", @splitted; - } + # LD_RUN_PATH now computed by ExtUtils::Liblist + ($self->{EXTRALIBS}, $self->{BSLOADLIBS}, $self->{LDLOADLIBS}, $self->{LD_RUN_PATH}) = @libs; last; } } @@ -1139,10 +1156,11 @@ sub init_others { # --- Initialize Other Attributes unless ( $self->{OBJECT} ){ # init_dirscan should have found out, if we have C files - $self->{OBJECT} = '$(BASEEXT).$(OBJ_EXT)' if @{$self->{C}||[]}; + $self->{OBJECT} = '$(BASEEXT)$(OBJ_EXT)' if @{$self->{C}||[]}; } $self->{OBJECT} =~ s/\n+/ \\\n\t/g; $self->{BOOTDEP} = (-f "$self->{BASEEXT}_BS") ? "$self->{BASEEXT}_BS" : ""; + $self->{PERLMAINCC} ||= '$(CC)'; $self->{LD} = ($Config::Config{ld} || 'ld') unless $self->{LD}; $self->{LDFROM} = '$(OBJECT)' unless $self->{LDFROM}; @@ -1158,7 +1176,9 @@ sub init_others { # --- Initialize Other Attributes # These get overridden for VMS and maybe some other systems $self->{NOOP} = ""; - $self->{MAKEFILE} ||= "Makefile"; + $self->{FIRST_MAKEFILE} ||= "Makefile"; + $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE}; + $self->{MAKE_APERL_FILE} ||= "Makefile.aperl"; $self->{RM_F} = "rm -f"; $self->{RM_RF} = "rm -rf"; $self->{TOUCH} = "touch"; @@ -1188,14 +1208,13 @@ in these dirs: my $abs; if ($name =~ m|^/|) { $abs = $name; + } elsif ($name =~ m|/|) { + $abs = $self->catfile(".", $name); # not absolute } else { $abs = $self->catfile($dir, $name); } print "Checking $abs\n" if ($trace >= 2); - if ($Is_OS2) { - $abs .= ".exe" unless -x $abs; - } - next unless -x "$abs"; + next unless $self->maybe_command($abs); print "Executing $abs\n" if ($trace >= 2); if (`$abs -e 'require $ver; print "VER_OK\n" ' 2>&1` =~ /VER_OK/) { print "Using PERL=$abs\n" if $trace; @@ -1207,6 +1226,12 @@ in these dirs: 0; # false and not empty } +sub maybe_command { + my($self,$file) = @_; + return 1 if -x $file && ! -d $file; + return; +} + sub post_initialize { my($self) = shift; unless (ref $self){ @@ -1279,9 +1304,12 @@ LIBPERL_A = $self->{LIBPERL_A} MAKEMAKER = \$(PERL_LIB)/ExtUtils/MakeMaker.pm MM_VERSION = $ExtUtils::MakeMaker::VERSION +FIRST_MAKEFILE = $self->{FIRST_MAKEFILE} +MAKE_APERL_FILE = $self->{MAKE_APERL_FILE} OBJ_EXT = $self->{OBJ_EXT} LIB_EXT = $self->{LIB_EXT} +PERLMAINCC = $self->{PERLMAINCC} AR = $self->{AR} "; @@ -1333,9 +1361,9 @@ MAN3EXT = $self->{MAN3EXT} # work around a famous dec-osf make(1) feature(?): makemakerdflt: all -.SUFFIXES: .xs .c .\$(OBJ_EXT) +.SUFFIXES: .xs .c \$(OBJ_EXT) -.PRECIOUS: Makefile +# .PRECIOUS: Makefile # seems to be not necessary anymore .PHONY: all config static dynamic test linkext @@ -1357,7 +1385,7 @@ INST_ARCHAUTODIR = $(INST_ARCHLIB)/auto/$(FULLEXT) if ($self->has_link_code()) { push @m, ' -INST_STATIC = $(INST_ARCHAUTODIR)/$(BASEEXT).$(LIB_EXT) +INST_STATIC = $(INST_ARCHAUTODIR)/$(BASEEXT)$(LIB_EXT) INST_DYNAMIC = $(INST_ARCHAUTODIR)/$(DLBASE).$(DLEXT) INST_BOOT = $(INST_ARCHAUTODIR)/$(BASEEXT).bs '; @@ -1449,8 +1477,8 @@ sub const_cccmd { } return $self->{CONST_CCCMD} if $self->{CONST_CCCMD}; return '' unless $self->needs_linking(); - $libperl or $libperl = $self->{LIBPERL_A} || "libperl.$self->{LIB_EXT}" ; - $libperl =~ s/\.\$\(A\)$/.$self->{LIB_EXT}/; + $libperl or $libperl = $self->{LIBPERL_A} || "libperl$self->{LIB_EXT}" ; + $libperl =~ s/\.\$\(A\)$/$self->{LIB_EXT}/; # This is implemented in the same manner as extliblist, # e.g., do both and compare results during the transition period. my($cc,$ccflags,$optimize,$large,$split, $shflags) @@ -1471,7 +1499,7 @@ sub const_cccmd { DM => '-DDEBUGGING -DEMBED -DMULTIPLICITY', ); - if ($libperl =~ /libperl(\w*)\.$self->{LIB_EXT}/){ + if ($libperl =~ /libperl(\w*)\Q$self->{LIB_EXT}/){ $uc = uc($1); } else { $uc = ""; # avoid warning @@ -1522,21 +1550,21 @@ sub const_cccmd { $optimize = $optdebug; } - my($new) = "$cc -c $ccflags $optimize $perltype $large $split"; + my($new) = "$cc -c \$(INC) $ccflags $optimize $perltype $large $split"; $new =~ s/^\s+//; $new =~ s/\s+/ /g; $new =~ s/\s+$//; - if (defined($old)){ - $old =~ s/^\s+//; $old =~ s/\s+/ /g; $old =~ s/\s+$//; - if ($new ne $old) { - print STDOUT "Warning (non-fatal): cflags evaluation in ", - "MakeMaker ($ExtUtils::MakeMaker::VERSION) ", - "differs from shell output\n", - " package: $self->{NAME}\n", - " old: $old\n", - " new: $new\n", - " Using 'old' set.\n", - Config::myconfig(), "\n"; - } - } +# if (defined($old)){ +# $old =~ s/^\s+//; $old =~ s/\s+/ /g; $old =~ s/\s+$//; +# if ($new ne $old) { +# print STDOUT "Warning (non-fatal): cflags evaluation in ", +# "MakeMaker ($ExtUtils::MakeMaker::VERSION) ", +# "differs from shell output\n", +# " package: $self->{NAME}\n", +# " old: $old\n", +# " new: $new\n", +# " Using 'old' set.\n", +# Config::myconfig(), "\n"; +# } +# } my($cccmd)=($old) ? $old : $new; $cccmd =~ s/^\s*\Q$Config::Config{cc}\E\s/\$(CC) /; $cccmd .= " \$(DEFINE_VERSION)"; @@ -1582,6 +1610,9 @@ sub tool_xsubpp { } push(@tmdeps, "typemap") if -f "typemap"; my(@tmargs) = map("-typemap $_", @tmdeps); + if( exists $self->{XSOPT} ){ + unshift( @tmargs, $self->{XSOPT} ); + } " XSUBPPDIR = $xsdir XSUBPP = \$(XSUBPPDIR)/xsubpp @@ -1634,7 +1665,7 @@ sub dist { my($postop) = $attribs{POSTOP} || '@ true'; # eg remove the distdir my($ci) = $attribs{CI} || 'ci -u'; my($rcs_label)= $attribs{RCS_LABEL}|| 'rcs -Nv$(VERSION_SYM): -q'; - my($dist_cp) = $attribs{DIST_CP} || 'cp'; + my($dist_cp) = $attribs{DIST_CP} || 'best'; my($dist_default) = $attribs{DIST_DEFAULT} || 'tardist'; push @m, " @@ -1684,10 +1715,11 @@ sub pasthru { } my(@m,$key); - my(@pasthru); # 1 was for runsubdirpl, 2 for normal make in subdirectories + my(@pasthru); foreach $key (qw(INSTALLPRIVLIB INSTALLARCHLIB INSTALLBIN - INSTALLMAN1DIR INSTALLMAN3DIR LIBPERL_A LINKTYPE)){ + INSTALLMAN1DIR INSTALLMAN3DIR LIBPERL_A + LINKTYPE)){ push @pasthru, "$key=\"\$($key)\""; } @@ -1706,8 +1738,8 @@ sub c_o { return '' unless $self->needs_linking(); my(@m); push @m, ' -.c.$(OBJ_EXT): - $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $(INC) $*.c +.c$(OBJ_EXT): + $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c '; join "", @m; } @@ -1733,9 +1765,9 @@ sub xs_o { # many makes are too dumb to use xs_c then c_o } return '' unless $self->needs_linking(); ' -.xs.$(OBJ_EXT): +.xs$(OBJ_EXT): $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSUBPPARGS) $*.xs >xstmp.c && mv xstmp.c $*.c - $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $(INC) $*.c + $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c '; } @@ -1802,7 +1834,7 @@ help: Version_check: @$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \ -e 'use ExtUtils::MakeMaker qw($$Version &Version_check);' \ - -e '&Version_check($(MM_VERSION))' + -e '&Version_check("$(MM_VERSION)")' }; join('',@m); @@ -1849,9 +1881,9 @@ static :: $self->{BASEEXT}.exp push(@m," $self->{BASEEXT}.exp: Makefile.PL ",' $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e \'use ExtUtils::MakeMaker qw(&mksymlists); \\ - &mksymlists(DL_FUNCS => ', + MM->mksymlists({DL_FUNCS => ', %$funcs ? neatvalue($funcs) : '""',', DL_VARS => ', - @$vars ? neatvalue($vars) : '""', ", NAME => \"$self->{NAME}\")' + @$vars ? neatvalue($vars) : '""', ", NAME => \"$self->{NAME}\"})' "); join('',@m); @@ -1930,7 +1962,7 @@ OTHERLDFLAGS = '.$otherldflags.' $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists $(EXPORT_LIST) $(PERL_ARCHIVE) '); if ($armaybe ne ':'){ - $ldfrom = "tmp.$(LIB_EXT)"; + $ldfrom = 'tmp$(LIB_EXT)'; push(@m,' $(ARMAYBE) cr '.$ldfrom.' $(OBJECT)'."\n"); push(@m,' $(RANLIB) '."$ldfrom\n"); } @@ -2053,13 +2085,31 @@ sub manifypods { ExtUtils::MakeMaker::TieAtt::warndirectuse((caller(0))[3]); $self = $ExtUtils::MakeMaker::Parent[-1]; } + return "\nmanifypods :\n" unless %{$self->{MANPODS}}; my($dist); + my($pod2man_exe); + if (defined $self->{PERL_SRC}) { + $pod2man_exe = "$self->{PERL_SRC}/pod/pod2man"; + } else { + $pod2man_exe = "$Config{bin}/pod2man"; + } + unless ($self->maybe_command($pod2man_exe)) { + # No pod2man but some MANPODS to be installed + print <{MAKEFILE}.q[";' \\ -e 'print "Installing $$m{$$_}\n";' \\ --e 'system("pod2man $$_>$$m{$$_}")==0 or warn "Couldn\\047t install $$m{$$_}\n";' \\ +-e 'system("$(PERL) $(POD2MAN_EXE) $$_>$$m{$$_}")==0 or warn "Couldn\\047t install $$m{$$_}\n";' \\ -e 'chmod 0644, $$m{$$_} or warn "chmod 644 $$m{$$_}: $$!\n";}' ]; push @m, "\nmanifypods :"; @@ -2141,7 +2191,7 @@ sub subdirs { # It calls the subdir_x() method for each subdirectory. foreach $dir (@{$self->{DIR}}){ push(@m, $self->subdir_x($dir)); - print "Including $dir subdirectory\n" if $ExtUtils::MakeMaker::Verbose; +#### print "Including $dir subdirectory\n"; } if (@m){ unshift(@m, " @@ -2177,7 +2227,7 @@ sub subdir_x { qq{ subdirs :: - \@ -cd $subdir && \$(MAKE) all \$(PASTHRU) + \@-cd $subdir && \$(MAKE) all \$(PASTHRU) }; } @@ -2207,7 +2257,7 @@ clean :: push(@otherfiles, qw[./blib Makeaperlfile $(INST_ARCHAUTODIR)/extralibs.all perlmain.c mon.out core so_locations *~ */*~ */*/*~ - *.$(OBJ_EXT) *.$(LIB_EXT) + *$(OBJ_EXT) *$(LIB_EXT) perl.exe $(BOOTSTRAP) $(BASEEXT).bso $(BASEEXT).def $(BASEEXT).exp ]); push @m, "\t-$self->{RM_RF} @otherfiles\n"; @@ -2264,6 +2314,12 @@ distcheck : -e 'fullcheck();' }; + push @m, q{ +skipcheck : + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e 'use ExtUtils::Manifest "&skipcheck";' \\ + -e 'skipcheck();' +}; + push @m, q{ manifest : $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e 'use ExtUtils::Manifest "&mkmanifest";' \\ @@ -2467,7 +2523,7 @@ sub makefile { # must force a manual rerun to be sure. But as it should only # happen very rarely it is not a significant problem. push @m, ' -$(OBJECT) : '.$self->{MAKEFILE}.' +$(OBJECT) : $(FIRST_MAKEFILE) ' if $self->{OBJECT}; push @m, ' @@ -2500,7 +2556,7 @@ sub staticmake { # And as it's not yet built, we add the current extension # but only if it has some C code (or XS code, which implies C code) if (@{$self->{C}}) { - @static="$self->{INST_ARCHLIB}/auto/$self->{FULLEXT}/$self->{BASEEXT}.$self->{LIB_EXT}"; + @static="$self->{INST_ARCHLIB}/auto/$self->{FULLEXT}/$self->{BASEEXT}$self->{LIB_EXT}"; } # Either we determine now, which libraries we will produce in the @@ -2609,13 +2665,23 @@ FULLPERL = $self->{FULLPERL} "; return join '', @m if $self->{PARENT}; + my($dir) = join ":", @{$self->{DIR}}; + unless ($self->{MAKEAPERL}) { - push @m, ' -$(MAP_TARGET) :: - $(MAKE) LINKTYPE=static all - $(PERL) Makefile.PL MAKEFILE=Makefile.aperl LINKTYPE=static MAKEAPERL=1 NORECURS=1 - $(MAKE) -f Makefile.aperl $(MAP_TARGET) -'; + push @m, q{ +$(MAP_TARGET) :: $(MAKE_APERL_FILE) + $(MAKE) -f Makefile.aperl static $@ + +$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) + @ echo Writing \"Makefile.aperl\" for this $(MAP_TARGET) + @ $(PERL) -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \ + Makefile.PL DIR=}, $dir, q{ \ + MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \ + MAKEAPERL=1 NORECURS=1}; + + push @m, map( " \\\n\t\t$_", @ARGV ); + push @m, "\n"; + return join '', @m; } @@ -2626,7 +2692,7 @@ $(MAP_TARGET) :: $cccmd = $self->const_cccmd($libperl); $cccmd =~ s/^CCCMD\s*=\s*//; - $cccmd =~ s/\s/ -I$self->{PERL_INC} /; + $cccmd =~ s/\$\(INC\)/ -I$self->{PERL_INC} /; $cccmd .= " $Config::Config{cccdlflags}" if ($Config::Config{d_shrplib}); $cccmd =~ s/\n/ /g; # yes I've seen "\n", don't ask me where it came from. A.K. @@ -2638,7 +2704,7 @@ $(MAP_TARGET) :: # Which *.a files could we make use of... local(%static); File::Find::find(sub { - return unless m/\.$self->{LIB_EXT}$/; + return unless m/\Q$self->{LIB_EXT}$/; return if m/^libperl/; # don't include the installed version of this extension. I # leave this line here, although it is not necessary anymore: @@ -2647,7 +2713,7 @@ $(MAP_TARGET) :: # Once the patch to minimod.PL is in the distribution, I can # drop it - return if $File::Find::name =~ m:auto/$self->{FULLEXT}/$self->{BASEEXT}.$self->{LIB_EXT}$:; + return if $File::Find::name =~ m:auto/$self->{FULLEXT}/$self->{BASEEXT}$self->{LIB_EXT}$:; $static{fastcwd() . "/" . $_}++; }, grep( -d $_, @{$searchdirs || []}) ); @@ -2657,7 +2723,7 @@ $(MAP_TARGET) :: $extra = [] unless $extra && ref $extra eq 'ARRAY'; for (sort keys %static) { - next unless /\.$self->{LIB_EXT}$/; + next unless /\Q$self->{LIB_EXT}$/; $_ = dirname($_) . "/extralibs.ld"; push @$extra, $_; } @@ -2674,7 +2740,7 @@ $(MAP_TARGET) :: MAP_LINKCMD = $linkcmd MAP_PERLINC = @{$perlinc || []} MAP_STATIC = ", -join(" \\\n\t", sort keys %static), " +join(" \\\n\t", reverse sort keys %static), " MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} "; @@ -2684,9 +2750,9 @@ MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} } unless ($libperl && -f $lperl) { # Could quite follow your idea her, Ilya my $dir = $self->{PERL_SRC} || "$self->{PERL_ARCHLIB}/CORE"; - $libperl ||= "libperl.$self->{LIB_EXT}"; + $libperl ||= "libperl$self->{LIB_EXT}"; $libperl = "$dir/$libperl"; - $lperl ||= "libperl.$self->{LIB_EXT}"; + $lperl ||= "libperl$self->{LIB_EXT}"; $lperl = "$dir/$lperl"; print STDOUT "Warning: $libperl not found If you're going to build a static perl binary, make sure perl is installed @@ -2710,21 +2776,21 @@ MAP_LIBPERL = $libperl } push @m, " -\$(MAP_TARGET) :: $tmp/perlmain.\$(OBJ_EXT) \$(MAP_LIBPERL) \$(MAP_STATIC) \$(INST_ARCHAUTODIR)/extralibs.all - \$(MAP_LINKCMD) -o \$\@ $tmp/perlmain.\$(OBJ_EXT) \$(MAP_LIBPERL) \$(MAP_STATIC) `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS) +\$(MAP_TARGET) :: $tmp/perlmain\$(OBJ_EXT) \$(MAP_LIBPERL) \$(MAP_STATIC) \$(INST_ARCHAUTODIR)/extralibs.all + \$(MAP_LINKCMD) -o \$\@ $tmp/perlmain\$(OBJ_EXT) \$(MAP_LIBPERL) \$(MAP_STATIC) `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS) @ echo 'To install the new \"\$(MAP_TARGET)\" binary, call' @ echo ' make -f $makefilename inst_perl MAP_TARGET=\$(MAP_TARGET)' @ echo 'To remove the intermediate files say' @ echo ' make -f $makefilename map_clean' -$tmp/perlmain.\$(OBJ_EXT): $tmp/perlmain.c +$tmp/perlmain\$(OBJ_EXT): $tmp/perlmain.c "; - push @m, "\tcd $tmp && $cccmd perlmain.c\n"; + push @m, "\tcd $tmp && $cccmd -I\$(PERL_INC) perlmain.c\n"; push @m, qq{ $tmp/perlmain.c: $makefilename}, q{ @ echo Writing $@ - @ $(FULLPERL) $(MAP_PERLINC) -e 'use ExtUtils::Miniperl; \\ + @ $(PERL) $(MAP_PERLINC) -e 'use ExtUtils::Miniperl; \\ writemain(grep s#.*/auto/##, qw|$(MAP_STATIC)|)' > $@.tmp && mv $@.tmp $@ }; @@ -2748,7 +2814,7 @@ pure_inst_perl: \$(MAP_TARGET) clean :: map_clean map_clean : - $self->{RM_F} $tmp/perlmain.\$(OBJ_EXT) $tmp/perlmain.c \$(MAP_TARGET) $makefilename \$(INST_ARCHAUTODIR)/extralibs.all + $self->{RM_F} $tmp/perlmain\$(OBJ_EXT) $tmp/perlmain.c \$(MAP_TARGET) $makefilename \$(INST_ARCHAUTODIR)/extralibs.all }; join '', @m; @@ -2849,7 +2915,7 @@ sub needs_linking { # Does this module need linking? Looks into # print "DEBUG:\n"; # print Carp::longmess(); # print "EO_DEBUG\n"; - if ($self->has_link_code){ + if ($self->has_link_code or $self->{MAKEAPERL}){ $self->{NEEDS_LINKING} = 1; return 1; } @@ -2865,7 +2931,7 @@ sub needs_linking { # Does this module need linking? Looks into sub has_link_code { my($self) = shift; return $self->{HAS_LINK_CODE} if defined $self->{HAS_LINK_CODE}; - if ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB} or $self->{MAKEAPERL}){ + if ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB}){ $self->{HAS_LINK_CODE} = 1; return 1; } @@ -2933,6 +2999,13 @@ sub replace_manpage_seperator { $man; } +sub maybe_command { + my($self,$file) = @_; + return 1 if -x $file && ! -d _; + return 1 if -x "$file.exe" && ! -d _; + return; +} + # the following keeps AutoSplit happy package ExtUtils::MakeMaker; 1; @@ -2963,6 +3036,8 @@ It splits the task of generating the Makefile into several subroutines that can be individually overridden. Each subroutine returns the text it wishes to have written to the Makefile. +=head2 Hintsfile support + MakeMaker.pm uses the architecture specific information from Config.pm. In addition it evaluates architecture specific hints files in a C directory. The hints files are expected to be named @@ -2972,6 +3047,13 @@ MakeMaker within the WriteMakefile() subroutine, and can be used to execute commands as well as to include special variables. The rules which hintsfile is chosen are the same as in Configure. +The hintsfile is eval()ed immediately after the arguments given to +WriteMakefile are stuffed into a hash reference $self but before this +reference becomes blessed. So if you want to do the equivalent to +override or create an attribute you would say something like + + $self->{LIBS} = ['-ldbm -lucb -lc']; + =head2 What's new in version 5 of MakeMaker MakeMaker 5 is pure object oriented. This allows us to write an @@ -2998,7 +3080,7 @@ There are no incompatibilities in the short term, as all changes are accompanied by short-term workarounds that guarantee full backwards compatibility. -You are likely to face a few warnings that expose depreciations which +You are likely to face a few warnings that expose deprecations which will result in incompatibilities in the long run: You should not use %att directly anymore. Instead any subroutine you @@ -3079,14 +3161,14 @@ the macros INST_LIB, INST_ARCHLIB, INST_EXE, INST_MAN1DIR, and INST_MAN3DIR. All these default to ./blib or something below blib if you are I building below the perl source directory. If you I building below the perl source, INST_LIB and INST_ARCHLIB default to -../../lib, and INST_EXE is not defined. + ../../lib, and INST_EXE is not defined. The I target of the generated Makefile is a recursive call to make which sets INST_LIB to INSTALLPRIVLIB INST_ARCHLIB to INSTALLARCHLIB - INST_EXE to INSTALLBIN + INST_EXE to INSTALLBIN INST_MAN1DIR to INSTALLMAN1DIR INST_MAN3DIR to INSTALLMAN3DIR @@ -3179,7 +3261,11 @@ is built. You can invoke the corresponding section of the makefile with That produces a new perl binary in the current directory with all extensions linked in that can be found in INST_ARCHLIB (which usually -is C<./blib>) and PERL_ARCHLIB. +is C<./blib>) and PERL_ARCHLIB. To do that, MakeMaker writes a new +Makefile, on UNIX, this is called Makefile.aperl (may be system +dependent). If you want to force the creation of a new perl, it is +recommended, that you delete this Makefile.aperl, so INST_ARCHLIB and +PERL_ARCHLIB are searched-through for linkable libraries again. The binary can be installed into the directory where perl normally resides on your machine with @@ -3383,7 +3469,7 @@ Something like C<"-DHAVE_UNISTD_H"> =item OBJECT -List of object files, defaults to '$(BASEEXT).$(OBJ_EXT)', but can be a long +List of object files, defaults to '$(BASEEXT)$(OBJ_EXT)', but can be a long string containing all object files, e.g. "tkpBind.o tkpButton.o tkpCanvas.o" @@ -3452,6 +3538,12 @@ Hashref of .xs files. MakeMaker will default this. e.g. The .c files will automatically be included in the list of files deleted by a make clean. +=item XSOPT + +String of options to pass to xsubpp. This might include C<-C++> or +C<-extern>. Do not include typemaps here; the TYPEMAP parameter exists for +that purpose. + =item C Ref to array of *.c file names. Initialised from a directory scan @@ -3569,10 +3661,17 @@ Boolean which tells MakeMaker, that it should include the rules to make a perl. This is handled automatically as a switch by MakeMaker. The user normally does not need it. +=item FIRST_MAKEFILE + =item MAKEFILE The name of the Makefile to be produced. +=item PERLMAINCC + +The call to the program that is able to compile perlmain.c. Defaults +to $(CC). + =back =head2 Additional lowercase attributes @@ -3616,9 +3715,12 @@ holding together several subdirectories specify {TARFLAGS => 'cvfF', COMPRESS => 'gzip', SUFFIX => 'gz', SHAR => 'shar -m', DIST_CP => 'ln'} -If you specify COMPRESS, then SUFFIX should also be altered, as it -is needed to tell make the target file of the compression. DIST_CP -can be useful, if you need to preserve the timestamps on your files. +If you specify COMPRESS, then SUFFIX should also be altered, as it is +needed to tell make the target file of the compression. Setting +DIST_CP to ln can be useful, if you need to preserve the timestamps on +your files. DIST_CP can take the values 'cp', which copies the file, +'ln', which links the file, and 'best' which copies symbolic links and +links the rest. Default is 'best'. =item tool_autosplit @@ -3673,6 +3775,12 @@ reports which files are below the build directory but not in the MANIFEST file and vice versa. (See ExtUtils::Manifest::fullcheck() for details) +=item make skipcheck + +reports which files are skipped due to the entries in the +C file (See ExtUtils::Manifest::skipcheck() for +details) + =item make distclean does a realclean first and then the distcheck. Note that this is not @@ -3693,7 +3801,7 @@ exists, it will be removed first. =item make disttest Makes a distdir first, and runs a C, a make, and -a make install in that directory. +a make test in that directory. =item make tardist diff --git a/lib/ExtUtils/Manifest.pm b/lib/ExtUtils/Manifest.pm index 027ead5e1b..d19b332c7a 100644 --- a/lib/ExtUtils/Manifest.pm +++ b/lib/ExtUtils/Manifest.pm @@ -16,6 +16,10 @@ C C +C + +C + C C @@ -45,6 +49,12 @@ file will not be reported as missing in the C file. Fullcheck() does both a manicheck() and a filecheck(). +Skipcheck() lists all the files that are skipped due to your +C file. + +Manifind() retruns a hash reference. The keys of the hash are the +files found below the current directory. + Maniread($file) reads a named C file (defaults to C in the current directory) and returns a HASH reference with files being the keys and comments being the values of the HASH. @@ -54,8 +64,10 @@ the HASH I<%$read> to the named target directory. The HASH reference I<$read> is typically returned by the maniread() function. This function is useful for producing a directory tree identical to the intended distribution tree. The third parameter $how can be used to -specify a different system call to do the copying (eg. C instead -of C, which is the default). +specify a different methods of "copying". Valid values are C, +which actually copies the files, C which creates hard links, and +C which mostly links the files but copies any symbolic link to +make a tree without any symbolic link. Best is the default. =head1 MANIFEST.SKIP @@ -124,8 +136,7 @@ $Debug = 0; $Verbose = 1; $Is_VMS = $Config{'osname'} eq 'VMS'; -($Version) = sprintf("%d.%02d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/); -$Version = $Version; #avoid warning +$VERSION = $VERSION = substr(q$Revision: 1.15 $,10,4); $Quiet = 0; @@ -157,7 +168,7 @@ sub mkmanifest { sub manifind { local $found = {}; - find(sub {return if -d $File::Find::name; + find(sub {return if -d $_; (my $name = $File::Find::name) =~ s|./||; warn "Debug: diskfile $name\n" if $Debug; $name =~ s#(.*)\.$#\L$1# if $Is_VMS; @@ -339,4 +350,13 @@ sub ln { chmod( $mode | ( $mode & 0100 ? 0111 : 0 ), $_ ); } +sub best { + my ($srcFile, $dstFile) = @_; + if (-l $srcFile) { + cp($srcFile, $dstFile); + } else { + ln($srcFile, $dstFile); + } +} + 1; diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index 44a3bf191b..9ed4fe102f 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -65,7 +65,7 @@ perl(1), perlapi(1) =cut # Global Constants -$XSUBPP_version = "1.922"; +$XSUBPP_version = "1.923"; require 5.001; $usage = "Usage: xsubpp [-v] [-C++] [-except] [-s pattern] [-typemap typemap]... file.xs\n"; @@ -349,7 +349,7 @@ sub check_cpp { sub Q { my($text) = @_; - $text =~ tr/#//d; + $text =~ s/^#//gm; $text =~ s/\[\[/{/g; $text =~ s/\]\]/}/g; $text; @@ -598,7 +598,8 @@ EOF # do code if (/^\s*NOT_IMPLEMENTED_YET/) { - print "\ncroak(\"$pname: not implemented yet\");\n"; + print "\n\tcroak(\"$pname: not implemented yet\");\n"; + $_ = '' ; } else { if ($ret_type ne "void") { print "\t" . &map_type($ret_type) . "\tRETVAL;\n" @@ -698,8 +699,10 @@ EOF } # print initialization routine -print qq/extern "C"\n/ if $cplusplus; print Q<<"EOF"; +##ifdef __cplusplus +#extern "C" +##endif #XS(boot_$Module_cname) #[[ # dXSARGS; diff --git a/lib/File/Find.pm b/lib/File/Find.pm index ba495a140a..c151bcc891 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -63,6 +63,8 @@ that don't resolve: @ISA = qw(Exporter); @EXPORT = qw(find finddepth $name $dir); +$dont_use_nlink = 1 if $Config{osname} =~ m:^os/?2$:i ; + # Usage: # use File::Find; # @@ -236,7 +238,7 @@ sub finddepth { sub finddepthdir { my($wanted,$dir,$nlink) = @_; my($dev,$ino,$mode,$subcount); - my($name); + local($name); # so &wanted sees current value # Get the list of files in the current directory. diff --git a/lib/File/Path.pm b/lib/File/Path.pm index ec117b8de9..438a08e820 100644 --- a/lib/File/Path.pm +++ b/lib/File/Path.pm @@ -147,7 +147,10 @@ sub rmtree { next; } print "unlink $root\n" if $verbose; - (unlink($root) && ++$count) or carp "Can't unlink file $root: $!"; + while (-e $root) { # delete all versions under VMS + (unlink($root) && ++$count) + or carp "Can't unlink file $root: $!"; + } } } diff --git a/lib/IPC/Open3.pm b/lib/IPC/Open3.pm index 8d324ccb62..db8652ee78 100644 --- a/lib/IPC/Open3.pm +++ b/lib/IPC/Open3.pm @@ -1,5 +1,5 @@ package IPC::Open3; -require 5.000; +require 5.001; require Exporter; use Carp; @@ -19,8 +19,8 @@ connects RDRFH for reading, WTRFH for writing, and ERRFH for errors. If ERRFH is '', or the same as RDRFH, then STDOUT and STDERR of the child are on the same file handle. -If WTRFH begins with ">&", then WTRFH will be closed in the parent, and -the child will read from it directly. if RDRFH or ERRFH begins with +If WTRFH begins with "<&", then WTRFH will be closed in the parent, and +the child will read from it directly. If RDRFH or ERRFH begins with ">&", then the child will send output directly to that file handle. In both cases, there will be a dup(2) instead of a pipe(2) made. @@ -33,6 +33,7 @@ All caveats from open2() continue to apply. See L for details. # &open3: Marc Horowitz # derived mostly from &open2 by tom christiansen, +# fixed for 5.001 by Ulrich Kunitz # # $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $ # @@ -45,7 +46,7 @@ All caveats from open2() continue to apply. See L for details. # of child, or 0 on failure. -# if wtr begins with '>&', then wtr will be closed in the parent, and +# if wtr begins with '<&', then wtr will be closed in the parent, and # the child will read from it directly. if rdr or err begins with # '>&', then the child will send output directly to that fd. In both # cases, there will be a dup() instead of a pipe() made. @@ -63,27 +64,27 @@ All caveats from open2() continue to apply. See L for details. $fh = 'FHOPEN000'; # package static in case called more than once sub open3 { - local($kidpid); - local($dad_wtr, $dad_rdr, $dad_err, @cmd) = @_; - local($dup_wtr, $dup_rdr, $dup_err); + my($kidpid); + my($dad_wtr, $dad_rdr, $dad_err, @cmd) = @_; + my($dup_wtr, $dup_rdr, $dup_err); $dad_wtr || croak "open3: wtr should not be null"; $dad_rdr || croak "open3: rdr should not be null"; $dad_err = $dad_rdr if ($dad_err eq ''); - $dup_wtr = ($dad_wtr =~ s/^\>\&//); - $dup_rdr = ($dad_rdr =~ s/^\>\&//); - $dup_err = ($dad_err =~ s/^\>\&//); + $dup_wtr = ($dad_wtr =~ s/^[<>]&//); + $dup_rdr = ($dad_rdr =~ s/^[<>]&//); + $dup_err = ($dad_err =~ s/^[<>]&//); # force unqualified filehandles into callers' package - local($package) = caller; - $dad_wtr =~ s/^[^']+$/$package'$&/; - $dad_rdr =~ s/^[^']+$/$package'$&/; - $dad_err =~ s/^[^']+$/$package'$&/; + my($package) = caller; + $dad_wtr =~ s/^[^:]+$/$package\:\:$&/; + $dad_rdr =~ s/^[^:]+$/$package\:\:$&/; + $dad_err =~ s/^[^:]+$/$package\:\:$&/; - local($kid_rdr) = ++$fh; - local($kid_wtr) = ++$fh; - local($kid_err) = ++$fh; + my($kid_rdr) = ++$fh; + my($kid_wtr) = ++$fh; + my($kid_err) = ++$fh; if (!$dup_wtr) { pipe($kid_rdr, $dad_wtr) || croak "open3: pipe 1 (stdin) failed: $!"; @@ -99,10 +100,10 @@ sub open3 { croak "open2: fork failed: $!"; } elsif ($kidpid == 0) { if ($dup_wtr) { - open(STDIN, ">&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr)); + open(STDIN, "<&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr)); } else { close($dad_wtr); - open(STDIN, ">&$kid_rdr"); + open(STDIN, "<&$kid_rdr"); } if ($dup_rdr) { open(STDOUT, ">&$dad_rdr") if (fileno(STDOUT) != fileno($dad_rdr)); diff --git a/lib/Shell.pm b/lib/Shell.pm index 8098bf2892..021f175947 100644 --- a/lib/Shell.pm +++ b/lib/Shell.pm @@ -1,5 +1,7 @@ package Shell; +use Config; + sub import { my $self = shift; my ($callpack, $callfile, $callline) = caller; @@ -20,8 +22,36 @@ AUTOLOAD { $cmd =~ s/^.*:://; eval qq { sub $AUTOLOAD { - if (\@_ < 2) { - `$cmd \@_`; + if (\@_ < 1) { + `$cmd`; + } + elsif (\$Config{'archname'} eq 'os2') { + local(\*SAVEOUT, \*READ, \*WRITE); + + open SAVEOUT, '>&STDOUT' or die; + pipe READ, WRITE or die; + open STDOUT, '>&WRITE' or die; + close WRITE; + + my \$pid = system(1, \$cmd, \@_); + die "Can't execute $cmd: \$!\n" if \$pid < 0; + + open STDOUT, '>&SAVEOUT' or die; + close SAVEOUT; + + if (wantarray) { + my \@ret = ; + close READ; + waitpid \$pid, 0; + \@ret; + } + else { + local(\$/) = undef; + my \$ret = ; + close READ; + waitpid \$pid, 0; + \$ret; + } } else { open(SUBPROC, "-|") diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm index 8422f8e4bc..635febdca5 100644 --- a/lib/Test/Harness.pm +++ b/lib/Test/Harness.pm @@ -2,6 +2,13 @@ package Test::Harness; use Exporter; use Benchmark; +use Config; + +$Is_OS2 = $Config{'osname'} =~ m|^os/?2$|i ; + +$ENV{EMXSHELL} = 'sh' if $Is_OS2; # to run commands +$path_s = $Is_OS2 ? ';' : ':' ; + @ISA=(Exporter); @EXPORT= qw(&runtests &test_lib); @EXPORT_OK= qw($verbose $switches); @@ -16,7 +23,7 @@ sub runtests { my $bad = 0; my $good = 0; my $total = @tests; - local($ENV{'PERL5LIB'}) = join(':', @INC); # pass -I flags to children + local($ENV{'PERL5LIB'}) = join($path_s, @INC); # pass -I flags to children my $t_start = new Benchmark; while ($test = shift(@tests)) { @@ -69,7 +76,7 @@ sub runtests { } else { $pct = sprintf("%.2f", $good / $total * 100); if ($bad == 1) { - warn "Failed 1 test, $pct% okay.\n"; + die "Failed 1 test, $pct% okay.\n"; } else { die "Failed $bad/$total tests, $pct% okay.\n"; } diff --git a/lib/Text/Tabs.pm b/lib/Text/Tabs.pm index fa866988cf..7cfb478b75 100644 --- a/lib/Text/Tabs.pm +++ b/lib/Text/Tabs.pm @@ -2,11 +2,13 @@ # expand and unexpand tabs as per the unix expand and # unexpand programs. # -# expand and unexpand operate on arrays of lines. +# expand and unexpand operate on arrays of lines. Do not +# feed strings that contain newlines to them. # # David Muir Sharnoff -# Version: 4/19/95 # +# Version: 9/21/95 +# package Text::Tabs; @@ -19,45 +21,31 @@ $tabstop = 8; sub expand { - my (@l) = @_; - my $l, @k; - my $nl; - for $l (@l) { - $nl = $/ if chomp($l); - @k = split($/,$l); - for $_ (@k) { - 1 while s/^([^\t]*)(\t+)/ - $1 . (" " x - ($tabstop * length($2) - - (length($1) % $tabstop))) - /e; - } - $l = join("\n",@k).$nl; + my @l = @_; + for $_ (@l) { + 1 while s/^([^\t]*)(\t+)/ + $1 . (" " x + ($tabstop * length($2) + - (length($1) % $tabstop))) + /e; } - return @l if $#l > 0; - return $l[0]; + return @l if wantarray; + return @l[0]; } sub unexpand { - my (@l) = &expand(@_); + my @l = &expand(@_); my @e; - my $k, @k; - my $nl; - for $k (@l) { - $nl = $/ if chomp($k); - @k = split($/,$k); - for $x (@k) { - @e = split(/(.{$tabstop})/,$x); - for $_ (@e) { - s/ +$/\t/; - } - $x = join('',@e); + for $x (@l) { + @e = split(/(.{$tabstop})/,$x); + for $_ (@e) { + s/ +$/\t/; } - $k = join("\n",@k).$nl; + $x = join('',@e); } - return @l if $#l > 0; - return $l[0]; + return @l if wantarray; + return @l[0]; } 1; diff --git a/lib/Text/Wrap.pm b/lib/Text/Wrap.pm new file mode 100644 index 0000000000..9b1d054704 --- /dev/null +++ b/lib/Text/Wrap.pm @@ -0,0 +1,68 @@ + +package Text::Wrap; + +# +# This is a very simple paragraph formatter. It formats one +# paragraph at a time by wrapping and indenting text. +# +# Usage: +# +# use Text::Wrap; +# +# print wrap($initial_tab,$subsequent_tab,@text); +# +# You can also set the number of columns to wrap before: +# +# $Text::Wrap::columns = 135; # <= width of screen +# +# use Text::Wrap qw(wrap $columns); +# $columns = 70; +# +# +# The first line will be printed with $initial_tab prepended. All +# following lines will have $subsequent_tab prepended. +# +# Example: +# +# print wrap("\t","","This is a bit of text that ..."); +# +# David Muir Sharnoff +# Version: 9/21/95 +# + +require Exporter; + +@ISA = (Exporter); +@EXPORT = qw(wrap); +@EXPORT_OK = qw($columns); + +BEGIN { + $Text::Wrap::columns = 76; # <= screen width +} + +use Text::Tabs; +use strict; + +sub wrap +{ + my ($ip, $xp, @t) = @_; + + my $r; + my $t = expand(join(" ",@t)); + my $lead = $ip; + my $ll = $Text::Wrap::columns - length(expand($lead)) - 1; + if ($t =~ s/^([^\n]{0,$ll})\s//) { + $r .= unexpand($lead . $1 . "\n"); + $lead = $xp; + my $ll = $Text::Wrap::columns - length(expand($lead)) - 1; + while ($t =~ s/^([^\n]{0,$ll})\s//) { + $r .= unexpand($lead . $1 . "\n"); + } + } + die "couldn't wrap '$t'" + if length($t) > $ll; + $r .= $t; + return $r; +} + +1; diff --git a/lib/TieHash.pm b/lib/TieHash.pm index 1abbe8379a..446cbcb25b 100644 --- a/lib/TieHash.pm +++ b/lib/TieHash.pm @@ -2,27 +2,27 @@ package TieHash; use Carp; sub new { - my $pack = shift; - $pack->TIEHASH(@_); + my $pkg = shift; + $pkg->TIEHASH(@_); } # Grandfather "new" sub TIEHASH { - my $pack = shift; - if (defined &{"$pack\::new"}) { - carp "WARNING: calling $pack\->new since $pack\->TIEHASH is missing" + my $pkg = shift; + if (defined &{"{$pkg}::new"}) { + carp "WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing" if $^W; - $pack->new(@_); + $pkg->new(@_); } else { - croak "$pack doesn't define a TIEHASH method"; + croak "$pkg doesn't define a TIEHASH method"; } } sub EXISTS { - my $pack = ref $_[0]; - croak "$pack doesn't define an EXISTS method"; + my $pkg = ref $_[0]; + croak "$pkg doesn't define an EXISTS method"; } sub CLEAR { diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm new file mode 100755 index 0000000000..073a456c81 --- /dev/null +++ b/lib/diagnostics.pm @@ -0,0 +1,502 @@ +#!/usr/local/bin/perl +eval 'exec perl -S $0 ${1+"$@"}' + if $0; + +use Config; +$diagnostics::PODFILE= $Config{privlib} . "/pod/perldiag.pod"; + +package diagnostics; +require 5.001; +use English; +use Carp; + +=head1 NAME + +diagnostics - Perl compiler pragma to force verbose warning diagnostics + +splain - standalone program to do the same thing + +=head1 SYNOPSIS + +As a pragma: + + use diagnostics; + use diagnostics -verbose; + + enable diagnostics; + disable diagnostics; + +Aa a program: + + perl program 2>diag.out + splain [-v] [-p] diag.out + + +=head1 DESCRIPTION + +=head2 The C Pragma + +This module extends the terse diagnostics normally emitted by both the +perl compiler and the perl interpeter, augmenting them wtih the more +explicative and endearing descriptions found in L. Like the +other pragmata, it affects to compilation phase of your program rather +than merely the execution phase. + +To use in your program as a pragma, merely invoke + + use diagnostics; + +at the start (or near the start) of your program. (Note +that this I enable perl's B<-w> flag.) Your whole +compilation will then be subject(ed :-) to the enhanced diagnostics. +These still go out B. + +Due to the interaction between runtime and compiletime issues, +and because it's probably not a very good idea anyway, +you may not use C to turn them off at compiletime. +However, you may control there behaviour at runtime using the +disable() and enable() methods to turn them off and on respectively. + +The B<-verbose> flag first prints out the L introduction before +any other diagnostics. The $diagnostics::PRETTY can generate nicer escape +sequences for pgers. + +=head2 The I Program + +While apparently a whole nuther program, I is actually nothing +more than a link to the (executable) F module, as well as +a link to the F documentation. The B<-v> flag is like +the C directive. +The B<-p> flag is like the +$diagnostics::PRETTY variable. Since you're post-processing with +I, there's no sense in being able to enable() or disable() processing. + +Output from I is directed to B, unlike the pragma. + +=head1 EXAMPLES + +The following file is certain to trigger a few errors at both +runtime and compiletime: + + use diagnostics; + print NOWHERE "nothing\n"; + print STDERR "\n\tThis message should be unadorned.\n"; + warn "\tThis is a user warning"; + print "\nDIAGNOSTIC TESTER: Please enter a here: "; + my $a, $b = scalar ; + print "\n"; + print $x/$y; + +If you prefer to run your program first and look at its problem +afterwards, do this: + + perl -w test.pl 2>test.out + ./splain < test.out + +Note that this is not in general possible in shells of more dubious heritage, +as the theorectical + + (perl -w test.pl >/dev/tty) >& test.out + ./splain < test.out + +Because you just moved the existing B to somewhere else. + +If you don't want to modify your source code, but still have on-the-fly +warnings, do this: + + exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&- + +Nifty, eh? + +If you want to control warnings on the fly, do something like this. +Make sure you do the C first, or you won't be able to get +at the enable() or disable() methods. + + use diagnostics; # checks entire compilation phase + print "\ntime for 1st bogus diags: SQUAWKINGS\n"; + print BOGUS1 'nada'; + print "done with 1st bogus\n"; + + disable diagnostics; # only turns off runtime warnings + print "\ntime for 2nd bogus: (squelched)\n"; + print BOGUS2 'nada'; + print "done with 2nd bogus\n"; + + enable diagnostics; # turns back on runtime warnings + print "\ntime for 3rd bogus: SQUAWKINGS\n"; + print BOGUS3 'nada'; + print "done with 3rd bogus\n"; + + disable diagnostics; + print "\ntime for 4th bogus: (squelched)\n"; + print BOGUS4 'nada'; + print "done with 4th bogus\n"; + +=head1 INTERNALS + +Diagnostic messages derive from the F file when available at +runtime. Otherwise, they may be embedded in the file itself when the +splain package is built. See the F for details. + +If an extant $SIG{__WARN__} handler is discovered, it will continue +to be honored, but only after the diagnostic::splainthis() function +(the module's $SIG{__WARN__} interceptor) has had its way with your +warnings. + +There is a $diagnostics::DEBUG variable you may set if you're desperately +curious what sorts of things are being intercepted. + + BEGIN { $diagnostics::DEBUG = 1 } + + +=head1 BUGS + +Not being able to say "no diagnostics" is annoying, but may not be +insurmountable. + +The C<-pretty> directive is called too late to affect matters. +You have to to this instead, and I you load the module. + + BEGIN { $diagnostics::PRETTY = 1 } + +I could start up faster by delaying compilation until it should be +needed, but this gets a "panic: top_level" +when using the pragma form in 5.001e. + +While it's true that this documentation is somewhat subserious, if you use +a program named I, you should expect a bit of whimsy. + +=head1 AUTHOR + +Tom Christiansen Ftchrist@mox.perl.comE>, 25 June 1995. + +=cut + +$DEBUG ||= 0; +my $WHOAMI = ref bless []; # nobody's business, prolly not even mine + +$OUTPUT_AUTOFLUSH = 1; + +local $_; + +CONFIG: { + $opt_p = $opt_d = $opt_v = $opt_f = ''; + %HTML_2_Troff = %HTML_2_Latin_1 = %HTML_2_ASCII_7 = (); + %exact_duplicate = (); + + unless (caller) { + $standalone++; + require Getopt::Std; + Getopt::Std::getopts('pdvf:') || die "Usage: $0 [-v] [-p] [-f splainpod]"; + $PODFILE = $opt_f if $opt_f; + $DEBUG = 2 if $opt_d; + $VERBOSE = $opt_v; + $PRETTY = $opt_p; + } + + if (open(POD_DIAG, $PODFILE)) { + warn "Happy happy podfile from real $PODFILE\n" if $DEBUG; + last CONFIG; + } + + if (caller) { + INCPATH: { + for $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) { + warn "Checking $file\n" if $DEBUG; + if (open(POD_DIAG, $file)) { + while () { + next unless /^__END__\s*# wish diag dbase were more accessible/; + print STDERR "podfile is $file\n" if $DEBUG; + last INCPATH; + } + } + } + } + } else { + print STDERR "podfile is \n" if $DEBUG; + *POD_DIAG = *main::DATA; + } +} +if (eof(POD_DIAG)) { + die "couldn't find diagnostic data in $PODFILE @INC $0"; +} + + +%HTML_2_Troff = ( + 'amp' => '&', # ampersand + 'lt' => '<', # left chevron, less-than + 'gt' => '>', # right chevron, greater-than + 'quot' => '"', # double quote + + "Aacute" => "A\\*'", # capital A, acute accent + # etc + +); + +%HTML_2_Latin_1 = ( + 'amp' => '&', # ampersand + 'lt' => '<', # left chevron, less-than + 'gt' => '>', # right chevron, greater-than + 'quot' => '"', # double quote + + "Aacute" => "\xC1" # capital A, acute accent + + # etc +); + +%HTML_2_ASCII_7 = ( + 'amp' => '&', # ampersand + 'lt' => '<', # left chevron, less-than + 'gt' => '>', # right chevron, greater-than + 'quot' => '"', # double quote + + "Aacute" => "A" # capital A, acute accent + # etc +); + +*HTML_Escapes = do { + if ($standalone) { + $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7; + } else { + \%HTML_2_Latin_1; + } +}; + +*THITHER = $standalone ? *STDOUT : *STDERR; + +$transmo = <) { + #s/(.*)\n//; + #$header = $1; + + unescape(); + if ($PRETTY) { + sub noop { return $_[0] } # spensive for a noop + sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; } + sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; } + s/[BC]<(.*?)>/bold($1)/ges; + s/[LIF]<(.*?)>/italic($1)/ges; + } else { + s/[BC]<(.*?)>/$1/gs; + s/[LIF]<(.*?)>/$1/gs; + } + unless (/^=/) { + if (defined $header) { + if ( $header eq 'DESCRIPTION' && + ( /Optional warnings are enabled/ + || /Some of these messages are generic./ + ) ) + { + next; + } + s/^/ /gm; + $msg{$header} .= $_; + } + next; + } + unless ( s/=item (.*)\s*\Z//) { + + if ( s/=head1\sDESCRIPTION//) { + $msg{$header = 'DESCRIPTION'} = ''; + } + next; + } + $header = $1; + + if ($header =~ /%[sd]/) { + $rhs = $lhs = $header; + #if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E\$/g) { + if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E/g) { + $lhs =~ s/\\%s/.*?/g; + } else { + # if i had lookbehind negations, i wouldn't have to do this \377 noise + $lhs =~ s/(.*?)%s/\Q$1\E.*?\377/g; + #$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/; + $lhs =~ s/\377([^\377]*)$/\Q$1\E/; + $lhs =~ s/\377//g; + } + $transmo .= " s{^$lhs}\n {\Q$rhs\E}\n\t&& return 1;\n"; + } else { + $transmo .= " m{^\Q$header\E} && return 1;\n"; + } + + print STDERR "Already saw $header" if $msg{$header}; + + $msg{$header} = ''; + } + + + close POD_DIAG unless *main::DATA eq *POD_DIAG; + + die "No diagnostics?" unless %msg; + + $transmo .= " return 0;\n}\n"; + print STDERR $transmo if $DEBUG; + eval $transmo; + die $@ if $@; + $RS = "\n"; +### } + +if ($standalone) { + if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } + while ($error = <>) { + splainthis($error) || print THITHER $error; + } + exit; +} else { + $old_w = 0; $oldwarn = ''; $olddie = ''; +} + +sub import { + shift; + $old_w = $^W; + $^W = 1; # yup, clobbered the global variable; tough, if you + # want diags, you want diags. + return if $SIG{__WARN__} eq \&warn_trap; + + for (@_) { + + /^-d(ebug)?$/ && do { + $DEBUG++; + next; + }; + + /^-v(erbose)?$/ && do { + $VERBOSE++; + next; + }; + + /^-p(retty)?$/ && do { + print STDERR "$0: I'm afraid it's too late for prettiness.\n"; + $PRETTY++; + next; + }; + + warn "Unknown flag: $_"; + } + + $oldwarn = $SIG{__WARN__}; + $olddie = $SIG{__DIE__}; + $SIG{__WARN__} = \&warn_trap; + $SIG{__DIE__} = \&death_trap; +} + +sub enable { &import } + +sub disable { + shift; + $^W = $old_w; + return unless $SIG{__WARN__} eq \&warn_trap; + $SIG{__WARN__} = $oldwarn; + $SIG{__DIE__} = $olddie; +} + +sub warn_trap { + my $warning = $_[0]; + if (caller eq $WHOAMI or !splainthis($warning)) { + print STDERR $warning; + } + &$oldwarn if $oldwarn and $oldwarn ne \&warn_trap; +}; + +sub death_trap { + my $exception = $_[0]; + splainthis($exception); + if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; } + &$olddie if defined $olddie and $olddie ne \&death_trap; + $SIG{__DIE__} = $SIG{__WARN__} = ''; + confess "Uncaught exception from user code:\n\t$exception Bailing out"; + # up we go; where we stop, nobody knows, but i think we die now + # but i'm deeply afraid of the &$olddie guy reraising and us getting + # into an indirect recursion loop +}; + +sub splainthis { + local $_ = shift; + ### &finish_compilation unless %msg; + s/\.?\n+$//; + my $orig = $_; + # return unless defined; + if ($exact_duplicate{$_}++) { + return 1; + } + s/, <.*?> (?:line|chunk).*$//; + $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/; + s/^\((.*)\)$/$1/; + return 0 unless &transmo; + $orig = shorten($orig); + if ($old_diag{$_}) { + autodescribe(); + print THITHER "$orig (#$old_diag{$_})\n"; + $wantspace = 1; + } else { + autodescribe(); + $old_diag{$_} = ++$count; + print THITHER "\n" if $wantspace; + $wantspace = 0; + print THITHER "$orig (#$old_diag{$_})\n"; + if ($msg{$_}) { + print THITHER $msg{$_}; + } else { + if (0 and $standalone) { + print THITHER " **** Error #$old_diag{$_} ", + ($real ? "is" : "appears to be"), + " an unknown diagnostic message.\n\n"; + } + return 0; + } + } + return 1; +} + +sub autodescribe { + if ($VERBOSE and not $count) { + print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"), + "\n$msg{DESCRIPTION}\n"; + } +} + +sub unescape { + s { + E< + ( [A-Za-z]+ ) + > + } { + do { + exists $HTML_Escapes{$1} + ? do { $HTML_Escapes{$1} } + : do { + warn "Unknown escape: $& in $_"; + "E<$1>"; + } + } + }egx; +} + +sub shorten { + my $line = $_[0]; + if (length $line > 79) { + my $space_place = rindex($line, ' ', 79); + if ($space_place != -1) { + substr($line, $space_place, 1) = "\n\t"; + } + } + return $line; +} + + +# have to do this: RS isn't set until run time, but we're executing at compile time +$RS = "\n"; + +1 unless $standalone; # or it'll complain about itself +__END__ # wish diag dbase were more accessible diff --git a/lib/dotsh.pl b/lib/dotsh.pl index 4db85e742b..8e9d9620e5 100644 --- a/lib/dotsh.pl +++ b/lib/dotsh.pl @@ -59,7 +59,7 @@ sub dotsh { close (_SH_ENV); system "rm -f /tmp/_sh_env$$"; - foreach $key (keys(ENV)) { + foreach $key (keys(%ENV)) { $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/; } eval $tmp; diff --git a/lib/lib.pm b/lib/lib.pm index a0fe89b13d..ab19426b04 100644 --- a/lib/lib.pm +++ b/lib/lib.pm @@ -1,12 +1,21 @@ package lib; +use Config; + +my $archname = $Config{'archname'}; + @ORIG_INC = (); # (avoid typo warning) @ORIG_INC = @INC; # take a handy copy of 'original' value sub import { shift; - unshift(@INC, @_); + foreach (@_) { + unshift(@INC, $_); + # Put a corresponding archlib directory infront of $_ if it + # looks like $_ has an archlib directory below it. + unshift(@INC, "$_/$archname") if -d "$_/$archname/auto"; + } } @@ -15,7 +24,10 @@ sub unimport { my $mode = shift if $_[0] =~ m/^:[A-Z]+/; my %names; - foreach(@_) { ++$names{$_} }; + foreach(@_) { + ++$names{$_}; + ++$names{"$_/$archname"} if -d "$_/$archname/auto"; + } if ($mode and $mode eq ':ALL') { # Remove ALL instances of each named directory. @@ -26,6 +38,7 @@ sub unimport { } } +1; __END__ =head1 NAME @@ -55,10 +68,18 @@ path. Saying use lib LIST; -is the same as saying +is I the same as saying BEGIN { unshift(@INC, LIST) } +For each directory in LIST (called $dir here) the lib module also +checks to see if a directory called $dir/$archname/auto exists. +If so the $dir/$archname directory is assumed to be a corresponding +architecture specific directory and is added to @INC in front of $dir. + +If LIST includes both $dir and $dir/$archname then $dir/$archname will +be added to @INC twice (if $dir/$archname/auto exists). + =head2 DELETING DIRECTORIES FROM @INC @@ -77,19 +98,23 @@ specify ':ALL' as the first parameter of C. For example: no lib qw(:ALL .); +For each directory in LIST (called $dir here) the lib module also +checks to see if a directory called $dir/$archname/auto exists. +If so the $dir/$archname directory is assumed to be a corresponding +architecture specific directory and is also deleted from @INC. + +If LIST includes both $dir and $dir/$archname then $dir/$archname will +be deleted from @INC twice (if $dir/$archname/auto exists). + =head2 RESTORING ORIGINAL @INC When the lib module is first loaded it records the current value of @INC in an array C<@lib::ORIG_INC>. To restore @INC to that value you -can say either +can say @INC = @lib::ORIG_INC; -or - - no lib @INC; - use lib @lib::ORIG_INC; =head1 SEE ALSO diff --git a/lib/overload.pm b/lib/overload.pm new file mode 100644 index 0000000000..3c9562aca5 --- /dev/null +++ b/lib/overload.pm @@ -0,0 +1,489 @@ +package overload; + +sub OVERLOAD { + $package = shift; + my %arg = @_; + my $hash = \%{$package . "::OVERLOAD"}; + for (keys %arg) { + $hash->{$_} = $arg{$_}; + } +} + +sub import { + $package = (caller())[0]; + # *{$package . "::OVERLOAD"} = \&OVERLOAD; + shift; + $package->overload::OVERLOAD(@_); +} + +sub unimport { + $package = (caller())[0]; + my $hash = \%{$package . "::OVERLOAD"}; + shift; + for (@_) { + delete $hash->{$_}; + } +} + +sub Overloaded { + defined ($package = ref $_[0]) and defined %{$package . "::OVERLOAD"}; +} + +sub OverloadedStringify { + defined ($package = ref $_[0]) and + defined %{$package . "::OVERLOAD"} and + exists $ {$package . "::OVERLOAD"}{'""'} and + defined &{$ {$package . "::OVERLOAD"}{'""'}}; +} + +sub Method { + defined ($package = ref $_[0]) and + defined %{$package . "::OVERLOAD"} and + $ {$package . "::OVERLOAD"}{$_[1]}; +} + +sub AddrRef { + $package = ref $_[0]; + bless $_[0], Overload::Fake; # Non-overloaded package + my $str = "$_[0]"; + bless $_[0], $package; # Back + $str; +} + +sub StrVal { + (OverloadedStringify) ? + (AddrRef) : + "$_[0]"; +} + +1; + +__END__ + +=head1 NAME + +C - Package for overloading perl operations + +=head1 SYNOPSIS + + package SomeThing; + + use overload + '+' => \&myadd, + '-' => \&mysub; + # etc + ... + + package main; + $a = new SomeThing 57; + $b=5+$a; + ... + if (overload::Overloaded $b) {...} + ... + $strval = overload::StrVal $b; + +=head1 CAVEAT SCRIPTOR + +Overloading of operators is a subject not to be taken lightly. +Neither its precise implementation, syntax, nor semantics are +100% endorsed by Larry Wall. So any of these may be changed +at some point in the future. + +=head1 DESCRIPTION + +=head2 Declaration of overloaded functions + +The compilation directive + + package Number; + use overload + "+" => \&add, + "*=" => "muas"; + +declares function Number::add() for addition, and method muas() in +the "class" C (or one of its base classes) +for the assignment form C<*=> of multiplication. + +Arguments of this directive come in (key, value) pairs. Legal values +are values legal inside a C<&{ ... }> call, so the name of a subroutine, +a reference to a subroutine, or an anonymous subroutine will all work. +Legal keys are listed below. + +The subroutine C will be called to execute C<$a+$b> if $a +is a reference to an object blessed into the package C, or if $a is +not an object from a package with defined mathemagic addition, but $b is a +reference to a C. It can also be called in other situations, like +C<$a+=7>, or C<$a++>. See L. (Mathemagical +methods refer to methods triggered by an overloaded mathematical +operator.) + +=head2 Calling Conventions for Binary Operations + +The functions specified in the C directive are called +with three (in one particular case with four, see L) +arguments. If the corresponding operation is binary, then the first +two arguments are the two arguments of the operation. However, due to +general object calling conventions, the first argument should always be +an object in the package, so in the situation of C<7+$a>, the +order of the arguments is interchanged. It probably does not matter +when implementing the addition method, but whether the arguments +are reversed is vital to the subtraction method. The method can +query this information by examining the third argument, which can take +three different values: + +=over 7 + +=item FALSE + +the order of arguments is as in the current operation. + +=item TRUE + +the arguments are reversed. + +=item C + +the current operation is an assignment variant (as in +C<$a+=7>), but the usual function is called instead. This additional +information can be used to generate some optimizations. + +=back + +=head2 Calling Conventions for Unary Operations + +Unary operation are considered binary operations with the second +argument being C. Thus the functions that overloads C<{"++"}> +is called with arguments C<($a,undef,'')> when $a++ is executed. + +=head2 Overloadable Operations + +The following symbols can be specified in C: + +=over 5 + +=item * I + + "+", "+=", "-", "-=", "*", "*=", "/", "/=", "%", "%=", + "**", "**=", "<<", "<<=", ">>", ">>=", "x", "x=", ".", ".=", + +For these operations a substituted non-assignment variant can be called if +the assignment variant is not available. Methods for operations "C<+>", +"C<->", "C<+=>", and "C<-=>" can be called to automatically generate +increment and decrement methods. The operation "C<->" can be used to +autogenerate missing methods for unary minus or C. + +=item * I + + "<", "<=", ">", ">=", "==", "!=", "<=>", + "lt", "le", "gt", "ge", "eq", "ne", "cmp", + +If the corresponding "spaceship" variant is available, it can be +used to substitute for the missing operation. During Cing +arrays, C is used to compare values subject to C. + +=item * I + + "&", "^", "|", "neg", "!", "~", + +"C" stands for unary minus. If the method for C is not +specified, it can be autogenerated using the method for subtraction. + +=item * I + + "++", "--", + +If undefined, addition and subtraction methods can be +used instead. These operations are called both in prefix and +postfix form. + +=item * I + + "atan2", "cos", "sin", "exp", "abs", "log", "sqrt", + +If C is unavailable, it can be autogenerated using methods +for "<" or "<=>" combined with either unary minus or subtraction. + +=item * I + + "bool", "\"\"", "0+", + +If one or two of these operations are unavailable, the remaining ones can +be used instead. C is used in the flow control operators +(like C) and for the ternary "C" operation. These functions can +return any arbitrary Perl value. If the corresponding operation for this value +is overloaded too, that operation will be called again with this value. + +=item * I + + "nomethod", "fallback", "=", + +see L>. + +=back + +See L<"Fallback"> for an explanation of when a missing method can be autogenerated. + +=head1 SPECIAL SYMBOLS FOR C + +Three keys are recognized by Perl that are not covered by the above +description. + +=head2 Last Resort + +C<"nomethod"> should be followed by a reference to a function of four +parameters. If defined, it is called when the overloading mechanism +cannot find a method for some operation. The first three arguments of +this function coincide with the arguments for the corresponding method if +it were found, the fourth argument is the symbol +corresponding to the missing method. If several methods are tried, +the last one is used. Say, C<1-$a> can be equivalent to + + &nomethodMethod($a,1,1,"-") + +if the pair C<"nomethod" =E "nomethodMethod"> was specified in the +C directive. + +If some operation cannot be resolved, and there is no function +assigned to C<"nomethod">, then an exception will be raised via die()-- +unless C<"fallback"> was specified as a key in C directive. + +=head2 Fallback + +The key C<"fallback"> governs what to do if a method for a particular +operation is not found. Three different cases are possible depending on +the value of C<"fallback">: + +=over 16 + +=item * C + +Perl tries to use a +substituted method (see L). If this fails, it +then tries to calls C<"nomethod"> value; if missing, an exception +will be raised. + +=item * TRUE + +The same as for the C value, but no exception is raised. Instead, +it silently reverts to what it would have done were there no C +present. + +=item * defined, but FALSE + +No autogeneration is tried. Perl tries to call +C<"nomethod"> value, and if this is missing, raises an exception. + +=back + +=head2 Copy Constructor + +The value for C<"="> is a reference to a function with three +arguments, i.e., it looks like the other values in C. However, it does not overload the Perl assignment +operator. This would go against Camel hair. + +This operation is called in the situations when a mutator is applied +to a reference that shares its object with some other reference, such +as + + $a=$b; + $a++; + +To make this change $a and not change $b, a copy of C<$$a> is made, +and $a is assigned a reference to this new object. This operation is +done during execution of the C<$a++>, and not during the assignment, +(so before the increment C<$$a> coincides with C<$$b>). This is only +done if C<++> is expressed via a method for C<'++'> or C<'+='>. Note +that if this operation is expressed via C<'+'> a nonmutator, i.e., as +in + + $a=$b; + $a=$a+1; + +then C<$a> does not reference a new copy of C<$$a>, since $$a does not +appear as lvalue when the above code is executed. + +If the copy constructor is required during the execution of some mutator, +but a method for C<'='> was not specified, it can be autogenerated as a +string copy if the object is a plain scalar. + +=over 5 + +=item B + +The actually executed code for + + $a=$b; + Something else which does not modify $a or $b.... + ++$a; + +may be + + $a=$b; + Something else which does not modify $a or $b.... + $a = $a->clone(undef,""); + $a->incr(undef,""); + +if $b was mathemagical, and C<'++'> was overloaded with C<\&incr>, +C<'='> was overloaded with C<\&clone>. + +=back + +=head1 MAGIC AUTOGENERATION + +If a method for an operation is not found, and the value for C<"fallback"> is +TRUE or undefined, Perl tries to autogenerate a substitute method for +the missing operation based on the defined operations. Autogenerated method +substitutions are possible for the following operations: + +=over 16 + +=item I + +C<$a+=$b> can use the method for C<"+"> if the method for C<"+="> +is not defined. + +=item I + +String, numeric, and boolean conversion are calculated in terms of one +another if not all of them are defined. + +=item I + +The C<++$a> operation can be expressed in terms of C<$a+=1> or C<$a+1>, +and C<$a--> in terms of C<$a-=1> and C<$a-1>. + +=item C + +can be expressed in terms of C<$aE0> and C<-$a> (or C<0-$a>). + +=item I + +can be expressed in terms of subtraction. + +=item I + +can be expressed in terms of string conversion. + +=item I + +can be expressed in terms of its "spaceship" counterpart: either +C=E> or C: + + <, >, <=, >=, ==, != in terms of <=> + lt, gt, le, ge, eq, ne in terms of cmp + +=item I + +can be expressed in terms of an assignment to the dereferenced value, if this +value is a scalar and not a reference. + +=back + +=head1 WARNING + +The restriction for the comparison operation is that even if, for example, +`C' should return a blessed reference, the autogenerated `C' +function will produce only a standard logical value based on the +numerical value of the result of `C'. In particular, a working +numeric conversion is needed in this case (possibly expressed in terms of +other conversions). + +Similarly, C<.=> and C operators lose their mathemagical properties +if the string conversion substitution is applied. + +When you chop() a mathemagical object it is promoted to a string and its +mathemagical properties are lost. The same can happen with other +operations as well. + +=head1 Run-time Overloading + +Since all C directives are executed at compile-time, the only way to +change overloading during run-time is to + + eval 'use overload "+" => \&addmethod'; + +You can also use + + eval 'no overload "+", "--", "<="'; + +though the use of these constructs during run-time is questionable. + +=head1 Public functions + +Package C provides the following public functions: + +=over 5 + +=item overload::StrVal(arg) + +Gives string value of C as in absence of stringify overloading. + +=item overload::Overloaded(arg) + +Returns true if C is subject to overloading of some operations. + +=item overload::Method(obj,op) + +Returns C or a reference to the method that implements C. + +=back + +=head1 IMPLEMENTATION + +What follows is subject to change RSN. + +The table of methods for all operations is cached as magic in the +symbol table hash for the package. The table is rechecked for changes due to +C, C, and @ISA only during +Cing; so if they are changed dynamically, you'll need an +additional fake Cing to update the table. + +(Every SVish thing has a magic queue, and magic is an entry in that queue. +This is how a single variable may participate in multiple forms of magic +simultaneously. For instance, environment variables regularly have two +forms at once: their %ENV magic and their taint magic.) + +If an object belongs to a package using overload, it carries a special +flag. Thus the only speed penalty during arithmetic operations without +overloading is the checking of this flag. + +In fact, if C is not present, there is almost no overhead for +overloadable operations, so most programs should not suffer measurable +performance penalties. A considerable effort was made to minimize the overhead +when overload is used and the current operation is overloadable but +the arguments in question do not belong to packages using overload. When +in doubt, test your speed with C and without it. So far there +have been no reports of substantial speed degradation if Perl is compiled +with optimization turned on. + +There is no size penalty for data if overload is not used. + +Copying (C<$a=$b>) is shallow; however, a one-level-deep copying is +carried out before any operation that can imply an assignment to the +object $a (or $b) refers to, like C<$a++>. You can override this +behavior by defining your own copy constructor (see L<"Copy Constructor">). + +It is expected that arguments to methods that are not explicitly supposed +to be changed are constant (but this is not enforced). + +=head1 AUTHOR + +Ilya Zakharevich >. + +=head1 DIAGNOSTICS + +When Perl is run with the B<-Do> switch or its equivalent, overloading +induces diagnostic messages. + +=head1 BUGS + +Because it is used for overloading, the per-package associative array +%OVERLOAD now has a special meaning in Perl. + +As shipped, mathemagical properties are not inherited via the @ISA tree. + +This document is confusing. + +=cut + diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 358b548a3c..b5be230eed 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -15,6 +15,12 @@ $header = '$RCSfile: perl5db.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:07 $'; # # $Log: perldb.pl,v $ +# Is Perl being run from Emacs? +$emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs')); +shift(@main::ARGV) if $emacs; + +#require Term::ReadLine; + local($^W) = 0; if (-e "/dev/tty") { @@ -30,6 +36,15 @@ else { $rcfile="perldb.ini"; } +# Around a bug: +if (defined $ENV{'OS2_SHELL'}) { # In OS/2 + if ($DB::emacs) { + $console = undef; + } else { + $console = "/dev/con"; + } +} + open(IN, "<$console") || open(IN, "<&STDIN"); # so we don't dingle stdin open(OUT,">$console") || open(OUT, ">&STDERR") || open(OUT, ">&STDOUT"); # so we don't dongle stdout @@ -39,10 +54,6 @@ select(STDOUT); $| = 1; # for real STDOUT $sub = ''; -# Is Perl being run from Emacs? -$emacs = $main::ARGV[0] eq '-emacs'; -shift(@main::ARGV) if $emacs; - $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/; print OUT "\nLoading DB routines from $header\n"; print OUT ("Emacs support ", diff --git a/lib/splain b/lib/splain new file mode 100755 index 0000000000..073a456c81 --- /dev/null +++ b/lib/splain @@ -0,0 +1,502 @@ +#!/usr/local/bin/perl +eval 'exec perl -S $0 ${1+"$@"}' + if $0; + +use Config; +$diagnostics::PODFILE= $Config{privlib} . "/pod/perldiag.pod"; + +package diagnostics; +require 5.001; +use English; +use Carp; + +=head1 NAME + +diagnostics - Perl compiler pragma to force verbose warning diagnostics + +splain - standalone program to do the same thing + +=head1 SYNOPSIS + +As a pragma: + + use diagnostics; + use diagnostics -verbose; + + enable diagnostics; + disable diagnostics; + +Aa a program: + + perl program 2>diag.out + splain [-v] [-p] diag.out + + +=head1 DESCRIPTION + +=head2 The C Pragma + +This module extends the terse diagnostics normally emitted by both the +perl compiler and the perl interpeter, augmenting them wtih the more +explicative and endearing descriptions found in L. Like the +other pragmata, it affects to compilation phase of your program rather +than merely the execution phase. + +To use in your program as a pragma, merely invoke + + use diagnostics; + +at the start (or near the start) of your program. (Note +that this I enable perl's B<-w> flag.) Your whole +compilation will then be subject(ed :-) to the enhanced diagnostics. +These still go out B. + +Due to the interaction between runtime and compiletime issues, +and because it's probably not a very good idea anyway, +you may not use C to turn them off at compiletime. +However, you may control there behaviour at runtime using the +disable() and enable() methods to turn them off and on respectively. + +The B<-verbose> flag first prints out the L introduction before +any other diagnostics. The $diagnostics::PRETTY can generate nicer escape +sequences for pgers. + +=head2 The I Program + +While apparently a whole nuther program, I is actually nothing +more than a link to the (executable) F module, as well as +a link to the F documentation. The B<-v> flag is like +the C directive. +The B<-p> flag is like the +$diagnostics::PRETTY variable. Since you're post-processing with +I, there's no sense in being able to enable() or disable() processing. + +Output from I is directed to B, unlike the pragma. + +=head1 EXAMPLES + +The following file is certain to trigger a few errors at both +runtime and compiletime: + + use diagnostics; + print NOWHERE "nothing\n"; + print STDERR "\n\tThis message should be unadorned.\n"; + warn "\tThis is a user warning"; + print "\nDIAGNOSTIC TESTER: Please enter a here: "; + my $a, $b = scalar ; + print "\n"; + print $x/$y; + +If you prefer to run your program first and look at its problem +afterwards, do this: + + perl -w test.pl 2>test.out + ./splain < test.out + +Note that this is not in general possible in shells of more dubious heritage, +as the theorectical + + (perl -w test.pl >/dev/tty) >& test.out + ./splain < test.out + +Because you just moved the existing B to somewhere else. + +If you don't want to modify your source code, but still have on-the-fly +warnings, do this: + + exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&- + +Nifty, eh? + +If you want to control warnings on the fly, do something like this. +Make sure you do the C first, or you won't be able to get +at the enable() or disable() methods. + + use diagnostics; # checks entire compilation phase + print "\ntime for 1st bogus diags: SQUAWKINGS\n"; + print BOGUS1 'nada'; + print "done with 1st bogus\n"; + + disable diagnostics; # only turns off runtime warnings + print "\ntime for 2nd bogus: (squelched)\n"; + print BOGUS2 'nada'; + print "done with 2nd bogus\n"; + + enable diagnostics; # turns back on runtime warnings + print "\ntime for 3rd bogus: SQUAWKINGS\n"; + print BOGUS3 'nada'; + print "done with 3rd bogus\n"; + + disable diagnostics; + print "\ntime for 4th bogus: (squelched)\n"; + print BOGUS4 'nada'; + print "done with 4th bogus\n"; + +=head1 INTERNALS + +Diagnostic messages derive from the F file when available at +runtime. Otherwise, they may be embedded in the file itself when the +splain package is built. See the F for details. + +If an extant $SIG{__WARN__} handler is discovered, it will continue +to be honored, but only after the diagnostic::splainthis() function +(the module's $SIG{__WARN__} interceptor) has had its way with your +warnings. + +There is a $diagnostics::DEBUG variable you may set if you're desperately +curious what sorts of things are being intercepted. + + BEGIN { $diagnostics::DEBUG = 1 } + + +=head1 BUGS + +Not being able to say "no diagnostics" is annoying, but may not be +insurmountable. + +The C<-pretty> directive is called too late to affect matters. +You have to to this instead, and I you load the module. + + BEGIN { $diagnostics::PRETTY = 1 } + +I could start up faster by delaying compilation until it should be +needed, but this gets a "panic: top_level" +when using the pragma form in 5.001e. + +While it's true that this documentation is somewhat subserious, if you use +a program named I, you should expect a bit of whimsy. + +=head1 AUTHOR + +Tom Christiansen Ftchrist@mox.perl.comE>, 25 June 1995. + +=cut + +$DEBUG ||= 0; +my $WHOAMI = ref bless []; # nobody's business, prolly not even mine + +$OUTPUT_AUTOFLUSH = 1; + +local $_; + +CONFIG: { + $opt_p = $opt_d = $opt_v = $opt_f = ''; + %HTML_2_Troff = %HTML_2_Latin_1 = %HTML_2_ASCII_7 = (); + %exact_duplicate = (); + + unless (caller) { + $standalone++; + require Getopt::Std; + Getopt::Std::getopts('pdvf:') || die "Usage: $0 [-v] [-p] [-f splainpod]"; + $PODFILE = $opt_f if $opt_f; + $DEBUG = 2 if $opt_d; + $VERBOSE = $opt_v; + $PRETTY = $opt_p; + } + + if (open(POD_DIAG, $PODFILE)) { + warn "Happy happy podfile from real $PODFILE\n" if $DEBUG; + last CONFIG; + } + + if (caller) { + INCPATH: { + for $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) { + warn "Checking $file\n" if $DEBUG; + if (open(POD_DIAG, $file)) { + while () { + next unless /^__END__\s*# wish diag dbase were more accessible/; + print STDERR "podfile is $file\n" if $DEBUG; + last INCPATH; + } + } + } + } + } else { + print STDERR "podfile is \n" if $DEBUG; + *POD_DIAG = *main::DATA; + } +} +if (eof(POD_DIAG)) { + die "couldn't find diagnostic data in $PODFILE @INC $0"; +} + + +%HTML_2_Troff = ( + 'amp' => '&', # ampersand + 'lt' => '<', # left chevron, less-than + 'gt' => '>', # right chevron, greater-than + 'quot' => '"', # double quote + + "Aacute" => "A\\*'", # capital A, acute accent + # etc + +); + +%HTML_2_Latin_1 = ( + 'amp' => '&', # ampersand + 'lt' => '<', # left chevron, less-than + 'gt' => '>', # right chevron, greater-than + 'quot' => '"', # double quote + + "Aacute" => "\xC1" # capital A, acute accent + + # etc +); + +%HTML_2_ASCII_7 = ( + 'amp' => '&', # ampersand + 'lt' => '<', # left chevron, less-than + 'gt' => '>', # right chevron, greater-than + 'quot' => '"', # double quote + + "Aacute" => "A" # capital A, acute accent + # etc +); + +*HTML_Escapes = do { + if ($standalone) { + $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7; + } else { + \%HTML_2_Latin_1; + } +}; + +*THITHER = $standalone ? *STDOUT : *STDERR; + +$transmo = <) { + #s/(.*)\n//; + #$header = $1; + + unescape(); + if ($PRETTY) { + sub noop { return $_[0] } # spensive for a noop + sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; } + sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; } + s/[BC]<(.*?)>/bold($1)/ges; + s/[LIF]<(.*?)>/italic($1)/ges; + } else { + s/[BC]<(.*?)>/$1/gs; + s/[LIF]<(.*?)>/$1/gs; + } + unless (/^=/) { + if (defined $header) { + if ( $header eq 'DESCRIPTION' && + ( /Optional warnings are enabled/ + || /Some of these messages are generic./ + ) ) + { + next; + } + s/^/ /gm; + $msg{$header} .= $_; + } + next; + } + unless ( s/=item (.*)\s*\Z//) { + + if ( s/=head1\sDESCRIPTION//) { + $msg{$header = 'DESCRIPTION'} = ''; + } + next; + } + $header = $1; + + if ($header =~ /%[sd]/) { + $rhs = $lhs = $header; + #if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E\$/g) { + if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E/g) { + $lhs =~ s/\\%s/.*?/g; + } else { + # if i had lookbehind negations, i wouldn't have to do this \377 noise + $lhs =~ s/(.*?)%s/\Q$1\E.*?\377/g; + #$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/; + $lhs =~ s/\377([^\377]*)$/\Q$1\E/; + $lhs =~ s/\377//g; + } + $transmo .= " s{^$lhs}\n {\Q$rhs\E}\n\t&& return 1;\n"; + } else { + $transmo .= " m{^\Q$header\E} && return 1;\n"; + } + + print STDERR "Already saw $header" if $msg{$header}; + + $msg{$header} = ''; + } + + + close POD_DIAG unless *main::DATA eq *POD_DIAG; + + die "No diagnostics?" unless %msg; + + $transmo .= " return 0;\n}\n"; + print STDERR $transmo if $DEBUG; + eval $transmo; + die $@ if $@; + $RS = "\n"; +### } + +if ($standalone) { + if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } + while ($error = <>) { + splainthis($error) || print THITHER $error; + } + exit; +} else { + $old_w = 0; $oldwarn = ''; $olddie = ''; +} + +sub import { + shift; + $old_w = $^W; + $^W = 1; # yup, clobbered the global variable; tough, if you + # want diags, you want diags. + return if $SIG{__WARN__} eq \&warn_trap; + + for (@_) { + + /^-d(ebug)?$/ && do { + $DEBUG++; + next; + }; + + /^-v(erbose)?$/ && do { + $VERBOSE++; + next; + }; + + /^-p(retty)?$/ && do { + print STDERR "$0: I'm afraid it's too late for prettiness.\n"; + $PRETTY++; + next; + }; + + warn "Unknown flag: $_"; + } + + $oldwarn = $SIG{__WARN__}; + $olddie = $SIG{__DIE__}; + $SIG{__WARN__} = \&warn_trap; + $SIG{__DIE__} = \&death_trap; +} + +sub enable { &import } + +sub disable { + shift; + $^W = $old_w; + return unless $SIG{__WARN__} eq \&warn_trap; + $SIG{__WARN__} = $oldwarn; + $SIG{__DIE__} = $olddie; +} + +sub warn_trap { + my $warning = $_[0]; + if (caller eq $WHOAMI or !splainthis($warning)) { + print STDERR $warning; + } + &$oldwarn if $oldwarn and $oldwarn ne \&warn_trap; +}; + +sub death_trap { + my $exception = $_[0]; + splainthis($exception); + if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; } + &$olddie if defined $olddie and $olddie ne \&death_trap; + $SIG{__DIE__} = $SIG{__WARN__} = ''; + confess "Uncaught exception from user code:\n\t$exception Bailing out"; + # up we go; where we stop, nobody knows, but i think we die now + # but i'm deeply afraid of the &$olddie guy reraising and us getting + # into an indirect recursion loop +}; + +sub splainthis { + local $_ = shift; + ### &finish_compilation unless %msg; + s/\.?\n+$//; + my $orig = $_; + # return unless defined; + if ($exact_duplicate{$_}++) { + return 1; + } + s/, <.*?> (?:line|chunk).*$//; + $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/; + s/^\((.*)\)$/$1/; + return 0 unless &transmo; + $orig = shorten($orig); + if ($old_diag{$_}) { + autodescribe(); + print THITHER "$orig (#$old_diag{$_})\n"; + $wantspace = 1; + } else { + autodescribe(); + $old_diag{$_} = ++$count; + print THITHER "\n" if $wantspace; + $wantspace = 0; + print THITHER "$orig (#$old_diag{$_})\n"; + if ($msg{$_}) { + print THITHER $msg{$_}; + } else { + if (0 and $standalone) { + print THITHER " **** Error #$old_diag{$_} ", + ($real ? "is" : "appears to be"), + " an unknown diagnostic message.\n\n"; + } + return 0; + } + } + return 1; +} + +sub autodescribe { + if ($VERBOSE and not $count) { + print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"), + "\n$msg{DESCRIPTION}\n"; + } +} + +sub unescape { + s { + E< + ( [A-Za-z]+ ) + > + } { + do { + exists $HTML_Escapes{$1} + ? do { $HTML_Escapes{$1} } + : do { + warn "Unknown escape: $& in $_"; + "E<$1>"; + } + } + }egx; +} + +sub shorten { + my $line = $_[0]; + if (length $line > 79) { + my $space_place = rindex($line, ' ', 79); + if ($space_place != -1) { + substr($line, $space_place, 1) = "\n\t"; + } + } + return $line; +} + + +# have to do this: RS isn't set until run time, but we're executing at compile time +$RS = "\n"; + +1 unless $standalone; # or it'll complain about itself +__END__ # wish diag dbase were more accessible diff --git a/makeaperl.SH b/makeaperl.SH old mode 100644 new mode 100755 diff --git a/mg.c b/mg.c index 1b69701086..d58b0cf494 100644 --- a/mg.c +++ b/mg.c @@ -80,6 +80,7 @@ SV* sv; U32 savemagic = SvMAGICAL(sv); SvMAGICAL_off(sv); + SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; for (mg = SvMAGIC(sv); mg; mg = nextmg) { MGVTBL* vtbl = mg->mg_virtual; @@ -550,6 +551,10 @@ MAGIC* mg; else croak("No such hook: %s", s); i = 0; + if (*svp) { + SvREFCNT_dec(*svp); + *svp = 0; + } } else { i = whichsig(s); /* ...no, a brick */ @@ -1093,7 +1098,7 @@ MAGIC* mg; #endif #endif uid = (I32)getuid(); - tainting |= (euid != uid || egid != gid); + tainting |= (uid && (euid != uid || egid != gid)); break; case '>': euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); @@ -1120,7 +1125,7 @@ MAGIC* mg; #endif #endif euid = (I32)geteuid(); - tainting |= (euid != uid || egid != gid); + tainting |= (uid && (euid != uid || egid != gid)); break; case '(': gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); @@ -1147,7 +1152,7 @@ MAGIC* mg; #endif #endif gid = (I32)getgid(); - tainting |= (euid != uid || egid != gid); + tainting |= (uid && (euid != uid || egid != gid)); break; case ')': egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); @@ -1174,7 +1179,7 @@ MAGIC* mg; #endif #endif egid = (I32)getegid(); - tainting |= (euid != uid || egid != gid); + tainting |= (uid && (euid != uid || egid != gid)); break; case ':': chopset = SvPV_force(sv,na); @@ -1240,17 +1245,6 @@ char *sig; return 0; } -char * -whichsigname(sig) -int sig; -{ - register int i; - for (i = 1; sig_num[i]; i++) /* sig_num[] is a 0-terminated list */ - if (sig_num[i] == sig) - return sig_name[i]; - return Nullch; -} - Signal_t sighandler(sig) int sig; @@ -1267,7 +1261,7 @@ int sig; signal(sig, SIG_ACK); #endif - signame = whichsigname(sig); + signame = sig_name[sig]; cv = sv_2cv(*hv_fetch(GvHVn(siggv),signame,strlen(signame), TRUE), &st, &gv, TRUE); diff --git a/minimod.PL b/minimod.PL index c0da491d08..ab4a7377fb 100644 --- a/minimod.PL +++ b/minimod.PL @@ -53,13 +53,25 @@ sub writemain{ my($pname); my($dl) = canon('/','DynaLoader'); print $head; + + foreach $_ (@exts){ + my($pname) = canon('/', $_); + my($mname, $cname); + ($mname = $pname) =~ s!/!::!g; + ($cname = $pname) =~ s!/!__!g; + print "EXTERN_C void boot_${cname} _((CV* cv));\n"; + } + + my ($tail1,$tail2) = ( $tail =~ /\A(.*\n)(\s*\}.*)\Z/s ); + print $tail1; + print " char *file = __FILE__;\n"; foreach $_ (@exts){ my($pname) = canon('/', $_); my($mname, $cname, $ccode); ($mname = $pname) =~ s!/!::!g; ($cname = $pname) =~ s!/!__!g; - print "\t{ extern void boot_${cname} _((CV* cv));\n"; + print "\t{\n"; if ($pname eq $dl){ # Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'! # boot_DynaLoader is called directly in DynaLoader.pm @@ -72,7 +84,7 @@ sub writemain{ } print "\t}\n"; } - print $tail; + print $tail2; } sub canon{ diff --git a/miniperlmain.c b/miniperlmain.c index ba74c4d4f9..2c1e0b62c8 100644 --- a/miniperlmain.c +++ b/miniperlmain.c @@ -2,24 +2,53 @@ * "The Road goes ever on and on, down from the door where it began." */ +#ifdef __cplusplus +extern "C" { +#endif + #include "EXTERN.h" #include "perl.h" +#ifdef __cplusplus +} +# define EXTERN_C extern "C" +#else +# define EXTERN_C extern +#endif + static void xs_init _((void)); static PerlInterpreter *my_perl; int +#ifndef CAN_PROTOTYPE main(argc, argv, env) int argc; char **argv; char **env; +#else /* def(CAN_PROTOTYPE) */ +main(int argc, char **argv, char **env) +#endif /* def(CAN_PROTOTYPE) */ { int exitstatus; +#ifdef OS2 + _response(&argc, &argv); + _wildcard(&argc, &argv); +#endif + #ifdef VMS getredirection(&argc,&argv); #endif +#if defined(HAS_SETLOCALE) && defined(LC_CTYPE) + if (setlocale(LC_CTYPE, "") == NULL) { + fprintf(stderr, + "setlocale(LC_CTYPE, \"\") failed (LC_CTYPE = \"%s\").\n", + getenv("LC_CTYPE")); + exit(1); + } +#endif + if (!do_undump) { my_perl = perl_alloc(); if (!my_perl) @@ -27,7 +56,7 @@ char **env; perl_construct( my_perl ); } - exitstatus = perl_parse( my_perl, xs_init, argc, argv, env ); + exitstatus = perl_parse( my_perl, xs_init, argc, argv, NULL ); if (exitstatus) exit( exitstatus ); @@ -41,8 +70,9 @@ char **env; /* Register any extra external extensions */ +/* Do not delete this line--writemain depends on it */ + static void xs_init() { - /* Do not delete this line--writemain depends on it */ } diff --git a/op.c b/op.c index 4c5d64a151..9ae1bdcde1 100644 --- a/op.c +++ b/op.c @@ -31,16 +31,25 @@ #endif /* USE_OP_MASK */ static I32 list_assignment _((OP *op)); -static OP *bad_type _((I32 n, char *t, OP *op, OP *kid)); +static OP *bad_type _((I32 n, char *t, char *name, OP *kid)); static OP *modkids _((OP *op, I32 type)); static OP *no_fh_allowed _((OP *op)); static OP *scalarboolean _((OP *op)); -static OP *too_few_arguments _((OP *op)); -static OP *too_many_arguments _((OP *op)); +static OP *too_few_arguments _((OP *op, char* name)); +static OP *too_many_arguments _((OP *op, char* name)); static void null _((OP* op)); static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, I32 seq, CV* startcv, I32 cx_ix)); +static char* +CvNAME(cv) +CV* cv; +{ + SV* tmpsv = sv_newmortal(); + gv_efullname(tmpsv, CvGV(cv)); + return SvPV(tmpsv,na); +} + static OP * no_fh_allowed(op) OP *op; @@ -52,32 +61,34 @@ OP *op; } static OP * -too_few_arguments(op) -OP *op; +too_few_arguments(op, name) +OP* op; +char* name; { - sprintf(tokenbuf,"Not enough arguments for %s", op_name[op->op_type]); + sprintf(tokenbuf,"Not enough arguments for %s", name); yyerror(tokenbuf); return op; } static OP * -too_many_arguments(op) +too_many_arguments(op, name) OP *op; +char* name; { - sprintf(tokenbuf,"Too many arguments for %s", op_name[op->op_type]); + sprintf(tokenbuf,"Too many arguments for %s", name); yyerror(tokenbuf); return op; } static OP * -bad_type(n, t, op, kid) +bad_type(n, t, name, kid) I32 n; char *t; -OP *op; +char *name; OP *kid; { sprintf(tokenbuf, "Type of arg %d to %s must be %s (not %s)", - (int) n, op_name[op->op_type], t, op_name[kid->op_type]); + (int) n, name, t, op_name[kid->op_type]); yyerror(tokenbuf); return op; } @@ -153,7 +164,7 @@ pad_findlex(char *name, PADOFFSET newoff, I32 seq, CV* startcv, I32 cx_ix) SV** svp = av_fetch(curlist, 0, FALSE); AV *curname; if (!svp || *svp == &sv_undef) - break; + continue; curname = (AV*)*svp; svp = AvARRAY(curname); for (off = AvFILL(curname); off > 0; off--) { @@ -229,7 +240,7 @@ char *name; I32 seq = cop_seqmax; /* The one we're looking for is probably just before comppad_name_fill. */ - for (off = comppad_name_fill; off > 0; off--) { + for (off = AvFILL(comppad_name); off > 0; off--) { if ((sv = svp[off]) && sv != &sv_undef && seq <= SvIVX(sv) && @@ -518,6 +529,8 @@ OP *op; switch (op->op_type) { case OP_REPEAT: + if (op->op_private & OPpREPEAT_DOLIST) + null(((LISTOP*)cBINOP->op_first)->op_first); scalar(cBINOP->op_first); break; case OP_OR: @@ -953,6 +966,8 @@ I32 type; modcount = 10000; break; case OP_RV2SV: + if (!type && cUNOP->op_first->op_type != OP_GV) + croak("Can't localize a reference"); ref(cUNOP->op_first, op->op_type); /* FALL THROUGH */ case OP_UNDEF: @@ -993,7 +1008,7 @@ I32 type; sv_magic(sv, Nullsv, mtype, Nullch, 0); curpad[op->op_targ] = sv; if (op->op_flags & OPf_KIDS) - mod(cBINOP->op_first, type); + mod(cBINOP->op_first->op_sibling, type); break; case OP_AELEM: @@ -1066,6 +1081,7 @@ I32 type; op->op_ppaddr = ppaddr[OP_RV2CV]; assert(cUNOP->op_first->op_type == OP_NULL); null(((LISTOP*)cUNOP->op_first)->op_first); /* disable pushmark */ + op->op_flags |= OPf_SPECIAL; } break; @@ -1075,6 +1091,8 @@ I32 type; break; case OP_RV2SV: ref(cUNOP->op_first, op->op_type); + /* FALL THROUGH */ + case OP_PADSV: if (type == OP_RV2AV || type == OP_RV2HV) { op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : OPpDEREF_HV); op->op_flags |= OPf_MOD; @@ -1204,7 +1222,7 @@ scope(o) OP *o; { if (o) { - if (o->op_flags & OPf_PARENS || perldb) { + if (o->op_flags & OPf_PARENS || perldb || tainting) { o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); o->op_type = OP_LEAVE; o->op_ppaddr = ppaddr[OP_LEAVE]; @@ -1876,6 +1894,7 @@ OP *repl; } if (curop == repl) { pm->op_pmflags |= PMf_CONST; /* const for long enough */ + pm->op_pmpermflags |= PMf_CONST; /* const for long enough */ prepend_elem(op->op_type, scalar(repl), op); } else { @@ -2021,27 +2040,31 @@ OP *arg; if (id->op_type != OP_CONST) croak("Module name must be constant"); - meth = newSVOP(OP_CONST, 0, - aver - ? newSVpv("import", 6) - : newSVpv("unimport", 8) - ); - - /* Make copy of id so we don't free it twice */ - pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv)); - - /* Fake up a require */ - rqop = newUNOP(OP_REQUIRE, 0, id); - /* Fake up an import/unimport */ - imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, + if (arg && arg->op_type == OP_STUB) + imop = arg; /* no import on explicit () */ + else { + /* Make copy of id so we don't free it twice */ + pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv)); + + meth = newSVOP(OP_CONST, 0, + aver + ? newSVpv("import", 6) + : newSVpv("unimport", 8) + ); + imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, append_elem(OP_LIST, prepend_elem(OP_LIST, pack, list(arg)), newUNOP(OP_METHOD, 0, meth))); + } + + /* Fake up a require */ + rqop = newUNOP(OP_REQUIRE, 0, id); /* Fake up the BEGIN {}, which does its thing immediately. */ newSUB(start_subparse(), newSVOP(OP_CONST, 0, newSVpv("BEGIN", 5)), + Nullop, append_elem(OP_LINESEQ, newSTATEOP(0, Nullch, rqop), newSTATEOP(0, Nullch, imop) )); @@ -2231,10 +2254,10 @@ OP *op; I32 i; SV *sv; for (i = min_intro_pending; i <= max_intro_pending; i++) { - if ((sv = svp[i]) && sv != &sv_undef) { + if ((sv = svp[i]) && sv != &sv_undef && !SvIVX(sv)) { SvIVX(sv) = 999999999; /* Don't know scope end yet. */ SvNVX(sv) = (double)cop_seqmax; - } + } } min_intro_pending = 0; comppad_name_fill = max_intro_pending; /* Needn't search higher */ @@ -2578,6 +2601,7 @@ newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont { LOOP *loop; int padoff = 0; + I32 iterflags = 0; copline = forline; if (sv) { @@ -2596,7 +2620,11 @@ newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont else { sv = newGVOP(OP_GV, 0, defgv); } - loop = (LOOP*)list(convert(OP_ENTERITER, 0, + if (expr->op_type == OP_RV2AV) { + expr = scalar(ref(expr, OP_ITER)); + iterflags |= OPf_STACKED; + } + loop = (LOOP*)list(convert(OP_ENTERITER, iterflags, append_elem(OP_LIST, mod(force_list(expr), OP_GREPSTART), scalar(sv)))); assert(!loop->op_next); @@ -2712,7 +2740,8 @@ CV* proto; if (svp[ix] != &sv_undef) { char *name = SvPVX(svp[ix]); /* XXX */ if (SvFLAGS(svp[ix]) & SVf_FAKE) { /* lexical from outside? */ - I32 off = pad_findlex(name,ix,curcop->cop_seq, CvOUTSIDE(proto), cxstack_ix); + I32 off = pad_findlex(name,ix,curcop->cop_seq, CvOUTSIDE(proto), + cxstack_ix); if (off != ix) croak("panic: cv_clone: %s", name); } @@ -2737,9 +2766,10 @@ CV* proto; } CV * -newSUB(floor,op,block) +newSUB(floor,op,proto,block) I32 floor; OP *op; +OP *proto; OP *block; { register CV *cv; @@ -2767,14 +2797,13 @@ OP *block; } } if (cv) { /* must reuse cv if autoloaded */ - if (CvGV(cv)) { - assert(SvREFCNT(CvGV(cv)) > 1); - SvREFCNT_dec(CvGV(cv)); - } + cv_undef(cv); CvOUTSIDE(cv) = CvOUTSIDE(compcv); CvOUTSIDE(compcv) = 0; CvPADLIST(cv) = CvPADLIST(compcv); CvPADLIST(compcv) = 0; + if (SvREFCNT(compcv) > 1) /* XXX Make closures transit through stub. */ + CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc((SV*)cv); SvREFCNT_dec(compcv); } else { @@ -2786,6 +2815,13 @@ OP *block; CvGV(cv) = SvREFCNT_inc(gv); CvSTASH(cv) = curstash; + if (proto) { + char *p = SvPVx(((SVOP*)proto)->op_sv, na); + if (SvPOK(cv) && strNE(SvPV((SV*)cv,na), p)) + warn("Prototype mismatch: (%s) vs (%s)", SvPV((SV*)cv, na), p); + sv_setpv((SV*)cv, p); + } + if (!block) { CvROOT(cv) = 0; op_free(op); @@ -2815,7 +2851,7 @@ OP *block; s++; else s = name; - if (strEQ(s, "BEGIN")) { + if (strEQ(s, "BEGIN") && !error_count) { line_t oldline = compiling.cop_line; ENTER; @@ -2839,7 +2875,7 @@ OP *block; curcop->cop_line = oldline; /* might have recursed to yylex */ LEAVE; } - else if (strEQ(s, "END")) { + else if (strEQ(s, "END") && !error_count) { if (!endav) endav = newAV(); av_unshift(endav, 1); @@ -2955,7 +2991,6 @@ OP *block; register CV *cv; char *name; GV *gv; - AV* av; I32 ix; if (op) @@ -3030,12 +3065,13 @@ OP* op; } OP * -newANONSUB(floor, block) +newANONSUB(floor, proto, block) I32 floor; +OP *proto; OP *block; { return newUNOP(OP_REFGEN, 0, - newSVOP(OP_ANONCODE, 0, (SV*)newSUB(floor, 0, block))); + newSVOP(OP_ANONCODE, 0, (SV*)newSUB(floor, 0, proto, block))); } OP * @@ -3418,7 +3454,7 @@ OP *op; *tokid = kid; } else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) - bad_type(numargs, "array", op, kid); + bad_type(numargs, "array", op_name[op->op_type], kid); mod(kid, type); break; case OA_HVREF: @@ -3436,7 +3472,7 @@ OP *op; *tokid = kid; } else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) - bad_type(numargs, "hash", op, kid); + bad_type(numargs, "hash", op_name[op->op_type], kid); mod(kid, type); break; case OA_CVREF: @@ -3479,7 +3515,7 @@ OP *op; } op->op_private = numargs; if (kid) - return too_many_arguments(op); + return too_many_arguments(op,op_name[op->op_type]); listkids(op); } else if (opargs[type] & OA_DEFGV) { @@ -3491,7 +3527,7 @@ OP *op; while (oa & OA_OPTIONAL) oa >>= 4; if (oa && oa != OA_LIST) - return too_few_arguments(op); + return too_few_arguments(op,op_name[op->op_type]); } return op; } @@ -3552,7 +3588,7 @@ OP *op; kid = cLISTOP->op_first->op_sibling; if (!kid || !kid->op_sibling) - return too_few_arguments(op); + return too_few_arguments(op,op_name[op->op_type]); for (kid = kid->op_sibling; kid; kid = kid->op_sibling) mod(kid, OP_GREPSTART); @@ -3629,6 +3665,7 @@ ck_match(op) OP *op; { cPMOP->op_pmflags |= PMf_RUNTIME; + cPMOP->op_pmpermflags |= PMf_RUNTIME; return op; } @@ -3811,7 +3848,7 @@ OP *op; scalar(kid); if (kid->op_sibling) - return too_many_arguments(op); + return too_many_arguments(op,op_name[op->op_type]); return op; } @@ -3820,16 +3857,116 @@ OP * ck_subr(op) OP *op; { - OP *o = ((cUNOP->op_first->op_sibling) - ? cUNOP : ((UNOP*)cUNOP->op_first))->op_first->op_sibling; - - if (o->op_type == OP_RV2CV) - null(o); /* disable rv2cv */ + OP *prev = ((cUNOP->op_first->op_sibling) + ? cUNOP : ((UNOP*)cUNOP->op_first))->op_first; + OP *o = prev->op_sibling; + OP *cvop; + char *proto = 0; + CV *cv = 0; + int optional = 0; + I32 arg = 0; + + for (cvop = o; cvop->op_sibling; cvop = cvop->op_sibling) ; + if (cvop->op_type == OP_RV2CV) { + SVOP* tmpop; + null(cvop); /* disable rv2cv */ + tmpop = (SVOP*)((UNOP*)cvop)->op_first; + if (tmpop->op_type == OP_GV) { + cv = GvCV(tmpop->op_sv); + if (cv && SvPOK(cv) && (op->op_flags & OPf_STACKED)) + proto = SvPV((SV*)cv,na); + } + } op->op_private = (hints & HINT_STRICT_REFS); if (perldb && curstash != debstash) op->op_private |= OPpDEREF_DB; - while (o = o->op_sibling) + while (o != cvop) { + if (proto) { + switch (*proto) { + case '\0': + return too_many_arguments(op, CvNAME(cv)); + case ';': + optional = 1; + proto++; + continue; + case '$': + proto++; + arg++; + scalar(o); + break; + case '%': + case '@': + list(o); + arg++; + break; + case '&': + proto++; + arg++; + if (o->op_type != OP_REFGEN && o->op_type != OP_UNDEF) + bad_type(arg, "block", CvNAME(cv), o); + break; + case '*': + proto++; + arg++; + if (o->op_type == OP_RV2GV) + goto wrapref; + { + OP* kid = o; + o = newUNOP(OP_RV2GV, 0, kid); + o->op_sibling = kid->op_sibling; + kid->op_sibling = 0; + prev->op_sibling = o; + } + goto wrapref; + case '\\': + proto++; + arg++; + switch (*proto++) { + case '*': + if (o->op_type != OP_RV2GV) + bad_type(arg, "symbol", CvNAME(cv), o); + goto wrapref; + case '&': + if (o->op_type != OP_RV2CV) + bad_type(arg, "sub", CvNAME(cv), o); + goto wrapref; + case '$': + if (o->op_type != OP_RV2SV && o->op_type != OP_PADSV) + bad_type(arg, "scalar", CvNAME(cv), o); + goto wrapref; + case '@': + if (o->op_type != OP_RV2AV && o->op_type != OP_PADAV) + bad_type(arg, "array", CvNAME(cv), o); + goto wrapref; + case '%': + if (o->op_type != OP_RV2HV && o->op_type != OP_PADHV) + bad_type(arg, "hash", CvNAME(cv), o); + wrapref: + { + OP* kid = o; + o = newUNOP(OP_REFGEN, 0, kid); + o->op_sibling = kid->op_sibling; + kid->op_sibling = 0; + prev->op_sibling = o; + } + break; + default: goto oops; + } + break; + default: + oops: + croak("Malformed prototype for %s: %s", + CvNAME(cv),SvPV((SV*)cv,na)); + } + } + else + list(o); mod(o, OP_ENTERSUB); + prev = o; + o = o->op_sibling; + } + if (proto && !optional && *proto == '$') + return too_few_arguments(op, CvNAME(cv)); return op; } diff --git a/op.h b/op.h index a4704ba94c..0b4fc28bfd 100644 --- a/op.h +++ b/op.h @@ -23,9 +23,9 @@ * which may or may not check number of children). */ -typedef U16 PADOFFSET; +typedef U32 PADOFFSET; -#ifdef DEBUGGING +#ifdef DEBUGGING_OPS #define OPCODE opcode #else #define OPCODE U16 @@ -147,6 +147,7 @@ struct pmop { REGEXP * op_pmregexp; /* compiled expression */ SV * op_pmshort; /* for a fast bypass of execute() */ U16 op_pmflags; + U16 op_pmpermflags; char op_pmslen; }; diff --git a/opcode.h b/opcode.h index 1651a259d0..0cfc50c4b6 100644 --- a/opcode.h +++ b/opcode.h @@ -1923,7 +1923,7 @@ EXT U32 opargs[] = { 0x00000000, /* and */ 0x00000000, /* or */ 0x00001106, /* xor */ - 0x00000000, /* cond_expr */ + 0x00000040, /* cond_expr */ 0x00000004, /* andassign */ 0x00000004, /* orassign */ 0x00000040, /* method */ diff --git a/opcode.pl b/opcode.pl index dcb6afeaa8..f1da5b6cc6 100755 --- a/opcode.pl +++ b/opcode.pl @@ -382,7 +382,7 @@ flop range (or flop) ck_null 0 and logical and ck_null 0 or logical or ck_null 0 xor logical xor ck_null fs S S -cond_expr conditional expression ck_null 0 +cond_expr conditional expression ck_null d andassign logical and assignment ck_null s orassign logical or assignment ck_null s diff --git a/os2/Makefile.SH b/os2/Makefile.SH new file mode 100644 index 0000000000..78c12187c0 --- /dev/null +++ b/os2/Makefile.SH @@ -0,0 +1,54 @@ +# This file is read by Makefile.SH to produce rules for $(perllib) +# We insert perl5.def since I do not know how to generate it yet. + +$spitshell >>Makefile <<'!NO!SUBS!' +$(perllib): perl.imp perl.dll perl5.def + emximp -o $(perllib) perl.imp + +perl.imp: perl5.def + emximp -o perl.imp perl5.def + +perl.dll: $(obj) perl5.def perl$(O) + $(LD) $(LDDLFLAGS) -o $@ perl$(O) $(obj) -lsocket perl5.def + +perl5.def: perl.linkexp + echo "LIBRARY 'Perl' INITINSTANCE TERMINSTANCE" > $@ + echo DESCRIPTION "'Perl interpreter, export autogenerated'" >>$@ + echo STACKSIZE 32768 >>$@ + echo CODE LOADONCALL >>$@ + echo DATA LOADONCALL NONSHARED MULTIPLE >>$@ + echo EXPORTS >>$@ + echo ' "ctermid"' >>$@ + echo ' "ttyname"' >>$@ + cat perl.linkexp >>$@ + +# grep -v '"\(malloc\|realloc\|free\)"' perl.linkexp >>$@ + + +# We assume here that perl is available somewhere ... + +perl.exports: perl.exp EXTERN.h perl.h + (echo '#include "EXTERN.h"'; echo '#include "perl.h"' ; \ + echo '#include "perl.exp"') | \ + $(CC) -DEMBED -E - | \ + awk '{if ($$2 == "") print $$1}' | sort | uniq > $@ + +# perl -ne 'print if (/^#!/ .. /^#\s/) && s/^(\w+) *$$/$$1/' > $@ + +perl.linkexp: perl.exports perl.map + cat perl.exports perl.map | sort | uniq -d | sed -e 's/\w\+/ "\0"/' > perl.linkexp + +perl.map: $(obj) perl$(O) miniperlmain$(O) + $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o dummy.exe miniperlmain$(O) perl$(O) $(obj) -lsocket -lm -Zmap -Zlinker /map + awk '{if ($$3 == "") print $$2}' perl.map + rm dummy.exe dummy.map + +depend: os2ish.h + +os2.c: os2/os2.c os2ish.h + cp $< $@ + +os2ish.h: os2/os2ish.h + cp $< $@ + +!NO!SUBS! diff --git a/os2/POSIX.mkfifo b/os2/POSIX.mkfifo new file mode 100644 index 0000000000..5bd820edfd --- /dev/null +++ b/os2/POSIX.mkfifo @@ -0,0 +1,16 @@ +diff -cr ..\perl5os2.patch\perl5.001m.andy/ext/POSIX/POSIX.xs ./ext/POSIX/POSIX.xs +*** ../perl5os2.patch/perl5.001m.andy/ext/POSIX/POSIX.xs Tue May 23 11:54:26 1995 +--- ./ext/POSIX/POSIX.xs Thu Sep 28 00:00:16 1995 +*************** +*** 81,86 **** +--- 81,90 ---- + /* Possibly needed prototypes */ + char *cuserid _((char *)); + ++ #ifndef HAS_MKFIFO ++ #define mkfifo(a,b) not_here("mkfifo") ++ #endif ++ + #ifndef HAS_CUSERID + #define cuserid(a) (char *) not_here("cuserid") + #endif diff --git a/os2/README b/os2/README new file mode 100644 index 0000000000..20614dd31a --- /dev/null +++ b/os2/README @@ -0,0 +1,155 @@ +# This message contains the description of the patch. +# The actual patch will be posted to p5-p later, the parts that +# are relevant to other lists will be posted there separately +# +# This is needed _before_ application of the patch: + +mkdir os2 +touch os2/Makefile.SH hints/os2.sh os2/os2.c os2/os2ish.h +touch ext/DynaLoader/dl_os2.xs +exit 0 + +======================================================== + +The OS/2 patchkit was submitted by ilya@math.ohio-state.edu. I have +applied some parts that I suspect won't cause any problems. +Others do things that I haven't had time to fully consider. + +Still other patches included here should perhaps be integrated with the +metaconfig package that generates Configure. + + Andy Dougherty + +======================================================== + +Notes on the patch: +~~~~~~~~~~~~~~~~~~~ +1) run the above commands +2) patches should be applied as + patch -p0 <..... + +Patches are relative to perl5.001n. +It is tested under Solaris and OS/2. +The complete distribution of this patch is available on + ftp://ftp.math.ohio-state.edu/pub/users/ilya/os2 +The file diff.for.o.Configure should be applied last. It will repatch +Configure. + +Target: +~~~~~~~ + +This is not supposed to make a perfect Perl on OS/2. This patch is +concerned only with perfect _build_ of Perl on OS/2. A lot of good +features from Andreas Kaiser port missed this patch. + +Annotations of changes: +~~~~~~~~~~~~~~~~~~~~~~~ +1) C files +2) Configure +3) MakeMaker +4) Build tools + +1) C files + a) mkfifo macro added to Posix.c + b) Copyright notice for OS/2 port changed + c) MYMALLOC section in perl.h moved (why?) + d) setgrent grent and getgrent wrapped in ifdef + e) declarations for #if defined(MYMALLOC) && defined(HIDEMYMALLOC) + added + f) some diagnostics added to tests + +2) Configure + 0) Differences are provided with plain 5.001m + andys. + a) New vars exe_ext obj_ext lib_ext ar plibext + firstmakefile archobjs cldlibs path_sep + I think they should be set by the hints files only + b) Support for extraction from NE style libraries. + c) a lot of + cc -o whatever + lines did not have $ldopts. + d) The above variables are used throughout the file for checks + +3) Build tools and libraries + + Since Configure can go out of sync with the other tools, + all the added configuration variables are checked for + existence, if not, set to reasonable values. Thus the + changes are independent of Configure patch. + + a) ln changed to $ln in some places + b) Makefiles and related scripts made to use $(O), $(A), $(AR) + using the vars found by Configure or defaulted to + some reasonable value. + c) $firstmakefile is the file make looks onto before Makefile + d) $plibext is the extension for the perl library + e) $archobjs is the list of additional object files needed for + local build. + $cldlibs are libs to use when linking miniperl. + f) Sanity checks look for perl$Config{exe_ext}. + g) installperl was looping through config.sh in a wrong way + h) installperl needs to change permission to 0777 before + unlink on OS/2. + i) Cwd.pm updated for OS/2. + j) Find.pm updated for OS/2. + k) Shell.pm updated for OS/2. + l) Makefile.SH : added sh in front of some commands + if $d_shrplib is 'custom', looks into + $osname/Makefile.$osname.SH to construct the section + on shared Perl library. + m) clean target extended to delete some intermediate files + n) Test::Harness works. + + +Notes on build on OS/2: +~~~~~~~~~~~~~~~~~~~~~~~ +The change of C code in this patch is based on the ak port of 5.001+. + +a) Make sure your sort is not the broken OS/2 one. + +b) when extraction perl5.001m.tar.gz you need to extract perl5.001m/Configure +separately, since by default perl5.001m/configure overwrites it; + +c) Necessary manual intervention when compiling on OS/2: + + Need to put perl.dll on LIBPATH after it is created. + +d) Compile summary: + +# Look for hints/os2.sh and correct what is different on your system +# I have rather spartan configuration. + + # Prefix means where to install: +sh Configure -des -D prefix=f:/perl5m +make + # Will probably die after build of miniperl (unless you have DLL + # from previous compile). Need to move DLL where it belongs +make + # some warnings in POSIX.c +make test + # some tests fail, 10 on my system + # + # before this you should create subdirs bin and lib in the + # prefix directory (f:/perl5m above): +make install + # man pages are not installed + +e) At the end of August GNU make and pdksh were too buggy for compile. +Both maintainers have patches that make it possible to compile perl. +They are included into distribution of this patch on + ftp://ftp.math.ohio-state.edu/pub/users/ilya/os2 + +!!!!!!!!!!!!!!!!! +If you see that some '/' became '\' in pdksh 5.2.3, you did not apply +my patches! +Same with segfaults in Make 3.74. +!!!!!!!!!!!!!!!!! + +Problems reported: + +a) one of the latest tr is broken, get an old one :-( + 1.11 works. (On compuserver?) +b) You need a perlglob.exe and link386. +c) Get rid of invalid perl.dll on your LIBPATH. + + +Send comments to ilya@math.ohio-state.edu. diff --git a/os2/diff.Makefile b/os2/diff.Makefile new file mode 100644 index 0000000000..f351b2594e --- /dev/null +++ b/os2/diff.Makefile @@ -0,0 +1,436 @@ +diff -cr ..\perl5os2.patch\perl5.001m.andy/Makefile.SH ./Makefile.SH +*** ../perl5os2.patch/perl5.001m.andy/Makefile.SH Mon Oct 09 21:40:46 1995 +--- ./Makefile.SH Thu Sep 28 00:13:40 1995 +*************** +*** 22,27 **** +--- 22,31 ---- + *) suidperl='';; + esac + ++ # In case Configure is not patched: ++ : ${obj_ext=.o} ${obj_ext_regexp='\.o'} ${lib_ext=.a} ${ar=ar} ${firstmakefile=makefile} ++ : ${exe_ext=} ${cldlibs="$libs $cryptlib"} ++ + shrpenv="" + case "$d_shrplib" in + *define*) +*************** +*** 31,43 **** + *[0-9]) plibsuf=.$so.$patchlevel;; + *) plibsuf=.$so;; + esac + case "$shrpdir" in + /usr/lib) ;; + "") ;; + *) shrpenv="env LD_RUN_PATH=$shrpdir";; + esac + pldlflags="$cccdlflags";; +! *) plibsuf=.a + pldlflags="";; + esac + +--- 35,48 ---- + *[0-9]) plibsuf=.$so.$patchlevel;; + *) plibsuf=.$so;; + esac ++ if test "x$plibext" != "x" ; then plibsuf=$plibext d_shrplib=custom ; fi + case "$shrpdir" in + /usr/lib) ;; + "") ;; + *) shrpenv="env LD_RUN_PATH=$shrpdir";; + esac + pldlflags="$cccdlflags";; +! *) plibsuf=$lib_ext + pldlflags="";; + esac + +*************** +*** 53,59 **** + static_ai_list=' ' + for f in $static_ext; do + base=`echo "$f" | sed 's/.*\///'` +! static_list="$static_list lib/auto/$f/$base.a" + if test -f ext/$f/AutoInit.c; then + static_ai_list="$static_ai_list ext/$f/AutoInit.c" + fi +--- 58,64 ---- + static_ai_list=' ' + for f in $static_ext; do + base=`echo "$f" | sed 's/.*\///'` +! static_list="$static_list lib/auto/$f/$base\$(A)" + if test -f ext/$f/AutoInit.c; then + static_ai_list="$static_ai_list ext/$f/AutoInit.c" + fi +*************** +*** 115,129 **** + static_ext = $static_list + ext = \$(dynamic_ext) \$(static_ext) + static_ext_autoinit = $static_ai_list +! DYNALOADER = lib/auto/DynaLoader/DynaLoader.a +! + + libs = $libs $cryptlib + + public = perl $suidperl + + shellflags = $shellflags + + ## To use an alternate make, set \$altmake in config.sh. + MAKE = ${altmake-make} + !GROK!THIS! +--- 120,152 ---- + static_ext = $static_list + ext = \$(dynamic_ext) \$(static_ext) + static_ext_autoinit = $static_ai_list +! DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(A) + + libs = $libs $cryptlib ++ cldlibs = $cldlibs + + public = perl $suidperl + + shellflags = $shellflags + ++ ## To make it possible a build on a case-unsensitive filesystem ++ ++ firstmakefile = $firstmakefile ++ ++ ## Architecture-specific objects ++ ++ archobjs = $archobjs ++ ++ ## Extention of object files ++ ++ O = $obj_ext ++ O_REGEXP = $obj_ext_regexp ++ A = $lib_ext ++ AR = $ar ++ exe_ext = $exe_ext ++ ++ .SUFFIXES: .c \$(O) ++ + ## To use an alternate make, set \$altmake in config.sh. + MAKE = ${altmake-make} + !GROK!THIS! +*************** +*** 153,163 **** + + c = $(c1) $(c2) $(c3) miniperlmain.c perlmain.c + +! obj1 = $(mallocobj) gv.o toke.o perly.o op.o regcomp.o dump.o util.o mg.o +! obj2 = hv.o av.o run.o pp_hot.o sv.o pp.o scope.o pp_ctl.o pp_sys.o +! obj3 = doop.o doio.o regexec.o taint.o deb.o globals.o + +! obj = $(obj1) $(obj2) $(obj3) + + # Once perl has been Configure'd and built ok you build different + # perl variants (Debugging, Embedded, Multiplicity etc) by saying: +--- 175,185 ---- + + c = $(c1) $(c2) $(c3) miniperlmain.c perlmain.c + +! obj1 = $(mallocobj) gv$(O) toke$(O) perly$(O) op$(O) regcomp$(O) dump$(O) util$(O) mg$(O) +! obj2 = hv$(O) av$(O) run$(O) pp_hot$(O) sv$(O) pp$(O) scope$(O) pp_ctl$(O) pp_sys$(O) +! obj3 = doop$(O) doio$(O) regexec$(O) taint$(O) deb$(O) globals$(O) + +! obj = $(obj1) $(obj2) $(obj3) $(archobjs) + + # Once perl has been Configure'd and built ok you build different + # perl variants (Debugging, Embedded, Multiplicity etc) by saying: +*************** +*** 175,184 **** + # grrr + SHELL = /bin/sh + +! .c.o: + $(CCCMD) $(PLDLFLAGS) $*.c + +! all: makefile miniperl $(private) $(public) $(dynamic_ext) + @echo " "; echo " Making x2p stuff"; cd x2p; $(MAKE) all + + # This is now done by installman only if you actually want the man pages. +--- 197,206 ---- + # grrr + SHELL = /bin/sh + +! .c$(O): + $(CCCMD) $(PLDLFLAGS) $*.c + +! all: $(firstmakefile) miniperl $(private) $(public) $(dynamic_ext) + @echo " "; echo " Making x2p stuff"; cd x2p; $(MAKE) all + + # This is now done by installman only if you actually want the man pages. +*************** +*** 187,208 **** + # Phony target to force checking subdirectories. + # Apparently some makes require an action for the FORCE target. + FORCE: +! @true + + # The $& notation tells Sequent machines that it can do a parallel make, + # and is harmless otherwise. + +! miniperl: $& miniperlmain.o $(perllib) +! $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain.o $(perllib) $(libs) + +! miniperlmain.o: miniperlmain.c + $(CCCMD) $(PLDLFLAGS) $*.c + +! perlmain.c: miniperlmain.c config.sh makefile $(static_ext_autoinit) + sh writemain $(DYNALOADER) $(static_ext) > tmp + sh mv-if-diff tmp perlmain.c + +! perlmain.o: perlmain.c + $(CCCMD) $(PLDLFLAGS) $*.c + + # The file ext.libs is a list of libraries that must be linked in +--- 209,230 ---- + # Phony target to force checking subdirectories. + # Apparently some makes require an action for the FORCE target. + FORCE: +! @sh -c true + + # The $& notation tells Sequent machines that it can do a parallel make, + # and is harmless otherwise. + +! miniperl: $& miniperlmain$(O) $(perllib) +! $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(O) $(perllib) $(cldlibs) + +! miniperlmain$(O): miniperlmain.c + $(CCCMD) $(PLDLFLAGS) $*.c + +! perlmain.c: miniperlmain.c config.sh $(firstmakefile) $(static_ext_autoinit) + sh writemain $(DYNALOADER) $(static_ext) > tmp + sh mv-if-diff tmp perlmain.c + +! perlmain$(O): perlmain.c + $(CCCMD) $(PLDLFLAGS) $*.c + + # The file ext.libs is a list of libraries that must be linked in +*************** +*** 211,238 **** + ext.libs: $(static_ext) + -@test -f ext.libs || touch ext.libs + +! perl: $& perlmain.o $(perllib) $(DYNALOADER) $(static_ext) ext.libs +! $(SHRPENV) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain.o $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs) + +! pureperl: $& perlmain.o $(perllib) $(DYNALOADER) $(static_ext) ext.libs +! purify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o pureperl perlmain.o $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs) + +- quantperl: $& perlmain.o $(perllib) $(DYNALOADER) $(static_ext) ext.libs +- quantify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o quantperl perlmain.o $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs) + +! $(perllib): $& perl.o $(obj) + !NO!SUBS! + + case "$d_shrplib" in + *define*) + $spitshell >>Makefile <<'!NO!SUBS!' +! $(LD) $(LDDLFLAGS) -o $@ perl.o $(obj) + !NO!SUBS! + ;; + *) + $spitshell >>Makefile <<'!NO!SUBS!' + rm -f $(perllib) +! ar rcu $(perllib) perl.o $(obj) + @$(ranlib) $(perllib) + !NO!SUBS! + ;; +--- 233,280 ---- + ext.libs: $(static_ext) + -@test -f ext.libs || touch ext.libs + +! perl: $& perlmain$(O) $(perllib) $(DYNALOADER) $(static_ext) ext.libs +! $(SHRPENV) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain$(O) $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs) +! +! pureperl: $& perlmain$(O) $(perllib) $(DYNALOADER) $(static_ext) ext.libs +! purify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o pureperl perlmain$(O) $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs) + +! quantperl: $& perlmain$(O) $(perllib) $(DYNALOADER) $(static_ext) ext.libs +! quantify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o quantperl perlmain$(O) $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs) +! +! !NO!SUBS! + + +! case "$d_shrplib" in +! custom) ;; +! *) +! $spitshell >>Makefile <<'!NO!SUBS!' +! $(perllib): $& perl$(O) $(obj) + !NO!SUBS! ++ esac + + case "$d_shrplib" in + *define*) + $spitshell >>Makefile <<'!NO!SUBS!' +! $(LD) $(LDDLFLAGS) -o $@ perl$(O) $(obj) + !NO!SUBS! + ;; ++ custom) ++ if test -r $osname/Makefile.SH ; then ++ . $osname/Makefile.SH ++ $spitshell >>Makefile <>Makefile <<'!NO!SUBS!' + rm -f $(perllib) +! $(AR) rcu $(perllib) perl$(O) $(obj) + @$(ranlib) $(perllib) + !NO!SUBS! + ;; +*************** +*** 245,254 **** + # checks as well as the special code to validate that the script in question + # has been invoked correctly. + +! suidperl: $& sperl.o perlmain.o $(perllib) $(DYNALOADER) $(static_ext) ext.libs +! $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o suidperl perlmain.o sperl.o $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs) + +! sperl.o: perl.c perly.h patchlevel.h $(h) + $(RMS) sperl.c + $(LNS) perl.c sperl.c + $(CCCMD) -DIAMSUID sperl.c +--- 287,296 ---- + # checks as well as the special code to validate that the script in question + # has been invoked correctly. + +! suidperl: $& sperl$(O) perlmain$(O) $(perllib) $(DYNALOADER) $(static_ext) ext.libs +! $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o suidperl perlmain$(O) sperl$(O) $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs) + +! sperl$(O): perl.c perly.h patchlevel.h $(h) + $(RMS) sperl.c + $(LNS) perl.c sperl.c + $(CCCMD) -DIAMSUID sperl.c +*************** +*** 258,264 **** + # test -d lib/auto || mkdir lib/auto + # + preplibrary: miniperl lib/Config.pm +! @./makedir lib/auto + @echo " AutoSplitting perl library" + @./miniperl -Ilib -e 'use AutoSplit; \ + autosplit_lib_modules(@ARGV)' lib/*.pm lib/*/*.pm +--- 300,306 ---- + # test -d lib/auto || mkdir lib/auto + # + preplibrary: miniperl lib/Config.pm +! @sh ./makedir lib/auto + @echo " AutoSplitting perl library" + @./miniperl -Ilib -e 'use AutoSplit; \ + autosplit_lib_modules(@ARGV)' lib/*.pm lib/*/*.pm +*************** +*** 339,346 **** + @sh ext/util/make_ext static $@ LIBPERL_A=$(perllib) + + clean: +! rm -f *.o *.a all perlmain.c + rm -f perl.exp ext.libs + -cd x2p; $(MAKE) clean + -cd pod; $(MAKE) clean + -@for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) ; do \ +--- 381,389 ---- + @sh ext/util/make_ext static $@ LIBPERL_A=$(perllib) + + clean: +! rm -f *$(O) *$(A) all perlmain.c + rm -f perl.exp ext.libs ++ -rm perl.export perl.dll perl.libexp perl.map perl.def + -cd x2p; $(MAKE) clean + -cd pod; $(MAKE) clean + -@for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) ; do \ +*************** +*** 356,362 **** + done + rm -f *.orig */*.orig *~ */*~ core t/core t/c t/perl + rm -rf $(addedbyconf) +! rm -f makefile makefile.old + rm -f $(private) + rm -rf lib/auto + rm -f lib/.exists +--- 399,405 ---- + done + rm -f *.orig */*.orig *~ */*~ core t/core t/c t/perl + rm -rf $(addedbyconf) +! rm -f $(firstmakefile) makefile.old + rm -f $(private) + rm -rf lib/auto + rm -f lib/.exists +*************** +*** 377,383 **** + lint: perly.c $(c) + lint $(lintflags) $(defs) perly.c $(c) > perl.fuzz + +! makefile: Makefile + $(MAKE) depend + + config.h: config.sh +--- 420,426 ---- + lint: perly.c $(c) + lint $(lintflags) $(defs) perly.c $(c) > perl.fuzz + +! $(firstmakefile): Makefile + $(MAKE) depend + + config.h: config.sh +*************** +*** 385,401 **** + + # When done, touch perlmain.c so that it doesn't get remade each time. + depend: makedepend +! ./makedepend + - test -s perlmain.c && touch perlmain.c + cd x2p; $(MAKE) depend + + test: miniperl perl preplibrary $(dynamic_ext) + - cd t && chmod +x TEST */*.t +! - cd t && (rm -f perl; $(LNS) ../perl perl) && ./perl TEST /dev/null 2>&1; then + gccversion=`./gccvers` + case "$gccversion" in + '') echo "You are not using GNU cc." ;; +--- 2165,2171 ---- + exit(0); + } + EOM +! if $cc -o gccvers gccvers.c $ldflags >/dev/null 2>&1; then + gccversion=`./gccvers` + case "$gccversion" in + '') echo "You are not using GNU cc." ;; +*************** +*** 3851,3856 **** +--- 3860,3871 ---- + *"-l$thislib "*);; + *) dflt="$dflt -l$thislib";; + esac ++ elif xxx=`./loc $thislib.lib X $libpth`; $test -f "$xxx"; then ++ echo "Found -l$thislib." ++ case " $dflt " in ++ *"-l$thislib "*);; ++ *) dflt="$dflt -l$thislib";; ++ esac + else + echo "No -l$thislib." + fi +*************** +*** 3964,3975 **** + : + elif try=`./loc lib$thislib.$so X $libpth`; $test -f "$try"; then + : +! elif try=`./loc lib$thislib.a X $libpth`; $test -f "$try"; then + : + elif try=`./loc lib$thislib X $libpth`; $test -f "$try"; then + : + elif try=`./loc $thislib X $libpth`; $test -f "$try"; then + : + elif try=`./loc Slib$thislib.a X $xlibpth`; $test -f "$try"; then + : + else +--- 3979,3992 ---- + : + elif try=`./loc lib$thislib.$so X $libpth`; $test -f "$try"; then + : +! elif try=`./loc lib$thislib$lib_ext X $libpth`; $test -f "$try"; then + : + elif try=`./loc lib$thislib X $libpth`; $test -f "$try"; then + : + elif try=`./loc $thislib X $libpth`; $test -f "$try"; then + : ++ elif try=`./loc $thislib$lib_ext X $libpth`; $test -f "$try"; then ++ : + elif try=`./loc Slib$thislib.a X $xlibpth`; $test -f "$try"; then + : + else +*************** +*** 4018,4028 **** + fi + elif $test -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then + echo "Your C library seems to be in $libc, as you said before." +! elif $test -r $incpath/usr/lib/libc.a; then +! libc=$incpath/usr/lib/libc.a; + echo "Your C library seems to be in $libc. That's fine." +! elif $test -r /lib/libc.a; then +! libc=/lib/libc.a; + echo "Your C library seems to be in $libc. You're normal." + else + if tans=`./loc libc.a blurfl/dyick $libpth`; $test -r "$tans"; then +--- 4035,4045 ---- + fi + elif $test -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then + echo "Your C library seems to be in $libc, as you said before." +! elif $test -r $incpath/usr/lib/libc$lib_ext; then +! libc=$incpath/usr/lib/libc$lib_ext; + echo "Your C library seems to be in $libc. That's fine." +! elif $test -r /lib/libc$lib_ext; then +! libc=/lib/libc$lib_ext; + echo "Your C library seems to be in $libc. You're normal." + else + if tans=`./loc libc.a blurfl/dyick $libpth`; $test -r "$tans"; then +*************** +*** 4135,4140 **** +--- 4152,4161 ---- + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun ++ elif com="$sed -n -e 's/^[-0-9a-f ]*_\(.*\)=.*/\1/p'";\ ++ eval $xscan;\ ++ $contains '^fprintf$' libc.list >/dev/null 2>&1; then ++ eval $xrun + else + nm -p $* 2>/dev/null >libc.tmp + $grep fprintf libc.tmp > libc.ptf +*************** +*** 4145,4167 **** + eval $xrun + else + echo " " +! echo "nm didn't seem to work right. Trying ar instead..." >&4 + com='' +! if ar t $libc > libc.tmp; then + for thisname in $libnames; do +! ar t $thisname >>libc.tmp + done +! $sed -e 's/\.o$//' < libc.tmp > libc.list + echo "Ok." >&4 + else +! echo "ar didn't seem to work right." >&4 + echo "Maybe this is a Cray...trying bld instead..." >&4 + if bld t $libc | $sed -e 's/.*\///' -e 's/\.o:.*$//' > libc.list + then + for thisname in $libnames; do + bld t $libnames | \ + $sed -e 's/.*\///' -e 's/\.o:.*$//' >>libc.list +! ar t $thisname >>libc.tmp + done + echo "Ok." >&4 + else +--- 4166,4189 ---- + eval $xrun + else + echo " " +! echo "nm didn't seem to work right. Trying $ar instead..." >&4 + com='' +! if test "X$osname" = "Xos2"; then ar_opt=tv ; else ar_opt=t ;fi +! if $ar $ar_opt $libc > libc.tmp; then + for thisname in $libnames; do +! $ar $ar_opt $thisname >>libc.tmp + done +! $sed -e 's/\.o$//' -e 's/^ \+//' < libc.tmp | grep -v "^IMPORT#" > libc.list + echo "Ok." >&4 + else +! echo "$ar didn't seem to work right." >&4 + echo "Maybe this is a Cray...trying bld instead..." >&4 + if bld t $libc | $sed -e 's/.*\///' -e 's/\.o:.*$//' > libc.list + then + for thisname in $libnames; do + bld t $libnames | \ + $sed -e 's/.*\///' -e 's/\.o:.*$//' >>libc.list +! $ar t $thisname >>libc.tmp + done + echo "Ok." >&4 + else +*************** +*** 4507,4513 **** + exit(0); + } + EOCP +! if $cc $ccflags try.c -o try >/dev/null 2>&1 && ./try > /dev/null; then + intsize=`./try` + echo "Your integers are $intsize bytes long." + else +--- 4529,4535 ---- + exit(0); + } + EOCP +! if $cc $ccflags $ldflags try.c -o try >/dev/null 2>&1 && ./try > /dev/null; then + intsize=`./try` + echo "Your integers are $intsize bytes long." + else +*************** +*** 4587,4593 **** + exit(result); + } + EOCP +! if $cc -o try $ccflags try.c >/dev/null 2>&1; then + ./try + yyy=$? + else +--- 4609,4615 ---- + exit(result); + } + EOCP +! if $cc -o try $ccflags try.c $ldflags >/dev/null 2>&1; then + ./try + yyy=$? + else +*************** +*** 4668,4674 **** + + } + EOCP +! if $cc -o try $ccflags try.c >/dev/null 2>&1; then + ./try + castflags=$? + else +--- 4690,4696 ---- + + } + EOCP +! if $cc -o try $ccflags try.c $ldflags >/dev/null 2>&1; then + ./try + castflags=$? + else +*************** +*** 4707,4713 **** + exit((unsigned long)vsprintf(buf,"%s",args) > 10L); + } + EOF +! if $cc $ccflags vprintf.c -o vprintf >/dev/null 2>&1 && ./vprintf; then + echo "Your vsprintf() returns (int)." >&4 + val2="$undef" + else +--- 4729,4735 ---- + exit((unsigned long)vsprintf(buf,"%s",args) > 10L); + } + EOF +! if $cc $ccflags vprintf.c $ldflags -o vprintf >/dev/null 2>&1 && ./vprintf; then + echo "Your vsprintf() returns (int)." >&4 + val2="$undef" + else +*************** +*** 4777,4783 **** + cryptlib=-lcrypt + fi + if $test -z "$cryptlib"; then +! cryptlib=`./loc libcrypt.a "" $libpth` + else + cryptlib=-lcrypt + fi +--- 4799,4805 ---- + cryptlib=-lcrypt + fi + if $test -z "$cryptlib"; then +! cryptlib=`./loc libcrypt$lib_ext "" $libpth` + else + cryptlib=-lcrypt + fi +*************** +*** 5284,5290 **** + } + EOM + if $cc $ccflags $cccdlflags -c dyna.c > /dev/null 2>&1 && +! $ld $lddlflags -o dyna.$dlext dyna.o > /dev/null 2>&1 && + $cc $ccflags $ldflags $cccdlflags $ccdlflags fred.c -o fred $libs > /dev/null 2>&1; then + xxx=`./fred` + case $xxx in +--- 5306,5312 ---- + } + EOM + if $cc $ccflags $cccdlflags -c dyna.c > /dev/null 2>&1 && +! $ld $lddlflags -o dyna.$dlext dyna$obj_ext > /dev/null 2>&1 && + $cc $ccflags $ldflags $cccdlflags $ccdlflags fred.c -o fred $libs > /dev/null 2>&1; then + xxx=`./fred` + case $xxx in +*************** +*** 5441,5447 **** + EOCP + : check sys/file.h first to get FREAD on Sun + if $test `./findhdr sys/file.h` && \ +! $cc $cppflags "-DI_SYS_FILE" open3.c -o open3 >/dev/null 2>&1 ; then + h_sysfile=true; + echo " defines the O_* constants..." >&4 + if ./open3; then +--- 5463,5469 ---- + EOCP + : check sys/file.h first to get FREAD on Sun + if $test `./findhdr sys/file.h` && \ +! $cc $cppflags $ldflags "-DI_SYS_FILE" open3.c -o open3 >/dev/null 2>&1 ; then + h_sysfile=true; + echo " defines the O_* constants..." >&4 + if ./open3; then +*************** +*** 5452,5458 **** + val="$undef" + fi + elif $test `./findhdr fcntl.h` && \ +! $cc "-DI_FCNTL" open3.c -o open3 >/dev/null 2>&1 ; then + h_fcntl=true; + echo " defines the O_* constants..." >&4 + if ./open3; then +--- 5474,5480 ---- + val="$undef" + fi + elif $test `./findhdr fcntl.h` && \ +! $cc "-DI_FCNTL" $ldflags open3.c -o open3 >/dev/null 2>&1 ; then + h_fcntl=true; + echo " defines the O_* constants..." >&4 + if ./open3; then +*************** +*** 5931,5937 **** + y*|true) + usemymalloc='y' + mallocsrc='malloc.c' +! mallocobj='malloc.o' + d_mymalloc="$define" + case "$libs" in + *-lmalloc*) +--- 5953,5959 ---- + y*|true) + usemymalloc='y' + mallocsrc='malloc.c' +! mallocobj="malloc$obj_ext" + d_mymalloc="$define" + case "$libs" in + *-lmalloc*) +*************** +*** 6366,6375 **** + : we will have to assume that it supports the 4.2 BSD interface + d_oldsock="$undef" + else +! echo "You don't have Berkeley networking in libc.a..." >&4 +! if test -f /usr/lib/libnet.a; then +! ( (nm $nm_opt /usr/lib/libnet.a | eval $nm_extract) || \ +! ar t /usr/lib/libnet.a) 2>/dev/null >> libc.list + if $contains socket libc.list >/dev/null 2>&1; then + echo "...but the Wollongong group seems to have hacked it in." >&4 + socketlib="-lnet" +--- 6388,6397 ---- + : we will have to assume that it supports the 4.2 BSD interface + d_oldsock="$undef" + else +! echo "You don't have Berkeley networking in libc$lib_ext..." >&4 +! if test -f /usr/lib/libnet$lib_ext; then +! ( (nm $nm_opt /usr/lib/libnet$lib_ext | eval $nm_extract) || \ +! $ar t /usr/lib/libnet$lib_ext) 2>/dev/null >> libc.list + if $contains socket libc.list >/dev/null 2>&1; then + echo "...but the Wollongong group seems to have hacked it in." >&4 + socketlib="-lnet" +*************** +*** 6382,6388 **** + d_oldsock="$define" + fi + else +! echo "or even in libnet.a, which is peculiar." >&4 + d_socket="$undef" + d_oldsock="$undef" + fi +--- 6404,6410 ---- + d_oldsock="$define" + fi + else +! echo "or even in libnet$lib_ext, which is peculiar." >&4 + d_socket="$undef" + d_oldsock="$undef" + fi +*************** +*** 6905,6911 **** + printf("%d\n", (char *)&try.bar - (char *)&try.foo); + } + EOCP +! if $cc $ccflags try.c -o try >/dev/null 2>&1; then + dflt=`./try` + else + dflt='8' +--- 6927,6933 ---- + printf("%d\n", (char *)&try.bar - (char *)&try.foo); + } + EOCP +! if $cc $ccflags $ldflags try.c -o try >/dev/null 2>&1; then + dflt=`./try` + else + dflt='8' +*************** +*** 6953,6959 **** + } + EOCP + xxx_prompt=y +! if $cc $ccflags try.c -o try >/dev/null 2>&1 && ./try > /dev/null; then + dflt=`./try` + case "$dflt" in + [1-4][1-4][1-4][1-4]|12345678|87654321) +--- 6975,6981 ---- + } + EOCP + xxx_prompt=y +! if $cc $ccflags $ldflags try.c -o try >/dev/null 2>&1 && ./try > /dev/null; then + dflt=`./try` + case "$dflt" in + [1-4][1-4][1-4][1-4]|12345678|87654321) +*************** +*** 7531,7537 **** + printf("%d\n",i); + } + EOCP +! if $cc try.c -o try >/dev/null 2>&1 ; then + dflt=`try` + else + dflt='?' +--- 7553,7559 ---- + printf("%d\n",i); + } + EOCP +! if $cc $ldflags try.c -o try >/dev/null 2>&1 ; then + dflt=`try` + else + dflt='?' +*************** +*** 7558,7575 **** + $cc $ccflags -c bar1.c >/dev/null 2>&1 + $cc $ccflags -c bar2.c >/dev/null 2>&1 + $cc $ccflags -c foo.c >/dev/null 2>&1 +! ar rc bar.a bar2.o bar1.o >/dev/null 2>&1 +! if $cc $ccflags $ldflags -o foobar foo.o bar.a $libs > /dev/null 2>&1 && + ./foobar >/dev/null 2>&1; then +! echo "ar appears to generate random libraries itself." + orderlib=false + ranlib=":" +! elif ar ts bar.a >/dev/null 2>&1 && +! $cc $ccflags $ldflags -o foobar foo.o bar.a $libs > /dev/null 2>&1 && + ./foobar >/dev/null 2>&1; then + echo "a table of contents needs to be added with 'ar ts'." + orderlib=false +! ranlib="ar ts" + else + case "$ranlib" in + :) ranlib='';; +--- 7580,7597 ---- + $cc $ccflags -c bar1.c >/dev/null 2>&1 + $cc $ccflags -c bar2.c >/dev/null 2>&1 + $cc $ccflags -c foo.c >/dev/null 2>&1 +! $ar rc bar$lib_ext bar2$obj_ext bar1$obj_ext >/dev/null 2>&1 +! if $cc $ccflags $ldflags -o foobar foo$obj_ext bar$lib_ext $libs > /dev/null 2>&1 && + ./foobar >/dev/null 2>&1; then +! echo "$ar appears to generate random libraries itself." + orderlib=false + ranlib=":" +! elif $ar ts bar$lib_ext >/dev/null 2>&1 && +! $cc $ccflags $ldflags -o foobar foo$obj_ext bar$lib_ext $libs > /dev/null 2>&1 && + ./foobar >/dev/null 2>&1; then + echo "a table of contents needs to be added with 'ar ts'." + orderlib=false +! ranlib="$ar ts" + else + case "$ranlib" in + :) ranlib='';; +*************** +*** 7641,7647 **** + '') $echo $n ".$c" + if $cc $ccflags \ + $i_time $i_systime $i_systimek $sysselect $s_timeval $s_timezone \ +! try.c -o try >/dev/null 2>&1 ; then + set X $i_time $i_systime $i_systimek $sysselect $s_timeval + shift + flags="$*" +--- 7663,7669 ---- + '') $echo $n ".$c" + if $cc $ccflags \ + $i_time $i_systime $i_systimek $sysselect $s_timeval $s_timezone \ +! try.c -o try $ldflags >/dev/null 2>&1 ; then + set X $i_time $i_systime $i_systimek $sysselect $s_timeval + shift + flags="$*" +*************** +*** 7710,7716 **** + #endif + } + EOCP +! if $cc $ccflags -DTRYBITS fd_set.c -o fd_set >fd_set.out 2>&1 ; then + d_fds_bits="$define" + d_fd_set="$define" + echo "Well, your system knows about the normal fd_set typedef..." >&4 +--- 7732,7738 ---- + #endif + } + EOCP +! if $cc $ccflags $ldflags -DTRYBITS fd_set.c -o fd_set >fd_set.out 2>&1 ; then + d_fds_bits="$define" + d_fd_set="$define" + echo "Well, your system knows about the normal fd_set typedef..." >&4 +*************** +*** 7727,7733 **** + $cat <<'EOM' + Hmm, your compiler has some difficulty with fd_set. Checking further... + EOM +! if $cc $ccflags fd_set.c -o fd_set >fd_set.out 2>&1 ; then + d_fds_bits="$undef" + d_fd_set="$define" + echo "Well, your system has some sort of fd_set available..." >&4 +--- 7749,7755 ---- + $cat <<'EOM' + Hmm, your compiler has some difficulty with fd_set. Checking further... + EOM +! if $cc $ccflags $ldflags fd_set.c -o fd_set >fd_set.out 2>&1 ; then + d_fds_bits="$undef" + d_fd_set="$define" + echo "Well, your system has some sort of fd_set available..." >&4 +*************** +*** 8353,8359 **** + else + echo "false" + fi +! $rm -f varargs.o + EOP + chmod +x varargs + +--- 8375,8381 ---- + else + echo "false" + fi +! $rm -f varargs$obj_ext + EOP + chmod +x varargs + +*************** +*** 8496,8506 **** + echo " " + echo "Stripping down executable paths..." >&4 + for file in $loclist $trylist; do +! eval $file="\$file" + done + ;; + esac + + : create config.sh file + echo " " + echo "Creating config.sh..." >&4 +--- 8518,8531 ---- + echo " " + echo "Stripping down executable paths..." >&4 + for file in $loclist $trylist; do +! if test X$file != Xln -o X$osname != Xos2; then eval $file="\$file"; fi + done + ;; + esac + ++ # Setup libraries for linking miniperl (if not set already) ++ : ${cldlibs="$libs $cryptlib"} ++ + : create config.sh file + echo " " + echo "Creating config.sh..." >&4 +*************** +*** 8556,8561 **** +--- 8581,8587 ---- + chmod='$chmod' + chown='$chown' + clocktype='$clocktype' ++ cldlibs='$cldlibs' + comm='$comm' + compress='$compress' + contains='$contains' +*************** +*** 8752,8757 **** +--- 8778,8784 ---- + expr='$expr' + extensions='$extensions' + find='$find' ++ firstmakefile='$firstmakefile' + flex='$flex' + fpostype='$fpostype' + freetype='$freetype' +*************** +*** 8962,8967 **** +--- 8989,9002 ---- + voidflags='$voidflags' + xlibpth='$xlibpth' + zcat='$zcat' ++ archobjs='$archobjs' ++ obj_ext='$obj_ext' ++ obj_ext_regexp='$obj_ext_regexp' ++ lib_ext='$lib_ext' ++ exe_ext='$exe_ext' ++ ar='$ar' ++ plibext='$plibext' ++ path_sep='$path_sep' + EOT + + : add special variables diff --git a/os2/diff.installperl b/os2/diff.installperl new file mode 100644 index 0000000000..c94db2e464 --- /dev/null +++ b/os2/diff.installperl @@ -0,0 +1,248 @@ +diff -cr ..\perl5os2.patch\perl5.001m.andy/installperl ./installperl +*** ../perl5os2.patch/perl5.001m.andy/installperl Wed Jun 21 12:09:26 1995 +--- ./installperl Thu Sep 28 00:00:20 1995 +*************** +*** 24,35 **** + # Read in the config file. + + open(CONFIG, "config.sh") || die "You haven't run Configure yet!\n"; +! while () { +! if (s/^(\w+=)/\$$1/) { + $accum =~ s/'undef'/undef/g; + eval $accum; + $accum = ''; + } + $accum .= $_; + } + close CONFIG; +--- 24,37 ---- + # Read in the config file. + + open(CONFIG, "config.sh") || die "You haven't run Configure yet!\n"; +! while (1) { +! $_ = ; +! if (s/^(\w+=)/\$$1/ or not defined $_) { + $accum =~ s/'undef'/undef/g; + eval $accum; + $accum = ''; + } ++ last unless defined $_; # To get the last two lines too + $accum .= $_; + } + close CONFIG; +*************** +*** 50,57 **** + -w $installbin || die "$installbin is not writable by you\n" + unless $installbin =~ m#^/afs/# || $nonono; + +! -x 'perl' || die "perl isn't executable!\n"; +! -x 'suidperl' || die "suidperl isn't executable!\n" if $d_dosuid; + + -x 't/TEST' || warn "WARNING: You've never run 'make test'!!!", + " (Installing anyway.)\n"; +--- 52,59 ---- + -w $installbin || die "$installbin is not writable by you\n" + unless $installbin =~ m#^/afs/# || $nonono; + +! -x 'perl' . $exe_ext || die "perl isn't executable!\n"; +! -x 'suidperl' . $exe_ext|| die "suidperl isn't executable!\n" if $d_dosuid; + + -x 't/TEST' || warn "WARNING: You've never run 'make test'!!!", + " (Installing anyway.)\n"; +*************** +*** 69,81 **** + + # First we install the version-numbered executables. + +! &safe_unlink("$installbin/perl$ver"); +! &cmd("cp perl $installbin/perl$ver"); + +! &safe_unlink("$installbin/sperl$ver"); + if ($d_dosuid) { +! &cmd("cp suidperl $installbin/sperl$ver"); +! &chmod(04711, "$installbin/sperl$ver"); + } + + exit 0 if $versiononly; +--- 71,83 ---- + + # First we install the version-numbered executables. + +! &safe_unlink("$installbin/perl$ver$exe_ext"); +! &cmd("cp perl$exe_ext $installbin/perl$ver$exe_ext"); + +! &safe_unlink("$installbin/sperl$ver$exe_ext"); + if ($d_dosuid) { +! &cmd("cp suidperl$exe_ext $installbin/sperl$ver$exe_ext"); +! &chmod(04711, "$installbin/sperl$ver$exe_ext"); + } + + exit 0 if $versiononly; +*************** +*** 83,97 **** + # Make links to ordinary names if installbin directory isn't current directory. + + if (! &samepath($installbin, '.')) { +! &safe_unlink("$installbin/perl", "$installbin/suidperl"); +! &link("$installbin/perl$ver", "$installbin/perl"); +! &link("$installbin/sperl$ver", "$installbin/suidperl") if $d_dosuid; + } + + if (! &samepath($installbin, 'x2p')) { +! &safe_unlink("$installbin/a2p"); +! &cmd("cp x2p/a2p $installbin/a2p"); +! &chmod(0755, "$installbin/a2p"); + } + + # Install scripts. +--- 85,100 ---- + # Make links to ordinary names if installbin directory isn't current directory. + + if (! &samepath($installbin, '.')) { +! &safe_unlink("$installbin/perl$exe_ext", "$installbin/suidperl$exe_ext"); +! &link("$installbin/perl$ver$exe_ext", "$installbin/perl$exe_ext"); +! &link("$installbin/sperl$ver$exe_ext", "$installbin/suidperl$exe_ext") +! if $d_dosuid; + } + + if (! &samepath($installbin, 'x2p')) { +! &safe_unlink("$installbin/a2p$exe_ext"); +! &cmd("cp x2p/a2p$exe_ext $installbin/a2p$exe_ext"); +! &chmod(0755, "$installbin/a2p$exe_ext"); + } + + # Install scripts. +*************** +*** 174,187 **** + if (-w $mainperldir && ! &samepath($mainperldir, $installbin) && !$nonono) { + # First make sure $mainperldir/perl is not already the same as + # the perl we just installed +! if (-x "$mainperldir/perl") { + # Try to be clever about mainperl being a symbolic link + # to binexp/perl if binexp and installbin are different. + $mainperl_is_instperl = +! &samepath("$mainperldir/perl", "$installbin/perl") || + (($binexp ne $installbin) && +! (-l "$mainperldir/perl") && +! ((readlink "$mainperldir/perl") eq "$binexp/perl")); + } + if ((! $mainperl_is_instperl) && + (&yn("Many scripts expect perl to be installed as " . +--- 177,190 ---- + if (-w $mainperldir && ! &samepath($mainperldir, $installbin) && !$nonono) { + # First make sure $mainperldir/perl is not already the same as + # the perl we just installed +! if (-x "$mainperldir/perl$exe_ext") { + # Try to be clever about mainperl being a symbolic link + # to binexp/perl if binexp and installbin are different. + $mainperl_is_instperl = +! &samepath("$mainperldir/perl$exe_ext", "$installbin/perl$exe_ext") || + (($binexp ne $installbin) && +! (-l "$mainperldir/perl$exe_ext") && +! ((readlink "$mainperldir/perl$exe_ext") eq "$binexp/perl$exe_ext")); + } + if ((! $mainperl_is_instperl) && + (&yn("Many scripts expect perl to be installed as " . +*************** +*** 189,198 **** + "Do you wish to have $mainperldir/perl be the same as\n" . + "$binexp/perl? [y] "))) + { +! unlink("$mainperldir/perl"); +! eval 'link("$installbin/perl", "$mainperldir/perl")' || +! eval 'symlink("$binexp/perl", "$mainperldir/perl")' || +! &cmd("cp $installbin/perl $mainperldir"); + $mainperl_is_instperl = 1; + } + } +--- 192,201 ---- + "Do you wish to have $mainperldir/perl be the same as\n" . + "$binexp/perl? [y] "))) + { +! unlink("$mainperldir/perl$exe_ext"); +! eval 'link("$installbin/perl$exe_ext", "$mainperldir/perl$exe_ext")' || +! eval 'symlink("$binexp/perl$exe_ext", "$mainperldir/perl$exe_ext")' || +! &cmd("cp $installbin/perl$exe_ext $mainperldir$exe_ext"); + $mainperl_is_instperl = 1; + } + } +*************** +*** 203,209 **** + # Also skip $mainperl if the user opted to have it be a link to the + # installed perl. + +! @path = split(/:/, $ENV{"PATH"}); + @otherperls = (); + for (@path) { + next unless m,^/,; +--- 206,214 ---- + # Also skip $mainperl if the user opted to have it be a link to the + # installed perl. + +! $dirsep = ($osname =~ m:^os/?2$:i) ? ';' : ':' ; +! ($path = $ENV{"PATH"}) =~ s:\\:/:g ; +! @path = split(/$dirsep/, $path); + @otherperls = (); + for (@path) { + next unless m,^/,; +*************** +*** 211,217 **** + # Use &samepath here because some systems have other dirs linked + # to $mainperldir (like SunOS) + next if ($mainperl_is_instperl && &samepath($_, $mainperldir)); +! push(@otherperls, "$_/perl") if (-x "$_/perl" && ! -d "$_/perl"); + } + if (@otherperls) { + print STDERR "\nWarning: perl appears in your path in the following " . +--- 216,223 ---- + # Use &samepath here because some systems have other dirs linked + # to $mainperldir (like SunOS) + next if ($mainperl_is_instperl && &samepath($_, $mainperldir)); +! push(@otherperls, "$_/perl$exe_ext") +! if (-x "$_/perl$exe_ext" && ! -d "$_/perl$exe_ext"); + } + if (@otherperls) { + print STDERR "\nWarning: perl appears in your path in the following " . +*************** +*** 244,249 **** +--- 250,256 ---- + foreach $name (@names) { + next unless -e $name; + print STDERR " unlink $name\n"; ++ chmod 0777, $name if $osname =~ m:^os/?2$:i ; + unlink($name) || warn "Couldn't unlink $name: $!\n" unless $nonono; + } + } +*************** +*** 255,260 **** +--- 262,268 ---- + next unless -e $name; + print STDERR " unlink $name\n"; + next if $nonono; ++ chmod 0777, $name if $osname =~ m:^os/?2$:i ; + next if unlink($name); + warn "Couldn't unlink $name: $!\n"; + if ($! =~ /busy/i) { +*************** +*** 290,296 **** + local($from,$to) = @_; + + print STDERR " ln $from $to\n"; +! link($from,$to) || warn "Couldn't link $from to $to: $!\n" unless $nonono; + } + + sub chmod { +--- 298,310 ---- + local($from,$to) = @_; + + print STDERR " ln $from $to\n"; +! eval { +! link($from,$to) || warn "Couldn't link $from to $to: $!\n" unless $nonono; +! }; +! if ($@) { +! system( $cp, $from, $to ) +! && warn "Couldn't copy $from to $to: $!\n" unless $nonono; +! } + } + + sub chmod { diff --git a/os2/diff.mkdep b/os2/diff.mkdep new file mode 100644 index 0000000000..595d260238 --- /dev/null +++ b/os2/diff.mkdep @@ -0,0 +1,128 @@ +diff -cr ..\perl5os2.patch\perl5.001m.andy/makedepend.SH ./makedepend.SH +*** ../perl5os2.patch/perl5.001m.andy/makedepend.SH Mon Oct 09 21:41:04 1995 +--- ./makedepend.SH Thu Sep 28 00:00:28 1995 +*************** +*** 43,48 **** +--- 43,51 ---- + ;; + esac + ++ # In case Configure is not patched: ++ : ${firstmakefile=makefile} ++ + # We need .. when we are in the x2p directory if we are using the + # cppstdin wrapper script. + # Put .. and . first so that we pick up the present cppstdin, not +*************** +*** 53,69 **** + $cat /dev/null >.deptmp + $rm -f *.c.c c/*.c.c + if test -f Makefile; then +! cp Makefile makefile + fi +! mf=makefile + if test -f $mf; then + defrule=`<$mf sed -n \ +! -e '/^\.c\.o:.*;/{' \ + -e 's/\$\*\.c//' \ + -e 's/^[^;]*;[ ]*//p' \ + -e q \ + -e '}' \ +! -e '/^\.c\.o: *$/{' \ + -e N \ + -e 's/\$\*\.c//' \ + -e 's/^.*\n[ ]*//p' \ +--- 56,72 ---- + $cat /dev/null >.deptmp + $rm -f *.c.c c/*.c.c + if test -f Makefile; then +! cp Makefile $firstmakefile + fi +! mf=$firstmakefile + if test -f $mf; then + defrule=`<$mf sed -n \ +! -e '/^\.c\$(O_REGEXP):.*;/{' \ + -e 's/\$\*\.c//' \ + -e 's/^[^;]*;[ ]*//p' \ + -e q \ + -e '}' \ +! -e '/^\.c\$(O_REGEXP): *$/{' \ + -e N \ + -e 's/\$\*\.c//' \ + -e 's/^.*\n[ ]*//p' \ +*************** +*** 91,97 **** + */*) finc="-I`echo $file | sed 's#/[^/]*$##`" ;; + *) finc= ;; + esac +! $echo "Finding dependencies for $filebase.o." + ( $echo "#line 1 \"$file\""; \ + $sed -n <$file \ + -e "/^${filebase}_init(/q" \ +--- 94,100 ---- + */*) finc="-I`echo $file | sed 's#/[^/]*$##`" ;; + *) finc= ;; + esac +! $echo "Finding dependencies for $filebase$obj_ext." + ( $echo "#line 1 \"$file\""; \ + $sed -n <$file \ + -e "/^${filebase}_init(/q" \ +*************** +*** 107,114 **** + -e 's#\.[0-9][0-9]*\.c#'"$file.c#" \ + -e 's/^[ ]*#[ ]*line/#/' \ + -e '/^# *[0-9][0-9]* *[".\/]/!d' \ +! -e 's/^.*"\(.*\)".*$/'$filebase'.o: \1/' \ +! -e 's/^# *[0-9][0-9]* \(.*\)$/'$filebase'.o: \1/' \ + -e 's|: \./|: |' \ + -e 's|\.c\.c|.c|' | \ + $uniq | $sort | $uniq >> .deptmp +--- 110,117 ---- + -e 's#\.[0-9][0-9]*\.c#'"$file.c#" \ + -e 's/^[ ]*#[ ]*line/#/' \ + -e '/^# *[0-9][0-9]* *[".\/]/!d' \ +! -e 's/^.*"\(.*\)".*$/'$filebase'\$(O): \1/' \ +! -e 's/^# *[0-9][0-9]* \(.*\)$/'$filebase'\$(O): \1/' \ + -e 's|: \./|: |' \ + -e 's|\.c\.c|.c|' | \ + $uniq | $sort | $uniq >> .deptmp +*************** +*** 126,132 **** + $echo "Updating $mf..." + $echo "# If this runs make out of memory, delete /usr/include lines." \ + >> $mf.new +! $sed 's|^\(.*\.o:\) *\(.*/.*\.c\) *$|\1 \2; '"$defrule \2|" .deptmp \ + >>$mf.new + else + $MAKE hlist || ($echo "Searching for .h files..."; \ +--- 129,135 ---- + $echo "Updating $mf..." + $echo "# If this runs make out of memory, delete /usr/include lines." \ + >> $mf.new +! $sed 's|^\(.*\$(O_REGEXP):\) *\(.*/.*\.c\) *$|\1 \2; '"$defrule \2|" .deptmp \ + >>$mf.new + else + $MAKE hlist || ($echo "Searching for .h files..."; \ +*************** +*** 136,145 **** + $echo "Updating $mf..." + <.clist $sed -n \ + -e '/\//{' \ +! -e 's|^\(.*\)/\(.*\)\.c|\2.o: \1/\2.c; '"$defrule \1/\2.c|p" \ + -e d \ + -e '}' \ +! -e 's|^\(.*\)\.c|\1.o: \1.c|p' >> $mf.new + <.hlist $sed -n 's|\(.*/\)\(.*\)|s= \2= \1\2=|p' >.hsed + <.deptmp $sed -n 's|c:#include "\(.*\)".*$|o: \1|p' | \ + $sed 's|^[^;]*/||' | \ +--- 139,148 ---- + $echo "Updating $mf..." + <.clist $sed -n \ + -e '/\//{' \ +! -e 's|^\(.*\)/\(.*\)\.c|\2\$(O): \1/\2.c; '"$defrule \1/\2.c|p" \ + -e d \ + -e '}' \ +! -e 's|^\(.*\)\.c|\1\$(O): \1.c|p' >> $mf.new + <.hlist $sed -n 's|\(.*/\)\(.*\)|s= \2= \1\2=|p' >.hsed + <.deptmp $sed -n 's|c:#include "\(.*\)".*$|o: \1|p' | \ + $sed 's|^[^;]*/||' | \ diff --git a/os2/diff.x2pMakefile b/os2/diff.x2pMakefile new file mode 100644 index 0000000000..af3058452f --- /dev/null +++ b/os2/diff.x2pMakefile @@ -0,0 +1,222 @@ +diff -cr ..\perl5os2.patch\perl5.001m.andy/x2p/Makefile.SH ./x2p/Makefile.SH +*** ../perl5os2.patch/perl5.001m.andy/x2p/Makefile.SH Fri May 26 07:33:48 1995 +--- ./x2p/Makefile.SH Thu Sep 28 00:00:42 1995 +*************** +*** 17,22 **** +--- 17,25 ---- + */*) cd `expr X$0 : 'X\(.*\)/'` ;; + esac + ++ # In case Configure is not patched: ++ : ${obj_ext=.o} ${obj_ext_regexp='\.o'} ${lib_ext=.a} ${ar=ar} ${firstmakefile=makefile} ++ + echo "Extracting x2p/Makefile (with variable substitutions)" + rm -f Makefile + cat >Makefile <>Makefile <<'!NO!SUBS!' +*************** +*** 56,76 **** + + c = hash.c $(mallocsrc) str.c util.c walk.c + +! obj = hash.o $(mallocobj) str.o util.o walk.o + + lintflags = -phbvxac + + # grrr + SHELL = /bin/sh + +! .c.o: + $(CCCMD) $*.c + + all: $(public) $(private) $(util) + touch all + +! a2p: $(obj) a2p.o +! $(CC) $(LDFLAGS) $(obj) a2p.o $(libs) -o a2p + + # I now supply a2p.c with the kits, so the following section is + # used only if you force byacc to run by saying +--- 67,87 ---- + + c = hash.c $(mallocsrc) str.c util.c walk.c + +! obj = hash$(O) $(mallocobj) str$(O) util$(O) walk$(O) + + lintflags = -phbvxac + + # grrr + SHELL = /bin/sh + +! .c$(O): + $(CCCMD) $*.c + + all: $(public) $(private) $(util) + touch all + +! a2p: $(obj) a2p$(O) +! $(CC) $(LDFLAGS) $(obj) a2p$(O) $(libs) -o a2p + + # I now supply a2p.c with the kits, so the following section is + # used only if you force byacc to run by saying +*************** +*** 86,100 **** + a2p.c: a2p.y + -@touch a2p.c + +! a2p.o: a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h handy.h ../config.h str.h hash.h + $(CCCMD) $(LARGE) a2p.c + + clean: +! rm -f a2p *.o + + realclean: clean + rm -f *.orig core $(addedbyconf) all malloc.c +! rm -f makefile makefile.old + + # The following lint has practically everything turned on. Unfortunately, + # you have to wade through a lot of mumbo jumbo that can't be suppressed. +--- 97,111 ---- + a2p.c: a2p.y + -@touch a2p.c + +! a2p$(O): a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h handy.h ../config.h str.h hash.h + $(CCCMD) $(LARGE) a2p.c + + clean: +! rm -f a2p *$(O) + + realclean: clean + rm -f *.orig core $(addedbyconf) all malloc.c +! rm -f $(firstmakefile) makefile.old + + # The following lint has practically everything turned on. Unfortunately, + # you have to wade through a lot of mumbo jumbo that can't be suppressed. +*************** +*** 105,111 **** + lint $(lintflags) $(defs) $(c) > a2p.fuzz + + depend: $(mallocsrc) ../makedepend +! ../makedepend + + clist: + echo $(c) | tr ' ' '\012' >.clist +--- 116,122 ---- + lint $(lintflags) $(defs) $(c) > a2p.fuzz + + depend: $(mallocsrc) ../makedepend +! sh ../makedepend + + clist: + echo $(c) | tr ' ' '\012' >.clist +*************** +*** 131,137 **** + case `pwd` in + *SH) + $rm -f ../Makefile +! ln Makefile ../Makefile + ;; + esac +! rm -f makefile +--- 142,148 ---- + case `pwd` in + *SH) + $rm -f ../Makefile +! $ln Makefile ../Makefile + ;; + esac +! rm -f $firstmakefile +*** installman.orig Thu Jun 22 10:42:40 1995 +--- installman Thu Nov 02 04:07:38 1995 +*************** +*** 6,11 **** +--- 6,12 ---- + require Cwd; + + umask 022; ++ $ENV{SHELL} = 'sh' if $Config{osname} eq 'os2'; + + $ver = $]; + $release = substr($ver,0,3); # Not used presently. +*************** +*** 38,48 **** + + #Sanity checks + +! -x "./perl" || warn "./perl not found! Have you run make?\n"; + -d $Config{'installprivlib'} + || warn "Perl library directory $Config{'installprivlib'} not found. + Have you run make install?. (Installing anyway.)\n"; +! -x 't/TEST' || warn "WARNING: You've never run 'make test'!!!", + " (Installing anyway.)\n"; + + # Install the main pod pages. +--- 39,50 ---- + + #Sanity checks + +! -x "./perl$Config{exe_ext}" +! or warn "./perl$Config{exe_ext} not found! Have you run make?\n"; + -d $Config{'installprivlib'} + || warn "Perl library directory $Config{'installprivlib'} not found. + Have you run make install?. (Installing anyway.)\n"; +! -x "t/perl$Config{exe_ext}" || warn "WARNING: You've never run 'make test'!!!", + " (Installing anyway.)\n"; + + # Install the main pod pages. +*************** +*** 66,72 **** + # are enhancements or changes from previous installed versions. + # The error message doesn't include the '..' because the user + # won't be aware that we've chdir to $poddir. +! -x "../pod/pod2man" || die "Executable pod/pod2man not found.\n"; + + # We want to be sure to use the current perl. We can't rely on + # the installed perl because it might not be actually installed +--- 68,74 ---- + # are enhancements or changes from previous installed versions. + # The error message doesn't include the '..' because the user + # won't be aware that we've chdir to $poddir. +! -r "../pod/pod2man" || die "Executable pod/pod2man not found.\n"; + + # We want to be sure to use the current perl. We can't rely on + # the installed perl because it might not be actually installed +*************** +*** 86,92 **** + # Convert name from File/Basename.pm to File::Basename.3 format, + # if necessary. + $manpage =~ s#\.p(m|od)$##; +! $manpage =~ s#/#::#g; + $manpage = "${mandir}/${manpage}.${manext}"; + # Print $release $patchlevel stuff? or should pod2man do that? + &cmd("$pod2man $mod > $manpage"); +--- 88,98 ---- + # Convert name from File/Basename.pm to File::Basename.3 format, + # if necessary. + $manpage =~ s#\.p(m|od)$##; +! if ($Config{osname} eq "os2") { +! $manpage =~ s#/#.#g; +! } else { +! $manpage =~ s#/#::#g; +! } + $manpage = "${mandir}/${manpage}.${manext}"; + # Print $release $patchlevel stuff? or should pod2man do that? + &cmd("$pod2man $mod > $manpage"); diff --git a/os2/os2.c b/os2/os2.c new file mode 100644 index 0000000000..f6c76082bd --- /dev/null +++ b/os2/os2.c @@ -0,0 +1,215 @@ +#define INCL_DOS +#define INCL_NOPM +#include + +/* + * Various Unix compatibility functions for OS/2 + */ + +#include +#include +#include +#include + +#include "EXTERN.h" +#include "perl.h" + +/*****************************************************************************/ +/* priorities */ + +int setpriority(int which, int pid, int val) +{ + return DosSetPriority((pid < 0) ? PRTYS_PROCESSTREE : PRTYS_PROCESS, + val >> 8, val & 0xFF, abs(pid)); +} + +int getpriority(int which /* ignored */, int pid) +{ + TIB *tib; + PIB *pib; + DosGetInfoBlocks(&tib, &pib); + return tib->tib_ptib2->tib2_ulpri; +} + +/*****************************************************************************/ +/* spawn */ + +static int +result(int flag, int pid) +{ + int r, status; + Signal_t (*ihand)(); /* place to save signal during system() */ + Signal_t (*qhand)(); /* place to save signal during system() */ + + if (pid < 0 || flag != 0) + return pid; + + ihand = signal(SIGINT, SIG_IGN); + qhand = signal(SIGQUIT, SIG_IGN); + r = waitpid(pid, &status, 0); + signal(SIGINT, ihand); + signal(SIGQUIT, qhand); + + statusvalue = (U16)status; + if (r < 0) + return -1; + return status & 0xFFFF; +} + +int +do_aspawn(really,mark,sp) +SV *really; +register SV **mark; +register SV **sp; +{ + register char **a; + char *tmps; + int rc; + int flag = P_WAIT, trueflag; + + if (sp > mark) { + New(401,Argv, sp - mark + 1, char*); + a = Argv; + + if (mark < sp && SvIOKp(*(mark+1))) { + ++mark; + flag = SvIVx(*mark); + } + + while (++mark <= sp) { + if (*mark) + *a++ = SvPVx(*mark, na); + else + *a++ = ""; + } + *a = Nullch; + + trueflag = flag; + if (flag == P_WAIT) + flag = P_NOWAIT; + + if (really && *(tmps = SvPV(really, na))) + rc = result(trueflag, spawnvp(flag,tmps,Argv)); + else + rc = result(trueflag, spawnvp(flag,Argv[0],Argv)); + + if (rc < 0 && dowarn) + warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno)); + } else + rc = -1; + do_execfree(); + return rc; +} + +int +do_spawn(cmd) +char *cmd; +{ + register char **a; + register char *s; + char flags[10]; + char *shell, *copt; + int rc; + + if ((shell = getenv("SHELL")) != NULL) + copt = "-c"; + else if ((shell = getenv("COMSPEC")) != NULL) + copt = "/C"; + else + shell = "cmd.exe"; + + /* save an extra exec if possible */ + /* see if there are shell metacharacters in it */ + + /*SUPPRESS 530*/ + if (*cmd == '@') { + ++cmd; + goto shell_cmd; + } + for (s = cmd; *s; s++) { + if (*s != ' ' && !isALPHA(*s) && strchr("%&|<>\n",*s)) { + if (*s == '\n' && !s[1]) { + *s = '\0'; + break; + } +shell_cmd: return result(P_WAIT, spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); + } + } + New(402,Argv, (s - cmd) / 2 + 2, char*); + Cmd = savepvn(cmd, s-cmd); + a = Argv; + for (s = Cmd; *s;) { + while (*s && isSPACE(*s)) s++; + if (*s) + *(a++) = s; + while (*s && !isSPACE(*s)) s++; + if (*s) + *s++ = '\0'; + } + *a = Nullch; + if (Argv[0]) { + rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv)); + if (rc < 0 && dowarn) + warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno)); + } else + rc = -1; + do_execfree(); + return rc; +} + +/*****************************************************************************/ + +#ifndef HAS_FORK +int +fork(void) +{ + die(no_func, "Unsupported function fork"); + errno = EINVAL; + return -1; +} +#endif + +/*****************************************************************************/ +/* not implemented in EMX 0.9a */ + +void * ctermid(x) { return 0; } +void * ttyname(x) { return 0; } + +void * gethostent() { return 0; } +void * getnetent() { return 0; } +void * getprotoent() { return 0; } +void * getservent() { return 0; } +void sethostent(x) {} +void setnetent(x) {} +void setprotoent(x) {} +void setservent(x) {} +void endhostent(x) {} +void endnetent(x) {} +void endprotoent(x) {} +void endservent(x) {} + +/*****************************************************************************/ +/* stat() hack for char/block device */ + +#if OS2_STAT_HACK + + /* First attempt used DosQueryFSAttach which crashed the system when + used with 5.001. Now just look for /dev/. */ + +int +os2_stat(char *name, struct stat *st) +{ + static int ino = SHRT_MAX; + + if (stricmp(name, "/dev/con") != 0 + && stricmp(name, "/dev/tty") != 0) + return stat(name, st); + + memset(st, 0, sizeof *st); + st->st_mode = S_IFCHR|0666; + st->st_ino = (ino-- & 0x7FFF); + st->st_nlink = 1; + return 0; +} + +#endif diff --git a/os2/os2ish.h b/os2/os2ish.h new file mode 100644 index 0000000000..061726dc2d --- /dev/null +++ b/os2/os2ish.h @@ -0,0 +1,72 @@ +#include + +/* HAS_IOCTL: + * This symbol, if defined, indicates that the ioctl() routine is + * available to set I/O characteristics + */ +#define HAS_IOCTL /**/ + +/* HAS_UTIME: + * This symbol, if defined, indicates that the routine utime() is + * available to update the access and modification times of files. + */ +#define HAS_UTIME /**/ + +#define HAS_KILL +#define HAS_WAIT + +#ifndef SIGABRT +# define SIGABRT SIGILL +#endif +#ifndef SIGILL +# define SIGILL 6 /* blech */ +#endif +#define ABORT() kill(getpid(),SIGABRT); + +/* + * fwrite1() should be a routine with the same calling sequence as fwrite(), + * but which outputs all of the bytes requested as a single stream (unlike + * fwrite() itself, which on some systems outputs several distinct records + * if the number_of_items parameter is >1). + */ +#define fwrite1 fwrite + +#define my_getenv(var) getenv(var) + +/*****************************************************************************/ + +#include /* before the following definitions */ +#include /* before the following definitions */ + +#define chdir _chdir2 +#define getcwd _getcwd2 + +/* This guy is needed for quick stdstd */ + +#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) +# define _filbuf _fill + /* Perl uses ungetc only with successful return */ +# define ungetc(c,fp) \ + (FILE_ptr(fp) > FILE_base(fp) && c == (int)*(FILE_ptr(fp) - 1) \ + ? (--FILE_ptr(fp), ++FILE_cnt(fp), (int)c) : ungetc(c,fp)) +#endif + +#define OP_BINARY O_BINARY + +#define OS2_STAT_HACK 1 +#if OS2_STAT_HACK + +#define Stat(fname,bufptr) os2_stat((fname),(bufptr)) +#define Fstat(fd,bufptr) fstat((fd),(bufptr)) + +#undef S_IFBLK +#undef S_ISBLK +#define S_IFBLK 0120000 +#define S_ISBLK(mode) (((mode) & S_IFMT) == S_IFBLK) + +#else + +#define Stat(fname,bufptr) stat((fname),(bufptr)) +#define Fstat(fd,bufptr) fstat((fd),(bufptr)) + +#endif diff --git a/patchlevel.h b/patchlevel.h index 110c86f392..e3d7670bc6 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 1 +#define PATCHLEVEL 2 diff --git a/perl.c b/perl.c index c6991affdb..39e8449faf 100644 --- a/perl.c +++ b/perl.c @@ -1,6 +1,6 @@ /* perl.c * - * Copyright (c) 1987-1994 Larry Wall + * Copyright (c) 1987-1995 Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -21,7 +21,7 @@ #endif */ -char rcsid[] = "perl.c\nPatch level: ###\n"; +dEXT char rcsid[] = "perl.c\nPatch level: ###\n"; #ifdef IAMSUID #ifndef DOSUID @@ -137,6 +137,14 @@ register PerlInterpreter *sv_interp; return; destruct_level = perl_destruct_level; +#ifdef DEBUGGING + { + char *s; + if (s = getenv("PERL_DESTRUCT_LEVEL")) + destruct_level = atoi(s); + } +#endif + LEAVE; FREETMPS; @@ -192,6 +200,7 @@ register PerlInterpreter *sv_interp; } if (sv_count != 0) warn("Scalars leaked: %d\n", sv_count); + sv_free_arenas(); DEBUG_P(debprofdump()); } @@ -295,6 +304,7 @@ setuid perl scripts securely.\n"); case 'c': case 'd': case 'D': + case 'h': case 'i': case 'l': case 'n': @@ -584,6 +594,7 @@ I32 create; if (create && !GvCV(gv)) return newSUB(start_subparse(), newSVOP(OP_CONST, 0, newSVpv(name,0)), + Nullop, Nullop); if (gv) return GvCV(gv); @@ -671,7 +682,25 @@ I32 flags; /* See G_* flags in cop.h */ cLOGOP->op_other = op; markstack_ptr--; - pp_entertry(); + /* we're trying to emulate pp_entertry() here */ + { + register CONTEXT *cx; + I32 gimme = GIMME; + + ENTER; + SAVETMPS; + + push_return(op->op_next); + PUSHBLOCK(cx, CXt_EVAL, stack_sp); + PUSHEVAL(cx, 0, 0); + eval_root = op; /* Only needed so that goto works right. */ + + in_eval = 1; + if (flags & G_KEEPERR) + in_eval |= 4; + else + sv_setpv(GvSV(errgv),""); + } markstack_ptr++; restart: @@ -716,8 +745,8 @@ I32 flags; /* See G_* flags in cop.h */ if (op) run(); retval = stack_sp - (stack_base + oldmark); - if (flags & G_EVAL) - sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),""); + if ((flags & G_EVAL) && !(flags & G_KEEPERR)) + sv_setpv(GvSV(errgv),""); cleanup: if (flags & G_EVAL) { @@ -745,78 +774,107 @@ I32 flags; /* See G_* flags in cop.h */ return retval; } -/* Older forms, here grandfathered. */ - -#ifdef DEPRECATED -I32 -perl_callargv(subname, spix, gimme, argv) -char *subname; -register I32 spix; /* current stack pointer index */ -I32 gimme; /* See G_* flags in cop.h */ -register char **argv; /* null terminated arg list, NULL for no arglist */ -{ - stack_sp = stack_base + spix; - return spix + perl_call_argv(subname, gimme, argv); -} - -I32 -perl_callpv(subname, spix, gimme, hasargs, numargs) -char *subname; -I32 spix; /* stack pointer index after args are pushed */ -I32 gimme; /* See G_* flags in cop.h */ -I32 hasargs; /* whether to create a @_ array for routine */ -I32 numargs; /* how many args are pushed on the stack */ -{ - stack_sp = stack_base + spix; - PUSHMARK(stack_sp - numargs); - return spix - numargs + perl_call_sv((SV*)perl_get_cv(subname, TRUE), - gimme, hasargs, numargs); -} +/* Eval a string. */ I32 -perl_callsv(sv, spix, gimme, hasargs, numargs) +perl_eval_sv(sv, flags) SV* sv; -I32 spix; /* stack pointer index after args are pushed */ -I32 gimme; /* See G_* flags in cop.h */ -I32 hasargs; /* whether to create a @_ array for routine */ -I32 numargs; /* how many args are pushed on the stack */ -{ - stack_sp = stack_base + spix; - PUSHMARK(stack_sp - numargs); - return spix - numargs + perl_call_sv(sv, gimme, hasargs, numargs); -} -#endif - -/* Require a module. */ - -void -perl_requirepv(pv) -char* pv; +I32 flags; /* See G_* flags in cop.h */ { UNOP myop; /* fake syntax tree node */ - SV* sv; - dSP; + SV** sp = stack_sp; + I32 oldmark = sp - stack_base; + I32 retval; + jmp_buf oldtop; + I32 oldscope; - ENTER; - SAVETMPS; + if (flags & G_DISCARD) { + ENTER; + SAVETMPS; + } + SAVESPTR(op); - sv = sv_newmortal(); - sv_setpv(sv, pv); op = (OP*)&myop; Zero(op, 1, UNOP); - XPUSHs(sv); + EXTEND(stack_sp, 1); + *++stack_sp = sv; + oldscope = scopestack_ix; - myop.op_type = OP_REQUIRE; + if (!(flags & G_NOARGS)) + myop.op_flags = OPf_STACKED; myop.op_next = Nullop; - myop.op_private = 1; - myop.op_flags = OPf_KNOW; + myop.op_flags |= OPf_KNOW; + if (flags & G_ARRAY) + myop.op_flags |= OPf_LIST; - PUTBACK; - if (op = pp_require()) + Copy(top_env, oldtop, 1, jmp_buf); + +restart: + switch (setjmp(top_env)) { + case 0: + break; + case 1: +#ifdef VMS + statusvalue = 255; /* XXX I don't think we use 1 anymore. */ +#else + statusvalue = 1; +#endif + /* FALL THROUGH */ + case 2: + /* my_exit() was called */ + curstash = defstash; + FREETMPS; + Copy(oldtop, top_env, 1, jmp_buf); + if (statusvalue) + croak("Callback called exit"); + my_exit(statusvalue); + /* NOTREACHED */ + case 3: + if (restartop) { + op = restartop; + restartop = 0; + goto restart; + } + stack_sp = stack_base + oldmark; + if (flags & G_ARRAY) + retval = 0; + else { + retval = 1; + *++stack_sp = &sv_undef; + } + goto cleanup; + } + + if (op == (OP*)&myop) + op = pp_entereval(); + if (op) run(); - stack_sp--; - FREETMPS; - LEAVE; + retval = stack_sp - (stack_base + oldmark); + if ((flags & G_EVAL) && !(flags & G_KEEPERR)) + sv_setpv(GvSV(errgv),""); + + cleanup: + Copy(oldtop, top_env, 1, jmp_buf); + if (flags & G_DISCARD) { + stack_sp = stack_base + oldmark; + retval = 0; + FREETMPS; + LEAVE; + } + return retval; +} + +/* Require a module. */ + +void +perl_require_pv(pv) +char* pv; +{ + SV* sv = sv_newmortal(); + sv_setpv(sv, "require '"); + sv_catpv(sv, pv); + sv_catpv(sv, "'"); + perl_eval_sv(sv, G_DISCARD); } void @@ -868,6 +926,38 @@ char *p; } } +void +usage(name) +char *name; +{ + printf("\nUsage: %s [switches] [filename] [arguments]\n",name); + printf("\n -0[octal] specify record separator (\\0, if no argument)"); + printf("\n -a autosplit mode with -n or -p"); + printf("\n -c check syntax only (runs BEGIN and END blocks)"); + printf("\n -d run scripts under debugger"); + printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)"); + printf("\n -e command one line of script, multiple -e options are allowed"); + printf("\n [filename] can be ommitted when -e is used"); + printf("\n -F regexp regular expression for autosplit (-a)"); + printf("\n -i[extension] edit <> files in place (make backup if extension supplied)"); + printf("\n -Idirectory specify include directory (may be used more then once)"); + printf("\n -l[octal] enable line ending processing, specifies line teminator"); + printf("\n -n assume 'while (<>) { ... }' loop arround your script"); + printf("\n -p assume loop like -n but print line also like sed"); + printf("\n -P run script through C preprocessor before compilation"); +#ifdef OS2 + printf("\n -R enable REXX variable pool"); +#endif + printf("\n -s enable some switch parsing for switches after script name"); + printf("\n -S look for the script using PATH environment variable"); + printf("\n -T turn on tainting checks"); + printf("\n -u dump core after parsing script"); + printf("\n -U allow unsafe operations"); + printf("\n -v print version number and patchlevel of perl"); + printf("\n -w turn warnings on for compilation of your script"); + printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n"); +} + /* This routine handles any switches that can be given during run */ char * @@ -906,11 +996,16 @@ char *s; return s; case 'd': taint_not("-d"); + s++; + if (*s == ':') { + sprintf(buf, "use Devel::%s;", ++s); + s += strlen(s); + my_setenv("PERL5DB",buf); + } if (!perldb) { perldb = TRUE; init_debugger(); } - s++; return s; case 'D': #ifdef DEBUGGING @@ -933,6 +1028,9 @@ char *s; #endif /*SUPPRESS 530*/ return s; + case 'h': + usage(origargv[0]); + exit(0); case 'i': if (inplace) Safefree(inplace); @@ -995,17 +1093,17 @@ char *s; s++; return s; case 'v': - printf("\nThis is perl, version %s\n\n",patchlevel); - fputs("\tUnofficial patchlevel 1n.\n",stdout); - fputs("\nCopyright 1987-1994, Larry Wall\n",stdout); + printf("\nThis is perl, version %s beta\n\n",patchlevel); + fputs("\nCopyright 1987-1995, Larry Wall\n",stdout); #ifdef MSDOS fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n", stdout); +#endif #ifdef OS2 - fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n", + fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" + "Version 5 port Copyright (c) 1994-1995, Andreas Kaiser\n", stdout); #endif -#endif #ifdef atarist fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout); #endif @@ -1077,9 +1175,13 @@ init_main_stash() incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV))); SvMULTI_on(incgv); defgv = gv_fetchpv("_",TRUE, SVt_PVAV); + errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV)); + SvMULTI_on(errgv); curstash = defstash; compiling.cop_stash = defstash; debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)); + /* We must init $/ before switches are processed. */ + sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1); } #ifdef CAN_PROTOTYPE @@ -1491,7 +1593,7 @@ init_ids() uid |= gid << 16; euid |= egid << 16; #endif - tainting |= (euid != uid || egid != gid); + tainting |= (uid && (euid != uid || egid != gid)); } static void @@ -1580,7 +1682,7 @@ init_predump_symbols() tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO); SvMULTI_on(tmpgv); IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout; - defoutgv = tmpgv; + setdefout(tmpgv); tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV); GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv)); SvMULTI_on(tmpgv); @@ -1653,6 +1755,13 @@ register char **env; hv = GvHVn(envgv); hv_clear(hv); #ifndef VMS /* VMS doesn't have environ array */ + /* Note that if the supplied env parameter is actually a copy + of the global environ then it may now point to free'd memory + if the environment has been modified since. To avoid this + problem we treat env==NULL as meaning 'use the default' + */ + if (!env) + env = environ; if (env != environ) { environ[0] = Nullch; hv_magic(hv, envgv, 'E'); @@ -1690,9 +1799,10 @@ init_perllib() incpush(getenv("PERLLIB")); } -#ifdef SITELIB_EXP - incpush(SITELIB_EXP); +#ifdef APPLLIB_EXP + incpush(APPLLIB_EXP); #endif + #ifdef ARCHLIB_EXP incpush(ARCHLIB_EXP); #endif @@ -1700,8 +1810,19 @@ init_perllib() #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" #endif incpush(PRIVLIB_EXP); + +#ifdef SITEARCH_EXP + incpush(SITEARCH_EXP); +#endif +#ifdef SITELIB_EXP + incpush(SITELIB_EXP); +#endif +#ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */ + incpush(OLDARCHLIB_EXP); +#endif - av_push(GvAVn(incgv),newSVpv(".",1)); + if (!tainting) + incpush("."); } void @@ -1721,7 +1842,7 @@ AV* list; switch (setjmp(top_env)) { case 0: { - SV* atsv = GvSV(gv_fetchpv("@",TRUE, SVt_PV)); + SV* atsv = GvSV(errgv); PUSHMARK(stack_sp); perl_call_sv((SV*)cv, G_EVAL|G_DISCARD); (void)SvPV(atsv, len); diff --git a/perl.h b/perl.h index a3ede9c64a..f5bf9526bb 100644 --- a/perl.h +++ b/perl.h @@ -32,22 +32,6 @@ * code can be a lot prettier. Well, so much for theory. Sorry, Henry... */ -#ifdef MYMALLOC -# ifdef HIDEMYMALLOC -# define malloc Mymalloc -# define realloc Myremalloc -# define free Myfree -# endif -# define safemalloc malloc -# define saferealloc realloc -# define safefree free -#endif - -/* work around some libPW problems */ -#ifdef DOINIT -EXT char Error[1]; -#endif - /* define this once if either system, instead of cluttering up the src */ #if defined(MSDOS) || defined(atarist) #define DOSISH 1 @@ -85,12 +69,16 @@ EXT char Error[1]; #endif #include -#ifdef USE_NEXT_CTYPE +#ifdef USE_NEXT_CTYPE #include #else #include #endif +#ifdef I_LOCALE +#include +#endif + #ifdef METHOD /* Defined by OSF/1 v3.0 by ctype.h */ #undef METHOD #endif @@ -110,6 +98,21 @@ EXT char Error[1]; # include #endif /* STANDARD_C */ +/* Maybe this comes after so we don't try to change + the standard library prototypes?. We'll use our own in + proto.h instead. I guess. The patch had no explanation. +*/ +#ifdef MYMALLOC +# ifdef HIDEMYMALLOC +# define malloc Mymalloc +# define realloc Myremalloc +# define free Myfree +# endif +# define safemalloc malloc +# define saferealloc realloc +# define safefree free +#endif + #define MEM_SIZE Size_t #if defined(I_STRING) || defined(__cplusplus) @@ -340,7 +343,7 @@ EXT char Error[1]; # endif # endif # endif -#endif +#endif #ifdef FPUTS_BOTCH /* work around botch in SunOS 4.0.1 and 4.0.2 */ @@ -537,7 +540,11 @@ typedef I32 (*filter_t) _((int, SV *, int)); #define FILTER_ISREADER(idx) (idx >= AvFILL(rsfp_filters)) #ifdef DOSISH +# if defined(OS2) +# include "os2ish.h" +# else # include "dosish.h" +# endif #else # if defined(VMS) # include "vmsish.h" @@ -582,6 +589,11 @@ union any { #include "mg.h" #include "scope.h" +/* work around some libPW problems */ +#ifdef DOINIT +EXT char Error[1]; +#endif + #if defined(iAPX286) || defined(M_I286) || defined(I80286) # define I286 #endif @@ -812,7 +824,7 @@ I32 unlnk _((char*)); #define SCAN_REPL 2 #ifdef DEBUGGING -# ifndef register +# ifndef register # define register # endif # define PAD_SV(po) pad_sv(po) @@ -848,6 +860,7 @@ EXT IV ** xiv_root; /* free xiv list--shared by interpreters */ EXT double * xnv_root; /* free xnv list--shared by interpreters */ EXT XRV * xrv_root; /* free xrv list--shared by interpreters */ EXT XPV * xpv_root; /* free xpv list--shared by interpreters */ +EXT HE * he_root; /* free he list--shared by interpreters */ /* Stack for currently executing thread--context switch must handle this. */ EXT SV ** stack_base; /* stack->array_ary */ @@ -1247,6 +1260,9 @@ IEXT I32 * Iscreamnext; IEXT I32 Imaxscream IINIT(-1); IEXT SV * Ilastscream; +/* shortcuts to misc objects */ +IEXT GV * Ierrgv; + /* shortcuts to debugging objects */ IEXT GV * IDBgv; IEXT GV * IDBline; @@ -1399,56 +1415,56 @@ extern "C" { /* The following must follow proto.h */ #ifdef DOINIT -MGVTBL vtbl_sv = {magic_get, +EXT MGVTBL vtbl_sv = {magic_get, magic_set, magic_len, 0, 0}; -MGVTBL vtbl_env = {0, 0, 0, 0, 0}; -MGVTBL vtbl_envelem = {0, magic_setenv, +EXT MGVTBL vtbl_env = {0, 0, 0, 0, 0}; +EXT MGVTBL vtbl_envelem = {0, magic_setenv, 0, magic_clearenv, 0}; -MGVTBL vtbl_sig = {0, 0, 0, 0, 0}; -MGVTBL vtbl_sigelem = {0, magic_setsig, +EXT MGVTBL vtbl_sig = {0, 0, 0, 0, 0}; +EXT MGVTBL vtbl_sigelem = {0, magic_setsig, 0, 0, 0}; -MGVTBL vtbl_pack = {0, 0, 0, magic_wipepack, +EXT MGVTBL vtbl_pack = {0, 0, 0, magic_wipepack, 0}; -MGVTBL vtbl_packelem = {magic_getpack, +EXT MGVTBL vtbl_packelem = {magic_getpack, magic_setpack, 0, magic_clearpack, 0}; -MGVTBL vtbl_dbline = {0, magic_setdbline, +EXT MGVTBL vtbl_dbline = {0, magic_setdbline, 0, 0, 0}; -MGVTBL vtbl_isa = {0, magic_setisa, +EXT MGVTBL vtbl_isa = {0, magic_setisa, 0, 0, 0}; -MGVTBL vtbl_isaelem = {0, magic_setisa, +EXT MGVTBL vtbl_isaelem = {0, magic_setisa, 0, 0, 0}; -MGVTBL vtbl_arylen = {magic_getarylen, +EXT MGVTBL vtbl_arylen = {magic_getarylen, magic_setarylen, 0, 0, 0}; -MGVTBL vtbl_glob = {magic_getglob, +EXT MGVTBL vtbl_glob = {magic_getglob, magic_setglob, 0, 0, 0}; -MGVTBL vtbl_mglob = {0, magic_setmglob, +EXT MGVTBL vtbl_mglob = {0, magic_setmglob, 0, 0, 0}; -MGVTBL vtbl_taint = {magic_gettaint,magic_settaint, +EXT MGVTBL vtbl_taint = {magic_gettaint,magic_settaint, 0, 0, 0}; -MGVTBL vtbl_substr = {0, magic_setsubstr, +EXT MGVTBL vtbl_substr = {0, magic_setsubstr, 0, 0, 0}; -MGVTBL vtbl_vec = {0, magic_setvec, +EXT MGVTBL vtbl_vec = {0, magic_setvec, 0, 0, 0}; -MGVTBL vtbl_pos = {magic_getpos, +EXT MGVTBL vtbl_pos = {magic_getpos, magic_setpos, 0, 0, 0}; -MGVTBL vtbl_bm = {0, magic_setbm, +EXT MGVTBL vtbl_bm = {0, magic_setbm, 0, 0, 0}; -MGVTBL vtbl_uvar = {magic_getuvar, +EXT MGVTBL vtbl_uvar = {magic_getuvar, magic_setuvar, 0, 0, 0}; #ifdef OVERLOAD -MGVTBL vtbl_amagic = {0, magic_setamagic, +EXT MGVTBL vtbl_amagic = {0, magic_setamagic, 0, 0, magic_setamagic}; -MGVTBL vtbl_amagicelem = {0, magic_setamagic, +EXT MGVTBL vtbl_amagicelem = {0, magic_setamagic, 0, 0, magic_setamagic}; #endif /* OVERLOAD */ diff --git a/perldoc.PL b/perldoc.PL new file mode 100644 index 0000000000..3e72dad10d --- /dev/null +++ b/perldoc.PL @@ -0,0 +1,336 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); + +# List explicitly here the shell variables you want Configure +# to look for. +# $startperl + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir(dirname($0)); +($file = basename($0)) =~ s/\.PL$//; +$file =~ s/\.pl$// + if ($Config{'osname'} eq 'VMS' or + $Config{'osname'} eq 'OS2'); # "case-forgiving" + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{'startperl'} + eval 'exec perl -S \$0 "\$@"' + if 0; +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; + +# +# Perldoc revision #1 -- look up a piece of documentation in .pod format that +# is embedded in the perl installation tree. +# +# This is not to be confused with Tom Christianson's perlman, which is a +# man replacement, written in perl. This perldoc is strictly for reading +# the perl manuals, though it too is written in perl. +# +# Version 1.1: Thu Nov 9 07:23:47 EST 1995 +# Kenneth Albanowski +# -added VMS support +# -added better error recognition (on no found pages, just exit. On +# missing nroff/pod2man, just display raw pod.) +# -added recursive/case-insensitive matching (thanks, Andreas). This +# slows things down a bit, unfortunately. Give a precise name, and +# it'll run faster. +# +# Version 1.01: Tue May 30 14:47:34 EDT 1995 +# Andy Dougherty +# -added pod documentation. +# -added PATH searching. +# -added searching pod/ subdirectory (mainly to pick up perlfunc.pod +# and friends. +# +# +# TODO: +# +# Cache directories read during sloppy match +# + +=head1 NAME + +perldoc - Look up Perl documentation in pod format. + +=head1 SYNOPSIS + +B [B<-h>] [B<-v>] PageName|ModuleName|ProgramName + +=head1 DESCRIPTION + +I looks up a piece of documentation in .pod format that is +embedded in the perl installation tree or in a perl script, and displays +it via pod2man | nroff -man | $PAGER. This is primarily used for the +documentation for the perl library modules. + +Your system may also have man pages installed for those modules, in +which case you can probably just use the man(1) command. + +=head1 OPTIONS + +=over 5 + +=item B<-h> help + +Prints out a brief help message. + +=item B<-v> verbose + +Describes search for the item in detail. + +=item B + +The item you want to look up. Nested modules (such as C) +are specified either as C or C. You may also +give a descriptive name of a page, such as C. You make also give a +partial or wrong-case name, such as "basename" for "File::Basename", but +this will be slower, if there is more then one page with the same partial +name, you will only get the first one. + +=back + +=head1 ENVIRONMENT + +Any switches in the C environment variable will be used before the +command line arguments. C also searches directories +specified by the C (or C if C is not +defined) and C environment variables. +(The latter is so that embedded pods for executables, such as +C itself, are available.) + +=head1 AUTHOR + +Kenneth Albanowski + +Minor updates by Andy Dougherty + +=head1 SEE ALSO + +=head1 DIAGNOSTICS + +=cut + +if(@ARGV<1) { + die <) { + if(/^=head/) { + close(TEST); + return 1; + } + } + close(TEST); + return 0; +} + + sub minus_f_nocase { + my($file) = @_; + local *DIR; + local($")="/"; + my(@p,$p,$cip); + foreach $p (split(/\//, $file)){ + if (-d ("@p/$p")){ + push @p, $p; + } elsif (-f ("@p/$p")) { + return "@p/$p"; + } else { + my $found=0; + my $lcp = lc $p; + opendir DIR, "@p"; + while ($cip=readdir(DIR)) { + if (lc $cip eq $lcp){ + $found++; + last; + } + } + closedir DIR; + return "" unless $found; + push @p, $cip; + return "@p" if -f "@p"; + } + } + return; # is not a file + } + + sub searchfor { + my($recurse,$s,@dirs) = @_; + $s =~ s!::!/!g; + printf STDERR "looking for $s in @dirs\n" if $opt_v; + my $ret; + my $i; + my $dir; + for ($i=0;$i<@dirs;$i++) { + $dir = $dirs[$i]; + if (( $ret = minus_f_nocase "$dir/$s.pod") + or ( $ret = minus_f_nocase "$dir/$s.pm" and containspod($ret)) + or ( $ret = minus_f_nocase "$dir/$s" and containspod($ret)) + or ( $ret = minus_f_nocase "$dir/pod/$s.pod") + or ( $ret = minus_f_nocase "$dir/pod/$s" and containspod($ret))) + { return $ret; } + + if($recurse) { + opendir(D,$dir); + my(@newdirs) = grep(-d,map("$dir/$_",grep(!/^\.\.?$/,readdir(D)))); + closedir(D); + print STDERR "Also looking in @newdirs\n" if $opt_v; + push(@dirs,@newdirs); + } + } + return (); + } + + +foreach (@pages) { + print STDERR "Searching for $_\n" if $opt_v; + # We must look both in @INC for library modules and in PATH + # for executables, like h2xs or perldoc itself. + @searchdirs = @INC; + push(@searchdirs, grep(-d, split(':', $ENV{'PATH'}))); + @files= searchfor(0,$_,@searchdirs); + if( @files ) { + print STDERR "Found as @files\n" if $opt_v; + } else { + # no match, try recursive search + + @searchdirs = grep(!/^\.$/,@INC); + + + @files= searchfor(1,$_,@searchdirs); + if( @files ) { + print STDERR "Loosly found as @files\n" if $opt_v; + } else { + print STDERR "No documentation found for '$_'\n"; + } + } + push(@found,@files); +} + +if(!@found) { + exit 1; +} + +$cmd=$filter=""; + +if( ! -t STDOUT ) { $opt_f = 1 } + +require Config; + +$VMS = $Config::Config{'osname'} eq "VMS"; + +unless($VMS) { + $tmp = "/tmp/perldoc1.$$"; + $tmp2 = "/tmp/perldoc2.$$"; + $goodresult = 0; +} else { + $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$; + $tmp2 = 'Sys$Scratch:perldoc.tmp2_'.$$; + $goodresult = 1; +} + +foreach (@found) { + + open(TMP,">>$tmp"); + $rslt = `pod2man $_ | nroff -man`; + if ($VMS) { $err = !($? % 2) || $rslt =~ /IVVERB/; } + else { $err = $?; } + print TMP $rslt unless $err; + close TMP; + + 1 while unlink($tmp2); # Possibly pointless VMSism + + if( $err or -z $tmp) { + open(OUT,">>$tmp"); + open(IN,"<$_"); + print OUT while ; + close(IN); + close(OUT); + } +} + +if( $opt_f ) { + open(TMP,"<$tmp"); + print while ; + close(TMP); +} else { + pager: + { + if( $ENV{PAGER} and system("$ENV{PAGER} $tmp")==$goodresult) + { last pager } + if( $Config{pager} and system("$Config{pager} $tmp")==$goodresult) + { last pager } + if( system("more $tmp")==$goodresult) + { last pager } + if( system("less $tmp")==$goodresult) + { last pager } + if( system("pg $tmp")==$goodresult) + { last pager } + if( system("view $tmp")==$goodresult) + { last pager } + } +} + +1 while unlink($tmp); #Possibly pointless VMSism + +exit 0; +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; diff --git a/perldoc.SH b/perldoc.SH deleted file mode 100644 index 54d4bfcfa5..0000000000 --- a/perldoc.SH +++ /dev/null @@ -1,201 +0,0 @@ -case $CONFIG in -'') - if test -f config.sh; then TOP=.; - elif test -f ../config.sh; then TOP=..; - elif test -f ../../config.sh; then TOP=../..; - elif test -f ../../../config.sh; then TOP=../../..; - elif test -f ../../../../config.sh; then TOP=../../../..; - else - echo "Can't find config.sh."; exit 1 - fi - . $TOP/config.sh - ;; -esac -: This forces SH files to create target in same directory as SH file. -: This is so that make depend always knows where to find SH derivatives. -case "$0" in -*/*) cd `expr X$0 : 'X\(.*\)/'` ;; -esac -echo "Extracting perldoc (with variable substitutions)" -$spitshell >perldoc <>perldoc <<'!NO!SUBS!' - -# -# Perldoc revision #1 -- look up a piece of documentation in .pod format that -# is embedded in the perl installation tree. -# -# This is not to be confused with Tom Christianson's perlman, which is a -# man replacement, written in perl. This perldoc is strictly for reading -# the perl manuals, though it too is written in perl. -# -# Version 1.01: Tue May 30 14:47:34 EDT 1995 -# Andy Dougherty -# -added pod documentation. -# -added PATH searching. -# -added searching pod/ subdirectory (mainly to pick up perlfunc.pod -# and friends. - -=head1 NAME - -perldoc - Look up Perl documentation in pod format. - -=head1 SYNOPSIS - -B [B<-h>] PageName|ModuleName - -=head1 DESCRIPTION - -I looks up a piece of documentation in .pod format that is -embedded in the perl installation tree or in a perl script, and displays -it via pod2man | nroff -man | $PAGER. This is primarily used for the -documentation for the perl library modules. - -Your system may also have man pages installed for those modules, in -which case you can probably just use the man(1) command. - -=head1 OPTIONS - -=over 5 - -=item B<-h> help - -Prints out a brief help message. - -=item B - -The item you want to look up. Nested modules (such as C) -are specified either as C or C. You -may also give a descriptive name of a page, such as C. - -=back - -=head1 ENVIRONMENT - -Any switches in the C environment variable will be used before the -command line arguments. C also searches directories -specified by the C (or C if C is not -defined) and C environment variables. -(The latter is so that embedded pods for executables, such as -C itself, are available.) - -=head1 AUTHOR - -Kenneth Albanowski - -Minor updates by Andy Dougherty - -=head1 SEE ALSO - -=head1 DIAGNOSTICS - -=cut - -if(@ARGV<1) { - die <) { - if(/^=head/) { - close(TEST); - return 1; - } - } - close(TEST); - return 0; -} - -sub searchfor { - my($s,@dirs) = @_; - $s =~ s!::!/!g; - # printf STDERR "looking for $s in @dirs\n"; - - foreach $dir (@dirs) { - if( -f "$dir/$s.pod") { return "$dir/$s.pod" } - elsif( -f "$dir/$s.pm" and containspod("$dir/$s.pm")) - { return "$dir/$s.pm" } - elsif( -f "$dir/$s" and containspod("$dir/$s")) - { return "$dir/$s" } - elsif( -f "$dir/pod/$s.pod") { return "$dir/pod/$s.pod" } - elsif( -f "$dir/pod/$s" and containspod("$dir/pod/$s")) - { return "$dir/pod/$s" } - } - return (); -} - - -$ENV{PAGER} ||= "more"; - -foreach (@pages) { - print STDERR "Searching for $_\n"; - # We must look both in @INC for library modules and in PATH - # for executables, like h2xs or perldoc itself. - @searchdirs = @INC; - push(@searchdirs, split(':', $ENV{'PATH'}) ); - @files= searchfor($_,@searchdirs); - if( @files ) { - print STDERR "Found as @files\n"; - } else { - print STDERR "No documentation found for $_\n"; - } - push(@found,@files); -} - -$cmd=$filter=""; - -if( ! -t STDOUT ) { $opt_f = 1 } - -$cmd = "pod2man - | nroff -man"; -if( ! $opt_f ) { $filter = "|$ENV{PAGER}" }; - -open(OUT,"|$cmd$filter"); -foreach (@found) { - open(IN,"<$_"); - print OUT while ; - close(IN); -} -close(OUT); -!NO!SUBS! -chmod 755 perldoc -$eunicefix perldoc diff --git a/perly.c b/perly.c index 895249ec7f..2c1f7fe7c8 100644 --- a/perly.c +++ b/perly.c @@ -14,600 +14,599 @@ dep() #define YYERRCODE 256 short yylhs[] = { -1, - 30, 0, 5, 3, 6, 6, 6, 7, 7, 7, + 31, 0, 5, 3, 6, 6, 6, 7, 7, 7, 7, 21, 21, 21, 21, 21, 21, 11, 11, 11, - 9, 9, 9, 9, 29, 29, 8, 8, 8, 8, - 8, 8, 8, 8, 10, 10, 25, 25, 28, 28, - 1, 1, 1, 1, 2, 2, 31, 31, 4, 32, - 32, 33, 13, 13, 13, 13, 12, 12, 12, 26, - 26, 26, 26, 26, 26, 26, 27, 27, 14, 14, + 9, 9, 9, 9, 30, 30, 8, 8, 8, 8, + 8, 8, 8, 8, 10, 10, 25, 25, 29, 29, + 1, 1, 1, 1, 2, 2, 32, 32, 28, 28, + 4, 33, 33, 34, 13, 13, 13, 13, 12, 12, + 12, 26, 26, 26, 26, 26, 26, 26, 26, 27, + 27, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 22, 22, - 23, 23, 23, 20, 15, 16, 17, 18, 19, 24, - 24, 24, 24, + 14, 14, 14, 22, 22, 23, 23, 23, 20, 15, + 16, 17, 18, 19, 24, 24, 24, 24, }; short yylen[] = { 2, 0, 2, 4, 0, 0, 2, 2, 2, 1, 2, 3, 1, 1, 3, 3, 3, 3, 0, 2, 6, 6, 6, 4, 4, 0, 2, 7, 7, 5, 5, 8, 7, 10, 3, 0, 1, 0, 1, 0, 1, - 1, 1, 1, 1, 4, 3, 4, 4, 0, 3, - 2, 4, 3, 3, 2, 1, 2, 3, 1, 3, - 5, 6, 3, 5, 2, 4, 1, 1, 3, 3, - 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 5, 3, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 3, 2, 3, 2, 4, 3, 3, 1, - 1, 4, 5, 4, 1, 1, 1, 5, 6, 5, - 6, 5, 4, 5, 1, 1, 3, 4, 3, 2, - 2, 4, 5, 4, 5, 1, 2, 1, 2, 2, - 1, 3, 3, 4, 4, 6, 1, 1, 0, 1, - 0, 1, 2, 2, 2, 2, 2, 2, 2, 1, - 1, 1, 1, + 1, 1, 1, 1, 4, 3, 5, 5, 0, 1, + 0, 3, 2, 4, 3, 3, 2, 1, 2, 3, + 1, 3, 5, 6, 3, 5, 2, 4, 4, 1, + 1, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 5, 3, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 3, 2, 3, 2, 4, + 3, 4, 1, 1, 4, 5, 4, 1, 1, 1, + 5, 6, 5, 6, 5, 4, 5, 1, 1, 3, + 4, 3, 2, 2, 4, 5, 4, 5, 1, 2, + 1, 2, 2, 2, 1, 3, 1, 3, 4, 4, + 6, 1, 1, 0, 1, 0, 1, 2, 2, 2, + 2, 2, 2, 2, 1, 1, 1, 1, }; short yydefred[] = { 1, - 0, 5, 0, 40, 49, 49, 0, 0, 6, 41, - 7, 9, 0, 42, 43, 44, 0, 0, 0, 51, - 0, 12, 4, 137, 0, 0, 115, 0, 49, 0, + 0, 5, 0, 40, 51, 51, 0, 0, 6, 41, + 7, 9, 0, 42, 43, 44, 0, 0, 0, 53, + 0, 12, 4, 142, 0, 0, 118, 0, 137, 0, + 51, 51, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 10, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 8, 0, 0, 0, 0, + 0, 108, 110, 104, 0, 0, 143, 0, 46, 0, + 52, 0, 0, 5, 155, 158, 157, 156, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 10, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 8, 0, 0, 0, 0, 0, 105, 107, - 101, 0, 0, 138, 0, 46, 0, 50, 0, 0, - 5, 150, 153, 152, 151, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 153, 0, + 124, 0, 0, 0, 0, 0, 0, 57, 0, 0, + 67, 0, 132, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 99, 0, 149, 150, 151, 152, 154, + 0, 34, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 148, 0, 121, 0, 0, 0, 0, - 0, 0, 55, 0, 0, 65, 0, 129, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 96, 0, - 144, 145, 146, 147, 149, 0, 34, 0, 0, 0, + 0, 0, 0, 0, 91, 92, 0, 0, 0, 0, + 0, 0, 0, 11, 45, 50, 0, 54, 0, 65, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 88, - 89, 0, 0, 0, 0, 0, 0, 0, 11, 45, - 48, 47, 52, 0, 63, 0, 0, 99, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 36, - 0, 132, 133, 0, 0, 0, 0, 0, 0, 98, - 0, 119, 0, 0, 0, 95, 26, 0, 0, 0, - 0, 0, 0, 53, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 36, 0, 136, 138, 0, + 0, 0, 0, 0, 0, 101, 0, 122, 0, 0, + 0, 98, 26, 0, 0, 0, 0, 0, 0, 55, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 67, 0, 68, 0, 0, 0, 0, 0, 0, 117, - 0, 3, 0, 135, 0, 0, 29, 0, 30, 0, - 0, 0, 23, 0, 24, 0, 0, 0, 134, 143, - 66, 0, 122, 0, 124, 0, 97, 0, 0, 0, - 0, 0, 0, 0, 104, 0, 102, 0, 113, 118, - 64, 0, 0, 0, 0, 19, 0, 0, 0, 0, - 0, 61, 123, 125, 112, 0, 110, 0, 0, 103, - 0, 108, 114, 136, 27, 28, 21, 0, 22, 0, - 32, 0, 111, 109, 62, 0, 0, 31, 0, 0, + 0, 0, 0, 0, 0, 0, 70, 0, 71, 0, + 0, 0, 0, 0, 0, 120, 0, 48, 47, 3, + 0, 140, 0, 69, 102, 0, 29, 0, 30, 0, + 0, 0, 23, 0, 24, 0, 0, 0, 139, 148, + 68, 0, 125, 0, 127, 0, 100, 0, 0, 0, + 0, 0, 0, 0, 107, 0, 105, 0, 116, 121, + 66, 0, 0, 0, 0, 19, 0, 0, 0, 0, + 0, 63, 126, 128, 115, 0, 113, 0, 0, 106, + 0, 111, 117, 141, 27, 28, 21, 0, 22, 0, + 32, 0, 114, 112, 64, 0, 0, 31, 0, 0, 20, 33, }; short yydgoto[] = { 1, - 9, 10, 81, 17, 84, 3, 11, 12, 63, 188, - 253, 64, 195, 66, 67, 68, 69, 70, 71, 72, - 190, 80, 196, 86, 180, 74, 234, 13, 137, 2, - 14, 15, 16, + 9, 10, 84, 17, 87, 3, 11, 12, 66, 194, + 263, 67, 201, 69, 70, 71, 72, 73, 74, 75, + 196, 83, 202, 89, 186, 77, 240, 177, 13, 142, + 2, 14, 15, 16, }; short yysindex[] = { 0, - 0, 0, -109, 0, 0, 0, -47, -221, 0, 0, - 0, 0, 585, 0, 0, 0, -106, -207, 3, 0, - 2059, 0, 0, 0, 94, 94, 0, 27, 0, -21, - -13, -12, -10, 11, 2059, 31, 34, 38, 94, 1787, - 2059, 961, -173, 1853, 1029, 1960, 2059, 2059, 2059, 2059, - 2059, 1140, 0, 2059, 2059, 1237, 94, 94, 94, 94, - 94, -187, 0, 50, 232, 3898, -65, -59, 0, 0, - 0, 60, 56, 0, -20, 0, -26, 0, 50, 57, - 0, 0, 0, 0, 0, 2059, 78, 2059, -20, 1853, - -20, 1853, -20, 1853, -20, 1853, -20, 1305, 79, 3898, - 80, 1416, 909, 0, 83, 0, 927, -19, 927, -5, - -54, 2059, 0, 0, -65, 0, 2059, 0, 927, 450, - 450, 450, -83, -83, 40, -41, 450, 450, 0, -90, - 0, 0, 0, 0, 0, -20, 0, 2059, 1853, 1853, - 1853, 1853, 1853, 1853, 1853, 2059, 2059, 2059, 2059, 2059, - 2059, 2059, 2059, 2059, 2059, 2059, 2059, 2059, 2059, 0, - 0, -22, 1853, 1853, 1853, 1853, 1853, 1512, 0, 0, - 0, 0, 0, -102, 0, 1853, 1351, 0, -210, 84, - -187, -39, -187, -17, -167, 35, -167, 70, 365, 0, - 1853, 0, 0, 44, 5, 91, 1853, 1581, 1688, 0, - 9, 0, 50, 1853, 48, 0, 0, 3898, -210, -210, - -210, -210, -155, 0, -48, 746, 927, 1382, 338, 1360, - 3898, 469, 797, 1069, 1103, 1180, 1455, 450, 450, 1853, - 0, 1853, 0, 100, -87, -44, -84, 76, -77, 0, - 46, 0, 108, 0, 2059, -20, 0, -20, 0, -20, - -20, 106, 0, -20, 0, 1853, -20, 58, 0, 0, - 0, 81, 0, 87, 0, 111, 0, -73, 1853, 28, - 2059, 122, -68, 1853, 0, 43, 0, 47, 0, 0, - 0, 2945, -187, -187, -167, 0, 1853, -167, 101, -187, - -20, 0, 0, 0, 0, -62, 0, 4048, 49, 0, - 132, 0, 0, 0, 0, 0, 0, 116, 0, 1305, - 0, -187, 0, 0, 0, -20, 134, 0, -167, -20, + 0, 0, -82, 0, 0, 0, -54, -205, 0, 0, + 0, 0, 592, 0, 0, 0, -110, -186, 25, 0, + 2094, 0, 0, 0, -35, -35, 0, 46, 0, 2094, + 0, 0, -12, -9, 1, 6, 36, 2094, 51, 68, + 76, -35, 1800, 2094, 979, -140, 1860, 1042, 1975, 2094, + 2094, 2094, 2094, 2094, 1276, 0, 2094, 2094, 1332, -35, + -35, -35, -35, -35, -151, 0, 86, 303, 1106, -65, + -59, 0, 0, 0, 92, 80, 0, 10, 0, -120, + 0, 86, 85, 0, 0, 0, 0, 0, 2094, 105, + 2094, 1106, 10, -120, 1860, 10, 1860, 10, 1860, 10, + 1860, 10, 1391, 109, 1106, 111, 1451, 923, 0, 110, + 0, 1357, -25, 1357, 28, -42, 2094, 0, 0, -65, + 0, 2094, 0, 1357, 788, 788, 788, -83, -83, 64, + -32, 788, 788, 0, -90, 0, 0, 0, 0, 0, + 10, 0, 2094, 1860, 1860, 1860, 1860, 1860, 1860, 1860, + 2094, 2094, 2094, 2094, 2094, 2094, 2094, 2094, 2094, 2094, + 2094, 2094, 2094, 2094, 0, 0, -30, 1860, 1860, 1860, + 1860, 1860, 1566, 0, 0, 0, -41, 0, -91, 0, + 1860, 2862, 2094, 10, -256, 113, -151, -29, -151, 2, + -157, 4, -157, 98, -39, 0, 1860, 0, 0, 16, + 77, 126, 1860, 1685, 1741, 0, 47, 0, 86, 1860, + 82, 0, 0, 1106, -256, -256, -256, -256, -117, 0, + 115, 754, 1357, 381, 888, 467, 1106, 1164, 807, 1893, + 2031, 1239, 739, 788, 788, 1860, 0, 1860, 0, 141, + -79, 142, -77, 149, 133, 0, 21, 0, 0, 0, + 150, 0, 2094, 0, 0, 10, 0, 10, 0, 10, + 10, 143, 0, 10, 0, 1860, 10, 49, 0, 0, + 0, 58, 0, 60, 0, 72, 0, 164, 1860, 69, + 2094, 161, 219, 1860, 0, 70, 0, 71, 0, 0, + 0, 359, -151, -151, -157, 0, 1860, -157, 138, -151, + 10, 0, 0, 0, 0, 236, 0, 3114, 73, 0, + 158, 0, 0, 0, 0, 0, 0, 74, 0, 1391, + 0, -151, 0, 0, 0, 10, 159, 0, -157, 10, 0, 0, }; short yyrindex[] = { 0, - 0, 0, 105, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 121, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 2263, 1892, 0, 0, 0, 0, - 0, 0, 0, 0, 2761, 2803, 0, 0, 0, 0, + 0, 0, 123, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 1, 0, 697, 4, 153, 2869, 2912, 0, 0, - 0, 2151, 0, 0, 0, 0, 0, 0, 2309, 0, - 0, 0, 0, 0, 0, 2351, 0, 0, 0, 141, - 0, 0, 0, 0, 0, 0, 0, 124, 0, 2544, - 0, 0, 143, 0, 2212, 0, 3721, 2869, 3753, 0, - 0, 2351, 0, 435, 526, 0, 0, 0, 3786, 3215, - 3255, 3311, 3062, 3174, 2413, 0, 3347, 3390, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 2610, 0, 0, + 147, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 2287, 2133, 0, + 0, 0, 0, 0, 0, 0, 0, 2773, 2817, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 11, 0, 332, 14, 1236, 2908, + 3038, 0, 0, 0, 2184, 0, 0, 0, 0, -17, + 0, 2331, 0, 0, 0, 0, 0, 0, 2460, 0, + 0, 1645, 0, 79, 168, 0, 0, 0, 0, 0, + 0, 0, 152, 0, 1914, 0, 0, 172, 0, 2239, + 0, 3740, 2908, 3784, 0, 0, 2460, 0, 448, 524, + 0, 0, 0, 3830, 3207, 3303, 3345, 3083, 3170, 2552, + 0, 3390, 3455, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 2596, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 857, 0, 143, 0, 0, 7, 0, - 1, 0, 1, 0, 53, 0, 53, 0, 126, 0, - 0, 0, 0, 0, 145, 0, 0, 0, 0, 0, - 0, 0, 2460, 0, 2719, 0, 0, 2586, 14, 16, - 18, 20, -37, 0, 0, 1443, 3822, 1763, 390, 3649, - 2845, 0, 4045, 4002, 3970, 3865, 3685, 3504, 3606, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 867, 0, + 172, 0, 2460, 0, 19, 0, 11, 0, 11, 0, + 67, 0, 67, 0, 160, 0, 0, 0, 0, 0, + 180, 0, 0, 0, 0, 0, 0, 0, 2646, 0, + 2722, 0, 0, 2282, 22, 33, 38, 84, 349, 0, + 0, -34, 3872, 3904, 166, 3610, 2422, 0, 496, 4003, + 3959, 3914, 3652, 3492, 3565, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 128, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 173, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 143, 0, 0, 0, 0, 0, 0, - 0, 0, 1, 1, 53, 0, 0, 53, 0, 1, - 0, 0, 0, 0, 0, 0, 0, 311, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 147, - 0, 1, 0, 0, 0, 0, 0, 0, 53, 0, + 0, 0, 0, 172, 0, 0, 0, 0, 0, 0, + 0, 0, 11, 11, 67, 0, 0, 67, 0, 11, + 0, 0, 0, 0, 0, 0, 0, 404, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 182, + 0, 11, 0, 0, 0, 0, 0, 0, 67, 0, 0, 0, }; short yygindex[] = { 0, - 0, 0, 0, 23, 209, 109, 0, 0, 0, -121, - -152, -3, 345, 4241, 878, 0, 0, 0, 0, 0, - 178, -32, -166, 494, -64, 0, 0, 0, -113, 0, - 0, 0, 0, + 0, 0, 0, 63, -13, 153, 0, 0, 0, -89, + -160, 29, 376, 4192, 890, 0, 0, 0, 0, 0, + 229, -21, -162, 880, -22, 0, 0, 156, 0, -152, + 0, 0, 0, 0, }; -#define YYTABLESIZE 4512 -short yytable[] = { 205, - 25, 248, 206, 54, 201, 275, 54, 163, 277, 243, - 270, 20, 116, 58, 276, 279, 23, 79, 90, 295, - 199, 54, 242, 250, 300, 165, 92, 94, 18, 96, - 313, 167, 171, 25, 255, 21, 25, 25, 25, 145, - 25, 79, 25, 25, 13, 25, 58, 38, 260, 77, - 98, 89, 18, 175, 16, 54, 17, 164, 14, 25, - 15, 78, 13, 166, 25, 38, 88, 247, 232, 249, - 101, 165, 16, 102, 17, 254, 14, 103, 15, 202, - 143, 144, 79, 112, 259, 18, 280, 136, 18, 18, - 18, 25, 18, 138, 18, 18, 23, 18, 291, 168, - 230, 23, 23, 164, 2, 251, 252, 301, 79, 23, - 23, 18, 23, 203, 169, 173, 18, 176, 191, 200, - 192, 292, 198, 25, 246, 25, 25, 293, 256, 58, - 204, 261, 307, 267, 278, 309, 144, 39, 269, 274, - 39, 39, 39, 18, 39, 287, 39, 39, 281, 39, - 75, 294, 297, 4, 5, 6, 316, 7, 8, 310, - 4, 5, 6, 39, 7, 8, 321, 302, 39, 305, - 306, 303, 315, 314, 320, 18, 311, 18, 18, 139, - 299, 37, 35, 141, 13, 142, 37, 35, 317, 174, - 73, 289, 0, 59, 0, 39, 59, 0, 318, 0, - 143, 144, 0, 143, 144, 0, 143, 144, 0, 19, - 59, 59, 0, 143, 144, 0, 23, 143, 144, 0, - 0, 62, 143, 144, 0, 76, 162, 39, 143, 144, - 39, 54, 54, 54, 54, 231, 143, 144, 91, 93, - 95, 97, 143, 144, 0, 59, 143, 144, 106, 143, - 144, 143, 144, 54, 118, 0, 25, 25, 25, 25, +#define YYTABLESIZE 4473 +short yytable[] = { 65, + 61, 267, 212, 79, 20, 61, 81, 168, 211, 81, + 25, 258, 23, 285, 205, 287, 207, 248, 251, 96, + 98, 100, 102, 81, 81, 170, 121, 95, 81, 111, + 97, 172, 265, 250, 257, 123, 259, 148, 149, 150, + 99, 49, 260, 25, 264, 101, 25, 25, 25, 82, + 25, 21, 25, 25, 13, 25, 269, 169, 81, 38, + 238, 290, 16, 171, 175, 170, 18, 180, 18, 25, + 80, 61, 13, 17, 25, 103, 82, 38, 14, 183, + 16, 23, 187, 81, 189, 91, 191, 23, 193, 301, + 106, 17, 236, 93, 94, 208, 14, 169, 302, 18, + 303, 25, 18, 18, 18, 49, 18, 107, 18, 18, + 23, 18, 304, 23, 326, 108, 117, 82, 261, 262, + 270, 311, 2, 23, 15, 18, 141, 213, 23, 143, + 18, 173, 23, 25, 317, 25, 25, 319, 174, 176, + 315, 316, 15, 178, 181, 82, 78, 321, 197, 204, + 209, 198, 206, 256, 210, 39, 266, 18, 39, 39, + 39, 254, 39, 249, 39, 39, 271, 39, 331, 328, + 255, 277, 279, 280, 4, 5, 6, 149, 7, 8, + 284, 39, 297, 4, 5, 6, 39, 7, 8, 18, + 291, 18, 18, 307, 312, 313, 320, 324, 325, 330, + 286, 49, 19, 148, 149, 144, 74, 288, 37, 74, + 35, 82, 146, 39, 148, 149, 148, 149, 13, 309, + 147, 85, 35, 74, 74, 289, 86, 237, 74, 167, + 327, 37, 144, 145, 146, 147, 179, 81, 81, 81, + 81, 76, 293, 299, 294, 39, 295, 296, 39, 184, + 298, 148, 149, 300, 148, 149, 305, 0, 74, 81, + 81, 148, 149, 81, 148, 149, 25, 25, 25, 25, 25, 25, 0, 25, 25, 25, 25, 25, 25, 25, - 25, 25, 25, 143, 144, 0, 25, 25, 0, 25, - 25, 25, 0, 170, 0, 172, 25, 25, 25, 25, - 25, 0, 0, 25, 25, 143, 144, 178, 0, 181, - 25, 183, 0, 185, 25, 187, 25, 25, 18, 18, - 18, 18, 18, 18, 0, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 143, 144, 0, 18, 18, - 0, 18, 18, 18, 143, 144, 143, 144, 18, 18, - 18, 18, 18, 0, 207, 18, 18, 0, 143, 144, - 82, 81, 18, 0, 81, 83, 18, 65, 18, 18, - 39, 39, 39, 39, 39, 39, 143, 144, 81, 81, - 39, 143, 144, 39, 39, 39, 39, 143, 144, 0, - 39, 39, 0, 39, 39, 39, 111, 0, 113, 0, - 39, 39, 39, 39, 39, 0, 126, 39, 39, 0, - 130, 143, 144, 81, 39, 257, 143, 144, 39, 0, - 39, 39, 143, 144, 0, 0, 0, 0, 0, 0, - 0, 59, 59, 59, 59, 0, 0, 0, 163, 0, - 71, 0, 0, 71, 179, 0, 182, 0, 184, 0, - 186, 0, 189, 59, 59, 0, 194, 71, 71, 0, - 0, 0, 71, 0, 283, 0, 284, 0, 285, 286, - 145, 0, 288, 0, 0, 290, 0, 150, 0, 0, - 150, 150, 150, 0, 150, 137, 150, 150, 137, 150, - 0, 0, 71, 209, 210, 211, 212, 213, 214, 215, - 0, 0, 137, 137, 0, 0, 0, 137, 150, 312, - 139, 140, 141, 142, 0, 0, 0, 235, 236, 237, - 238, 239, 241, 0, 0, 0, 0, 0, 0, 87, - 0, 0, 143, 144, 319, 137, 271, 137, 322, 0, - 0, 152, 104, 0, 0, 258, 0, 0, 117, 0, - 163, 262, 264, 266, 0, 0, 0, 0, 268, 0, - 131, 132, 133, 134, 135, 0, 0, 137, 151, 163, - 150, 151, 151, 151, 0, 151, 100, 151, 151, 100, - 151, 0, 145, 0, 272, 0, 273, 0, 0, 81, - 81, 81, 81, 100, 100, 0, 0, 0, 100, 151, - 0, 145, 0, 0, 0, 0, 197, 0, 0, 0, - 179, 81, 81, 0, 0, 81, 0, 0, 0, 0, - 0, 0, 0, 296, 0, 0, 0, 47, 100, 0, - 58, 60, 57, 0, 52, 0, 61, 55, 0, 54, - 0, 308, 0, 139, 140, 141, 142, 0, 0, 158, - 0, 0, 159, 53, 0, 160, 161, 162, 59, 0, - 0, 151, 0, 0, 65, 143, 144, 0, 71, 71, - 71, 71, 0, 0, 0, 0, 0, 71, 0, 0, - 0, 71, 71, 71, 71, 56, 0, 0, 0, 0, - 71, 71, 0, 0, 71, 71, 71, 71, 71, 0, - 71, 150, 150, 150, 150, 150, 0, 0, 0, 0, - 150, 0, 0, 137, 137, 137, 137, 23, 0, 0, - 48, 150, 137, 150, 150, 150, 137, 137, 137, 137, - 150, 150, 150, 150, 150, 137, 137, 150, 150, 137, - 137, 137, 137, 137, 150, 137, 137, 56, 150, 137, - 150, 150, 137, 137, 137, 0, 146, 0, 0, 0, - 147, 148, 149, 150, 159, 56, 0, 160, 161, 162, - 0, 0, 0, 151, 153, 154, 155, 156, 0, 157, - 158, 0, 0, 159, 0, 0, 160, 161, 162, 0, - 0, 0, 151, 151, 151, 151, 151, 0, 0, 56, - 0, 151, 0, 0, 100, 100, 100, 100, 0, 0, - 0, 0, 151, 100, 151, 151, 151, 100, 100, 100, - 100, 151, 151, 151, 151, 151, 100, 100, 151, 151, - 100, 100, 100, 100, 100, 151, 100, 100, 0, 151, - 100, 151, 151, 100, 100, 100, 163, 0, 0, 0, - 22, 24, 25, 26, 27, 28, 0, 0, 0, 0, - 29, 0, 0, 30, 31, 32, 33, 0, 0, 0, - 34, 35, 0, 36, 37, 38, 0, 0, 145, 0, - 39, 40, 41, 42, 43, 0, 0, 44, 45, 0, - 0, 0, 0, 0, 46, 0, 0, 163, 49, 39, - 50, 51, 39, 39, 39, 0, 39, 0, 39, 39, - 0, 39, 85, 85, 0, 0, 0, 0, 0, 0, - 0, 99, 0, 0, 0, 39, 85, 108, 0, 145, - 39, 0, 115, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 85, 85, 85, 85, 85, 0, - 0, 47, 0, 0, 58, 60, 57, 39, 52, 0, - 61, 55, 0, 54, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 56, 56, 56, 56, 0, - 0, 0, 59, 0, 0, 0, 0, 0, 0, 39, - 115, 0, 39, 0, 0, 0, 0, 56, 56, 0, - 0, 0, 0, 47, 0, 0, 58, 60, 57, 56, - 52, 0, 61, 55, 0, 54, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 163, 0, 110, - 0, 0, 0, 0, 59, 0, 0, 147, 148, 149, - 150, 23, 0, 0, 48, 0, 0, 0, 0, 233, - 0, 153, 154, 155, 156, 0, 157, 158, 0, 145, - 159, 56, 0, 160, 161, 162, 0, 0, 0, 0, - 0, 47, 0, 0, 58, 60, 57, 0, 52, 0, - 61, 55, 0, 54, 0, 0, 0, 0, 147, 148, - 149, 150, 0, 0, 0, 0, 48, 0, 0, 0, - 0, 0, 59, 154, 155, 156, 0, 157, 158, 0, - 0, 159, 0, 0, 160, 161, 162, 0, 0, 0, - 0, 0, 39, 39, 39, 39, 39, 39, 0, 56, - 0, 0, 39, 0, 0, 39, 39, 39, 39, 0, - 0, 0, 39, 39, 0, 39, 39, 39, 0, 0, - 0, 0, 39, 39, 39, 39, 39, 0, 0, 39, - 39, 23, 0, 0, 48, 0, 39, 0, 0, 163, - 39, 0, 39, 39, 0, 114, 25, 26, 27, 28, - 83, 0, 47, 0, 29, 58, 60, 57, 0, 52, - 125, 61, 55, 0, 54, 35, 0, 36, 37, 38, - 0, 145, 0, 163, 39, 40, 41, 42, 43, 0, - 0, 44, 45, 59, 0, 0, 0, 0, 46, 0, - 149, 150, 49, 0, 50, 51, 0, 24, 25, 26, - 27, 28, 0, 0, 0, 145, 29, 157, 158, 0, - 56, 159, 0, 0, 160, 161, 162, 35, 0, 36, - 37, 38, 0, 0, 0, 0, 39, 40, 41, 42, - 43, 0, 0, 44, 45, 0, 0, 0, 0, 0, - 46, 0, 0, 0, 49, 48, 50, 51, 0, 47, - 163, 0, 58, 60, 57, 0, 52, 0, 61, 55, - 0, 54, 0, 0, 0, 114, 25, 26, 27, 28, - 83, 0, 0, 0, 29, 0, 0, 0, 0, 0, - 59, 0, 145, 0, 0, 35, 0, 36, 37, 38, - 0, 0, 0, 0, 39, 40, 41, 42, 43, 0, - 0, 0, 45, 0, 0, 0, 0, 56, 46, 129, - 0, 0, 49, 0, 50, 51, 0, 47, 0, 0, - 58, 60, 57, 0, 52, 0, 61, 55, 0, 54, - 147, 148, 149, 150, 0, 0, 0, 0, 0, 0, - 0, 0, 48, 0, 0, 0, 155, 156, 59, 157, - 158, 0, 0, 159, 0, 0, 160, 161, 162, 0, - 0, 0, 0, 0, 147, 148, 149, 150, 0, 0, - 0, 244, 0, 0, 245, 56, 24, 25, 26, 27, - 28, 156, 0, 157, 158, 29, 0, 159, 0, 0, - 160, 161, 162, 152, 0, 0, 35, 0, 36, 37, - 38, 0, 0, 0, 0, 39, 40, 41, 42, 43, - 48, 0, 44, 45, 0, 0, 0, 0, 0, 46, - 0, 163, 0, 49, 0, 50, 51, 0, 47, 0, - 163, 58, 60, 57, 0, 52, 193, 61, 55, 0, - 54, 147, 148, 149, 150, 0, 0, 0, 0, 0, - 0, 0, 163, 145, 0, 0, 0, 0, 0, 59, - 157, 158, 145, 78, 159, 0, 78, 160, 161, 162, - 0, 0, 0, 24, 25, 26, 27, 28, 0, 0, - 78, 78, 29, 0, 145, 78, 56, 0, 0, 0, - 0, 0, 0, 35, 0, 36, 37, 38, 0, 0, - 0, 0, 39, 40, 41, 42, 43, 0, 0, 44, - 45, 0, 0, 0, 0, 78, 46, 0, 0, 0, - 49, 48, 50, 51, 47, 163, 0, 58, 60, 57, - 0, 52, 240, 61, 55, 0, 54, 0, 0, 0, - 22, 24, 25, 26, 27, 28, 0, 0, 0, 0, - 29, 0, 0, 0, 0, 59, 0, 145, 0, 0, - 0, 35, 0, 36, 37, 38, 0, 0, 0, 0, - 39, 40, 41, 42, 43, 0, 0, 44, 45, 0, - 0, 0, 56, 0, 46, 0, 0, 0, 49, 0, - 50, 51, 0, 47, 0, 0, 58, 60, 57, 0, - 52, 263, 61, 55, 0, 54, 0, 0, 146, 0, - 0, 0, 147, 148, 149, 150, 0, 48, 0, 0, - 0, 0, 0, 149, 59, 151, 153, 154, 155, 156, - 0, 157, 158, 0, 0, 159, 0, 0, 160, 161, - 162, 158, 0, 147, 159, 149, 150, 160, 161, 162, - 0, 56, 24, 25, 26, 27, 28, 0, 0, 0, - 0, 29, 157, 158, 0, 0, 159, 0, 0, 160, - 161, 162, 35, 0, 36, 37, 38, 0, 0, 0, - 0, 39, 40, 41, 42, 43, 48, 0, 44, 45, - 0, 78, 78, 78, 78, 46, 0, 0, 0, 49, - 47, 50, 51, 58, 60, 57, 0, 52, 265, 61, - 55, 0, 54, 78, 78, 0, 0, 78, 149, 150, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 59, 0, 0, 0, 0, 158, 0, 0, 159, - 0, 0, 160, 161, 162, 0, 0, 0, 24, 25, - 26, 27, 28, 0, 0, 0, 0, 29, 56, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 35, 0, - 36, 37, 38, 0, 0, 0, 0, 39, 40, 41, - 42, 43, 0, 75, 44, 45, 75, 0, 0, 0, - 0, 46, 0, 48, 0, 49, 0, 50, 51, 47, - 75, 75, 58, 60, 57, 75, 52, 0, 61, 55, - 0, 54, 0, 0, 0, 0, 0, 24, 25, 26, - 27, 28, 0, 0, 0, 0, 29, 0, 0, 0, - 59, 0, 0, 0, 0, 75, 0, 35, 0, 36, - 37, 38, 0, 0, 0, 0, 39, 40, 41, 42, - 43, 0, 0, 44, 45, 0, 0, 56, 0, 0, - 46, 0, 0, 0, 49, 47, 50, 51, 58, 60, - 57, 0, 52, 0, 61, 55, 0, 54, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 23, - 0, 0, 48, 0, 0, 0, 59, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 131, 0, 0, 131, 0, 0, 0, 0, - 0, 0, 0, 56, 24, 25, 26, 27, 28, 131, - 131, 0, 0, 29, 131, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 35, 0, 36, 37, 38, 0, - 0, 0, 0, 39, 40, 41, 42, 43, 48, 0, - 44, 45, 131, 0, 131, 0, 0, 46, 0, 0, - 0, 49, 47, 50, 51, 58, 60, 57, 0, 52, - 0, 61, 55, 0, 54, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 131, 0, 0, 0, 0, 0, - 0, 0, 0, 59, 0, 0, 0, 0, 0, 0, - 0, 75, 75, 75, 75, 0, 0, 0, 0, 0, - 75, 0, 0, 105, 25, 26, 27, 28, 0, 0, - 56, 0, 29, 75, 75, 0, 0, 75, 75, 75, - 75, 75, 0, 35, 0, 36, 37, 38, 0, 0, - 0, 0, 39, 40, 41, 42, 43, 0, 0, 0, - 45, 0, 23, 0, 0, 48, 46, 0, 0, 0, - 49, 47, 50, 51, 58, 60, 57, 0, 52, 0, - 61, 55, 0, 54, 0, 0, 0, 0, 0, 24, - 25, 26, 27, 28, 0, 0, 0, 0, 29, 0, - 0, 0, 59, 0, 0, 0, 0, 0, 0, 35, - 0, 36, 37, 38, 0, 0, 0, 0, 39, 40, - 41, 42, 43, 0, 0, 44, 45, 0, 0, 56, - 0, 0, 46, 0, 0, 0, 49, 0, 50, 51, - 131, 131, 131, 131, 0, 0, 0, 0, 0, 131, - 0, 0, 0, 131, 131, 131, 131, 0, 0, 0, - 0, 0, 131, 131, 48, 0, 131, 131, 131, 131, - 131, 116, 131, 131, 116, 0, 131, 0, 0, 131, - 131, 131, 0, 0, 0, 0, 0, 0, 116, 116, - 0, 0, 0, 116, 0, 0, 24, 25, 26, 27, - 28, 0, 0, 0, 0, 29, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 35, 0, 36, 37, - 38, 116, 0, 116, 0, 39, 40, 41, 42, 43, - 0, 0, 137, 45, 0, 137, 0, 0, 0, 46, - 0, 0, 0, 49, 0, 50, 51, 0, 0, 137, - 137, 0, 0, 116, 137, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 25, 25, 25, 25, 25, 25, 0, 322, 0, 25, + 25, 0, 25, 25, 25, 148, 149, 148, 149, 25, + 25, 25, 25, 25, 0, 0, 25, 25, 0, 148, + 149, 310, 329, 25, 148, 149, 332, 25, 0, 25, + 25, 0, 18, 18, 18, 18, 18, 18, 323, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 148, 149, 0, 18, 18, 0, 18, 18, + 18, 148, 149, 148, 149, 18, 18, 18, 18, 18, + 0, 0, 18, 18, 0, 148, 149, 148, 149, 18, + 148, 149, 58, 18, 0, 18, 18, 0, 39, 39, + 39, 39, 39, 39, 0, 39, 39, 39, 68, 56, + 58, 39, 56, 0, 39, 39, 39, 39, 0, 314, + 0, 39, 39, 0, 39, 39, 39, 56, 148, 149, + 0, 39, 39, 39, 39, 39, 0, 0, 39, 39, + 116, 157, 118, 0, 58, 39, 148, 149, 0, 39, + 131, 39, 39, 0, 135, 148, 149, 74, 74, 74, + 74, 56, 148, 149, 84, 0, 74, 84, 0, 168, + 74, 74, 74, 74, 148, 149, 0, 148, 149, 74, + 74, 84, 84, 74, 74, 74, 74, 74, 0, 74, + 185, 168, 188, 0, 190, 0, 192, 0, 195, 0, + 155, 150, 200, 155, 155, 155, 0, 155, 142, 155, + 155, 142, 155, 0, 0, 0, 84, 0, 0, 0, + 0, 0, 0, 150, 0, 142, 142, 0, 0, 0, + 142, 155, 148, 149, 0, 0, 0, 0, 0, 215, + 216, 217, 218, 219, 220, 221, 0, 0, 0, 148, + 149, 0, 0, 0, 0, 0, 83, 0, 142, 83, + 142, 0, 0, 241, 242, 243, 244, 245, 247, 0, + 0, 0, 0, 83, 83, 0, 156, 168, 83, 156, + 156, 156, 0, 156, 103, 156, 156, 103, 156, 0, + 142, 0, 268, 155, 144, 145, 146, 147, 272, 274, + 276, 103, 103, 0, 0, 278, 103, 156, 83, 150, + 0, 0, 0, 0, 0, 0, 148, 149, 0, 0, + 0, 0, 0, 58, 58, 58, 58, 0, 0, 0, + 0, 282, 0, 283, 0, 0, 103, 0, 0, 0, + 56, 56, 56, 56, 50, 58, 58, 61, 63, 60, + 0, 55, 0, 64, 58, 0, 57, 0, 0, 151, + 0, 185, 56, 152, 153, 154, 155, 0, 0, 156, + 56, 0, 0, 0, 306, 62, 156, 158, 159, 160, + 161, 0, 162, 163, 0, 152, 164, 154, 155, 165, + 166, 167, 318, 0, 0, 84, 84, 84, 84, 0, + 0, 0, 59, 0, 162, 163, 0, 0, 164, 0, + 0, 165, 166, 167, 0, 68, 0, 84, 84, 0, + 0, 84, 0, 0, 155, 155, 155, 155, 155, 0, + 155, 155, 155, 0, 23, 0, 155, 51, 0, 142, + 142, 142, 142, 0, 0, 0, 0, 155, 142, 155, + 155, 155, 142, 142, 142, 142, 155, 155, 155, 155, + 155, 142, 142, 155, 155, 142, 142, 142, 142, 142, + 155, 142, 142, 154, 155, 142, 155, 155, 142, 142, + 142, 0, 0, 0, 0, 0, 0, 83, 83, 83, + 83, 163, 0, 0, 164, 0, 83, 165, 166, 167, + 156, 156, 156, 156, 156, 0, 156, 156, 156, 83, + 83, 0, 156, 83, 83, 103, 103, 103, 103, 0, + 0, 0, 0, 156, 103, 156, 156, 156, 103, 103, + 103, 103, 156, 156, 156, 156, 156, 103, 103, 156, + 156, 103, 103, 103, 103, 103, 156, 103, 103, 168, + 156, 103, 156, 156, 103, 103, 103, 0, 0, 0, + 0, 0, 0, 0, 168, 0, 0, 22, 24, 25, + 26, 27, 28, 0, 29, 30, 31, 0, 0, 0, + 32, 150, 0, 33, 34, 35, 36, 0, 0, 0, + 37, 38, 0, 39, 40, 41, 150, 0, 168, 0, + 42, 43, 44, 45, 46, 0, 0, 47, 48, 0, + 0, 0, 0, 0, 49, 0, 0, 168, 52, 39, + 53, 54, 39, 39, 39, 90, 39, 0, 39, 39, + 150, 39, 0, 0, 88, 88, 0, 0, 0, 0, + 0, 109, 0, 0, 0, 39, 104, 122, 0, 150, + 39, 88, 113, 0, 0, 0, 0, 120, 0, 136, + 137, 138, 139, 140, 0, 0, 0, 0, 0, 88, + 88, 88, 88, 88, 0, 50, 0, 39, 61, 63, + 60, 0, 55, 0, 64, 58, 0, 57, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 168, 0, + 0, 0, 0, 0, 0, 0, 62, 203, 0, 39, + 0, 0, 39, 0, 0, 0, 0, 120, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 137, 126, 137, 0, 126, 0, 0, 0, - 0, 0, 0, 0, 0, 24, 25, 26, 27, 28, - 126, 126, 0, 0, 29, 126, 0, 0, 0, 0, - 0, 0, 0, 0, 137, 35, 0, 36, 37, 38, - 0, 0, 0, 0, 39, 40, 41, 42, 43, 140, - 0, 0, 45, 0, 0, 126, 0, 0, 46, 0, - 0, 0, 49, 0, 50, 51, 140, 140, 0, 0, - 0, 140, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 126, 0, 0, 0, 0, - 0, 139, 0, 0, 139, 0, 0, 0, 0, 140, - 0, 140, 0, 0, 0, 0, 0, 0, 139, 139, - 0, 0, 0, 139, 0, 0, 0, 0, 0, 116, - 116, 116, 116, 0, 0, 0, 0, 0, 116, 0, - 0, 140, 116, 116, 116, 116, 0, 0, 0, 0, - 0, 116, 116, 139, 0, 116, 116, 116, 116, 116, - 0, 116, 116, 94, 0, 116, 94, 0, 116, 116, - 116, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 94, 94, 0, 139, 0, 94, 0, 0, 0, 0, - 137, 137, 137, 137, 0, 0, 0, 0, 0, 137, - 0, 0, 0, 137, 137, 137, 137, 0, 0, 0, - 60, 0, 137, 137, 0, 94, 137, 137, 137, 137, - 137, 0, 137, 137, 0, 0, 137, 60, 60, 137, - 137, 137, 60, 0, 0, 0, 0, 0, 0, 0, - 0, 126, 126, 126, 126, 94, 0, 0, 0, 0, - 126, 0, 0, 0, 126, 126, 126, 126, 0, 0, - 60, 0, 60, 126, 126, 0, 0, 126, 126, 126, - 126, 126, 0, 126, 126, 0, 0, 126, 0, 0, - 126, 126, 126, 0, 0, 0, 0, 140, 140, 140, - 140, 0, 60, 0, 127, 0, 140, 127, 0, 0, - 140, 140, 140, 140, 0, 0, 0, 0, 0, 140, - 140, 127, 127, 140, 140, 140, 140, 140, 0, 140, - 140, 0, 0, 140, 0, 0, 140, 140, 140, 139, - 139, 139, 139, 0, 0, 0, 58, 0, 139, 58, - 0, 0, 139, 139, 139, 139, 127, 0, 0, 0, - 0, 139, 139, 58, 58, 139, 139, 139, 139, 139, - 57, 139, 139, 57, 0, 139, 0, 0, 139, 139, - 139, 0, 0, 0, 0, 0, 0, 57, 57, 0, - 0, 0, 57, 0, 0, 0, 0, 0, 58, 0, - 0, 94, 94, 94, 94, 0, 0, 0, 0, 0, - 94, 0, 0, 0, 94, 94, 94, 94, 0, 0, - 0, 0, 57, 94, 94, 0, 0, 94, 94, 94, - 94, 94, 0, 94, 94, 0, 0, 94, 0, 0, - 94, 94, 94, 0, 0, 0, 0, 0, 60, 60, - 60, 60, 57, 0, 0, 0, 0, 60, 0, 0, - 0, 60, 60, 60, 60, 0, 0, 0, 0, 0, - 60, 60, 0, 0, 60, 60, 60, 60, 60, 93, - 60, 60, 93, 0, 60, 0, 0, 60, 60, 60, - 0, 0, 0, 0, 0, 0, 93, 93, 0, 0, - 0, 93, 0, 0, 0, 0, 0, 0, 0, 0, + 150, 50, 0, 59, 61, 63, 60, 0, 55, 0, + 64, 58, 0, 57, 0, 154, 155, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 115, 152, 153, + 154, 155, 62, 163, 0, 23, 164, 0, 51, 165, + 166, 167, 158, 159, 160, 161, 239, 162, 163, 0, + 0, 164, 0, 0, 165, 166, 167, 0, 0, 59, + 0, 0, 0, 0, 50, 0, 0, 61, 63, 60, + 0, 55, 0, 64, 58, 0, 57, 0, 0, 0, + 0, 152, 153, 154, 155, 164, 0, 0, 165, 166, + 167, 0, 0, 0, 51, 62, 159, 160, 161, 0, + 162, 163, 0, 0, 164, 0, 0, 165, 166, 167, + 0, 0, 39, 39, 39, 39, 39, 39, 0, 39, + 39, 39, 59, 0, 0, 39, 0, 0, 39, 39, + 39, 39, 0, 0, 0, 39, 39, 0, 39, 39, + 39, 0, 0, 0, 0, 39, 39, 39, 39, 39, + 0, 0, 39, 39, 23, 0, 0, 51, 157, 39, + 0, 0, 0, 39, 0, 39, 39, 0, 0, 119, + 25, 26, 27, 28, 86, 29, 30, 31, 0, 0, + 0, 32, 163, 0, 0, 164, 168, 0, 165, 166, + 167, 0, 38, 0, 39, 40, 41, 0, 0, 0, + 0, 42, 43, 44, 45, 46, 0, 0, 47, 48, + 0, 281, 0, 0, 0, 49, 157, 0, 150, 52, + 0, 53, 54, 0, 0, 24, 25, 26, 27, 28, + 0, 29, 30, 31, 0, 0, 0, 32, 0, 0, + 0, 0, 0, 0, 168, 0, 0, 0, 38, 0, + 39, 40, 41, 0, 0, 0, 0, 42, 43, 44, + 45, 46, 0, 0, 47, 48, 61, 0, 0, 61, + 0, 49, 0, 0, 0, 52, 150, 53, 54, 0, + 0, 0, 0, 61, 61, 0, 0, 0, 119, 25, + 26, 27, 28, 86, 29, 30, 31, 0, 50, 0, + 32, 61, 63, 60, 0, 55, 130, 64, 58, 0, + 57, 38, 0, 39, 40, 41, 0, 0, 61, 168, + 42, 43, 44, 45, 46, 0, 0, 0, 48, 62, + 0, 0, 0, 0, 49, 0, 0, 0, 52, 0, + 53, 54, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 150, 0, 0, 50, 0, 59, 61, 63, 60, + 0, 55, 0, 64, 58, 0, 57, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 151, 0, 0, 0, + 152, 153, 154, 155, 0, 62, 0, 0, 0, 0, + 0, 51, 0, 156, 158, 159, 160, 161, 0, 162, + 163, 0, 0, 164, 0, 0, 165, 166, 167, 0, + 0, 0, 59, 50, 134, 0, 61, 63, 60, 0, + 55, 0, 64, 58, 0, 57, 0, 0, 0, 0, + 0, 0, 0, 0, 151, 0, 0, 168, 152, 153, + 154, 155, 0, 0, 62, 0, 0, 51, 0, 0, + 0, 156, 158, 159, 160, 161, 0, 162, 163, 0, + 0, 164, 0, 0, 165, 166, 167, 0, 0, 150, + 0, 59, 0, 50, 0, 0, 61, 63, 60, 0, + 55, 199, 64, 58, 0, 57, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 61, 61, 61, + 61, 0, 0, 0, 62, 0, 51, 0, 0, 0, + 0, 0, 0, 152, 153, 154, 155, 0, 0, 61, + 61, 0, 24, 25, 26, 27, 28, 0, 29, 30, + 31, 59, 162, 163, 32, 0, 164, 0, 0, 165, + 166, 167, 0, 0, 0, 38, 0, 39, 40, 41, + 0, 0, 0, 0, 42, 43, 44, 45, 46, 0, + 0, 47, 48, 0, 0, 0, 51, 0, 49, 0, + 0, 0, 52, 0, 53, 54, 0, 0, 24, 25, + 26, 27, 28, 0, 29, 30, 31, 0, 50, 0, + 32, 61, 63, 60, 0, 55, 246, 64, 58, 0, + 57, 38, 0, 39, 40, 41, 0, 0, 0, 0, + 42, 43, 44, 45, 46, 0, 0, 47, 48, 62, + 0, 0, 0, 0, 49, 0, 0, 0, 52, 0, + 53, 54, 0, 154, 155, 0, 22, 24, 25, 26, + 27, 28, 0, 29, 30, 31, 59, 0, 0, 32, + 162, 163, 0, 0, 164, 0, 0, 165, 166, 167, + 38, 0, 39, 40, 41, 0, 0, 0, 0, 42, + 43, 44, 45, 46, 0, 134, 47, 48, 134, 0, + 0, 51, 0, 49, 0, 0, 0, 52, 0, 53, + 54, 0, 134, 134, 0, 0, 0, 24, 25, 26, + 27, 28, 0, 29, 30, 31, 0, 50, 0, 32, + 61, 63, 60, 0, 55, 273, 64, 58, 0, 57, + 38, 0, 39, 40, 41, 0, 0, 134, 0, 42, + 43, 44, 45, 46, 0, 0, 47, 48, 62, 0, + 0, 0, 0, 49, 0, 0, 0, 52, 0, 53, + 54, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 50, 0, 59, 61, 63, 60, 0, + 55, 275, 64, 58, 0, 57, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 139, 0, 0, 139, 0, 0, 0, 0, 0, - 0, 93, 127, 127, 127, 127, 0, 0, 139, 139, - 0, 0, 0, 139, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 127, 127, 0, 0, 0, 0, - 0, 93, 0, 128, 0, 0, 128, 0, 0, 0, - 0, 0, 0, 139, 58, 58, 58, 58, 0, 0, - 128, 128, 0, 0, 0, 128, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 58, 58, 57, 57, - 57, 57, 0, 0, 0, 69, 0, 57, 69, 0, - 0, 57, 57, 57, 57, 128, 0, 0, 0, 0, - 57, 57, 69, 69, 57, 57, 57, 57, 57, 100, - 57, 57, 100, 0, 57, 0, 0, 57, 57, 57, - 0, 0, 0, 0, 0, 0, 100, 100, 0, 0, - 0, 100, 0, 0, 0, 0, 0, 69, 0, 0, + 0, 0, 0, 0, 62, 0, 0, 0, 0, 0, + 51, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 24, 25, 26, 27, 28, 0, 29, 30, + 31, 59, 50, 0, 32, 61, 63, 60, 0, 55, + 0, 64, 58, 0, 57, 38, 0, 39, 40, 41, + 0, 0, 0, 0, 42, 43, 44, 45, 46, 0, + 0, 47, 48, 62, 0, 0, 51, 0, 49, 0, + 0, 0, 52, 0, 53, 54, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 106, 0, 0, 106, 0, 0, 0, 0, - 0, 100, 0, 0, 0, 0, 0, 0, 0, 106, - 106, 0, 0, 0, 106, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 304, 0, 93, 93, 93, - 93, 0, 0, 0, 0, 0, 93, 0, 0, 0, - 93, 93, 93, 93, 106, 0, 0, 152, 0, 93, - 93, 0, 0, 93, 93, 93, 93, 93, 0, 93, - 93, 0, 0, 93, 0, 0, 93, 93, 93, 139, - 139, 139, 139, 0, 0, 163, 0, 0, 139, 0, - 0, 0, 139, 139, 139, 139, 0, 0, 0, 0, - 0, 139, 139, 0, 0, 139, 139, 139, 139, 139, - 0, 139, 139, 0, 0, 139, 0, 145, 139, 139, - 139, 128, 128, 128, 128, 0, 0, 0, 0, 0, - 128, 0, 0, 0, 128, 128, 128, 128, 0, 0, - 0, 0, 0, 128, 128, 0, 0, 128, 128, 128, - 128, 128, 90, 128, 128, 90, 0, 128, 0, 0, - 128, 128, 128, 69, 69, 69, 69, 0, 0, 90, - 90, 0, 0, 0, 90, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 69, 69, 100, 100, 100, - 100, 0, 0, 0, 0, 0, 100, 0, 0, 0, - 100, 100, 100, 100, 90, 0, 0, 0, 0, 100, - 100, 0, 0, 100, 100, 100, 100, 100, 0, 100, - 100, 0, 0, 100, 0, 0, 100, 100, 100, 0, - 106, 106, 106, 106, 0, 0, 0, 0, 0, 106, - 0, 0, 0, 106, 106, 106, 106, 0, 0, 0, - 0, 0, 106, 106, 0, 0, 106, 106, 106, 106, - 106, 0, 106, 106, 91, 0, 106, 91, 0, 106, - 106, 106, 146, 0, 0, 0, 147, 148, 149, 150, - 0, 91, 91, 0, 0, 0, 91, 0, 0, 151, - 153, 154, 155, 156, 0, 157, 158, 0, 0, 159, - 0, 0, 160, 161, 162, 85, 0, 0, 85, 0, - 0, 0, 0, 0, 0, 0, 91, 0, 0, 0, - 0, 0, 85, 85, 0, 0, 0, 85, 0, 0, + 59, 0, 50, 0, 0, 61, 63, 60, 0, 55, + 0, 64, 58, 0, 57, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 134, 134, 134, 134, + 0, 0, 23, 62, 0, 51, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 134, 134, + 0, 24, 25, 26, 27, 28, 0, 29, 30, 31, + 59, 0, 0, 32, 130, 0, 0, 130, 0, 0, + 0, 0, 0, 0, 38, 0, 39, 40, 41, 0, + 0, 130, 130, 42, 43, 44, 45, 46, 0, 0, + 47, 48, 0, 168, 0, 51, 0, 49, 0, 0, + 0, 52, 0, 53, 54, 0, 0, 24, 25, 26, + 27, 28, 0, 29, 30, 31, 130, 50, 0, 32, + 61, 63, 60, 0, 55, 150, 64, 58, 0, 57, + 38, 0, 39, 40, 41, 0, 0, 0, 0, 42, + 43, 44, 45, 46, 0, 0, 47, 48, 62, 0, + 0, 0, 0, 49, 0, 0, 0, 52, 0, 53, + 54, 0, 0, 0, 0, 0, 110, 25, 26, 27, + 28, 0, 29, 30, 31, 59, 0, 0, 32, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 38, + 0, 39, 40, 41, 0, 0, 0, 0, 42, 43, + 44, 45, 46, 0, 0, 0, 48, 23, 0, 0, + 51, 0, 49, 0, 0, 0, 52, 0, 53, 54, + 0, 0, 0, 0, 0, 0, 24, 25, 26, 27, + 28, 168, 29, 30, 31, 0, 50, 0, 32, 61, + 63, 60, 0, 55, 0, 64, 58, 0, 57, 38, + 0, 39, 40, 41, 0, 0, 0, 0, 42, 43, + 44, 45, 46, 150, 0, 47, 48, 62, 0, 0, + 0, 0, 49, 0, 0, 0, 52, 0, 53, 54, + 0, 0, 0, 135, 0, 0, 135, 152, 153, 154, + 155, 0, 0, 0, 59, 130, 130, 130, 130, 0, + 135, 135, 0, 160, 161, 135, 162, 163, 0, 0, + 164, 0, 0, 165, 166, 167, 0, 130, 130, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 51, + 0, 0, 0, 135, 119, 135, 0, 119, 0, 0, + 0, 24, 25, 26, 27, 28, 0, 29, 30, 31, + 0, 119, 119, 32, 0, 0, 119, 0, 0, 0, + 0, 0, 0, 0, 38, 135, 39, 40, 41, 0, + 0, 0, 0, 42, 43, 44, 45, 46, 0, 0, + 0, 48, 0, 0, 119, 0, 119, 49, 0, 142, + 0, 52, 142, 53, 54, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 142, 142, 0, 0, + 0, 142, 0, 0, 0, 0, 119, 0, 0, 0, + 0, 0, 0, 0, 0, 152, 153, 154, 155, 0, + 0, 0, 60, 0, 0, 60, 0, 129, 0, 142, + 129, 142, 161, 0, 162, 163, 0, 0, 164, 60, + 60, 165, 166, 167, 129, 129, 0, 0, 0, 129, + 24, 25, 26, 27, 28, 0, 29, 30, 31, 0, + 0, 142, 32, 0, 0, 0, 0, 0, 0, 0, + 0, 145, 0, 38, 60, 39, 40, 41, 0, 129, + 0, 0, 42, 43, 44, 45, 46, 0, 145, 145, + 48, 0, 0, 145, 0, 0, 49, 0, 0, 0, + 52, 0, 53, 54, 135, 135, 135, 135, 0, 129, + 0, 0, 0, 135, 0, 0, 0, 135, 135, 135, + 135, 145, 0, 145, 0, 0, 135, 135, 0, 0, + 135, 135, 135, 135, 135, 0, 135, 135, 0, 0, + 135, 0, 0, 135, 135, 135, 0, 0, 0, 0, + 0, 0, 0, 145, 0, 119, 119, 119, 119, 0, + 0, 0, 72, 0, 119, 72, 0, 0, 119, 119, + 119, 119, 0, 0, 0, 0, 0, 119, 119, 72, + 72, 119, 119, 119, 119, 119, 0, 119, 119, 0, + 0, 119, 0, 0, 119, 119, 119, 0, 0, 0, + 144, 0, 0, 144, 0, 0, 0, 0, 0, 0, + 142, 142, 142, 142, 72, 0, 0, 144, 144, 142, + 0, 0, 144, 142, 142, 142, 142, 0, 0, 0, + 0, 0, 142, 142, 0, 0, 142, 142, 142, 142, + 142, 0, 142, 142, 0, 0, 142, 0, 0, 142, + 142, 142, 144, 60, 60, 60, 60, 0, 129, 129, + 129, 129, 0, 0, 0, 0, 0, 129, 0, 0, + 0, 129, 129, 129, 129, 60, 60, 0, 0, 0, + 129, 129, 144, 0, 129, 129, 129, 129, 129, 0, + 129, 129, 97, 0, 129, 97, 0, 129, 129, 129, + 0, 0, 145, 145, 145, 145, 0, 0, 0, 97, + 97, 145, 0, 0, 97, 145, 145, 145, 145, 0, + 0, 0, 0, 0, 145, 145, 0, 0, 145, 145, + 145, 145, 145, 0, 145, 145, 59, 0, 145, 59, + 0, 145, 145, 145, 97, 0, 0, 0, 0, 0, + 0, 0, 0, 59, 59, 0, 0, 0, 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 86, 0, 0, 86, 0, - 0, 0, 0, 0, 0, 0, 0, 85, 0, 0, - 0, 0, 86, 86, 0, 0, 0, 86, 0, 0, + 0, 0, 0, 0, 97, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 62, 0, 59, 0, + 0, 0, 0, 72, 72, 72, 72, 0, 0, 0, + 0, 0, 0, 62, 62, 0, 0, 0, 62, 0, + 0, 0, 0, 0, 0, 72, 72, 0, 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 90, 90, 90, 90, 0, 0, 0, 0, 0, 90, - 0, 0, 0, 90, 90, 90, 90, 86, 0, 0, - 0, 87, 90, 90, 87, 0, 90, 90, 90, 90, - 90, 0, 90, 90, 0, 0, 90, 0, 87, 87, - 0, 0, 0, 87, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 83, 0, 0, - 83, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 87, 83, 83, 0, 0, 0, 83, + 0, 144, 144, 144, 144, 0, 62, 0, 62, 0, + 144, 0, 0, 0, 144, 144, 144, 144, 0, 0, + 0, 0, 0, 144, 144, 0, 0, 144, 144, 144, + 144, 144, 96, 144, 144, 96, 0, 144, 62, 0, + 144, 144, 144, 0, 0, 0, 0, 0, 0, 96, + 96, 0, 0, 0, 96, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 84, 0, 0, 84, 0, 0, 0, 0, 0, 83, - 0, 0, 91, 91, 91, 91, 0, 84, 84, 0, - 0, 91, 84, 0, 0, 91, 91, 91, 91, 0, - 0, 0, 0, 0, 91, 91, 0, 0, 91, 91, - 91, 91, 91, 0, 91, 91, 0, 0, 91, 0, - 0, 0, 84, 85, 85, 85, 85, 0, 0, 0, - 0, 0, 85, 0, 0, 0, 85, 85, 85, 85, - 0, 0, 0, 0, 0, 85, 85, 0, 0, 85, - 85, 85, 85, 85, 0, 85, 85, 0, 0, 0, - 0, 0, 0, 86, 86, 86, 86, 0, 0, 0, - 0, 0, 86, 0, 0, 0, 86, 86, 86, 86, - 0, 0, 0, 0, 82, 86, 86, 82, 0, 86, - 86, 86, 86, 86, 0, 86, 86, 0, 0, 0, - 0, 82, 82, 0, 0, 0, 82, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 87, - 87, 87, 87, 0, 0, 0, 0, 0, 87, 0, - 0, 0, 87, 87, 87, 87, 82, 0, 0, 0, - 0, 87, 87, 0, 0, 87, 87, 87, 87, 87, - 0, 87, 87, 0, 0, 83, 83, 83, 83, 0, - 0, 0, 0, 0, 83, 0, 0, 0, 83, 83, - 83, 83, 0, 0, 0, 0, 0, 83, 83, 0, - 0, 83, 83, 83, 83, 83, 70, 83, 83, 70, - 0, 0, 0, 0, 0, 0, 0, 0, 84, 84, - 84, 84, 0, 70, 70, 0, 0, 84, 70, 0, - 0, 84, 84, 84, 84, 0, 0, 0, 0, 0, - 84, 84, 0, 0, 84, 84, 84, 84, 84, 72, - 84, 84, 72, 0, 0, 0, 0, 0, 70, 0, - 0, 0, 0, 0, 0, 0, 72, 72, 0, 0, - 0, 72, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 73, 0, 0, 73, 0, + 0, 0, 0, 144, 96, 0, 144, 0, 0, 0, + 0, 0, 0, 97, 97, 97, 97, 0, 0, 0, + 144, 144, 97, 0, 0, 144, 97, 97, 97, 97, + 0, 0, 0, 0, 96, 97, 97, 0, 0, 97, + 97, 97, 97, 97, 0, 97, 97, 131, 0, 97, + 131, 0, 97, 97, 97, 144, 0, 59, 59, 59, + 59, 0, 0, 0, 131, 131, 59, 0, 0, 131, + 59, 59, 59, 59, 0, 0, 0, 0, 0, 59, + 59, 0, 0, 59, 59, 59, 59, 59, 0, 59, + 59, 0, 252, 59, 0, 253, 59, 59, 59, 131, + 0, 0, 0, 0, 0, 0, 0, 62, 62, 62, + 62, 0, 0, 0, 157, 0, 62, 0, 0, 0, + 62, 62, 62, 62, 0, 0, 0, 0, 0, 62, + 62, 0, 0, 62, 62, 62, 62, 62, 103, 62, + 62, 103, 168, 62, 0, 0, 62, 62, 62, 0, + 0, 0, 0, 0, 0, 103, 103, 0, 0, 0, + 103, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 150, 0, 0, 0, 0, 0, + 0, 0, 0, 96, 96, 96, 96, 0, 0, 0, + 103, 0, 96, 0, 0, 0, 96, 96, 96, 96, + 0, 0, 0, 0, 0, 96, 96, 0, 0, 96, + 96, 96, 96, 96, 0, 96, 96, 0, 0, 96, + 0, 0, 96, 96, 96, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 144, 144, 144, 144, 0, 0, + 0, 0, 0, 144, 0, 0, 0, 144, 144, 144, + 144, 0, 0, 0, 0, 0, 144, 144, 0, 0, + 144, 144, 144, 144, 144, 0, 144, 144, 109, 0, + 144, 109, 0, 144, 144, 144, 0, 0, 131, 131, + 131, 131, 0, 0, 0, 109, 109, 131, 0, 0, + 109, 131, 131, 131, 131, 0, 0, 0, 0, 0, + 131, 131, 0, 0, 131, 131, 131, 131, 131, 0, + 131, 131, 0, 93, 131, 0, 93, 131, 131, 131, + 109, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 93, 93, 151, 0, 0, 93, 152, 153, 154, 155, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 156, + 158, 159, 160, 161, 0, 162, 163, 0, 0, 164, + 0, 0, 165, 166, 167, 93, 157, 0, 0, 103, + 103, 103, 103, 0, 0, 0, 0, 0, 103, 0, + 0, 0, 103, 103, 103, 103, 0, 0, 0, 0, + 0, 103, 103, 0, 168, 103, 103, 103, 103, 103, + 94, 103, 103, 94, 0, 103, 0, 0, 103, 103, + 103, 0, 0, 0, 0, 0, 0, 94, 94, 0, + 0, 0, 94, 0, 0, 0, 150, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 88, 0, 0, + 88, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 94, 0, 88, 88, 0, 0, 0, 88, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 72, 73, 73, 0, 0, 0, 73, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 120, 0, 0, 120, 0, 0, 0, 0, 0, - 0, 0, 82, 82, 82, 82, 0, 73, 120, 120, - 0, 82, 0, 120, 0, 82, 82, 82, 82, 0, - 0, 0, 0, 92, 82, 82, 92, 0, 82, 82, - 82, 82, 82, 0, 82, 82, 0, 0, 0, 0, - 92, 92, 0, 120, 0, 92, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 130, 0, 0, 130, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 88, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 109, + 109, 109, 109, 0, 0, 0, 0, 0, 109, 0, + 0, 0, 109, 109, 109, 109, 0, 0, 0, 0, + 0, 109, 109, 0, 0, 109, 109, 109, 109, 109, + 0, 109, 109, 89, 0, 109, 89, 0, 109, 109, + 109, 0, 0, 0, 93, 93, 93, 93, 0, 0, + 89, 89, 0, 93, 0, 89, 0, 93, 93, 93, + 93, 0, 0, 0, 0, 0, 93, 93, 0, 0, + 93, 93, 93, 93, 93, 90, 93, 93, 90, 0, + 93, 0, 0, 0, 151, 89, 0, 0, 152, 153, + 154, 155, 90, 90, 0, 0, 0, 90, 0, 0, + 0, 0, 158, 159, 160, 161, 0, 162, 163, 0, + 0, 164, 0, 0, 165, 166, 167, 0, 0, 0, + 86, 0, 0, 86, 0, 0, 0, 90, 0, 0, + 0, 94, 94, 94, 94, 0, 0, 86, 86, 0, + 94, 0, 86, 0, 94, 94, 94, 94, 0, 0, + 0, 0, 0, 94, 94, 0, 0, 94, 94, 94, + 94, 94, 0, 94, 94, 0, 0, 94, 88, 88, + 88, 88, 86, 0, 0, 0, 0, 88, 0, 0, + 0, 88, 88, 88, 88, 87, 0, 0, 87, 0, + 88, 88, 0, 0, 88, 88, 88, 88, 88, 0, + 88, 88, 87, 87, 0, 0, 0, 87, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 130, 130, 92, 0, 0, 130, 0, + 0, 0, 85, 0, 0, 85, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 87, 0, 85, + 85, 0, 0, 0, 85, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 74, 0, 0, 74, 0, 0, 0, 0, - 0, 0, 0, 0, 70, 70, 70, 70, 130, 74, - 74, 0, 0, 70, 74, 0, 0, 70, 70, 70, - 70, 0, 0, 0, 0, 0, 70, 70, 0, 0, - 70, 70, 70, 70, 70, 76, 70, 70, 76, 0, - 0, 0, 0, 0, 74, 0, 0, 72, 72, 72, - 72, 0, 76, 76, 0, 0, 72, 76, 0, 0, - 72, 72, 0, 72, 0, 0, 0, 0, 0, 72, - 72, 0, 0, 72, 72, 72, 72, 72, 0, 72, - 0, 0, 0, 73, 73, 73, 73, 76, 0, 0, - 152, 0, 73, 0, 0, 0, 73, 73, 0, 0, - 0, 0, 0, 0, 0, 73, 73, 0, 0, 73, - 73, 73, 73, 73, 0, 73, 0, 0, 163, 120, - 120, 120, 120, 0, 0, 0, 0, 0, 120, 0, - 0, 0, 120, 120, 0, 0, 0, 0, 0, 0, - 77, 120, 120, 77, 0, 120, 120, 120, 120, 120, - 145, 92, 92, 92, 92, 0, 0, 77, 77, 0, - 92, 0, 77, 0, 92, 92, 0, 0, 0, 0, - 0, 0, 79, 92, 92, 79, 0, 92, 92, 92, - 92, 92, 0, 0, 130, 130, 130, 130, 0, 79, - 79, 0, 77, 130, 79, 0, 0, 130, 130, 0, - 0, 0, 0, 0, 0, 0, 130, 130, 0, 0, - 130, 130, 130, 130, 130, 80, 0, 0, 80, 0, - 74, 74, 74, 74, 79, 0, 0, 0, 0, 74, - 0, 0, 80, 80, 74, 0, 0, 80, 0, 0, - 152, 0, 74, 74, 0, 0, 74, 74, 74, 74, - 74, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 76, 76, 76, 76, 80, 163, 0, - 0, 0, 76, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 76, 76, 0, 0, 76, - 76, 76, 76, 76, 0, 0, 0, 0, 0, 0, - 145, 0, 0, 0, 0, 146, 0, 0, 0, 147, - 148, 149, 150, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 151, 153, 154, 155, 156, 0, 157, 158, - 0, 0, 159, 0, 0, 160, 161, 162, 0, 0, + 0, 0, 0, 0, 89, 89, 89, 89, 0, 0, + 0, 0, 0, 89, 85, 0, 0, 89, 89, 89, + 89, 0, 0, 0, 0, 0, 89, 89, 0, 0, + 89, 89, 89, 89, 89, 73, 89, 89, 73, 0, + 0, 0, 0, 0, 0, 0, 90, 90, 90, 90, + 0, 0, 73, 73, 0, 90, 0, 73, 0, 90, + 90, 90, 90, 0, 0, 0, 0, 0, 90, 90, + 0, 0, 90, 90, 90, 90, 90, 0, 90, 90, + 75, 0, 0, 75, 0, 0, 0, 73, 0, 0, + 0, 86, 86, 86, 86, 0, 0, 75, 75, 0, + 86, 0, 75, 0, 86, 86, 86, 86, 0, 0, + 0, 0, 0, 86, 86, 0, 0, 86, 86, 86, + 86, 86, 76, 86, 86, 76, 0, 0, 0, 0, + 0, 0, 75, 0, 0, 0, 0, 0, 0, 76, + 76, 0, 0, 0, 76, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 87, 87, 87, 87, + 0, 0, 0, 0, 0, 87, 0, 0, 0, 87, + 87, 87, 87, 0, 76, 0, 0, 0, 87, 87, + 0, 0, 87, 87, 87, 87, 87, 0, 87, 87, + 0, 0, 0, 85, 85, 85, 85, 0, 0, 0, + 0, 0, 85, 0, 0, 0, 85, 85, 85, 85, + 123, 0, 0, 123, 0, 85, 85, 0, 0, 85, + 85, 85, 85, 85, 0, 85, 85, 123, 123, 0, + 0, 0, 123, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 95, 0, 0, 95, 0, 0, + 0, 0, 123, 0, 0, 0, 73, 73, 73, 73, + 0, 95, 95, 0, 0, 73, 95, 0, 0, 73, + 73, 73, 73, 0, 0, 0, 0, 0, 73, 73, + 0, 0, 73, 73, 73, 73, 73, 0, 73, 73, + 133, 0, 0, 133, 0, 0, 95, 0, 0, 0, + 0, 75, 75, 75, 75, 0, 0, 133, 133, 0, + 75, 0, 133, 0, 75, 75, 0, 75, 0, 0, + 0, 0, 0, 75, 75, 0, 0, 75, 75, 75, + 75, 75, 77, 75, 0, 77, 0, 0, 0, 0, + 0, 0, 133, 76, 76, 76, 76, 0, 0, 77, + 77, 0, 76, 0, 77, 0, 76, 76, 0, 0, + 0, 0, 0, 0, 78, 76, 76, 78, 0, 76, + 76, 76, 76, 76, 79, 76, 0, 79, 0, 0, + 0, 78, 78, 0, 77, 0, 78, 0, 0, 0, + 0, 79, 79, 0, 0, 0, 79, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 77, 77, - 77, 77, 0, 0, 0, 0, 0, 77, 0, 0, + 0, 0, 0, 0, 0, 0, 78, 0, 0, 80, + 0, 0, 80, 0, 0, 0, 79, 0, 0, 0, + 0, 123, 123, 123, 123, 0, 80, 80, 0, 0, + 123, 80, 0, 0, 123, 123, 0, 0, 0, 0, + 0, 0, 0, 123, 123, 0, 0, 123, 123, 123, + 123, 123, 0, 82, 0, 0, 82, 0, 0, 0, + 0, 80, 0, 0, 0, 95, 95, 95, 95, 0, + 82, 82, 0, 0, 95, 82, 0, 0, 95, 95, + 0, 0, 0, 0, 0, 0, 0, 95, 95, 0, + 0, 95, 95, 95, 95, 95, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 82, 0, 0, 0, 0, + 0, 133, 133, 133, 133, 0, 0, 0, 0, 0, + 133, 0, 0, 0, 133, 133, 0, 0, 0, 0, + 0, 0, 0, 133, 133, 0, 0, 133, 133, 133, + 133, 133, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 77, 77, 77, 77, 0, 0, 0, + 0, 0, 77, 0, 0, 0, 0, 77, 0, 0, + 0, 0, 0, 0, 0, 77, 77, 0, 0, 77, + 77, 77, 77, 77, 0, 78, 78, 78, 78, 0, + 0, 0, 0, 0, 78, 79, 79, 79, 79, 0, + 0, 0, 0, 0, 79, 0, 0, 78, 78, 0, + 0, 78, 78, 78, 78, 78, 0, 79, 79, 0, + 0, 79, 79, 79, 79, 79, 0, 0, 0, 0, + 0, 92, 0, 0, 0, 0, 0, 0, 0, 105, + 80, 80, 80, 80, 112, 114, 0, 0, 0, 80, + 124, 125, 126, 127, 128, 129, 0, 0, 132, 133, + 0, 0, 80, 80, 0, 0, 80, 80, 80, 80, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 77, 77, 0, 0, 77, 77, 77, 77, 0, 0, - 79, 79, 79, 79, 0, 100, 0, 0, 0, 79, - 107, 109, 0, 0, 0, 0, 119, 120, 121, 122, - 123, 124, 79, 79, 127, 128, 79, 79, 79, 0, + 0, 0, 0, 0, 82, 82, 82, 82, 0, 0, + 0, 0, 182, 82, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 82, 82, 0, 0, + 82, 82, 82, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 80, 80, 80, 80, 0, 0, 0, - 0, 0, 80, 0, 0, 146, 0, 0, 177, 147, - 148, 149, 150, 0, 0, 80, 80, 0, 0, 80, - 80, 0, 0, 153, 154, 155, 156, 0, 157, 158, - 0, 0, 159, 0, 0, 160, 161, 162, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 208, 0, - 0, 0, 0, 0, 0, 0, 216, 217, 218, 219, - 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, + 0, 0, 0, 0, 214, 0, 0, 0, 0, 0, + 0, 0, 222, 223, 224, 225, 226, 227, 228, 229, + 230, 231, 232, 233, 234, 235, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, @@ -616,452 +615,448 @@ short yytable[] = { 205, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 282, 0, 0, 0, 0, + 0, 0, 0, 0, 292, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 298, + 0, 0, 308, }; -short yycheck[] = { 41, - 0, 41, 93, 41, 59, 93, 44, 91, 93, 176, - 59, 59, 45, 36, 59, 93, 123, 21, 40, 93, - 40, 59, 125, 41, 93, 91, 40, 40, 6, 40, - 93, 91, 59, 33, 187, 257, 36, 37, 38, 123, - 40, 45, 42, 43, 41, 45, 36, 41, 44, 257, - 40, 29, 0, 86, 41, 93, 41, 123, 41, 59, - 41, 59, 59, 123, 64, 59, 40, 181, 91, 183, - 40, 91, 59, 40, 59, 41, 59, 40, 59, 112, - 291, 292, 86, 257, 41, 33, 41, 275, 36, 37, - 38, 91, 40, 44, 42, 43, 123, 45, 41, 40, - 123, 123, 123, 123, 0, 273, 274, 274, 112, 123, - 123, 59, 123, 117, 59, 59, 64, 40, 40, 125, - 41, 41, 40, 123, 41, 125, 126, 41, 59, 36, - 91, 41, 285, 125, 59, 288, 292, 33, 91, 40, - 36, 37, 38, 91, 40, 40, 42, 43, 41, 45, - 257, 41, 125, 263, 264, 265, 41, 267, 268, 59, - 263, 264, 265, 59, 267, 268, 319, 125, 64, 283, - 284, 125, 41, 125, 41, 123, 290, 125, 126, 59, - 59, 41, 59, 41, 59, 41, 59, 41, 310, 81, - 13, 256, -1, 41, -1, 91, 44, -1, 312, -1, - 291, 292, -1, 291, 292, -1, 291, 292, -1, 257, - 58, 59, -1, 291, 292, -1, 123, 291, 292, -1, - -1, 13, 291, 292, -1, 17, 310, 123, 291, 292, - 126, 269, 270, 271, 272, 258, 291, 292, 30, 31, - 32, 33, 291, 292, -1, 93, 291, 292, 40, 291, - 292, 291, 292, 291, 46, -1, 256, 257, 258, 259, +short yycheck[] = { 13, + 36, 41, 93, 17, 59, 36, 41, 91, 41, 44, + 0, 41, 123, 93, 40, 93, 59, 59, 181, 33, + 34, 35, 36, 58, 59, 91, 48, 40, 63, 43, + 40, 91, 193, 125, 187, 49, 189, 294, 295, 123, + 40, 59, 41, 33, 41, 40, 36, 37, 38, 21, + 40, 257, 42, 43, 41, 45, 41, 123, 93, 41, + 91, 41, 41, 123, 78, 91, 0, 89, 6, 59, + 257, 36, 59, 41, 64, 40, 48, 59, 41, 93, + 59, 123, 96, 59, 98, 40, 100, 123, 102, 41, + 40, 59, 123, 31, 32, 117, 59, 123, 41, 33, + 41, 91, 36, 37, 38, 123, 40, 40, 42, 43, + 123, 45, 41, 123, 41, 40, 257, 89, 276, 277, + 44, 284, 0, 123, 41, 59, 278, 141, 123, 44, + 64, 40, 123, 123, 295, 125, 126, 298, 59, 260, + 293, 294, 59, 59, 40, 117, 257, 300, 40, 40, + 122, 41, 125, 41, 91, 33, 59, 91, 36, 37, + 38, 183, 40, 177, 42, 43, 41, 45, 329, 322, + 184, 125, 91, 59, 266, 267, 268, 295, 270, 271, + 40, 59, 40, 266, 267, 268, 64, 270, 271, 123, + 41, 125, 126, 125, 125, 125, 59, 125, 41, 41, + 59, 123, 257, 294, 295, 59, 41, 59, 41, 44, + 59, 183, 41, 91, 294, 295, 294, 295, 59, 59, + 41, 257, 41, 58, 59, 93, 262, 258, 63, 313, + 320, 59, 272, 273, 274, 275, 84, 272, 273, 274, + 275, 13, 256, 266, 258, 123, 260, 261, 126, 94, + 264, 294, 295, 267, 294, 295, 93, -1, 93, 294, + 295, 294, 295, 298, 294, 295, 256, 257, 258, 259, 260, 261, -1, 263, 264, 265, 266, 267, 268, 269, - 270, 271, 272, 291, 292, -1, 276, 277, -1, 279, - 280, 281, -1, 75, -1, 77, 286, 287, 288, 289, - 290, -1, -1, 293, 294, 291, 292, 89, -1, 91, - 300, 93, -1, 95, 304, 97, 306, 307, 256, 257, - 258, 259, 260, 261, -1, 263, 264, 265, 266, 267, - 268, 269, 270, 271, 272, 291, 292, -1, 276, 277, - -1, 279, 280, 281, 291, 292, 291, 292, 286, 287, - 288, 289, 290, -1, 136, 293, 294, -1, 291, 292, - 257, 41, 300, -1, 44, 262, 304, 13, 306, 307, - 256, 257, 258, 259, 260, 261, 291, 292, 58, 59, - 266, 291, 292, 269, 270, 271, 272, 291, 292, -1, - 276, 277, -1, 279, 280, 281, 42, -1, 44, -1, - 286, 287, 288, 289, 290, -1, 52, 293, 294, -1, - 56, 291, 292, 93, 300, 41, 291, 292, 304, -1, - 306, 307, 291, 292, -1, -1, -1, -1, -1, -1, - -1, 269, 270, 271, 272, -1, -1, -1, 91, -1, - 41, -1, -1, 44, 90, -1, 92, -1, 94, -1, - 96, -1, 98, 291, 292, -1, 102, 58, 59, -1, - -1, -1, 63, -1, 246, -1, 248, -1, 250, 251, - 123, -1, 254, -1, -1, 257, -1, 33, -1, -1, - 36, 37, 38, -1, 40, 41, 42, 43, 44, 45, - -1, -1, 93, 139, 140, 141, 142, 143, 144, 145, - -1, -1, 58, 59, -1, -1, -1, 63, 64, 291, - 269, 270, 271, 272, -1, -1, -1, 163, 164, 165, - 166, 167, 168, -1, -1, -1, -1, -1, -1, 26, - -1, -1, 291, 292, 316, 91, 58, 93, 320, -1, - -1, 63, 39, -1, -1, 191, -1, -1, 45, -1, - 91, 197, 198, 199, -1, -1, -1, -1, 204, -1, - 57, 58, 59, 60, 61, -1, -1, 123, 33, 91, - 126, 36, 37, 38, -1, 40, 41, 42, 43, 44, - 45, -1, 123, -1, 230, -1, 232, -1, -1, 269, - 270, 271, 272, 58, 59, -1, -1, -1, 63, 64, - -1, 123, -1, -1, -1, -1, 103, -1, -1, -1, - 256, 291, 292, -1, -1, 295, -1, -1, -1, -1, - -1, -1, -1, 269, -1, -1, -1, 33, 93, -1, - 36, 37, 38, -1, 40, -1, 42, 43, -1, 45, - -1, 287, -1, 269, 270, 271, 272, -1, -1, 302, - -1, -1, 305, 59, -1, 308, 309, 310, 64, -1, - -1, 126, -1, -1, 310, 291, 292, -1, 269, 270, - 271, 272, -1, -1, -1, -1, -1, 278, -1, -1, - -1, 282, 283, 284, 285, 91, -1, -1, -1, -1, - 291, 292, -1, -1, 295, 296, 297, 298, 299, -1, - 301, 257, 258, 259, 260, 261, -1, -1, -1, -1, - 266, -1, -1, 269, 270, 271, 272, 123, -1, -1, - 126, 277, 278, 279, 280, 281, 282, 283, 284, 285, - 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, - 296, 297, 298, 299, 300, 301, 302, 41, 304, 305, - 306, 307, 308, 309, 310, -1, 278, -1, -1, -1, - 282, 283, 284, 285, 305, 59, -1, 308, 309, 310, - -1, -1, -1, 295, 296, 297, 298, 299, -1, 301, - 302, -1, -1, 305, -1, -1, 308, 309, 310, -1, - -1, -1, 257, 258, 259, 260, 261, -1, -1, 93, - -1, 266, -1, -1, 269, 270, 271, 272, -1, -1, - -1, -1, 277, 278, 279, 280, 281, 282, 283, 284, - 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, - 295, 296, 297, 298, 299, 300, 301, 302, -1, 304, - 305, 306, 307, 308, 309, 310, 91, -1, -1, -1, - 256, 257, 258, 259, 260, 261, -1, -1, -1, -1, - 266, -1, -1, 269, 270, 271, 272, -1, -1, -1, - 276, 277, -1, 279, 280, 281, -1, -1, 123, -1, - 286, 287, 288, 289, 290, -1, -1, 293, 294, -1, - -1, -1, -1, -1, 300, -1, -1, 91, 304, 33, - 306, 307, 36, 37, 38, -1, 40, -1, 42, 43, - -1, 45, 25, 26, -1, -1, -1, -1, -1, -1, - -1, 34, -1, -1, -1, 59, 39, 40, -1, 123, - 64, -1, 45, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 57, 58, 59, 60, 61, -1, - -1, 33, -1, -1, 36, 37, 38, 91, 40, -1, - 42, 43, -1, 45, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 269, 270, 271, 272, -1, - -1, -1, 64, -1, -1, -1, -1, -1, -1, 123, - 103, -1, 126, -1, -1, -1, -1, 291, 292, -1, - -1, -1, -1, 33, -1, -1, 36, 37, 38, 91, - 40, -1, 42, 43, -1, 45, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 91, -1, 59, - -1, -1, -1, -1, 64, -1, -1, 282, 283, 284, - 285, 123, -1, -1, 126, -1, -1, -1, -1, 162, - -1, 296, 297, 298, 299, -1, 301, 302, -1, 123, - 305, 91, -1, 308, 309, 310, -1, -1, -1, -1, - -1, 33, -1, -1, 36, 37, 38, -1, 40, -1, - 42, 43, -1, 45, -1, -1, -1, -1, 282, 283, - 284, 285, -1, -1, -1, -1, 126, -1, -1, -1, - -1, -1, 64, 297, 298, 299, -1, 301, 302, -1, - -1, 305, -1, -1, 308, 309, 310, -1, -1, -1, - -1, -1, 256, 257, 258, 259, 260, 261, -1, 91, - -1, -1, 266, -1, -1, 269, 270, 271, 272, -1, - -1, -1, 276, 277, -1, 279, 280, 281, -1, -1, - -1, -1, 286, 287, 288, 289, 290, -1, -1, 293, - 294, 123, -1, -1, 126, -1, 300, -1, -1, 91, - 304, -1, 306, 307, -1, 257, 258, 259, 260, 261, - 262, -1, 33, -1, 266, 36, 37, 38, -1, 40, - 41, 42, 43, -1, 45, 277, -1, 279, 280, 281, - -1, 123, -1, 91, 286, 287, 288, 289, 290, -1, - -1, 293, 294, 64, -1, -1, -1, -1, 300, -1, - 284, 285, 304, -1, 306, 307, -1, 257, 258, 259, - 260, 261, -1, -1, -1, 123, 266, 301, 302, -1, - 91, 305, -1, -1, 308, 309, 310, 277, -1, 279, - 280, 281, -1, -1, -1, -1, 286, 287, 288, 289, - 290, -1, -1, 293, 294, -1, -1, -1, -1, -1, - 300, -1, -1, -1, 304, 126, 306, 307, -1, 33, - 91, -1, 36, 37, 38, -1, 40, -1, 42, 43, - -1, 45, -1, -1, -1, 257, 258, 259, 260, 261, - 262, -1, -1, -1, 266, -1, -1, -1, -1, -1, - 64, -1, 123, -1, -1, 277, -1, 279, 280, 281, - -1, -1, -1, -1, 286, 287, 288, 289, 290, -1, - -1, -1, 294, -1, -1, -1, -1, 91, 300, 93, - -1, -1, 304, -1, 306, 307, -1, 33, -1, -1, - 36, 37, 38, -1, 40, -1, 42, 43, -1, 45, - 282, 283, 284, 285, -1, -1, -1, -1, -1, -1, - -1, -1, 126, -1, -1, -1, 298, 299, 64, 301, - 302, -1, -1, 305, -1, -1, 308, 309, 310, -1, - -1, -1, -1, -1, 282, 283, 284, 285, -1, -1, - -1, 41, -1, -1, 44, 91, 257, 258, 259, 260, - 261, 299, -1, 301, 302, 266, -1, 305, -1, -1, - 308, 309, 310, 63, -1, -1, 277, -1, 279, 280, - 281, -1, -1, -1, -1, 286, 287, 288, 289, 290, - 126, -1, 293, 294, -1, -1, -1, -1, -1, 300, - -1, 91, -1, 304, -1, 306, 307, -1, 33, -1, - 91, 36, 37, 38, -1, 40, 41, 42, 43, -1, - 45, 282, 283, 284, 285, -1, -1, -1, -1, -1, - -1, -1, 91, 123, -1, -1, -1, -1, -1, 64, - 301, 302, 123, 41, 305, -1, 44, 308, 309, 310, - -1, -1, -1, 257, 258, 259, 260, 261, -1, -1, - 58, 59, 266, -1, 123, 63, 91, -1, -1, -1, - -1, -1, -1, 277, -1, 279, 280, 281, -1, -1, - -1, -1, 286, 287, 288, 289, 290, -1, -1, 293, - 294, -1, -1, -1, -1, 93, 300, -1, -1, -1, - 304, 126, 306, 307, 33, 91, -1, 36, 37, 38, - -1, 40, 41, 42, 43, -1, 45, -1, -1, -1, - 256, 257, 258, 259, 260, 261, -1, -1, -1, -1, - 266, -1, -1, -1, -1, 64, -1, 123, -1, -1, - -1, 277, -1, 279, 280, 281, -1, -1, -1, -1, - 286, 287, 288, 289, 290, -1, -1, 293, 294, -1, - -1, -1, 91, -1, 300, -1, -1, -1, 304, -1, - 306, 307, -1, 33, -1, -1, 36, 37, 38, -1, - 40, 41, 42, 43, -1, 45, -1, -1, 278, -1, - -1, -1, 282, 283, 284, 285, -1, 126, -1, -1, - -1, -1, -1, 284, 64, 295, 296, 297, 298, 299, - -1, 301, 302, -1, -1, 305, -1, -1, 308, 309, - 310, 302, -1, 282, 305, 284, 285, 308, 309, 310, - -1, 91, 257, 258, 259, 260, 261, -1, -1, -1, - -1, 266, 301, 302, -1, -1, 305, -1, -1, 308, - 309, 310, 277, -1, 279, 280, 281, -1, -1, -1, - -1, 286, 287, 288, 289, 290, 126, -1, 293, 294, - -1, 269, 270, 271, 272, 300, -1, -1, -1, 304, - 33, 306, 307, 36, 37, 38, -1, 40, 41, 42, - 43, -1, 45, 291, 292, -1, -1, 295, 284, 285, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 64, -1, -1, -1, -1, 302, -1, -1, 305, - -1, -1, 308, 309, 310, -1, -1, -1, 257, 258, - 259, 260, 261, -1, -1, -1, -1, 266, 91, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 277, -1, - 279, 280, 281, -1, -1, -1, -1, 286, 287, 288, - 289, 290, -1, 41, 293, 294, 44, -1, -1, -1, - -1, 300, -1, 126, -1, 304, -1, 306, 307, 33, - 58, 59, 36, 37, 38, 63, 40, -1, 42, 43, - -1, 45, -1, -1, -1, -1, -1, 257, 258, 259, - 260, 261, -1, -1, -1, -1, 266, -1, -1, -1, - 64, -1, -1, -1, -1, 93, -1, 277, -1, 279, - 280, 281, -1, -1, -1, -1, 286, 287, 288, 289, - 290, -1, -1, 293, 294, -1, -1, 91, -1, -1, - 300, -1, -1, -1, 304, 33, 306, 307, 36, 37, + 270, 271, 272, 273, 274, 275, -1, 301, -1, 279, + 280, -1, 282, 283, 284, 294, 295, 294, 295, 289, + 290, 291, 292, 293, -1, -1, 296, 297, -1, 294, + 295, 93, 326, 303, 294, 295, 330, 307, -1, 309, + 310, -1, 256, 257, 258, 259, 260, 261, 93, 263, + 264, 265, 266, 267, 268, 269, 270, 271, 272, 273, + 274, 275, 294, 295, -1, 279, 280, -1, 282, 283, + 284, 294, 295, 294, 295, 289, 290, 291, 292, 293, + -1, -1, 296, 297, -1, 294, 295, 294, 295, 303, + 294, 295, 41, 307, -1, 309, 310, -1, 256, 257, + 258, 259, 260, 261, -1, 263, 264, 265, 13, 41, + 59, 269, 44, -1, 272, 273, 274, 275, -1, 41, + -1, 279, 280, -1, 282, 283, 284, 59, 294, 295, + -1, 289, 290, 291, 292, 293, -1, -1, 296, 297, + 45, 63, 47, -1, 93, 303, 294, 295, -1, 307, + 55, 309, 310, -1, 59, 294, 295, 272, 273, 274, + 275, 93, 294, 295, 41, -1, 281, 44, -1, 91, + 285, 286, 287, 288, 294, 295, -1, 294, 295, 294, + 295, 58, 59, 298, 299, 300, 301, 302, -1, 304, + 95, 91, 97, -1, 99, -1, 101, -1, 103, -1, + 33, 123, 107, 36, 37, 38, -1, 40, 41, 42, + 43, 44, 45, -1, -1, -1, 93, -1, -1, -1, + -1, -1, -1, 123, -1, 58, 59, -1, -1, -1, + 63, 64, 294, 295, -1, -1, -1, -1, -1, 144, + 145, 146, 147, 148, 149, 150, -1, -1, -1, 294, + 295, -1, -1, -1, -1, -1, 41, -1, 91, 44, + 93, -1, -1, 168, 169, 170, 171, 172, 173, -1, + -1, -1, -1, 58, 59, -1, 33, 91, 63, 36, + 37, 38, -1, 40, 41, 42, 43, 44, 45, -1, + 123, -1, 197, 126, 272, 273, 274, 275, 203, 204, + 205, 58, 59, -1, -1, 210, 63, 64, 93, 123, + -1, -1, -1, -1, -1, -1, 294, 295, -1, -1, + -1, -1, -1, 272, 273, 274, 275, -1, -1, -1, + -1, 236, -1, 238, -1, -1, 93, -1, -1, -1, + 272, 273, 274, 275, 33, 294, 295, 36, 37, 38, + -1, 40, -1, 42, 43, -1, 45, -1, -1, 281, + -1, 266, 294, 285, 286, 287, 288, -1, -1, 126, + 59, -1, -1, -1, 279, 64, 298, 299, 300, 301, + 302, -1, 304, 305, -1, 285, 308, 287, 288, 311, + 312, 313, 297, -1, -1, 272, 273, 274, 275, -1, + -1, -1, 91, -1, 304, 305, -1, -1, 308, -1, + -1, 311, 312, 313, -1, 320, -1, 294, 295, -1, + -1, 298, -1, -1, 257, 258, 259, 260, 261, -1, + 263, 264, 265, -1, 123, -1, 269, 126, -1, 272, + 273, 274, 275, -1, -1, -1, -1, 280, 281, 282, + 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, + 293, 294, 295, 296, 297, 298, 299, 300, 301, 302, + 303, 304, 305, 287, 307, 308, 309, 310, 311, 312, + 313, -1, -1, -1, -1, -1, -1, 272, 273, 274, + 275, 305, -1, -1, 308, -1, 281, 311, 312, 313, + 257, 258, 259, 260, 261, -1, 263, 264, 265, 294, + 295, -1, 269, 298, 299, 272, 273, 274, 275, -1, + -1, -1, -1, 280, 281, 282, 283, 284, 285, 286, + 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, + 297, 298, 299, 300, 301, 302, 303, 304, 305, 91, + 307, 308, 309, 310, 311, 312, 313, -1, -1, -1, + -1, -1, -1, -1, 91, -1, -1, 256, 257, 258, + 259, 260, 261, -1, 263, 264, 265, -1, -1, -1, + 269, 123, -1, 272, 273, 274, 275, -1, -1, -1, + 279, 280, -1, 282, 283, 284, 123, -1, 91, -1, + 289, 290, 291, 292, 293, -1, -1, 296, 297, -1, + -1, -1, -1, -1, 303, -1, -1, 91, 307, 33, + 309, 310, 36, 37, 38, 26, 40, -1, 42, 43, + 123, 45, -1, -1, 25, 26, -1, -1, -1, -1, + -1, 42, -1, -1, -1, 59, 37, 48, -1, 123, + 64, 42, 43, -1, -1, -1, -1, 48, -1, 60, + 61, 62, 63, 64, -1, -1, -1, -1, -1, 60, + 61, 62, 63, 64, -1, 33, -1, 91, 36, 37, 38, -1, 40, -1, 42, 43, -1, 45, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 123, - -1, -1, 126, -1, -1, -1, 64, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 91, -1, + -1, -1, -1, -1, -1, -1, 64, 108, -1, 123, + -1, -1, 126, -1, -1, -1, -1, 108, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 41, -1, -1, 44, -1, -1, -1, -1, - -1, -1, -1, 91, 257, 258, 259, 260, 261, 58, - 59, -1, -1, 266, 63, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 277, -1, 279, 280, 281, -1, - -1, -1, -1, 286, 287, 288, 289, 290, 126, -1, - 293, 294, 91, -1, 93, -1, -1, 300, -1, -1, - -1, 304, 33, 306, 307, 36, 37, 38, -1, 40, - -1, 42, 43, -1, 45, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 123, -1, -1, -1, -1, -1, - -1, -1, -1, 64, -1, -1, -1, -1, -1, -1, - -1, 269, 270, 271, 272, -1, -1, -1, -1, -1, - 278, -1, -1, 257, 258, 259, 260, 261, -1, -1, - 91, -1, 266, 291, 292, -1, -1, 295, 296, 297, - 298, 299, -1, 277, -1, 279, 280, 281, -1, -1, - -1, -1, 286, 287, 288, 289, 290, -1, -1, -1, - 294, -1, 123, -1, -1, 126, 300, -1, -1, -1, - 304, 33, 306, 307, 36, 37, 38, -1, 40, -1, - 42, 43, -1, 45, -1, -1, -1, -1, -1, 257, - 258, 259, 260, 261, -1, -1, -1, -1, 266, -1, - -1, -1, 64, -1, -1, -1, -1, -1, -1, 277, - -1, 279, 280, 281, -1, -1, -1, -1, 286, 287, - 288, 289, 290, -1, -1, 293, 294, -1, -1, 91, - -1, -1, 300, -1, -1, -1, 304, -1, 306, 307, - 269, 270, 271, 272, -1, -1, -1, -1, -1, 278, - -1, -1, -1, 282, 283, 284, 285, -1, -1, -1, - -1, -1, 291, 292, 126, -1, 295, 296, 297, 298, - 299, 41, 301, 302, 44, -1, 305, -1, -1, 308, - 309, 310, -1, -1, -1, -1, -1, -1, 58, 59, - -1, -1, -1, 63, -1, -1, 257, 258, 259, 260, - 261, -1, -1, -1, -1, 266, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 277, -1, 279, 280, - 281, 91, -1, 93, -1, 286, 287, 288, 289, 290, - -1, -1, 41, 294, -1, 44, -1, -1, -1, 300, - -1, -1, -1, 304, -1, 306, 307, -1, -1, 58, - 59, -1, -1, 123, 63, -1, -1, -1, -1, -1, + 123, 33, -1, 91, 36, 37, 38, -1, 40, -1, + 42, 43, -1, 45, -1, 287, 288, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 59, 285, 286, + 287, 288, 64, 305, -1, 123, 308, -1, 126, 311, + 312, 313, 299, 300, 301, 302, 167, 304, 305, -1, + -1, 308, -1, -1, 311, 312, 313, -1, -1, 91, + -1, -1, -1, -1, 33, -1, -1, 36, 37, 38, + -1, 40, -1, 42, 43, -1, 45, -1, -1, -1, + -1, 285, 286, 287, 288, 308, -1, -1, 311, 312, + 313, -1, -1, -1, 126, 64, 300, 301, 302, -1, + 304, 305, -1, -1, 308, -1, -1, 311, 312, 313, + -1, -1, 256, 257, 258, 259, 260, 261, -1, 263, + 264, 265, 91, -1, -1, 269, -1, -1, 272, 273, + 274, 275, -1, -1, -1, 279, 280, -1, 282, 283, + 284, -1, -1, -1, -1, 289, 290, 291, 292, 293, + -1, -1, 296, 297, 123, -1, -1, 126, 63, 303, + -1, -1, -1, 307, -1, 309, 310, -1, -1, 257, + 258, 259, 260, 261, 262, 263, 264, 265, -1, -1, + -1, 269, 305, -1, -1, 308, 91, -1, 311, 312, + 313, -1, 280, -1, 282, 283, 284, -1, -1, -1, + -1, 289, 290, 291, 292, 293, -1, -1, 296, 297, + -1, 58, -1, -1, -1, 303, 63, -1, 123, 307, + -1, 309, 310, -1, -1, 257, 258, 259, 260, 261, + -1, 263, 264, 265, -1, -1, -1, 269, -1, -1, + -1, -1, -1, -1, 91, -1, -1, -1, 280, -1, + 282, 283, 284, -1, -1, -1, -1, 289, 290, 291, + 292, 293, -1, -1, 296, 297, 41, -1, -1, 44, + -1, 303, -1, -1, -1, 307, 123, 309, 310, -1, + -1, -1, -1, 58, 59, -1, -1, -1, 257, 258, + 259, 260, 261, 262, 263, 264, 265, -1, 33, -1, + 269, 36, 37, 38, -1, 40, 41, 42, 43, -1, + 45, 280, -1, 282, 283, 284, -1, -1, 93, 91, + 289, 290, 291, 292, 293, -1, -1, -1, 297, 64, + -1, -1, -1, -1, 303, -1, -1, -1, 307, -1, + 309, 310, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 123, -1, -1, 33, -1, 91, 36, 37, 38, + -1, 40, -1, 42, 43, -1, 45, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 281, -1, -1, -1, + 285, 286, 287, 288, -1, 64, -1, -1, -1, -1, + -1, 126, -1, 298, 299, 300, 301, 302, -1, 304, + 305, -1, -1, 308, -1, -1, 311, 312, 313, -1, + -1, -1, 91, 33, 93, -1, 36, 37, 38, -1, + 40, -1, 42, 43, -1, 45, -1, -1, -1, -1, + -1, -1, -1, -1, 281, -1, -1, 91, 285, 286, + 287, 288, -1, -1, 64, -1, -1, 126, -1, -1, + -1, 298, 299, 300, 301, 302, -1, 304, 305, -1, + -1, 308, -1, -1, 311, 312, 313, -1, -1, 123, + -1, 91, -1, 33, -1, -1, 36, 37, 38, -1, + 40, 41, 42, 43, -1, 45, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 272, 273, 274, + 275, -1, -1, -1, 64, -1, 126, -1, -1, -1, + -1, -1, -1, 285, 286, 287, 288, -1, -1, 294, + 295, -1, 257, 258, 259, 260, 261, -1, 263, 264, + 265, 91, 304, 305, 269, -1, 308, -1, -1, 311, + 312, 313, -1, -1, -1, 280, -1, 282, 283, 284, + -1, -1, -1, -1, 289, 290, 291, 292, 293, -1, + -1, 296, 297, -1, -1, -1, 126, -1, 303, -1, + -1, -1, 307, -1, 309, 310, -1, -1, 257, 258, + 259, 260, 261, -1, 263, 264, 265, -1, 33, -1, + 269, 36, 37, 38, -1, 40, 41, 42, 43, -1, + 45, 280, -1, 282, 283, 284, -1, -1, -1, -1, + 289, 290, 291, 292, 293, -1, -1, 296, 297, 64, + -1, -1, -1, -1, 303, -1, -1, -1, 307, -1, + 309, 310, -1, 287, 288, -1, 256, 257, 258, 259, + 260, 261, -1, 263, 264, 265, 91, -1, -1, 269, + 304, 305, -1, -1, 308, -1, -1, 311, 312, 313, + 280, -1, 282, 283, 284, -1, -1, -1, -1, 289, + 290, 291, 292, 293, -1, 41, 296, 297, 44, -1, + -1, 126, -1, 303, -1, -1, -1, 307, -1, 309, + 310, -1, 58, 59, -1, -1, -1, 257, 258, 259, + 260, 261, -1, 263, 264, 265, -1, 33, -1, 269, + 36, 37, 38, -1, 40, 41, 42, 43, -1, 45, + 280, -1, 282, 283, 284, -1, -1, 93, -1, 289, + 290, 291, 292, 293, -1, -1, 296, 297, 64, -1, + -1, -1, -1, 303, -1, -1, -1, 307, -1, 309, + 310, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 33, -1, 91, 36, 37, 38, -1, + 40, 41, 42, 43, -1, 45, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 64, -1, -1, -1, -1, -1, + 126, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 257, 258, 259, 260, 261, -1, 263, 264, + 265, 91, 33, -1, 269, 36, 37, 38, -1, 40, + -1, 42, 43, -1, 45, 280, -1, 282, 283, 284, + -1, -1, -1, -1, 289, 290, 291, 292, 293, -1, + -1, 296, 297, 64, -1, -1, 126, -1, 303, -1, + -1, -1, 307, -1, 309, 310, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 91, 41, 93, -1, 44, -1, -1, -1, - -1, -1, -1, -1, -1, 257, 258, 259, 260, 261, - 58, 59, -1, -1, 266, 63, -1, -1, -1, -1, - -1, -1, -1, -1, 123, 277, -1, 279, 280, 281, - -1, -1, -1, -1, 286, 287, 288, 289, 290, 41, - -1, -1, 294, -1, -1, 93, -1, -1, 300, -1, - -1, -1, 304, -1, 306, 307, 58, 59, -1, -1, - -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 123, -1, -1, -1, -1, - -1, 41, -1, -1, 44, -1, -1, -1, -1, 91, - -1, 93, -1, -1, -1, -1, -1, -1, 58, 59, - -1, -1, -1, 63, -1, -1, -1, -1, -1, 269, - 270, 271, 272, -1, -1, -1, -1, -1, 278, -1, - -1, 123, 282, 283, 284, 285, -1, -1, -1, -1, - -1, 291, 292, 93, -1, 295, 296, 297, 298, 299, - -1, 301, 302, 41, -1, 305, 44, -1, 308, 309, - 310, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 58, 59, -1, 123, -1, 63, -1, -1, -1, -1, - 269, 270, 271, 272, -1, -1, -1, -1, -1, 278, - -1, -1, -1, 282, 283, 284, 285, -1, -1, -1, - 41, -1, 291, 292, -1, 93, 295, 296, 297, 298, - 299, -1, 301, 302, -1, -1, 305, 58, 59, 308, - 309, 310, 63, -1, -1, -1, -1, -1, -1, -1, - -1, 269, 270, 271, 272, 123, -1, -1, -1, -1, - 278, -1, -1, -1, 282, 283, 284, 285, -1, -1, - 91, -1, 93, 291, 292, -1, -1, 295, 296, 297, - 298, 299, -1, 301, 302, -1, -1, 305, -1, -1, - 308, 309, 310, -1, -1, -1, -1, 269, 270, 271, - 272, -1, 123, -1, 41, -1, 278, 44, -1, -1, - 282, 283, 284, 285, -1, -1, -1, -1, -1, 291, - 292, 58, 59, 295, 296, 297, 298, 299, -1, 301, - 302, -1, -1, 305, -1, -1, 308, 309, 310, 269, - 270, 271, 272, -1, -1, -1, 41, -1, 278, 44, - -1, -1, 282, 283, 284, 285, 93, -1, -1, -1, - -1, 291, 292, 58, 59, 295, 296, 297, 298, 299, - 41, 301, 302, 44, -1, 305, -1, -1, 308, 309, - 310, -1, -1, -1, -1, -1, -1, 58, 59, -1, - -1, -1, 63, -1, -1, -1, -1, -1, 93, -1, - -1, 269, 270, 271, 272, -1, -1, -1, -1, -1, - 278, -1, -1, -1, 282, 283, 284, 285, -1, -1, - -1, -1, 93, 291, 292, -1, -1, 295, 296, 297, - 298, 299, -1, 301, 302, -1, -1, 305, -1, -1, - 308, 309, 310, -1, -1, -1, -1, -1, 269, 270, - 271, 272, 123, -1, -1, -1, -1, 278, -1, -1, - -1, 282, 283, 284, 285, -1, -1, -1, -1, -1, - 291, 292, -1, -1, 295, 296, 297, 298, 299, 41, - 301, 302, 44, -1, 305, -1, -1, 308, 309, 310, + 91, -1, 33, -1, -1, 36, 37, 38, -1, 40, + -1, 42, 43, -1, 45, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 272, 273, 274, 275, + -1, -1, 123, 64, -1, 126, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 294, 295, + -1, 257, 258, 259, 260, 261, -1, 263, 264, 265, + 91, -1, -1, 269, 41, -1, -1, 44, -1, -1, + -1, -1, -1, -1, 280, -1, 282, 283, 284, -1, + -1, 58, 59, 289, 290, 291, 292, 293, -1, -1, + 296, 297, -1, 91, -1, 126, -1, 303, -1, -1, + -1, 307, -1, 309, 310, -1, -1, 257, 258, 259, + 260, 261, -1, 263, 264, 265, 93, 33, -1, 269, + 36, 37, 38, -1, 40, 123, 42, 43, -1, 45, + 280, -1, 282, 283, 284, -1, -1, -1, -1, 289, + 290, 291, 292, 293, -1, -1, 296, 297, 64, -1, + -1, -1, -1, 303, -1, -1, -1, 307, -1, 309, + 310, -1, -1, -1, -1, -1, 257, 258, 259, 260, + 261, -1, 263, 264, 265, 91, -1, -1, 269, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 280, + -1, 282, 283, 284, -1, -1, -1, -1, 289, 290, + 291, 292, 293, -1, -1, -1, 297, 123, -1, -1, + 126, -1, 303, -1, -1, -1, 307, -1, 309, 310, + -1, -1, -1, -1, -1, -1, 257, 258, 259, 260, + 261, 91, 263, 264, 265, -1, 33, -1, 269, 36, + 37, 38, -1, 40, -1, 42, 43, -1, 45, 280, + -1, 282, 283, 284, -1, -1, -1, -1, 289, 290, + 291, 292, 293, 123, -1, 296, 297, 64, -1, -1, + -1, -1, 303, -1, -1, -1, 307, -1, 309, 310, + -1, -1, -1, 41, -1, -1, 44, 285, 286, 287, + 288, -1, -1, -1, 91, 272, 273, 274, 275, -1, + 58, 59, -1, 301, 302, 63, 304, 305, -1, -1, + 308, -1, -1, 311, 312, 313, -1, 294, 295, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 126, + -1, -1, -1, 91, 41, 93, -1, 44, -1, -1, + -1, 257, 258, 259, 260, 261, -1, 263, 264, 265, + -1, 58, 59, 269, -1, -1, 63, -1, -1, -1, + -1, -1, -1, -1, 280, 123, 282, 283, 284, -1, + -1, -1, -1, 289, 290, 291, 292, 293, -1, -1, + -1, 297, -1, -1, 91, -1, 93, 303, -1, 41, + -1, 307, 44, 309, 310, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 58, 59, -1, -1, - -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 63, -1, -1, -1, -1, 123, -1, -1, -1, + -1, -1, -1, -1, -1, 285, 286, 287, 288, -1, + -1, -1, 41, -1, -1, 44, -1, 41, -1, 91, + 44, 93, 302, -1, 304, 305, -1, -1, 308, 58, + 59, 311, 312, 313, 58, 59, -1, -1, -1, 63, + 257, 258, 259, 260, 261, -1, 263, 264, 265, -1, + -1, 123, 269, -1, -1, -1, -1, -1, -1, -1, + -1, 41, -1, 280, 93, 282, 283, 284, -1, 93, + -1, -1, 289, 290, 291, 292, 293, -1, 58, 59, + 297, -1, -1, 63, -1, -1, 303, -1, -1, -1, + 307, -1, 309, 310, 272, 273, 274, 275, -1, 123, + -1, -1, -1, 281, -1, -1, -1, 285, 286, 287, + 288, 91, -1, 93, -1, -1, 294, 295, -1, -1, + 298, 299, 300, 301, 302, -1, 304, 305, -1, -1, + 308, -1, -1, 311, 312, 313, -1, -1, -1, -1, + -1, -1, -1, 123, -1, 272, 273, 274, 275, -1, + -1, -1, 41, -1, 281, 44, -1, -1, 285, 286, + 287, 288, -1, -1, -1, -1, -1, 294, 295, 58, + 59, 298, 299, 300, 301, 302, -1, 304, 305, -1, + -1, 308, -1, -1, 311, 312, 313, -1, -1, -1, + 41, -1, -1, 44, -1, -1, -1, -1, -1, -1, + 272, 273, 274, 275, 93, -1, -1, 58, 59, 281, + -1, -1, 63, 285, 286, 287, 288, -1, -1, -1, + -1, -1, 294, 295, -1, -1, 298, 299, 300, 301, + 302, -1, 304, 305, -1, -1, 308, -1, -1, 311, + 312, 313, 93, 272, 273, 274, 275, -1, 272, 273, + 274, 275, -1, -1, -1, -1, -1, 281, -1, -1, + -1, 285, 286, 287, 288, 294, 295, -1, -1, -1, + 294, 295, 123, -1, 298, 299, 300, 301, 302, -1, + 304, 305, 41, -1, 308, 44, -1, 311, 312, 313, + -1, -1, 272, 273, 274, 275, -1, -1, -1, 58, + 59, 281, -1, -1, 63, 285, 286, 287, 288, -1, + -1, -1, -1, -1, 294, 295, -1, -1, 298, 299, + 300, 301, 302, -1, 304, 305, 41, -1, 308, 44, + -1, 311, 312, 313, 93, -1, -1, -1, -1, -1, + -1, -1, -1, 58, 59, -1, -1, -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 41, -1, -1, 44, -1, -1, -1, -1, -1, - -1, 93, 269, 270, 271, 272, -1, -1, 58, 59, - -1, -1, -1, 63, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 291, 292, -1, -1, -1, -1, - -1, 123, -1, 41, -1, -1, 44, -1, -1, -1, - -1, -1, -1, 93, 269, 270, 271, 272, -1, -1, - 58, 59, -1, -1, -1, 63, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 291, 292, 269, 270, - 271, 272, -1, -1, -1, 41, -1, 278, 44, -1, - -1, 282, 283, 284, 285, 93, -1, -1, -1, -1, - 291, 292, 58, 59, 295, 296, 297, 298, 299, 41, - 301, 302, 44, -1, 305, -1, -1, 308, 309, 310, - -1, -1, -1, -1, -1, -1, 58, 59, -1, -1, - -1, 63, -1, -1, -1, -1, -1, 93, -1, -1, + -1, -1, -1, -1, 123, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 41, -1, 93, -1, + -1, -1, -1, 272, 273, 274, 275, -1, -1, -1, + -1, -1, -1, 58, 59, -1, -1, -1, 63, -1, + -1, -1, -1, -1, -1, 294, 295, -1, 123, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 41, -1, -1, 44, -1, -1, -1, -1, - -1, 93, -1, -1, -1, -1, -1, -1, -1, 58, + -1, 272, 273, 274, 275, -1, 91, -1, 93, -1, + 281, -1, -1, -1, 285, 286, 287, 288, -1, -1, + -1, -1, -1, 294, 295, -1, -1, 298, 299, 300, + 301, 302, 41, 304, 305, 44, -1, 308, 123, -1, + 311, 312, 313, -1, -1, -1, -1, -1, -1, 58, 59, -1, -1, -1, 63, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 41, -1, 269, 270, 271, - 272, -1, -1, -1, -1, -1, 278, -1, -1, -1, - 282, 283, 284, 285, 93, -1, -1, 63, -1, 291, - 292, -1, -1, 295, 296, 297, 298, 299, -1, 301, - 302, -1, -1, 305, -1, -1, 308, 309, 310, 269, - 270, 271, 272, -1, -1, 91, -1, -1, 278, -1, - -1, -1, 282, 283, 284, 285, -1, -1, -1, -1, - -1, 291, 292, -1, -1, 295, 296, 297, 298, 299, - -1, 301, 302, -1, -1, 305, -1, 123, 308, 309, - 310, 269, 270, 271, 272, -1, -1, -1, -1, -1, - 278, -1, -1, -1, 282, 283, 284, 285, -1, -1, - -1, -1, -1, 291, 292, -1, -1, 295, 296, 297, - 298, 299, 41, 301, 302, 44, -1, 305, -1, -1, - 308, 309, 310, 269, 270, 271, 272, -1, -1, 58, - 59, -1, -1, -1, 63, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 291, 292, 269, 270, 271, - 272, -1, -1, -1, -1, -1, 278, -1, -1, -1, - 282, 283, 284, 285, 93, -1, -1, -1, -1, 291, - 292, -1, -1, 295, 296, 297, 298, 299, -1, 301, - 302, -1, -1, 305, -1, -1, 308, 309, 310, -1, - 269, 270, 271, 272, -1, -1, -1, -1, -1, 278, - -1, -1, -1, 282, 283, 284, 285, -1, -1, -1, - -1, -1, 291, 292, -1, -1, 295, 296, 297, 298, - 299, -1, 301, 302, 41, -1, 305, 44, -1, 308, - 309, 310, 278, -1, -1, -1, 282, 283, 284, 285, - -1, 58, 59, -1, -1, -1, 63, -1, -1, 295, - 296, 297, 298, 299, -1, 301, 302, -1, -1, 305, - -1, -1, 308, 309, 310, 41, -1, -1, 44, -1, - -1, -1, -1, -1, -1, -1, 93, -1, -1, -1, - -1, -1, 58, 59, -1, -1, -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 41, -1, -1, 44, -1, - -1, -1, -1, -1, -1, -1, -1, 93, -1, -1, - -1, -1, 58, 59, -1, -1, -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 269, 270, 271, 272, -1, -1, -1, -1, -1, 278, - -1, -1, -1, 282, 283, 284, 285, 93, -1, -1, - -1, 41, 291, 292, 44, -1, 295, 296, 297, 298, - 299, -1, 301, 302, -1, -1, 305, -1, 58, 59, - -1, -1, -1, 63, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 41, 93, -1, 44, -1, -1, -1, + -1, -1, -1, 272, 273, 274, 275, -1, -1, -1, + 58, 59, 281, -1, -1, 63, 285, 286, 287, 288, + -1, -1, -1, -1, 123, 294, 295, -1, -1, 298, + 299, 300, 301, 302, -1, 304, 305, 41, -1, 308, + 44, -1, 311, 312, 313, 93, -1, 272, 273, 274, + 275, -1, -1, -1, 58, 59, 281, -1, -1, 63, + 285, 286, 287, 288, -1, -1, -1, -1, -1, 294, + 295, -1, -1, 298, 299, 300, 301, 302, -1, 304, + 305, -1, 41, 308, -1, 44, 311, 312, 313, 93, + -1, -1, -1, -1, -1, -1, -1, 272, 273, 274, + 275, -1, -1, -1, 63, -1, 281, -1, -1, -1, + 285, 286, 287, 288, -1, -1, -1, -1, -1, 294, + 295, -1, -1, 298, 299, 300, 301, 302, 41, 304, + 305, 44, 91, 308, -1, -1, 311, 312, 313, -1, + -1, -1, -1, -1, -1, 58, 59, -1, -1, -1, + 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 123, -1, -1, -1, -1, -1, + -1, -1, -1, 272, 273, 274, 275, -1, -1, -1, + 93, -1, 281, -1, -1, -1, 285, 286, 287, 288, + -1, -1, -1, -1, -1, 294, 295, -1, -1, 298, + 299, 300, 301, 302, -1, 304, 305, -1, -1, 308, + -1, -1, 311, 312, 313, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 272, 273, 274, 275, -1, -1, + -1, -1, -1, 281, -1, -1, -1, 285, 286, 287, + 288, -1, -1, -1, -1, -1, 294, 295, -1, -1, + 298, 299, 300, 301, 302, -1, 304, 305, 41, -1, + 308, 44, -1, 311, 312, 313, -1, -1, 272, 273, + 274, 275, -1, -1, -1, 58, 59, 281, -1, -1, + 63, 285, 286, 287, 288, -1, -1, -1, -1, -1, + 294, 295, -1, -1, 298, 299, 300, 301, 302, -1, + 304, 305, -1, 41, 308, -1, 44, 311, 312, 313, + 93, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 58, 59, 281, -1, -1, 63, 285, 286, 287, 288, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 298, + 299, 300, 301, 302, -1, 304, 305, -1, -1, 308, + -1, -1, 311, 312, 313, 93, 63, -1, -1, 272, + 273, 274, 275, -1, -1, -1, -1, -1, 281, -1, + -1, -1, 285, 286, 287, 288, -1, -1, -1, -1, + -1, 294, 295, -1, 91, 298, 299, 300, 301, 302, + 41, 304, 305, 44, -1, 308, -1, -1, 311, 312, + 313, -1, -1, -1, -1, -1, -1, 58, 59, -1, + -1, -1, 63, -1, -1, -1, 123, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 41, -1, -1, 44, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 93, 58, 59, -1, -1, -1, 63, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 41, -1, -1, 44, -1, -1, -1, -1, -1, 93, - -1, -1, 269, 270, 271, 272, -1, 58, 59, -1, - -1, 278, 63, -1, -1, 282, 283, 284, 285, -1, - -1, -1, -1, -1, 291, 292, -1, -1, 295, 296, - 297, 298, 299, -1, 301, 302, -1, -1, 305, -1, - -1, -1, 93, 269, 270, 271, 272, -1, -1, -1, - -1, -1, 278, -1, -1, -1, 282, 283, 284, 285, - -1, -1, -1, -1, -1, 291, 292, -1, -1, 295, - 296, 297, 298, 299, -1, 301, 302, -1, -1, -1, - -1, -1, -1, 269, 270, 271, 272, -1, -1, -1, - -1, -1, 278, -1, -1, -1, 282, 283, 284, 285, - -1, -1, -1, -1, 41, 291, 292, 44, -1, 295, - 296, 297, 298, 299, -1, 301, 302, -1, -1, -1, - -1, 58, 59, -1, -1, -1, 63, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 269, - 270, 271, 272, -1, -1, -1, -1, -1, 278, -1, - -1, -1, 282, 283, 284, 285, 93, -1, -1, -1, - -1, 291, 292, -1, -1, 295, 296, 297, 298, 299, - -1, 301, 302, -1, -1, 269, 270, 271, 272, -1, - -1, -1, -1, -1, 278, -1, -1, -1, 282, 283, - 284, 285, -1, -1, -1, -1, -1, 291, 292, -1, - -1, 295, 296, 297, 298, 299, 41, 301, 302, 44, - -1, -1, -1, -1, -1, -1, -1, -1, 269, 270, - 271, 272, -1, 58, 59, -1, -1, 278, 63, -1, - -1, 282, 283, 284, 285, -1, -1, -1, -1, -1, - 291, 292, -1, -1, 295, 296, 297, 298, 299, 41, - 301, 302, 44, -1, -1, -1, -1, -1, 93, -1, - -1, -1, -1, -1, -1, -1, 58, 59, -1, -1, - -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 41, -1, -1, 44, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 93, 58, 59, -1, -1, -1, 63, -1, -1, + -1, -1, 93, -1, 58, 59, -1, -1, -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 41, -1, -1, 44, -1, -1, -1, -1, -1, - -1, -1, 269, 270, 271, 272, -1, 93, 58, 59, - -1, 278, -1, 63, -1, 282, 283, 284, 285, -1, - -1, -1, -1, 41, 291, 292, 44, -1, 295, 296, - 297, 298, 299, -1, 301, 302, -1, -1, -1, -1, - 58, 59, -1, 93, -1, 63, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 41, -1, -1, 44, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 58, 59, 93, -1, -1, 63, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 93, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 272, + 273, 274, 275, -1, -1, -1, -1, -1, 281, -1, + -1, -1, 285, 286, 287, 288, -1, -1, -1, -1, + -1, 294, 295, -1, -1, 298, 299, 300, 301, 302, + -1, 304, 305, 41, -1, 308, 44, -1, 311, 312, + 313, -1, -1, -1, 272, 273, 274, 275, -1, -1, + 58, 59, -1, 281, -1, 63, -1, 285, 286, 287, + 288, -1, -1, -1, -1, -1, 294, 295, -1, -1, + 298, 299, 300, 301, 302, 41, 304, 305, 44, -1, + 308, -1, -1, -1, 281, 93, -1, -1, 285, 286, + 287, 288, 58, 59, -1, -1, -1, 63, -1, -1, + -1, -1, 299, 300, 301, 302, -1, 304, 305, -1, + -1, 308, -1, -1, 311, 312, 313, -1, -1, -1, + 41, -1, -1, 44, -1, -1, -1, 93, -1, -1, + -1, 272, 273, 274, 275, -1, -1, 58, 59, -1, + 281, -1, 63, -1, 285, 286, 287, 288, -1, -1, + -1, -1, -1, 294, 295, -1, -1, 298, 299, 300, + 301, 302, -1, 304, 305, -1, -1, 308, 272, 273, + 274, 275, 93, -1, -1, -1, -1, 281, -1, -1, + -1, 285, 286, 287, 288, 41, -1, -1, 44, -1, + 294, 295, -1, -1, 298, 299, 300, 301, 302, -1, + 304, 305, 58, 59, -1, -1, -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 41, -1, -1, 44, -1, -1, -1, -1, - -1, -1, -1, -1, 269, 270, 271, 272, 93, 58, - 59, -1, -1, 278, 63, -1, -1, 282, 283, 284, - 285, -1, -1, -1, -1, -1, 291, 292, -1, -1, - 295, 296, 297, 298, 299, 41, 301, 302, 44, -1, - -1, -1, -1, -1, 93, -1, -1, 269, 270, 271, - 272, -1, 58, 59, -1, -1, 278, 63, -1, -1, - 282, 283, -1, 285, -1, -1, -1, -1, -1, 291, - 292, -1, -1, 295, 296, 297, 298, 299, -1, 301, - -1, -1, -1, 269, 270, 271, 272, 93, -1, -1, - 63, -1, 278, -1, -1, -1, 282, 283, -1, -1, - -1, -1, -1, -1, -1, 291, 292, -1, -1, 295, - 296, 297, 298, 299, -1, 301, -1, -1, 91, 269, - 270, 271, 272, -1, -1, -1, -1, -1, 278, -1, - -1, -1, 282, 283, -1, -1, -1, -1, -1, -1, - 41, 291, 292, 44, -1, 295, 296, 297, 298, 299, - 123, 269, 270, 271, 272, -1, -1, 58, 59, -1, - 278, -1, 63, -1, 282, 283, -1, -1, -1, -1, - -1, -1, 41, 291, 292, 44, -1, 295, 296, 297, - 298, 299, -1, -1, 269, 270, 271, 272, -1, 58, - 59, -1, 93, 278, 63, -1, -1, 282, 283, -1, - -1, -1, -1, -1, -1, -1, 291, 292, -1, -1, - 295, 296, 297, 298, 299, 41, -1, -1, 44, -1, - 269, 270, 271, 272, 93, -1, -1, -1, -1, 278, - -1, -1, 58, 59, 283, -1, -1, 63, -1, -1, - 63, -1, 291, 292, -1, -1, 295, 296, 297, 298, - 299, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 269, 270, 271, 272, 93, 91, -1, - -1, -1, 278, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 291, 292, -1, -1, 295, - 296, 297, 298, 299, -1, -1, -1, -1, -1, -1, - 123, -1, -1, -1, -1, 278, -1, -1, -1, 282, - 283, 284, 285, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 295, 296, 297, 298, 299, -1, 301, 302, - -1, -1, 305, -1, -1, 308, 309, 310, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 93, -1, 58, + 59, -1, -1, -1, 63, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 272, 273, 274, 275, -1, -1, + -1, -1, -1, 281, 93, -1, -1, 285, 286, 287, + 288, -1, -1, -1, -1, -1, 294, 295, -1, -1, + 298, 299, 300, 301, 302, 41, 304, 305, 44, -1, + -1, -1, -1, -1, -1, -1, 272, 273, 274, 275, + -1, -1, 58, 59, -1, 281, -1, 63, -1, 285, + 286, 287, 288, -1, -1, -1, -1, -1, 294, 295, + -1, -1, 298, 299, 300, 301, 302, -1, 304, 305, + 41, -1, -1, 44, -1, -1, -1, 93, -1, -1, + -1, 272, 273, 274, 275, -1, -1, 58, 59, -1, + 281, -1, 63, -1, 285, 286, 287, 288, -1, -1, + -1, -1, -1, 294, 295, -1, -1, 298, 299, 300, + 301, 302, 41, 304, 305, 44, -1, -1, -1, -1, + -1, -1, 93, -1, -1, -1, -1, -1, -1, 58, + 59, -1, -1, -1, 63, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 272, 273, 274, 275, + -1, -1, -1, -1, -1, 281, -1, -1, -1, 285, + 286, 287, 288, -1, 93, -1, -1, -1, 294, 295, + -1, -1, 298, 299, 300, 301, 302, -1, 304, 305, + -1, -1, -1, 272, 273, 274, 275, -1, -1, -1, + -1, -1, 281, -1, -1, -1, 285, 286, 287, 288, + 41, -1, -1, 44, -1, 294, 295, -1, -1, 298, + 299, 300, 301, 302, -1, 304, 305, 58, 59, -1, + -1, -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 41, -1, -1, 44, -1, -1, + -1, -1, 93, -1, -1, -1, 272, 273, 274, 275, + -1, 58, 59, -1, -1, 281, 63, -1, -1, 285, + 286, 287, 288, -1, -1, -1, -1, -1, 294, 295, + -1, -1, 298, 299, 300, 301, 302, -1, 304, 305, + 41, -1, -1, 44, -1, -1, 93, -1, -1, -1, + -1, 272, 273, 274, 275, -1, -1, 58, 59, -1, + 281, -1, 63, -1, 285, 286, -1, 288, -1, -1, + -1, -1, -1, 294, 295, -1, -1, 298, 299, 300, + 301, 302, 41, 304, -1, 44, -1, -1, -1, -1, + -1, -1, 93, 272, 273, 274, 275, -1, -1, 58, + 59, -1, 281, -1, 63, -1, 285, 286, -1, -1, + -1, -1, -1, -1, 41, 294, 295, 44, -1, 298, + 299, 300, 301, 302, 41, 304, -1, 44, -1, -1, + -1, 58, 59, -1, 93, -1, 63, -1, -1, -1, + -1, 58, 59, -1, -1, -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 269, 270, - 271, 272, -1, -1, -1, -1, -1, 278, -1, -1, + -1, -1, -1, -1, -1, -1, 93, -1, -1, 41, + -1, -1, 44, -1, -1, -1, 93, -1, -1, -1, + -1, 272, 273, 274, 275, -1, 58, 59, -1, -1, + 281, 63, -1, -1, 285, 286, -1, -1, -1, -1, + -1, -1, -1, 294, 295, -1, -1, 298, 299, 300, + 301, 302, -1, 41, -1, -1, 44, -1, -1, -1, + -1, 93, -1, -1, -1, 272, 273, 274, 275, -1, + 58, 59, -1, -1, 281, 63, -1, -1, 285, 286, + -1, -1, -1, -1, -1, -1, -1, 294, 295, -1, + -1, 298, 299, 300, 301, 302, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 93, -1, -1, -1, -1, + -1, 272, 273, 274, 275, -1, -1, -1, -1, -1, + 281, -1, -1, -1, 285, 286, -1, -1, -1, -1, + -1, -1, -1, 294, 295, -1, -1, 298, 299, 300, + 301, 302, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 272, 273, 274, 275, -1, -1, -1, + -1, -1, 281, -1, -1, -1, -1, 286, -1, -1, + -1, -1, -1, -1, -1, 294, 295, -1, -1, 298, + 299, 300, 301, 302, -1, 272, 273, 274, 275, -1, + -1, -1, -1, -1, 281, 272, 273, 274, 275, -1, + -1, -1, -1, -1, 281, -1, -1, 294, 295, -1, + -1, 298, 299, 300, 301, 302, -1, 294, 295, -1, + -1, 298, 299, 300, 301, 302, -1, -1, -1, -1, + -1, 30, -1, -1, -1, -1, -1, -1, -1, 38, + 272, 273, 274, 275, 43, 44, -1, -1, -1, 281, + 49, 50, 51, 52, 53, 54, -1, -1, 57, 58, + -1, -1, 294, 295, -1, -1, 298, 299, 300, 301, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 291, 292, -1, -1, 295, 296, 297, 298, -1, -1, - 269, 270, 271, 272, -1, 35, -1, -1, -1, 278, - 40, 41, -1, -1, -1, -1, 46, 47, 48, 49, - 50, 51, 291, 292, 54, 55, 295, 296, 297, -1, + -1, -1, -1, -1, 272, 273, 274, 275, -1, -1, + -1, -1, 91, 281, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 294, 295, -1, -1, + 298, 299, 300, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 269, 270, 271, 272, -1, -1, -1, - -1, -1, 278, -1, -1, 278, -1, -1, 88, 282, - 283, 284, 285, -1, -1, 291, 292, -1, -1, 295, - 296, -1, -1, 296, 297, 298, 299, -1, 301, 302, - -1, -1, 305, -1, -1, 308, 309, 310, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 138, -1, - -1, -1, -1, -1, -1, -1, 146, 147, 148, 149, - 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, + -1, -1, -1, -1, 143, -1, -1, -1, -1, -1, + -1, -1, 151, 152, 153, 154, 155, 156, 157, 158, + 159, 160, 161, 162, 163, 164, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, @@ -1070,16 +1065,16 @@ short yycheck[] = { 41, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 245, -1, -1, -1, -1, + -1, -1, -1, -1, 253, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 271, + -1, -1, 281, }; #define YYFINAL 1 #ifndef YYDEBUG #define YYDEBUG 0 #endif -#define YYMAXTOKEN 310 +#define YYMAXTOKEN 313 #if YYDEBUG char *yyname[] = { "end-of-file",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, @@ -1090,12 +1085,13 @@ char *yyname[] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,"WORD","METHOD","FUNCMETH","THING", -"PMFUNC","PRIVATEREF","LABEL","FORMAT","SUB","ANONSUB","PACKAGE","USE","WHILE", -"UNTIL","IF","UNLESS","ELSE","ELSIF","CONTINUE","FOR","LOOPEX","DOTDOT","FUNC0", -"FUNC1","FUNC","RELOP","EQOP","MULOP","ADDOP","DOLSHARP","DO","LOCAL", -"HASHBRACK","NOAMP","OROP","ANDOP","NOTOP","LSTOP","ASSIGNOP","OROR","ANDAND", -"BITOROP","BITANDOP","UNIOP","SHIFTOP","MATCHOP","UMINUS","REFGEN","POWOP", -"PREINC","PREDEC","POSTINC","POSTDEC","ARROW", +"PMFUNC","PRIVATEREF","FUNC0SUB","UNIOPSUB","LSTOPSUB","LABEL","FORMAT","SUB", +"ANONSUB","PACKAGE","USE","WHILE","UNTIL","IF","UNLESS","ELSE","ELSIF", +"CONTINUE","FOR","LOOPEX","DOTDOT","FUNC0","FUNC1","FUNC","RELOP","EQOP", +"MULOP","ADDOP","DOLSHARP","DO","LOCAL","HASHBRACK","NOAMP","OROP","ANDOP", +"NOTOP","LSTOP","ASSIGNOP","OROR","ANDAND","BITOROP","BITANDOP","UNIOP", +"SHIFTOP","MATCHOP","UMINUS","REFGEN","POWOP","PREINC","PREDEC","POSTINC", +"POSTDEC","ARROW", }; char *yyrule[] = { "$accept : prog", @@ -1145,8 +1141,10 @@ char *yyrule[] = { "decl : use", "format : FORMAT startsub WORD block", "format : FORMAT startsub block", -"subrout : SUB startsub WORD block", -"subrout : SUB startsub WORD ';'", +"subrout : SUB startsub WORD proto block", +"subrout : SUB startsub WORD proto ';'", +"proto :", +"proto : THING", "startsub :", "package : PACKAGE WORD ';'", "package : PACKAGE ';'", @@ -1165,6 +1163,7 @@ char *yyrule[] = { "listop : FUNCMETH indirob '(' listexprcom ')'", "listop : LSTOP listexpr", "listop : FUNC '(' listexprcom ')'", +"listop : LSTOPSUB startsub block listexpr", "method : METHOD", "method : scalar", "term : term ASSIGNOP term", @@ -1197,7 +1196,7 @@ char *yyrule[] = { "term : '[' ']'", "term : HASHBRACK expr ';' '}'", "term : HASHBRACK ';' '}'", -"term : ANONSUB startsub block", +"term : ANONSUB startsub proto block", "term : scalar", "term : star", "term : scalar '[' expr ']'", @@ -1229,8 +1228,10 @@ char *yyrule[] = { "term : UNIOP", "term : UNIOP block", "term : UNIOP term", +"term : UNIOPSUB term", "term : FUNC0", "term : FUNC0 '(' ')'", +"term : FUNC0SUB", "term : FUNC1 '(' ')'", "term : FUNC1 '(' expr ')'", "term : PMFUNC '(' term ')'", @@ -1274,9 +1275,9 @@ int yyerrflag; int yychar; YYSTYPE yyval; YYSTYPE yylval; -#line 545 "perly.y" +#line 563 "perly.y" /* PROGRAM */ -#line 1347 "y.tab.c" +#line 1351 "y.tab.c" #define YYABORT goto yyabort #define YYACCEPT goto yyaccept #define YYERROR goto yyerrlab @@ -1501,7 +1502,7 @@ yyreduce: switch (yyn) { case 1: -#line 83 "perly.y" +#line 84 "perly.y" { #if defined(YYDEBUG) && defined(DEBUGGING) yydebug = (debug & 1); @@ -1510,38 +1511,38 @@ case 1: } break; case 2: -#line 90 "perly.y" +#line 91 "perly.y" { newPROG(yyvsp[0].opval); } break; case 3: -#line 94 "perly.y" +#line 95 "perly.y" { yyval.opval = block_end(yyvsp[-3].ival,yyvsp[-2].ival,yyvsp[-1].opval); } break; case 4: -#line 98 "perly.y" +#line 99 "perly.y" { yyval.ival = block_start(); } break; case 5: -#line 102 "perly.y" +#line 103 "perly.y" { yyval.opval = Nullop; } break; case 6: -#line 104 "perly.y" +#line 105 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; case 7: -#line 106 "perly.y" +#line 107 "perly.y" { yyval.opval = append_list(OP_LINESEQ, (LISTOP*)yyvsp[-1].opval, (LISTOP*)yyvsp[0].opval); pad_reset_pending = TRUE; if (yyvsp[-1].opval && yyvsp[0].opval) hints |= HINT_BLOCK_SCOPE; } break; case 8: -#line 113 "perly.y" +#line 114 "perly.y" { yyval.opval = newSTATEOP(0, yyvsp[-1].pval, yyvsp[0].opval); } break; case 10: -#line 116 "perly.y" +#line 117 "perly.y" { if (yyvsp[-1].pval != Nullch) { yyval.opval = newSTATEOP(0, yyvsp[-1].pval, newOP(OP_NULL, 0)); } @@ -1552,119 +1553,120 @@ case 10: expect = XSTATE; } break; case 11: -#line 125 "perly.y" +#line 126 "perly.y" { yyval.opval = newSTATEOP(0, yyvsp[-2].pval, yyvsp[-1].opval); expect = XSTATE; } break; case 12: -#line 130 "perly.y" +#line 131 "perly.y" { yyval.opval = Nullop; } break; case 13: -#line 132 "perly.y" +#line 133 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 14: -#line 134 "perly.y" +#line 135 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); } break; case 15: -#line 136 "perly.y" +#line 137 "perly.y" { yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); } break; case 16: -#line 138 "perly.y" +#line 139 "perly.y" { yyval.opval = newLOOPOP(OPf_PARENS, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); } break; case 17: -#line 140 "perly.y" +#line 141 "perly.y" { yyval.opval = newLOOPOP(OPf_PARENS, 1, invert(scalar(yyvsp[0].opval)), yyvsp[-2].opval);} break; case 18: -#line 144 "perly.y" +#line 145 "perly.y" { yyval.opval = Nullop; } break; case 19: -#line 146 "perly.y" +#line 147 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; case 20: -#line 148 "perly.y" +#line 149 "perly.y" { copline = yyvsp[-5].ival; yyval.opval = newSTATEOP(0, 0, - newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); } + newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); + hints |= HINT_BLOCK_SCOPE; } break; case 21: -#line 154 "perly.y" +#line 156 "perly.y" { copline = yyvsp[-5].ival; yyval.opval = newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval); } break; case 22: -#line 157 "perly.y" +#line 159 "perly.y" { copline = yyvsp[-5].ival; yyval.opval = newCONDOP(0, invert(scalar(yyvsp[-3].opval)), scope(yyvsp[-1].opval), yyvsp[0].opval); } break; case 23: -#line 161 "perly.y" +#line 163 "perly.y" { copline = yyvsp[-3].ival; deprecate("if BLOCK BLOCK"); yyval.opval = newCONDOP(0, scope(yyvsp[-2].opval), scope(yyvsp[-1].opval), yyvsp[0].opval); } break; case 24: -#line 165 "perly.y" +#line 167 "perly.y" { copline = yyvsp[-3].ival; deprecate("unless BLOCK BLOCK"); yyval.opval = newCONDOP(0, invert(scalar(scope(yyvsp[-2].opval))), scope(yyvsp[-1].opval), yyvsp[0].opval); } break; case 25: -#line 172 "perly.y" +#line 174 "perly.y" { yyval.opval = Nullop; } break; case 26: -#line 174 "perly.y" +#line 176 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; case 27: -#line 178 "perly.y" +#line 180 "perly.y" { copline = yyvsp[-5].ival; yyval.opval = newSTATEOP(0, yyvsp[-6].pval, newWHILEOP(0, 1, (LOOP*)Nullop, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval) ); } break; case 28: -#line 183 "perly.y" +#line 185 "perly.y" { copline = yyvsp[-5].ival; yyval.opval = newSTATEOP(0, yyvsp[-6].pval, newWHILEOP(0, 1, (LOOP*)Nullop, invert(scalar(yyvsp[-3].opval)), yyvsp[-1].opval, yyvsp[0].opval) ); } break; case 29: -#line 188 "perly.y" +#line 190 "perly.y" { copline = yyvsp[-3].ival; yyval.opval = newSTATEOP(0, yyvsp[-4].pval, newWHILEOP(0, 1, (LOOP*)Nullop, scope(yyvsp[-2].opval), yyvsp[-1].opval, yyvsp[0].opval) ); } break; case 30: -#line 193 "perly.y" +#line 195 "perly.y" { copline = yyvsp[-3].ival; yyval.opval = newSTATEOP(0, yyvsp[-4].pval, newWHILEOP(0, 1, (LOOP*)Nullop, invert(scalar(scope(yyvsp[-2].opval))), yyvsp[-1].opval, yyvsp[0].opval)); } break; case 31: -#line 198 "perly.y" +#line 200 "perly.y" { yyval.opval = newFOROP(0, yyvsp[-7].pval, yyvsp[-6].ival, mod(yyvsp[-5].opval, OP_ENTERLOOP), yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval); } break; case 32: -#line 201 "perly.y" +#line 203 "perly.y" { yyval.opval = newFOROP(0, yyvsp[-6].pval, yyvsp[-5].ival, Nullop, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval); } break; case 33: -#line 204 "perly.y" +#line 206 "perly.y" { copline = yyvsp[-8].ival; yyval.opval = append_elem(OP_LINESEQ, newSTATEOP(0, yyvsp[-9].pval, scalar(yyvsp[-6].opval)), @@ -1673,333 +1675,344 @@ case 33: scalar(yyvsp[-4].opval), yyvsp[0].opval, scalar(yyvsp[-2].opval)) )); } break; case 34: -#line 211 "perly.y" +#line 213 "perly.y" { yyval.opval = newSTATEOP(0, yyvsp[-2].pval, newWHILEOP(0, 1, (LOOP*)Nullop, Nullop, yyvsp[-1].opval, yyvsp[0].opval)); } break; case 35: -#line 217 "perly.y" +#line 219 "perly.y" { yyval.opval = Nullop; } break; case 37: -#line 222 "perly.y" +#line 224 "perly.y" { (void)scan_num("1"); yyval.opval = yylval.opval; } break; case 39: -#line 227 "perly.y" +#line 229 "perly.y" { yyval.pval = Nullch; } break; case 41: -#line 232 "perly.y" +#line 234 "perly.y" { yyval.ival = 0; } break; case 42: -#line 234 "perly.y" +#line 236 "perly.y" { yyval.ival = 0; } break; case 43: -#line 236 "perly.y" +#line 238 "perly.y" { yyval.ival = 0; } break; case 44: -#line 238 "perly.y" +#line 240 "perly.y" { yyval.ival = 0; } break; case 45: -#line 242 "perly.y" +#line 244 "perly.y" { newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } break; case 46: -#line 244 "perly.y" +#line 246 "perly.y" { newFORM(yyvsp[-1].ival, Nullop, yyvsp[0].opval); } break; case 47: -#line 248 "perly.y" -{ newSUB(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } +#line 250 "perly.y" +{ newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); } break; case 48: -#line 250 "perly.y" -{ newSUB(yyvsp[-2].ival, yyvsp[-1].opval, Nullop); expect = XSTATE; } +#line 252 "perly.y" +{ newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, Nullop); expect = XSTATE; } break; case 49: -#line 254 "perly.y" +#line 256 "perly.y" +{ yyval.opval = Nullop; } +break; +case 51: +#line 261 "perly.y" { yyval.ival = start_subparse(); } break; -case 50: -#line 258 "perly.y" +case 52: +#line 265 "perly.y" { package(yyvsp[-1].opval); } break; -case 51: -#line 260 "perly.y" +case 53: +#line 267 "perly.y" { package(Nullop); } break; -case 52: -#line 264 "perly.y" +case 54: +#line 271 "perly.y" { utilize(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval); } break; -case 53: -#line 268 "perly.y" +case 55: +#line 275 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 54: -#line 270 "perly.y" +case 56: +#line 277 "perly.y" { yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 55: -#line 272 "perly.y" +case 57: +#line 279 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; -case 57: -#line 277 "perly.y" +case 59: +#line 284 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; -case 58: -#line 279 "perly.y" +case 60: +#line 286 "perly.y" { yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 60: -#line 284 "perly.y" +case 62: +#line 291 "perly.y" { yyval.opval = convert(yyvsp[-2].ival, OPf_STACKED, prepend_elem(OP_LIST, newGVREF(yyvsp[-2].ival,yyvsp[-1].opval), yyvsp[0].opval) ); } break; -case 61: -#line 287 "perly.y" +case 63: +#line 294 "perly.y" { yyval.opval = convert(yyvsp[-4].ival, OPf_STACKED, prepend_elem(OP_LIST, newGVREF(yyvsp[-4].ival,yyvsp[-2].opval), yyvsp[-1].opval) ); } break; -case 62: -#line 290 "perly.y" -{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, +case 64: +#line 297 "perly.y" +{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, - prepend_elem(OP_LIST, yyvsp[-5].opval, list(yyvsp[-1].opval)), + prepend_elem(OP_LIST, yyvsp[-5].opval, yyvsp[-1].opval), newUNOP(OP_METHOD, 0, yyvsp[-3].opval))); } break; -case 63: -#line 295 "perly.y" -{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, +case 65: +#line 302 "perly.y" +{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, - prepend_elem(OP_LIST, yyvsp[-1].opval, list(yyvsp[0].opval)), + prepend_elem(OP_LIST, yyvsp[-1].opval, yyvsp[0].opval), newUNOP(OP_METHOD, 0, yyvsp[-2].opval))); } break; -case 64: -#line 300 "perly.y" -{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, +case 66: +#line 307 "perly.y" +{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, - prepend_elem(OP_LIST, yyvsp[-3].opval, list(yyvsp[-1].opval)), + prepend_elem(OP_LIST, yyvsp[-3].opval, yyvsp[-1].opval), newUNOP(OP_METHOD, 0, yyvsp[-4].opval))); } break; -case 65: -#line 305 "perly.y" +case 67: +#line 312 "perly.y" { yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; -case 66: -#line 307 "perly.y" +case 68: +#line 314 "perly.y" { yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; case 69: -#line 315 "perly.y" +#line 316 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, + prepend_elem(OP_LIST, newANONSUB(yyvsp[-2].ival, 0, yyvsp[-1].opval), yyvsp[0].opval), + yyvsp[-3].opval)); } +break; +case 72: +#line 327 "perly.y" { yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); } break; -case 70: -#line 317 "perly.y" +case 73: +#line 329 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 71: -#line 319 "perly.y" +case 74: +#line 331 "perly.y" { if (yyvsp[-1].ival != OP_REPEAT) scalar(yyvsp[-2].opval); yyval.opval = newBINOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, scalar(yyvsp[0].opval)); } break; -case 72: -#line 323 "perly.y" +case 75: +#line 335 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 73: -#line 325 "perly.y" +case 76: +#line 337 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 74: -#line 327 "perly.y" +case 77: +#line 339 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 75: -#line 329 "perly.y" +case 78: +#line 341 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 76: -#line 331 "perly.y" +case 79: +#line 343 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 77: -#line 333 "perly.y" +case 80: +#line 345 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 78: -#line 335 "perly.y" +case 81: +#line 347 "perly.y" { yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));} break; -case 79: -#line 337 "perly.y" +case 82: +#line 349 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 80: -#line 339 "perly.y" +case 83: +#line 351 "perly.y" { yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 81: -#line 341 "perly.y" +case 84: +#line 353 "perly.y" { yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 82: -#line 343 "perly.y" +case 85: +#line 355 "perly.y" { yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 83: -#line 346 "perly.y" +case 86: +#line 358 "perly.y" { yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); } break; -case 84: -#line 348 "perly.y" +case 87: +#line 360 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 85: -#line 350 "perly.y" +case 88: +#line 362 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; -case 86: -#line 352 "perly.y" +case 89: +#line 364 "perly.y" { yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));} break; -case 87: -#line 354 "perly.y" +case 90: +#line 366 "perly.y" { yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); } break; -case 88: -#line 356 "perly.y" +case 91: +#line 368 "perly.y" { yyval.opval = newUNOP(OP_POSTINC, 0, mod(scalar(yyvsp[-1].opval), OP_POSTINC)); } break; -case 89: -#line 359 "perly.y" +case 92: +#line 371 "perly.y" { yyval.opval = newUNOP(OP_POSTDEC, 0, mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); } break; -case 90: -#line 362 "perly.y" +case 93: +#line 374 "perly.y" { yyval.opval = newUNOP(OP_PREINC, 0, mod(scalar(yyvsp[0].opval), OP_PREINC)); } break; -case 91: -#line 365 "perly.y" +case 94: +#line 377 "perly.y" { yyval.opval = newUNOP(OP_PREDEC, 0, mod(scalar(yyvsp[0].opval), OP_PREDEC)); } break; -case 92: -#line 368 "perly.y" +case 95: +#line 380 "perly.y" { yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); } break; -case 93: -#line 370 "perly.y" +case 96: +#line 382 "perly.y" { yyval.opval = sawparens(yyvsp[-1].opval); } break; -case 94: -#line 372 "perly.y" +case 97: +#line 384 "perly.y" { yyval.opval = sawparens(newNULLLIST()); } break; -case 95: -#line 374 "perly.y" +case 98: +#line 386 "perly.y" { yyval.opval = newANONLIST(yyvsp[-1].opval); } break; -case 96: -#line 376 "perly.y" +case 99: +#line 388 "perly.y" { yyval.opval = newANONLIST(Nullop); } break; -case 97: -#line 378 "perly.y" +case 100: +#line 390 "perly.y" { yyval.opval = newANONHASH(yyvsp[-2].opval); } break; -case 98: -#line 380 "perly.y" +case 101: +#line 392 "perly.y" { yyval.opval = newANONHASH(Nullop); } break; -case 99: -#line 382 "perly.y" -{ yyval.opval = newANONSUB(yyvsp[-1].ival, yyvsp[0].opval); } +case 102: +#line 394 "perly.y" +{ yyval.opval = newANONSUB(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } break; -case 100: -#line 384 "perly.y" +case 103: +#line 396 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 101: -#line 386 "perly.y" +case 104: +#line 398 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 102: -#line 388 "perly.y" +case 105: +#line 400 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); } break; -case 103: -#line 390 "perly.y" +case 106: +#line 402 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-4].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; -case 104: -#line 394 "perly.y" +case 107: +#line 406 "perly.y" { assertref(yyvsp[-3].opval); yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-3].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; -case 105: -#line 398 "perly.y" +case 108: +#line 410 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 106: -#line 400 "perly.y" +case 109: +#line 412 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 107: -#line 402 "perly.y" +case 110: +#line 414 "perly.y" { yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));} break; -case 108: -#line 404 "perly.y" +case 111: +#line 416 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; -case 109: -#line 407 "perly.y" +case 112: +#line 419 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-5].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; -case 110: -#line 412 "perly.y" +case 113: +#line 424 "perly.y" { assertref(yyvsp[-4].opval); yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-4].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; -case 111: -#line 417 "perly.y" +case 114: +#line 429 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); } break; -case 112: -#line 419 "perly.y" +case 115: +#line 431 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); } break; -case 113: -#line 421 "perly.y" +case 116: +#line 433 "perly.y" { yyval.opval = prepend_elem(OP_ASLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_ASLICE, 0, list(yyvsp[-1].opval), ref(yyvsp[-3].opval, OP_ASLICE))); } break; -case 114: -#line 427 "perly.y" +case 117: +#line 439 "perly.y" { yyval.opval = prepend_elem(OP_HSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_HSLICE, 0, @@ -2007,170 +2020,180 @@ case 114: ref(oopsHV(yyvsp[-4].opval), OP_HSLICE))); expect = XOPERATOR; } break; -case 115: -#line 434 "perly.y" +case 118: +#line 446 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 116: -#line 436 "perly.y" +case 119: +#line 448 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); } break; -case 117: -#line 439 "perly.y" +case 120: +#line 451 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); } break; -case 118: -#line 441 "perly.y" +case 121: +#line 453 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, - list(append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval)))); } + append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval))); } break; -case 119: -#line 444 "perly.y" +case 122: +#line 456 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, - list(append_elem(OP_LIST, - yyvsp[0].opval, newCVREF(scalar(yyvsp[-1].opval))))); } + append_elem(OP_LIST, + yyvsp[0].opval, newCVREF(scalar(yyvsp[-1].opval)))); } break; -case 120: -#line 448 "perly.y" +case 123: +#line 460 "perly.y" { yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); } break; -case 121: -#line 450 "perly.y" +case 124: +#line 462 "perly.y" { yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); } break; -case 122: -#line 452 "perly.y" +case 125: +#line 464 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, - list(prepend_elem(OP_LIST, - scalar(newCVREF(scalar(yyvsp[-2].opval))), Nullop))); dep();} + prepend_elem(OP_LIST, + scalar(newCVREF(scalar(yyvsp[-2].opval))), Nullop)); dep();} break; -case 123: -#line 456 "perly.y" +case 126: +#line 468 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, - list(append_elem(OP_LIST, + append_elem(OP_LIST, yyvsp[-1].opval, - scalar(newCVREF(scalar(yyvsp[-3].opval)))))); dep();} + scalar(newCVREF(scalar(yyvsp[-3].opval))))); dep();} break; -case 124: -#line 461 "perly.y" +case 127: +#line 473 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, - list(prepend_elem(OP_LIST, - scalar(newCVREF(scalar(yyvsp[-2].opval))), Nullop))); dep();} + prepend_elem(OP_LIST, + scalar(newCVREF(scalar(yyvsp[-2].opval))), Nullop)); dep();} break; -case 125: -#line 465 "perly.y" +case 128: +#line 477 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, - list(prepend_elem(OP_LIST, + prepend_elem(OP_LIST, yyvsp[-1].opval, - scalar(newCVREF(scalar(yyvsp[-3].opval)))))); dep();} + scalar(newCVREF(scalar(yyvsp[-3].opval))))); dep();} break; -case 126: -#line 470 "perly.y" +case 129: +#line 482 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL); hints |= HINT_BLOCK_SCOPE; } break; -case 127: -#line 473 "perly.y" +case 130: +#line 485 "perly.y" { yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); } break; -case 128: -#line 475 "perly.y" +case 131: +#line 487 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; -case 129: -#line 477 "perly.y" +case 132: +#line 489 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; -case 130: -#line 479 "perly.y" +case 133: +#line 491 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; -case 131: -#line 481 "perly.y" +case 134: +#line 493 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } +break; +case 135: +#line 496 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; -case 132: -#line 483 "perly.y" +case 136: +#line 498 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, 0); } break; -case 133: -#line 485 "perly.y" +case 137: +#line 500 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, 0, + scalar(yyvsp[0].opval)); } +break; +case 138: +#line 503 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); } break; -case 134: -#line 487 "perly.y" +case 139: +#line 505 "perly.y" { yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; -case 135: -#line 489 "perly.y" +case 140: +#line 507 "perly.y" { yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); } break; -case 136: -#line 491 "perly.y" +case 141: +#line 509 "perly.y" { yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); } break; -case 139: -#line 497 "perly.y" +case 144: +#line 515 "perly.y" { yyval.opval = Nullop; } break; -case 140: -#line 499 "perly.y" +case 145: +#line 517 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 141: -#line 503 "perly.y" +case 146: +#line 521 "perly.y" { yyval.opval = Nullop; } break; -case 142: -#line 505 "perly.y" +case 147: +#line 523 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 143: -#line 507 "perly.y" +case 148: +#line 525 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; -case 144: -#line 511 "perly.y" +case 149: +#line 529 "perly.y" { yyval.opval = newCVREF(yyvsp[0].opval); } break; -case 145: -#line 515 "perly.y" +case 150: +#line 533 "perly.y" { yyval.opval = newSVREF(yyvsp[0].opval); } break; -case 146: -#line 519 "perly.y" +case 151: +#line 537 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; -case 147: -#line 523 "perly.y" +case 152: +#line 541 "perly.y" { yyval.opval = newHVREF(yyvsp[0].opval); } break; -case 148: -#line 527 "perly.y" +case 153: +#line 545 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; -case 149: -#line 531 "perly.y" +case 154: +#line 549 "perly.y" { yyval.opval = newGVREF(0,yyvsp[0].opval); } break; -case 150: -#line 535 "perly.y" +case 155: +#line 553 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; -case 151: -#line 537 "perly.y" +case 156: +#line 555 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; -case 152: -#line 539 "perly.y" +case 157: +#line 557 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; -case 153: -#line 542 "perly.y" +case 158: +#line 560 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -#line 2157 "y.tab.c" +#line 2183 "y.tab.c" } yyssp -= yym; yystate = *yyssp; diff --git a/perly.c.diff b/perly.c.diff index 2f7fb7021b..f72163ec46 100644 --- a/perly.c.diff +++ b/perly.c.diff @@ -1,7 +1,7 @@ -*** perly.c.orig Thu Feb 9 17:56:15 1995 ---- perly.c Thu Feb 9 17:56:17 1995 +*** perly.c.orig Tue Nov 14 17:16:49 1995 +--- perly.c Tue Nov 14 17:17:44 1995 *************** -*** 12,79 **** +*** 12,82 **** deprecate("\"do\" to call subroutines"); } @@ -19,60 +19,63 @@ - #define THING 260 - #define PMFUNC 261 - #define PRIVATEREF 262 -- #define LABEL 263 -- #define FORMAT 264 -- #define SUB 265 -- #define ANONSUB 266 -- #define PACKAGE 267 -- #define USE 268 -- #define WHILE 269 -- #define UNTIL 270 -- #define IF 271 -- #define UNLESS 272 -- #define ELSE 273 -- #define ELSIF 274 -- #define CONTINUE 275 -- #define FOR 276 -- #define LOOPEX 277 -- #define DOTDOT 278 -- #define FUNC0 279 -- #define FUNC1 280 -- #define FUNC 281 -- #define RELOP 282 -- #define EQOP 283 -- #define MULOP 284 -- #define ADDOP 285 -- #define DOLSHARP 286 -- #define DO 287 -- #define LOCAL 288 -- #define HASHBRACK 289 -- #define NOAMP 290 -- #define OROP 291 -- #define ANDOP 292 -- #define NOTOP 293 -- #define LSTOP 294 -- #define ASSIGNOP 295 -- #define OROR 296 -- #define ANDAND 297 -- #define BITOROP 298 -- #define BITANDOP 299 -- #define UNIOP 300 -- #define SHIFTOP 301 -- #define MATCHOP 302 -- #define UMINUS 303 -- #define REFGEN 304 -- #define POWOP 305 -- #define PREINC 306 -- #define PREDEC 307 -- #define POSTINC 308 -- #define POSTDEC 309 -- #define ARROW 310 +- #define FUNC0SUB 263 +- #define UNIOPSUB 264 +- #define LSTOPSUB 265 +- #define LABEL 266 +- #define FORMAT 267 +- #define SUB 268 +- #define ANONSUB 269 +- #define PACKAGE 270 +- #define USE 271 +- #define WHILE 272 +- #define UNTIL 273 +- #define IF 274 +- #define UNLESS 275 +- #define ELSE 276 +- #define ELSIF 277 +- #define CONTINUE 278 +- #define FOR 279 +- #define LOOPEX 280 +- #define DOTDOT 281 +- #define FUNC0 282 +- #define FUNC1 283 +- #define FUNC 284 +- #define RELOP 285 +- #define EQOP 286 +- #define MULOP 287 +- #define ADDOP 288 +- #define DOLSHARP 289 +- #define DO 290 +- #define LOCAL 291 +- #define HASHBRACK 292 +- #define NOAMP 293 +- #define OROP 294 +- #define ANDOP 295 +- #define NOTOP 296 +- #define LSTOP 297 +- #define ASSIGNOP 298 +- #define OROR 299 +- #define ANDAND 300 +- #define BITOROP 301 +- #define BITANDOP 302 +- #define UNIOP 303 +- #define SHIFTOP 304 +- #define MATCHOP 305 +- #define UMINUS 306 +- #define REFGEN 307 +- #define POWOP 308 +- #define PREINC 309 +- #define PREDEC 310 +- #define POSTINC 311 +- #define POSTDEC 312 +- #define ARROW 313 #define YYERRCODE 256 short yylhs[] = { -1, - 30, 0, 5, 3, 6, 6, 6, 7, 7, 7, + 31, 0, 5, 3, 6, 6, 6, 7, 7, 7, --- 12,17 ---- *************** -*** 1334,1346 **** +*** 1338,1350 **** int yynerrs; int yyerrflag; int yychar; @@ -83,13 +86,13 @@ - short yyss[YYSTACKSIZE]; - YYSTYPE yyvs[YYSTACKSIZE]; - #define yystacksize YYSTACKSIZE - #line 545 "perly.y" + #line 563 "perly.y" /* PROGRAM */ - #line 1347 "y.tab.c" ---- 1272,1279 ---- + #line 1351 "y.tab.c" +--- 1273,1280 ---- *************** -*** 1347,1360 **** ---- 1280,1338 ---- +*** 1351,1364 **** +--- 1281,1339 ---- #define YYABORT goto yyabort #define YYACCEPT goto yyaccept #define YYERROR goto yyerrlab @@ -150,8 +153,8 @@ { yyn = *yys; *************** -*** 1367,1372 **** ---- 1345,1358 ---- +*** 1371,1376 **** +--- 1346,1359 ---- yyerrflag = 0; yychar = (-1); @@ -167,7 +170,7 @@ yyvsp = yyvs; *yyssp = yystate = 0; *************** -*** 1382,1388 **** +*** 1386,1392 **** yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; @@ -175,7 +178,7 @@ yychar, yys); } #endif ---- 1368,1374 ---- +--- 1369,1375 ---- yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; @@ -184,7 +187,7 @@ } #endif *************** -*** 1392,1403 **** +*** 1396,1407 **** { #if YYDEBUG if (yydebug) @@ -197,7 +200,7 @@ } *++yyssp = yystate = yytable[yyn]; *++yyvsp = yylval; ---- 1378,1403 ---- +--- 1379,1404 ---- { #if YYDEBUG if (yydebug) @@ -225,7 +228,7 @@ *++yyssp = yystate = yytable[yyn]; *++yyvsp = yylval; *************** -*** 1433,1444 **** +*** 1437,1448 **** { #if YYDEBUG if (yydebug) @@ -238,7 +241,7 @@ } *++yyssp = yystate = yytable[yyn]; *++yyvsp = yylval; ---- 1433,1459 ---- +--- 1434,1460 ---- { #if YYDEBUG if (yydebug) @@ -267,7 +270,7 @@ *++yyssp = yystate = yytable[yyn]; *++yyvsp = yylval; *************** -*** 1448,1455 **** +*** 1452,1459 **** { #if YYDEBUG if (yydebug) @@ -276,7 +279,7 @@ #endif if (yyssp <= yyss) goto yyabort; --yyssp; ---- 1463,1471 ---- +--- 1464,1472 ---- { #if YYDEBUG if (yydebug) @@ -287,7 +290,7 @@ if (yyssp <= yyss) goto yyabort; --yyssp; *************** -*** 1466,1473 **** +*** 1470,1477 **** yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; @@ -296,7 +299,7 @@ } #endif yychar = (-1); ---- 1482,1490 ---- +--- 1483,1491 ---- yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; @@ -307,7 +310,7 @@ #endif yychar = (-1); *************** -*** 1476,1482 **** +*** 1480,1486 **** yyreduce: #if YYDEBUG if (yydebug) @@ -315,7 +318,7 @@ yystate, yyn, yyrule[yyn]); #endif yym = yylen[yyn]; ---- 1493,1499 ---- +--- 1494,1500 ---- yyreduce: #if YYDEBUG if (yydebug) @@ -324,7 +327,7 @@ #endif yym = yylen[yyn]; *************** -*** 2163,2170 **** +*** 2189,2196 **** { #if YYDEBUG if (yydebug) @@ -333,7 +336,7 @@ #endif yystate = YYFINAL; *++yyssp = YYFINAL; ---- 2180,2188 ---- +--- 2203,2211 ---- { #if YYDEBUG if (yydebug) @@ -344,7 +347,7 @@ yystate = YYFINAL; *++yyssp = YYFINAL; *************** -*** 2178,2184 **** +*** 2204,2210 **** yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; @@ -352,7 +355,7 @@ YYFINAL, yychar, yys); } #endif ---- 2196,2202 ---- +--- 2219,2225 ---- yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; @@ -361,7 +364,7 @@ } #endif *************** -*** 2193,2212 **** +*** 2219,2238 **** yystate = yydgoto[yym]; #if YYDEBUG if (yydebug) @@ -382,7 +385,7 @@ yyaccept: ! return (0); } ---- 2211,2245 ---- +--- 2234,2268 ---- yystate = yydgoto[yym]; #if YYDEBUG if (yydebug) diff --git a/perly.h b/perly.h index dc49c2bcdc..56eaf7e2a4 100644 --- a/perly.h +++ b/perly.h @@ -4,54 +4,57 @@ #define THING 260 #define PMFUNC 261 #define PRIVATEREF 262 -#define LABEL 263 -#define FORMAT 264 -#define SUB 265 -#define ANONSUB 266 -#define PACKAGE 267 -#define USE 268 -#define WHILE 269 -#define UNTIL 270 -#define IF 271 -#define UNLESS 272 -#define ELSE 273 -#define ELSIF 274 -#define CONTINUE 275 -#define FOR 276 -#define LOOPEX 277 -#define DOTDOT 278 -#define FUNC0 279 -#define FUNC1 280 -#define FUNC 281 -#define RELOP 282 -#define EQOP 283 -#define MULOP 284 -#define ADDOP 285 -#define DOLSHARP 286 -#define DO 287 -#define LOCAL 288 -#define HASHBRACK 289 -#define NOAMP 290 -#define OROP 291 -#define ANDOP 292 -#define NOTOP 293 -#define LSTOP 294 -#define ASSIGNOP 295 -#define OROR 296 -#define ANDAND 297 -#define BITOROP 298 -#define BITANDOP 299 -#define UNIOP 300 -#define SHIFTOP 301 -#define MATCHOP 302 -#define UMINUS 303 -#define REFGEN 304 -#define POWOP 305 -#define PREINC 306 -#define PREDEC 307 -#define POSTINC 308 -#define POSTDEC 309 -#define ARROW 310 +#define FUNC0SUB 263 +#define UNIOPSUB 264 +#define LSTOPSUB 265 +#define LABEL 266 +#define FORMAT 267 +#define SUB 268 +#define ANONSUB 269 +#define PACKAGE 270 +#define USE 271 +#define WHILE 272 +#define UNTIL 273 +#define IF 274 +#define UNLESS 275 +#define ELSE 276 +#define ELSIF 277 +#define CONTINUE 278 +#define FOR 279 +#define LOOPEX 280 +#define DOTDOT 281 +#define FUNC0 282 +#define FUNC1 283 +#define FUNC 284 +#define RELOP 285 +#define EQOP 286 +#define MULOP 287 +#define ADDOP 288 +#define DOLSHARP 289 +#define DO 290 +#define LOCAL 291 +#define HASHBRACK 292 +#define NOAMP 293 +#define OROP 294 +#define ANDOP 295 +#define NOTOP 296 +#define LSTOP 297 +#define ASSIGNOP 298 +#define OROR 299 +#define ANDAND 300 +#define BITOROP 301 +#define BITANDOP 302 +#define UNIOP 303 +#define SHIFTOP 304 +#define MATCHOP 305 +#define UMINUS 306 +#define REFGEN 307 +#define POWOP 308 +#define PREINC 309 +#define PREDEC 310 +#define POSTINC 311 +#define POSTDEC 312 +#define ARROW 313 typedef union { I32 ival; char *pval; diff --git a/perly.y b/perly.y index 907df3e903..78d975a1bf 100644 --- a/perly.y +++ b/perly.y @@ -36,6 +36,7 @@ dep() %token '{' ')' %token WORD METHOD FUNCMETH THING PMFUNC PRIVATEREF +%token FUNC0SUB UNIOPSUB LSTOPSUB %token LABEL %token FORMAT SUB ANONSUB PACKAGE USE %token WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE FOR @@ -48,7 +49,7 @@ dep() %type block lineseq line loop cond nexpr else argexpr %type expr term scalar ary hsh arylen star amper sideff %type listexpr listexprcom indirob -%type texpr listop method +%type texpr listop method proto %type label %type cont @@ -147,7 +148,8 @@ else : /* NULL */ | ELSIF '(' expr ')' block else { copline = $1; $$ = newSTATEOP(0, 0, - newCONDOP(0, $3, scope($5), $6)); } + newCONDOP(0, $3, scope($5), $6)); + hints |= HINT_BLOCK_SCOPE; } ; cond : IF '(' expr ')' block else @@ -244,12 +246,17 @@ format : FORMAT startsub WORD block { newFORM($2, Nullop, $3); } ; -subrout : SUB startsub WORD block - { newSUB($2, $3, $4); } - | SUB startsub WORD ';' - { newSUB($2, $3, Nullop); expect = XSTATE; } +subrout : SUB startsub WORD proto block + { newSUB($2, $3, $4, $5); } + | SUB startsub WORD proto ';' + { newSUB($2, $3, $4, Nullop); expect = XSTATE; } ; +proto : /* NULL */ + { $$ = Nullop; } + | THING + ; + startsub: /* NULL */ /* start a subroutine scope */ { $$ = start_subparse(); } ; @@ -287,24 +294,29 @@ listop : LSTOP indirob argexpr { $$ = convert($1, OPf_STACKED, prepend_elem(OP_LIST, newGVREF($1,$3), $4) ); } | term ARROW method '(' listexprcom ')' - { $$ = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, + { $$ = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, - prepend_elem(OP_LIST, $1, list($5)), + prepend_elem(OP_LIST, $1, $5), newUNOP(OP_METHOD, 0, $3))); } | METHOD indirob listexpr - { $$ = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, + { $$ = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, - prepend_elem(OP_LIST, $2, list($3)), + prepend_elem(OP_LIST, $2, $3), newUNOP(OP_METHOD, 0, $1))); } | FUNCMETH indirob '(' listexprcom ')' - { $$ = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, + { $$ = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, - prepend_elem(OP_LIST, $2, list($4)), + prepend_elem(OP_LIST, $2, $4), newUNOP(OP_METHOD, 0, $1))); } | LSTOP listexpr { $$ = convert($1, 0, $2); } | FUNC '(' listexprcom ')' { $$ = convert($1, 0, $3); } + | LSTOPSUB startsub block listexpr %prec LSTOP + { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, + prepend_elem(OP_LIST, newANONSUB($2, 0, $3), $4), + $1)); } ; method : METHOD @@ -378,8 +390,8 @@ term : term ASSIGNOP term { $$ = newANONHASH($2); } | HASHBRACK ';' '}' %prec '(' { $$ = newANONHASH(Nullop); } - | ANONSUB startsub block %prec '(' - { $$ = newANONSUB($2, $3); } + | ANONSUB startsub proto block %prec '(' + { $$ = newANONSUB($2, $3, $4); } | scalar %prec '(' { $$ = $1; } | star %prec '(' @@ -439,33 +451,33 @@ term : term ASSIGNOP term { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar($1)); } | amper '(' expr ')' { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, - list(append_elem(OP_LIST, $3, scalar($1)))); } + append_elem(OP_LIST, $3, scalar($1))); } | NOAMP WORD listexpr { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, - list(append_elem(OP_LIST, - $3, newCVREF(scalar($2))))); } + append_elem(OP_LIST, + $3, newCVREF(scalar($2)))); } | DO term %prec UNIOP { $$ = newUNOP(OP_DOFILE, 0, scalar($2)); } | DO block %prec '(' { $$ = newUNOP(OP_NULL, OPf_SPECIAL, scope($2)); } | DO WORD '(' ')' { $$ = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, - list(prepend_elem(OP_LIST, - scalar(newCVREF(scalar($2))), Nullop))); dep();} + prepend_elem(OP_LIST, + scalar(newCVREF(scalar($2))), Nullop)); dep();} | DO WORD '(' expr ')' { $$ = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, - list(append_elem(OP_LIST, + append_elem(OP_LIST, $4, - scalar(newCVREF(scalar($2)))))); dep();} + scalar(newCVREF(scalar($2))))); dep();} | DO scalar '(' ')' { $$ = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, - list(prepend_elem(OP_LIST, - scalar(newCVREF(scalar($2))), Nullop))); dep();} + prepend_elem(OP_LIST, + scalar(newCVREF(scalar($2))), Nullop)); dep();} | DO scalar '(' expr ')' { $$ = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, - list(prepend_elem(OP_LIST, + prepend_elem(OP_LIST, $4, - scalar(newCVREF(scalar($2)))))); dep();} + scalar(newCVREF(scalar($2))))); dep();} | LOOPEX { $$ = newOP($1, OPf_SPECIAL); hints |= HINT_BLOCK_SCOPE; } @@ -477,10 +489,16 @@ term : term ASSIGNOP term { $$ = newUNOP($1, 0, $2); } | UNIOP term { $$ = newUNOP($1, 0, $2); } + | UNIOPSUB term + { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, $2, scalar($1))); } | FUNC0 { $$ = newOP($1, 0); } | FUNC0 '(' ')' { $$ = newOP($1, 0); } + | FUNC0SUB + { $$ = newUNOP(OP_ENTERSUB, 0, + scalar($1)); } | FUNC1 '(' ')' { $$ = newOP($1, OPf_SPECIAL); } | FUNC1 '(' expr ')' diff --git a/pod/Makefile b/pod/Makefile index 6ef971db45..38d5b0fd11 100644 --- a/pod/Makefile +++ b/pod/Makefile @@ -1,21 +1,24 @@ -all: man +CONVERTERS = pod2html pod2latex pod2man + +all: $(CONVERTERS) man PERL = ../miniperl POD = \ perl.pod \ - perlxs.pod \ perlbook.pod \ perlbot.pod \ perlcall.pod \ perldata.pod \ perldebug.pod \ perldiag.pod \ + perldsc.pod \ perlembed.pod \ perlform.pod \ perlfunc.pod \ perlguts.pod \ perlipc.pod \ + perllol.pod \ perlmod.pod \ perlobj.pod \ perlop.pod \ @@ -29,22 +32,25 @@ POD = \ perlsub.pod \ perlsyn.pod \ perltrap.pod \ - perlvar.pod + perlvar.pod \ + perlxs.pod \ + perlxstut.pod MAN = \ perl.man \ - perlxs.man \ perlbook.man \ perlbot.man \ perlcall.man \ perldata.man \ perldebug.man \ perldiag.man \ + perldsc.man \ perlembed.man \ perlform.man \ perlfunc.man \ perlguts.man \ perlipc.man \ + perllol.man \ perlmod.man \ perlobj.man \ perlop.man \ @@ -58,22 +64,25 @@ MAN = \ perlsub.man \ perlsyn.man \ perltrap.man \ - perlvar.man + perlvar.man \ + perlxs.man \ + perlxstut.man HTML = \ perl.html \ - perlxs.html \ perlbook.html \ perlbot.html \ perlcall.html \ perldata.html \ perldebug.html \ perldiag.html \ + perldsc.html \ perlembed.html \ perlform.html \ perlfunc.html \ perlguts.html \ perlipc.html \ + perllol.html \ perlmod.html \ perlobj.html \ perlop.html \ @@ -87,22 +96,25 @@ HTML = \ perlsub.html \ perlsyn.html \ perltrap.html \ - perlvar.html + perlvar.html \ + perlxs.html \ + perlxstut.html TEX = \ perl.tex \ - perlxs.tex \ perlbook.tex \ perlbot.tex \ perlcall.tex \ perldata.tex \ perldebug.tex \ perldiag.tex \ + perldsc.tex \ perlembed.tex \ perlform.tex \ perlfunc.tex \ perlguts.tex \ perlipc.tex \ + perllol.tex \ perlmod.tex \ perlobj.tex \ perlop.tex \ @@ -116,8 +128,9 @@ TEX = \ perlsub.tex \ perlsyn.tex \ perltrap.tex \ - perlvar.tex - + perlvar.tex \ + perlxs.tex \ + perlxstut.tex man: pod2man $(MAN) @@ -152,11 +165,11 @@ realclean: clean distclean: realclean # Dependencies. -pod2latex: pod2latex.SH ../config.sh - sh pod2latex.SH +pod2latex: pod2latex.PL ../lib/Config.pm + $(PERL) -I../lib pod2latex.PL -pod2html: pod2html.SH ../config.sh - sh pod2html.SH +pod2html: pod2html.PL ../lib/Config.pm + $(PERL) -I ../lib pod2html.PL -pod2man: pod2man.SH ../config.sh - sh pod2man.SH +pod2man: pod2man.PL ../lib/Config.pm + $(PERL) -I ../lib pod2man.PL diff --git a/pod/perl.pod b/pod/perl.pod index 3664ab6402..f0504c4271 100644 --- a/pod/perl.pod +++ b/pod/perl.pod @@ -17,7 +17,9 @@ of sections: perlvar Perl predefined variables perlsub Perl subroutines perlmod Perl modules - perlref Perl references and nested data structures + perlref Perl references + perldsc Perl data structures intro + perllol Perl data structures: lists of lists perlobj Perl objects perlbot Perl OO tricks and examples perldebug Perl debugging @@ -28,6 +30,7 @@ of sections: perltrap Perl traps for the unwary perlstyle Perl style guide perlxs Perl XS application programming interface + perlxstut Perl XS tutorial perlguts Perl internal functions for those doing extensions perlcall Perl calling conventions from C perlovl Perl overloading semantics @@ -38,21 +41,21 @@ of sections: (If you're intending to read these straight through for the first time, the suggested order will tend to reduce the number of forward references.) -Additional documentation for perl modules is available in -the F directory. You can view this -with a man(1) program by including the following in the -appropriate start-up files. (You may have to adjust the path to -match $Config{'man3dir'}.) +Additional documentation for Perl modules is available in the +F directory. Some of this is distributed standard with +Perl, but you'll also find third-party modules there. You should be able +to view this with your man(1) program by including the proper directories +in the appropriate start-up files. To find out where these are, type: - .profile (for sh, bash or ksh users): - MANPATH=$MANPATH:/usr/local/lib/perl5/man - export MANPATH + perl -le 'use Config; print "@Config{man1dir,man3dir}"' - .login (for csh or tcsh users): - setenv MANPATH $MANPATH:/usr/local/lib/perl5/man +If the directories were F and F, +you would only need to add F to your MANPATH. If +they are different, you'll have to add both stems. If that doesn't work for some reason, you can still use the -supplied perldoc script to view module information. +supplied F script to view module information. You might +also look into getting a replacement man program. If something strange has gone wrong with your program and you're not sure where you should look for help, try the B<-w> switch first. It @@ -202,7 +205,12 @@ used. A colon-separated list of directories in which to look for Perl library files before looking in the standard library and the current -directory. If PERL5LIB is not defined, PERLLIB is used. +directory. If PERL5LIB is not defined, PERLLIB is used. When running +taint checks (because the script was running setuid or setgid, or the +B<-T> switch was used), neither variable is used. The script should +instead say + + use lib "/my/directory"; =item PERL5DB @@ -216,7 +224,6 @@ A colon-separated list of directories in which to look for Perl library files before looking in the standard library and the current directory. If PERL5LIB is defined, PERLLIB is not used. - =back Apart from these, Perl uses no other environment variables, except @@ -231,7 +238,7 @@ honest: =head1 AUTHOR -Larry Wall , with the help of oodles of other folks. +Larry Wall EE, with the help of oodles of other folks. =head1 FILES @@ -241,6 +248,7 @@ Larry Wall , with the help of oodles of other folks. =head1 SEE ALSO a2p awk to perl translator + s2p sed to perl translator =head1 DIAGNOSTICS @@ -265,7 +273,8 @@ switch? The B<-w> switch is not mandatory. Perl is at the mercy of your machine's definitions of various -operations such as type casting, atof() and sprintf(). +operations such as type casting, atof() and sprintf(). The latter +can even trigger a coredump when passed ludicrous input values. If your stdio requires a seek or eof between reads and writes on a particular stream, so does Perl. (This doesn't apply to sysread() @@ -277,6 +286,8 @@ given identifier may not be longer than 255 characters, and no component of your PATH may be longer than 255 if you use B<-S>. A regular expression may not compile to more than 32767 bytes internally. +See the perl bugs database at L. + Perl actually stands for Pathologically Eclectic Rubbish Lister, but don't tell anyone I said that. @@ -285,6 +296,6 @@ don't tell anyone I said that. The Perl motto is "There's more than one way to do it." Divining how many more is left as an exercise to the reader. -The three principle virtues of a programmer are Laziness, +The three principal virtues of a programmer are Laziness, Impatience, and Hubris. See the Camel Book for why. diff --git a/pod/perlbook.pod b/pod/perlbook.pod index 16f74df403..5bb4bfb0b5 100644 --- a/pod/perlbook.pod +++ b/pod/perlbook.pod @@ -12,9 +12,11 @@ I is a tutorial that covers the most frequently used subset of the language. Programming Perl (the Camel Book): - ISBN 0-937175-64-1 (English) - ISBN 4-89052-384-7 (Japanese) + ISBN 0-937175-64-1 (English) + ISBN 4-89052-384-7 (Japanese) Learning Perl (the Llama Book): - ISBN 1-56592-042-2 (English) - + ISBN 1-56592-042-2 (English) + ISBN 4-89502-678-1 (Japanese) + ISBN 2-84177-005-2 (French) + ISBN 3-930673-08-8 (German) diff --git a/pod/perlbot.pod b/pod/perlbot.pod index de2207a961..61a37266a2 100644 --- a/pod/perlbot.pod +++ b/pod/perlbot.pod @@ -199,11 +199,10 @@ relationships between objects. =head1 OVERRIDING SUPERCLASS METHODS -The following example demonstrates how one might override a superclass -method and then call the method after it has been overridden. The -Foo::Inherit class allows the programmer to call an overridden superclass -method without actually knowing where that method is defined. - +The following example demonstrates how to override a superclass method and +then call the overridden method. The B pseudo-class allows the +programmer to call an overridden superclass method without actually knowing +where that method is defined. package Buz; sub goo { print "here's the goo\n" } @@ -216,7 +215,6 @@ method without actually knowing where that method is defined. package Foo; @ISA = qw( Bar Baz ); - @Foo::Inherit::ISA = @ISA; # Access to overridden methods. sub new { my $type = shift; @@ -225,15 +223,15 @@ method without actually knowing where that method is defined. sub grr { print "grumble\n" } sub goo { my $self = shift; - $self->Foo::Inherit::goo(); + $self->SUPER::goo(); } sub mumble { my $self = shift; - $self->Foo::Inherit::mumble(); + $self->SUPER::mumble(); } sub google { my $self = shift; - $self->Foo::Inherit::google(); + $self->SUPER::google(); } package main; diff --git a/pod/perldata.pod b/pod/perldata.pod index 4042ecf74e..648f0922e1 100644 --- a/pod/perldata.pod +++ b/pod/perldata.pod @@ -108,17 +108,27 @@ lists. See L. =head2 Scalar values +All data in Perl is a scalar or an array of scalars or a hash of scalars. Scalar variables may contain various kinds of singular data, such as -numbers, strings and references. In general, conversion from one form -to another is transparent. (A scalar may not contain multiple values, -but may contain a reference to an array or hash containing multiple -values.) Because of the automatic conversion of scalars, operations and -functions that return scalars don't need to care (and, in fact, can't -care) whether the context is looking for a string or a number. +numbers, strings, and references. In general, conversion from one form to +another is transparent. (A scalar may not contain multiple values, but +may contain a reference to an array or hash containing multiple values.) +Because of the automatic conversion of scalars, operations and functions +that return scalars don't need to care (and, in fact, can't care) whether +the context is looking for a string or a number. + +Scalars aren't necessarily one thing or another. There's no place to +declare a scalar variable to be of type "string", or of type "number", or +type "filehandle", or anything else. Perl is a contextually polymorphic +language whose scalars can be strings, numbers, or references (which +includes objects). While strings and numbers are considered the pretty +much same thing for nearly all purposes, but references are strongly-typed +uncastable pointers with built-in reference-counting and destructor +invocation. A scalar value is interpreted as TRUE in the Boolean sense if it is not the null string or the number 0 (or its string equivalent, "0"). The -Boolean context is just a special kind of scalar context. +Boolean context is just a special kind of scalar context. There are actually two varieties of null scalars: defined and undefined. Undefined null scalars are returned when there is no real @@ -128,6 +138,15 @@ array. An undefined null scalar may become defined the first time you use it as if it were defined, but prior to that you can use the defined() operator to determine whether the value is defined or not. +To find out whether a given string is a valid non-zero number, it's usally +enough to test it against both numeric 0 and also lexical "0" (although +this will cause B<-w> noises). That's because strings that aren't +numbers count as 0, just as the do in I: + + if ($str == 0 && $str ne "0") { + warn "That doesn't look like a number"; + } + The length of an array is a scalar value. You may find the length of array @days by evaluating C<$#days>, as in B. (Actually, it's not the length of the array, it's the subscript of the last element, since @@ -158,6 +177,11 @@ So in general you can just assume that scalar(@whatever) == $#whatever + 1; +Some programmer choose to use an explcit conversion so nothing's +left to doubt: + + $element_count = scalar(@whatever); + If you evaluate a hash in a scalar context, it returns a value which is true if and only if the hash contains any key/value pairs. (If there are any key/value pairs, the value returned is a string consisting of @@ -174,7 +198,6 @@ isn't supposed to happen.) Numeric literals are specified in any of the customary floating point or integer formats: - 12345 12345.67 .23E-10 @@ -182,7 +205,7 @@ integer formats: 0377 # octal 4_294_967_296 # underline for legibility -String literals are delimited by either single or double quotes. They +String literals are usually delimited by either single or double quotes. They work much like shell quotes: double-quoted string literals are subject to backslash and variable substitution; single-quoted strings are not (except for "C<\'>" and "C<\\>"). The usual Unix backslash rules apply for making @@ -229,7 +252,7 @@ logical end of the script before the actual end of file. Any following text is ignored, but may be read via the DATA filehandle. (The DATA filehandle may read data only from the main script, but not from any required file or evaluated string.) The two control characters ^D and -^Z are synonyms for __END__. +^Z are synonyms for __END__ (or __DATA__ in a module). A word that has no other interpretation in the grammar will be treated as if it were a quoted string. These are known as @@ -248,7 +271,8 @@ by saying C. Array variables are interpolated into double-quoted strings by joining all the elements of the array with the delimiter specified in the C<$"> -variable, space by default. The following are equivalent: +variable ($LIST_SEPARATOR in English), space by default. The following +are equivalent: $temp = join($",@ARGV); system "echo $temp"; @@ -286,9 +310,6 @@ whitespace) on the terminating line. The price is $Price. EOF - print << x 10; # Legal but discouraged. Use <<"". - Merry Christmas! - print <<`EOC`; # execute commands echo hi there echo lo there @@ -359,7 +380,8 @@ identity in a LIST--the list (@foo,@bar,&SomeSub) contains all the elements of @foo followed by all the elements of @bar, -followed by all the elements returned by the subroutine named SomeSub. +followed by all the elements returned by the subroutine named SomeSub when +it's called in a list context. To make a list reference that does I interpolate, see L. The null list is represented by (). Interpolating it in a list @@ -373,6 +395,9 @@ put the list in parentheses to avoid ambiguity. Examples: # Stat returns list value. $time = (stat($file))[8]; + # SYNTAX ERROR HERE. + $time = stat($file)[8]; # OOPS, FORGOT PARENS + # Find a hex digit. $hexdigit = ('a','b','c','d','e','f')[$digit-10]; @@ -386,12 +411,22 @@ is legal to assign to: ($map{'red'}, $map{'blue'}, $map{'green'}) = (0x00f, 0x0f0, 0xf00); +Array assignment in a scalar context returns the number of elements +produced by the expression on the right side of the assignment: + + $x = (($foo,$bar) = (3,2,1)); # set $x to 3, not 2 + $x = (($foo,$bar) = f()); # set $x to f()'s return count + +This is very handy when you want to do a list assignment in a Boolean +context, since most list functions return a null list when finished, +which when assigned produces a 0, which is interpreted as FALSE. + The final element may be an array or a hash: ($a, $b, @rest) = split; local($a, $b, %rest) = @_; -You can actually put an array anywhere in the list, but the first array +You can actually put an array or hash anywhere in the list, but the first one in the list will soak up all the values, and anything after it will get a null value. This may be useful in a local() or my(). @@ -401,21 +436,38 @@ as a key and a value: # same as map assignment above %map = ('red',0x00f,'blue',0x0f0,'green',0xf00); -It is often more readable to use the C<=E> operator between key/value pairs -(the C<=E> operator is actually nothing more than a more visually -distinctive synonym for a comma): +While literal lists and named arrays are usually interchangeable, that's +not the case for hashes. Just because you can subscript a list value like +a normal array does not mean that you can subscript a list value as a +hash. Likewise, hashes included as parts of other lists (including +parameters lists and return lists from functions) always flatten out into +key/value pairs. That's why it's good to use references sometimes. - %map = ( - 'red' => 0x00f, - 'blue' => 0x0f0, - 'green' => 0xf00, - ); - -Array assignment in a scalar context returns the number of elements -produced by the expression on the right side of the assignment: +It is often more readable to use the C<=E> operator between key/value +pairs. The C<=E> operator is mostly just a more visually distinctive +synonym for a comma, but it also quotes its left-hand operand, which makes +it nice for initializing hashes: - $x = (($foo,$bar) = (3,2,1)); # set $x to 3, not 2 - -This is very handy when you want to do a list assignment in a Boolean -context, since most list functions return a null list when finished, -which when assigned produces a 0, which is interpreted as FALSE. + %map = ( + red => 0x00f, + blue => 0x0f0, + green => 0xf00, + ); + +or for initializing hash references to be used as records: + + $rec = { + witch => 'Mable the Merciless', + cat => 'Fluffy the Ferocious', + date => '10/31/1776', + }; + +or for using call-by-named-parameter to complicated functions: + + $field = $query->radio_group( + name => 'group_name', + values => ['eenie','meenie','minie'], + default => 'meenie', + linebreak => 'true', + labels => \%labels + ); diff --git a/pod/perldiag.pod b/pod/perldiag.pod index e41c29939a..ad4a532aaf 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -194,13 +194,6 @@ could indicate that SvREFCNT_dec() was called too many times, or that SvREFCNT_inc() was called too few times, or that the SV was mortalized when it shouldn't have been, or that memory has been corrupted. -=item Attempt to use reference as hash key - -(W) References as not very meaningful as hash keys. You probably forgot to -dereference the reference before using it in a hash list, or got mixed up -and used C<{}> or C<[]> instead of C<()>. Or perhaps a missing key in the -hash list is causing values to be treated as keys. - =item Bad arg length for %s, is %d, should be %d (F) You passed a buffer of the wrong size to one of msgctl(), semctl() or @@ -262,6 +255,10 @@ Compilation stops immediately and the interpreter is exited. (W) You tried to do a bind on a closed socket. Did you forget to check the return value of your socket() call? See L. +=item Bizarre copy of %s in %s + +(P) Perl detected an attempt to copy an internal value that is not copiable. + =item Callback called exit (F) A subroutine invoked from an external package via perl_call_sv() @@ -490,6 +487,13 @@ call for another. It can't manufacture one out of whole cloth. In general you should only be calling it out of an AUTOLOAD routine anyway. See L. +=item Can't localize a reference + +(F) You said something like C, which is not allowed because +the compiler can't determine whether $ref will end up pointing to anything +with a symbol table entry, and a symbol table entry is necessary to +do a local. + =item Can't localize lexical variable %s (F) You used local on a variable name that was previous declared as a @@ -740,6 +744,10 @@ times than it has returned. This probably indicates an infinite recursion, unless you're writing strange benchmark programs, in which case it indicates something else. +=item Did you mean &%s instead? + +(W) You probably referred to an imported subroutine &FOO as $FOO or some such. + =item Did you mean $ or @ instead of %? (W) You probably said %hash{$key} when you meant $hash{$key} or @hash{@keys}. @@ -770,6 +778,13 @@ declaration. (S) An internal routine called free() on something that had already been freed. +=item elseif should be elsif + +(S) There is no keyword "elseif" in Perl because Larry thinks it's +ugly. Your code will be interpreted as an attempt to call a method +named "elseif" for the class returned by the following block. This is +unlikely to be what you want. + =item END failed--cleanup aborted (F) An untrapped exception was raised while executing an END subroutine. @@ -1570,6 +1585,11 @@ last argument of the previous construct, for example: open FOO || die; +=item Prototype mismatch: (%s) vs (%s) + +(S) The subroutine being defined had a predeclared (forward) declaration +with a different function prototype. + =item Read on closed filehandle <%s> (W) The filehandle you're reading from got itself closed sometime before now. @@ -1742,7 +1762,7 @@ But before sort was a keyword, people sometimes used it as a filehandle. =item Sort subroutine didn't return a numeric value (F) A sort comparison routine must return a number. You probably blew -it by not using C=E or C, or by not using them correctly. +it by not using C=E> or C, or by not using them correctly. See L. =item Sort subroutine didn't return single value @@ -1931,6 +1951,10 @@ certain type. Arrays must be @NAME or @{EXPR}. Hashes must be (W) A umask of 222 is incorrect. It should be 0222, since octal literals always start with 0 in Perl, as in C. +=item Unable to create sub named "%s" + +(F) You attempted to create or access a subroutine with an illegal name. + =item Unbalanced context: %d more PUSHes than POPs (W) The exit code detected an internal inconsistency in how many execution @@ -1976,6 +2000,11 @@ or if it was, it has since been undefined. (F) The sort comparison routine specified is declared but doesn't seem to have been defined yet. See L. +=item Undefined top format "%s" called + +(F) The format indicated doesn't seem to exist. Perhaps it's really in +another package? See L. + =item unexec of %s into %s failed! (F) The unexec() routine failed for some reason. See your local FSF @@ -2076,6 +2105,11 @@ from C. This usually means there's a better way to do it in Perl. because there's a better way to do it, and also because the old way has bad side effects. +=item Use of bare << to mean <<"" is deprecated + +(D) You are now encouraged to use the explicitly quoted form if you +wish to use a blank line as the terminator of the here-document. + =item Use of implicit split to @_ is deprecated (D) It makes a lot of work for the compiler when you clobber a @@ -2119,6 +2153,14 @@ a scalar context, the comma is treated like C's comma operator, which throws away the left argument, which is not what you want. See L for more on this. +=item Variable "%s" is not exported + +(F) While "use strict" in effect, you referred to a global variable +that you apparently thought was imported from another module, because +something else of the same name (usually a subroutine) is exported +by that module. It usually means you put the wrong funny character +on the front of your variable. + =item Warning: unable to close filehandle %s properly. (S) The implicit close() done by an open() got an error indication on the diff --git a/pod/perldsc.pod b/pod/perldsc.pod new file mode 100644 index 0000000000..1d51af8ab3 --- /dev/null +++ b/pod/perldsc.pod @@ -0,0 +1,348 @@ +=head1 TITLE + +perldsc - Manipulating Complex Data Structures in Perl + +=head1 INTRODUCTION + +The single feature most sorely lacking in the Perl programming language +prior to its 5.0 release was complex data structures. Even without direct +language support, some valiant programmers did manage to emulate them, but +it was hard work and not for the faint of heart. You could occasionally +get away with the C<$m{$LoL,$b}> notation borrowed from I in which the +keys are actually more like a single concatenated string C<"$LoL$b">, but +traversal and sorting were difficult. More desperate programmers even +hacked Perl's internal symbol table directly, a strategy that proved hard +to develop and maintain--to put it mildly. + +The 5.0 release of Perl let us have complex data structures. You +may now write something like this and all of a sudden, you'd have a array +with three dimensions! + + for $x (1 .. 10) { + for $y (1 .. 10) { + for $z (1 .. 10) { + $LoL[$x][$y][$z] = + $x ** $y + $z; + } + } + } + +Alas, however simple this may appear, underneath it's a much more +elaborate construct than meets the eye! + +How do you print it out? Why can't you just say C? How do +you sort it? How can you pass it to a function or get one of these back +from a function? Is is an object? Can you save it to disk to read +back later? How do you access whole rows or columns of that matrix? Do +all the values have to be numeric? + +As you see, it's quite easy to become confused. While some small portion +of the blame for this can be attributed to the reference-based +implementation, it's really more due to a lack of existing documentation with +examples designed for the beginner. + +This document is meant to be a detailed but understandable treatment of +the many different sorts of data structures you might want to develop. It should +also serve as a cookbook of examples. That way, when you need to create one of these +complex data structures, you can just pinch, pilfer, or purloin +a drop-in example from here. + +Let's look at each of these possible constructs in detail. There are separate +documents on each of the following: + +=over 5 + +=item * arrays of arrays + +=item * hashes of arrays + +=item * arrays of hashes + +=item * hashes of hashes + +=item * more elaborate constructs + +=item * recursive and self-referential data structures + +=item * objects + +=back + +But for now, let's look at some of the general issues common to all +of these types of data structures. + +=head1 REFERENCES + +The most important thing to understand about all data structures in Perl +-- including multidimensional arrays--is that even though they might +appear otherwise, Perl C<@ARRAY>s and C<%HASH>es are all internally +one-dimensional. They can only hold scalar values (meaning a string, +number, or a reference). They cannot directly contain other arrays or +hashes, but instead contain I to other arrays or hashes. + +You can't use a reference to a array or hash in quite the same way that +you would a real array or hash. For C or C++ programmers unused to distinguishing +between arrays and pointers to the same, this can be confusing. If so, +just think of it as the difference between a structure and a pointer to a +structure. + +You can (and should) read more about references in the perlref(1) man +page. Briefly, references are rather like pointers that know what they +point to. (Objects are also a kind of reference, but we won't be needing +them right away--if ever.) That means that when you have something that +looks to you like an access to two-or-more-dimensional array and/or hash, +that what's really going on is that in all these cases, the base type is +merely a one-dimensional entity that contains references to the next +level. It's just that you can I it as though it were a +two-dimensional one. This is actually the way almost all C +multidimensional arrays work as well. + + $list[7][12] # array of arrays + $list[7]{string} # array of hashes + $hash{string}[7] # hash of arrays + $hash{string}{'another string'} # hash of hashes + +Now, because the top level only contains references, if you try to print +out your array in with a simple print() function, you'll get something +that doesn't look very nice, like this: + + @LoL = ( [2, 3], [4, 5, 7], [0] ); + print $LoL[1][2]; + 7 + print @LoL; + ARRAY(0x83c38)ARRAY(0x8b194)ARRAY(0x8b1d0) + + +That's because Perl doesn't (ever) implicitly dereference your variables. +If you want to get at the thing a reference is referring to, then you have +to do this yourself using either prefix typing indicators, like +C<${$blah}>, C<@{$blah}>, C<@{$blah[$i]}>, or else postfix pointer arrows, +like C<$a-E[3]>, C<$h-E{fred}>, or even C<$ob-Emethod()-E[3]>. + +=head1 COMMON MISTAKES + +The two most common mistakes made in constructing something like +an array of arrays is either accidentally counting the number of +elements or else taking a reference to the same memory location +repeatedly. Here's the case where you just get the count instead +of a nested array: + + for $i (1..10) { + @list = somefunc($i); + $LoL[$i] = @list; # WRONG! + } + +That's just the simple case of assigning a list to a scalar and getting +its element count. If that's what you really and truly want, then you +might do well to consider being a tad more explicit about it, like this: + + for $i (1..10) { + @list = somefunc($i); + $counts[$i] = scalar @list; + } + +Here's the case of taking a reference to the same memory location +again and again: + + for $i (1..10) { + @list = somefunc($i); + $LoL[$i] = \@list; # WRONG! + } + +So, just what's the big problem with that? It looks right, doesn't it? +After all, I just told you that you need an array of references, so by +golly, you've made me one! + +Unfortunately, while this is true, it's still broken. All the references +in @LoL refer to the I, and they will therefore all hold +whatever was last in @list! It's similar to the problem demonstrated in +the following C program: + + #include + main() { + struct passwd *getpwnam(), *rp, *dp; + rp = getpwnam("root"); + dp = getpwnam("daemon"); + + printf("daemon name is %s\nroot name is %s\n", + dp->pw_name, rp->pw_name); + } + +Which will print + + daemon name is daemon + root name is daemon + +The problem is that both C and C are pointers to the same location +in memory! In C, you'd have to remember to malloc() yourself some new +memory. In Perl, you'll want to use the array constructor C<[]> or the +hash constructor C<{}> instead. Here's the right way to do the preceding +broken code fragments + + for $i (1..10) { + @list = somefunc($i); + $LoL[$i] = [ @list ]; + } + +The square brackets make a reference to a new array with a I +of what's in @list at the time of the assignment. This is what +you want. + +Note that this will produce something similar, but it's +much harder to read: + + for $i (1..10) { + @list = 0 .. $i; + @{$LoL[$i]} = @list; + } + +Is it the same? Well, maybe so--and maybe not. The subtle difference +is that when you assign something in square brackets, you know for sure +it's always a brand new reference with a new I of the data. +Something else could be going on in this new case with the C<@{$LoL[$i]}}> +dereference on the left-hand-side of the assignment. It all depends on +whether C<$LoL[$i]> had been undefined to start with, or whether it +already contained a reference. If you had already populated @LoL with +references, as in + + $LoL[3] = \@another_list; + +Then the assignment with the indirection on the left-hand-side would +use the existing reference that was already there: + + @{$LoL[3]} = @list; + +Of course, this I have the "interesting" effect of clobbering +@another_list. (Have you ever noticed how when a programmer says +something is "interesting", that rather than meaning "intriguing", +they're disturbingly more apt to mean that it's "annoying", +"difficult", or both? :-) + +So just remember to always use the array or hash constructors with C<[]> +or C<{}>, and you'll be fine, although it's not always optimally +efficient. + +Surprisingly, the following dangerous-looking construct will +actually work out fine: + + for $i (1..10) { + my @list = somefunc($i); + $LoL[$i] = \@list; + } + +That's because my() is more of a run-time statement than it is a +compile-time declaration I. This means that the my() variable is +remade afresh each time through the loop. So even though it I as +though you stored the same variable reference each time, you actually did +not! This is a subtle distinction that can produce more efficient code at +the risk of misleading all but the most experienced of programmers. So I +usually advise against teaching it to beginners. In fact, except for +passing arguments to functions, I seldom like to see the gimme-a-reference +operator (backslash) used much at all in code. Instead, I advise +beginners that they (and most of the rest of us) should try to use the +much more easily understood constructors C<[]> and C<{}> instead of +relying upon lexical (or dynamic) scoping and hidden reference-counting to +do the right thing behind the scenes. + +In summary: + + $LoL[$i] = [ @list ]; # usually best + $LoL[$i] = \@list; # perilous; just how my() was that list? + @{ $LoL[$i] } = @list; # way too tricky for most programmers + + +=head1 CAVEAT ON PRECEDENCE + +Speaking of things like C<@{$LoL[$i]}>, the following are actually the +same thing: + + $listref->[2][2] # clear + $$listref[2][2] # confusing + +That's because Perl's precedence rules on its five prefix dereferencers +(which look like someone swearing: C<$ @ * % &>) make them bind more +tightly than the postfix subscripting brackets or braces! This will no +doubt come as a great shock to the C or C++ programmer, who is quite +accustomed to using C<*a[i]> to mean what's pointed to by the I +element of C. That is, they first take the subscript, and only then +dereference the thing at that subscript. That's fine in C, but this isn't C. + +The seemingly equivalent construct in Perl, C<$$listref[$i]> first does +the deref of C<$listref>, making it take $listref as a reference to an +array, and then dereference that, and finally tell you the I value +of the array pointed to by $LoL. If you wanted the C notion, you'd have to +write C<${$LoL[$i]}> to force the C<$LoL[$i]> to get evaluated first +before the leading C<$> dereferencer. + +=head1 WHY YOU SHOULD ALWAYS C + +If this is starting to sound scarier than it's worth, relax. Perl has +some features to help you avoid its most common pitfalls. The best +way to avoid getting confused is to start every program like this: + + #!/usr/bin/perl -w + use strict; + +This way, you'll be forced to declare all your variables with my() and +also disallow accidental "symbolic dereferencing". Therefore if you'd done +this: + + my $listref = [ + [ "fred", "barney", "pebbles", "bambam", "dino", ], + [ "homer", "bart", "marge", "maggie", ], + [ "george", "jane", "alroy", "judy", ], + ]; + + print $listref[2][2]; + +The compiler would immediately flag that as an error I, +because you were accidentally accessing C<@listref>, an undeclared +variable, and it would thereby remind you to instead write: + + print $listref->[2][2] + +=head1 DEBUGGING + +The standard Perl debugger in 5.001 doesn't do a very nice job of +printing out complex data structures. However, the perl5db that +Ilya Zakharevich EFE +wrote, which is accessible at + + ftp://ftp.perl.com/pub/perl/ext/perl5db-kit-0.9.tar.gz + +has several new features, including command line editing as well +as the C command to dump out complex data structures. For example, +given the assignment to $LoL above, here's the debugger output: + + DB<1> X $LoL + $LoL = ARRAY(0x13b5a0) + 0 ARRAY(0x1f0a24) + 0 'fred' + 1 'barney' + 2 'pebbles' + 3 'bambam' + 4 'dino' + 1 ARRAY(0x13b558) + 0 'homer' + 1 'bart' + 2 'marge' + 3 'maggie' + 2 ARRAY(0x13b540) + 0 'george' + 1 'jane' + 2 'alroy' + 3 'judy' + +There's also a lower-case B command which is nearly the same. + +=head1 SEE ALSO + +perlref(1), perldata(1) + +=head1 AUTHOR + +Tom Christiansen EFE + +Last update: +Sat Oct 7 22:41:09 MDT 1995 + diff --git a/pod/perlform.pod b/pod/perlform.pod index 99e0746c1a..c4bb78cfcd 100644 --- a/pod/perlform.pod +++ b/pod/perlform.pod @@ -310,4 +310,5 @@ is to printf(), do this: Lexical variables (declared with "my") are not visible within a format unless the format is declared within the scope of the lexical -variable. (They weren't visiblie at all before version 5.001.) +variable. (They weren't visible at all before version 5.001.) See +L for other issues. diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 42ec30fb55..2cc480cfe8 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -150,7 +150,9 @@ are found, it's a C<-B> file, otherwise it's a C<-T> file. Also, any file containing null in the first block is considered a binary file. If C<-T> or C<-B> is used on a filehandle, the current stdio buffer is examined rather than the first block. Both C<-T> and C<-B> return TRUE on a null -file, or a file at EOF when testing a filehandle. +file, or a file at EOF when testing a filehandle. Because you have to +read a file to do the C<-T> test, on most occasions you want to use a C<-f> +against the file first, as in C. If any of the file tests (or either the stat() or lstat() operators) are given the special filehandle consisting of a solitary underline, then the stat @@ -179,7 +181,7 @@ Returns the absolute value of its argument. Accepts an incoming socket connect, just as the accept(2) system call does. Returns the packed address if it succeeded, FALSE otherwise. -See example in L. +See example in L. =item alarm SECONDS @@ -192,9 +194,10 @@ argument of 0 may be supplied to cancel the previous timer without starting a new one. The returned value is the amount of time remaining on the previous timer. -For sleeps of finer granularity than one second, you may use Perl's +For delays of finer granularity than one second, you may use Perl's syscall() interface to access setitimer(2) if your system supports it, -or else see L below. +or else see L below. It is not advised to intermix alarm() +and sleep() calls. =item atan2 Y,X @@ -204,8 +207,8 @@ Returns the arctangent of Y/X in the range -PI to PI. Binds a network address to a socket, just as the bind system call does. Returns TRUE if it succeeded, FALSE otherwise. NAME should be a -packed address of the appropriate type for the socket. See example in -L. +packed address of the appropriate type for the socket. See the examples in +L. =item binmode FILEHANDLE @@ -213,18 +216,21 @@ Arranges for the file to be read or written in "binary" mode in operating systems that distinguish between binary and text files. Files that are not in binary mode have CR LF sequences translated to LF on input and LF translated to CR LF on output. Binmode has no effect -under Unix; in DOS, it may be imperative. If FILEHANDLE is an expression, +under Unix; in DOS, it may be imperative--otherwise your DOS C library +may mangle your file. If FILEHANDLE is an expression, the value is taken as the name of the filehandle. -=item bless REF,PACKAGE +=item bless REF,CLASSNAME =item bless REF This function tells the referenced object (passed as REF) that it is now -an object in PACKAGE--or the current package if no PACKAGE is specified, -which is the usual case. It returns the reference for convenience, since -a bless() is often the last thing in a constructor. See L for -more about the blessing (and blessings) of objects. +an object in the CLASSNAME package--or the current package if no CLASSNAME +is specified, which is often the case. It returns the reference for +convenience, since a bless() is often the last thing in a constructor. +Always use the two-argument version if the function doing the blessing +might be inherited by a derived class. See L for more about the +blessing (and blessings) of objects. =item caller EXPR @@ -244,7 +250,7 @@ to go back before the current one. $subroutine, $hasargs, $wantargs) = caller($i); Furthermore, when called from within the DB package, caller returns more -detailed information: it sets sets the list variable @DB:args to be the +detailed information: it sets the list variable @DB::args to be the arguments with which that subroutine was invoked. =item chdir EXPR @@ -256,8 +262,8 @@ otherwise. See example under die(). =item chmod LIST Changes the permissions of a list of files. The first element of the -list must be the numerical mode. Returns the number of files -successfully changed. +list must be the numerical mode, which should probably be an octal +number. Returns the number of files successfully changed. $cnt = chmod 0755, 'foo', 'bar'; chmod 0755, @executables; @@ -342,6 +348,11 @@ Here's an example that looks up non-numeric uids in the passwd file: @ary = <${pattern}>; # expand filenames chown $uid, $gid, @ary; +On most systems, you are not allowed to change the ownership of the +file unless you're the superuser, although you should be able to change +the group to any of your secondary groups. On insecure systems, these +restrictions may be relaxed, but this is not a portable assumption. + =item chr NUMBER Returns the character represented by that NUMBER in the character set. @@ -349,16 +360,19 @@ For example, C is "A" in ASCII. =item chroot FILENAME -Does the same as the system call of that name. If you don't know what -it does, don't worry about it. If FILENAME is omitted, does chroot to -$_. +This function works as the system call by the same name: it makes the +named directory the new root directory for all further pathnames that +begin with a "/" by your process and all of its children. (It doesn't +change your current working directory is unaffected.) For security +reasons, this call is restricted to the superuser. If FILENAME is +omitted, does chroot to $_. =item close FILEHANDLE Closes the file or pipe associated with the file handle, returning TRUE only if stdio successfully flushes buffers and closes the system file descriptor. You don't have to close FILEHANDLE if you are immediately -going to do another open on it, since open will close it for you. (See +going to do another open() on it, since open() will close it for you. (See open().) However, an explicit close on an input file resets the line counter ($.), while the implicit close done by open() does not. Also, closing a pipe will wait for the process executing on the pipe to @@ -381,8 +395,8 @@ Closes a directory opened by opendir(). Attempts to connect to a remote socket, just as the connect system call does. Returns TRUE if it succeeded, FALSE otherwise. NAME should be a -packed address of the appropriate type for the socket. See example in -L. +packed address of the appropriate type for the socket. See the examples in +L. =item cos EXPR @@ -391,9 +405,11 @@ takes cosine of $_. =item crypt PLAINTEXT,SALT -Encrypts a string exactly like the crypt(3) function in the C library. -Useful for checking the password file for lousy passwords, amongst -other things. Only the guys wearing white hats should do this. +Encrypts a string exactly like the crypt(3) function in the C library +(assuming that you actually have a version there that has not been +extirpated as a potential munition). This can prove useful for checking +the password file for lousy passwords, amongst other things. Only the +guys wearing white hats should do this. Here's an example that makes sure that whoever runs this program knows their own password: @@ -426,15 +442,16 @@ Breaks the binding between a DBM file and an associative array. [This function has been superseded by the tie() function.] -This binds a dbm(3) or ndbm(3) file to an associative array. ASSOC is the +This binds a dbm(3), ndbm(3), sdbm(3), gdbm(), or Berkeley DB file to an associative array. ASSOC is the name of the associative array. (Unlike normal open, the first argument is I a filehandle, even though it looks like one). DBNAME is the -name of the database (without the F<.dir> or F<.pag> extension). If the +name of the database (without the F<.dir> or F<.pag> extension if any). If the database does not exist, it is created with protection specified by MODE (as modified by the umask()). If your system only supports the older DBM functions, you may perform only one dbmopen() in your program. -If your system has neither DBM nor ndbm, calling dbmopen() produces a -fatal error. +In order versions of Perl, +if your system had neither DBM nor ndbm, calling dbmopen() produced a +fatal error; it now falls back to sdbm(3). If you don't have write access to the DBM file, you can only read associative array variables, not set them. If you want to test whether @@ -452,6 +469,8 @@ function to iterate over large DBM files. Example: } dbmclose(%HIST); +See also L for many other interesting possibilities. + =item defined EXPR Returns a boolean value saying whether the lvalue EXPR has a real value @@ -501,10 +520,11 @@ a hash key lookup: =item die LIST Outside of an eval(), prints the value of LIST to C and exits with -the current value of $! (errno). If $! is 0, exits with the value of +the current value of $! (errno). If $! is 0, exits with the value of C<($? EE 8)> (backtick `command` status). If C<($? EE 8)> is 0, exits with 255. Inside an eval(), the error message is stuffed into C<$@>, -and the eval() is terminated with the undefined value. +and the eval() is terminated with the undefined value; this makes die() +the way to raise an exception. Equivalent examples: @@ -558,7 +578,8 @@ reparse the file every time you call it, so you probably don't want to do this inside a loop. Note that inclusion of library modules is better done with the -use() and require() operators. +use() and require() operators, which also do error checking +and raise an exception if there's a problem. =item dump LABEL @@ -595,7 +616,7 @@ Example: =item each ASSOC_ARRAY -Returns a 2 element array consisting of the key and value for the next +Returns a 2-element array consisting of the key and value for the next value of an associative array, so that you can iterate over it. Entries are returned in an apparently random order. When the array is entirely read, a null array is returned (which when assigned produces a @@ -615,6 +636,8 @@ See also keys() and values(). =item eof FILEHANDLE +=item eof () + =item eof Returns 1 if the next read on FILEHANDLE will return end of file, or if @@ -627,7 +650,7 @@ as terminals may lose the end-of-file condition if you do. An C without an argument uses the last file read as argument. Empty parentheses () may be used to indicate -the pseudo file formed of the files listed on the command line, i.e. +the pseudofile formed of the files listed on the command line, i.e. C is reasonable to use inside a while (<>) loop to detect the end of only the last file. Use C or eof without the parentheses to test I file in a while (<>) loop. Examples: @@ -649,7 +672,7 @@ test I file in a while (<>) loop. Examples: } Practical hint: you almost never need to use C in Perl, because the -input operators return undef when they run out of data. +input operators return undef when they run out of data. Testing C =item eval EXPR @@ -668,7 +691,7 @@ string. If EXPR is omitted, evaluates $_. The final semicolon, if any, may be omitted from the expression. Note that, since eval() traps otherwise-fatal errors, it is useful for -determining whether a particular feature (such as dbmopen() or symlink()) +determining whether a particular feature (such as socket() or symlink()) is implemented. It is also Perl's exception trapping mechanism, where the die operator is used to raise exceptions. @@ -797,10 +820,12 @@ value is taken as the name of the filehandle. =item flock FILEHANDLE,OPERATION -Calls flock(2) on FILEHANDLE. See L for -definition of OPERATION. Returns TRUE for success, FALSE on failure. -Will produce a fatal error if used on a machine that doesn't implement -flock(2). Here's a mailbox appender for BSD systems. +Calls flock(2) on FILEHANDLE. See L for definition of +OPERATION. Returns TRUE for success, FALSE on failure. Will produce a +fatal error if used on a machine that doesn't implement either flock(2) or +fcntl(2). (fcntl(2) will be automatically used if flock(2) is missing.) + +Here's a mailbox appender for BSD systems. $LOCK_SH = 1; $LOCK_EX = 2; @@ -825,13 +850,13 @@ flock(2). Here's a mailbox appender for BSD systems. print MBOX $msg,"\n\n"; unlock(); -Note that flock() can't lock things over the network. You need to do -locking with fcntl() for that. +Note that many versions of flock() cannot lock things over the network. +You need to do locking with fcntl() for that. =item fork Does a fork(2) system call. Returns the child pid to the parent process -and 0 to the child process, or undef if the fork is unsuccessful. +and 0 to the child process, or C if the fork is unsuccessful. Note: unflushed buffers remain unflushed in both processes, which means you may need to set C<$|> ($AUTOFLUSH in English) or call the autoflush() FileHandle method to avoid duplicate output. @@ -839,7 +864,7 @@ autoflush() FileHandle method to avoid duplicate output. If you fork() without ever waiting on your children, you will accumulate zombies: - $SIG{'CHLD'} = sub { wait }; + $SIG{CHLD} = sub { wait }; There's also the double-fork trick (error checking on fork() returns omitted); @@ -849,7 +874,7 @@ fork() returns omitted); exec "what you really wanna do"; die "no exec"; # ... or ... - some_perl_code_here; + ## (some_perl_code_here) exit 0; } exit 0; @@ -859,21 +884,22 @@ fork() returns omitted); =item formline PICTURE, LIST -This is an internal function used by formats, though you may call it +This is an internal function used by Cs, though you may call it too. It formats (see L) a list of values according to the contents of PICTURE, placing the output into the format output -accumulator, C<$^A>. Eventually, when a write() is done, the contents of +accumulator, C<$^A> (or $ACCUMULATOR in English). +Eventually, when a write() is done, the contents of C<$^A> are written to some filehandle, but you could also read C<$^A> yourself and then set C<$^A> back to "". Note that a format typically does one formline() per line of form, but the formline() function itself doesn't care how many newlines are embedded in the PICTURE. This means -that the ~ and ~~ tokens will treat the entire PICTURE as a single line. +that the C<~> and C<~~> tokens will treat the entire PICTURE as a single line. You may therefore need to use multiple formlines to implement a single record format, just like the format compiler. Be careful if you put double quotes around the picture, since an "C<@>" character may be taken to mean the beginning of an array name. -formline() always returns TRUE. +formline() always returns TRUE. See L for other examples. =item getc FILEHANDLE @@ -881,27 +907,55 @@ formline() always returns TRUE. Returns the next character from the input file attached to FILEHANDLE, or a null string at end of file. If FILEHANDLE is omitted, reads from STDIN. +This is not particularly efficient. It cannot be used to get unbuffered +single-character + + if ($BSD_STYLE) { + system "stty cbreak /dev/tty 2>&1"; + } + else { + system "stty", '-icanon', + system "stty", 'eol', "\001"; + } + + $key = getc(STDIN); + + if ($BSD_STYLE) { + system "stty -cbreak /dev/tty 2>&1"; + } + else { + system "stty", 'icanon'; + system "stty", 'eol', '^@'; # ascii null + } + print "\n"; + +Determination of whether to whether $BSD_STYLE should be set +is left as an exercise to the reader. =item getlogin Returns the current login from F, if any. If null, use -getpwuid(). +getpwuid(). $login = getlogin || (getpwuid($<))[0] || "Kilroy"; +Do not consider getlogin() for authorentication: it is not as +secure as getpwuid(). + =item getpeername SOCKET Returns the packed sockaddr address of other end of the SOCKET connection. - # An internet sockaddr - $sockaddr = 'S n a4 x8'; - $hersockaddr = getpeername(S); - ($family, $port, $heraddr) = unpack($sockaddr,$hersockaddr); + use Socket; + $hersockaddr = getpeername(SOCK); + ($port, $iaddr) = unpack_sockaddr_in($hersockaddr); + $herhostname = gethostbyaddr($iaddr, AF_INET); + $herstraddr = inet_ntoa($iaddr); =item getpgrp PID Returns the current process group for the specified PID, 0 for the -current process. Will produce a fatal error if used on a machine that +current process. Will raise an exception if used on a machine that doesn't implement getpgrp(2). If PID is omitted, returns process group of current process. @@ -911,8 +965,8 @@ Returns the process id of the parent process. =item getpriority WHICH,WHO -Returns the current priority for a process, a process group, or a -user. (See L.) Will produce a fatal error if used on a +Returns the current priority for a process, a process group, or a user. +(See L.) Will raise a fatal exception if used on a machine that doesn't implement getpriority(2). =item getpwnam NAME @@ -1017,11 +1071,9 @@ by saying something like: Returns the packed sockaddr address of this end of the SOCKET connection. - # An internet sockaddr - $sockaddr = 'S n a4 x8'; - $mysockaddr = getsockname(S); - ($family, $port, $myaddr) = - unpack($sockaddr,$mysockaddr); + use Socket; + $mysockaddr = getsockname(SOCK); + ($port, $myaddr) = unpack_sockaddr_in($mysockaddr); =item getsockopt SOCKET,LEVEL,OPTNAME @@ -1031,13 +1083,13 @@ Returns the socket option requested, or undefined if there is an error. Returns the value of EXPR with filename expansions such as a shell would do. This is the internal function implementing the <*.*> -operator. +operator, except it's easier to use. =item gmtime EXPR Converts a time as returned by the time function to a 9-element array -with the time localized for the Greenwich timezone. Typically used as -follows: +with the time localized for the standard Greenwich timezone. +Typically used as follows: ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = @@ -1098,25 +1150,25 @@ array. =item hex EXPR -Returns the decimal value of EXPR interpreted as an hex string. (To -interpret strings that might start with 0 or 0x see oct().) If EXPR is -omitted, uses $_. +Interprets EXPR as a hex string and returns the corresponding decimal +value. (To convert strings that might start with 0 or 0x see +oct().) If EXPR is omitted, uses $_. =item import There is no built-in import() function. It is merely an ordinary -method subroutine defined (or inherited) by modules that wish to export +method (subroutine) defined (or inherited) by modules that wish to export names to another module. The use() function calls the import() method -for the package used. See also L and L. +for the package used. See also L, L, and L. =item index STR,SUBSTR,POSITION =item index STR,SUBSTR -Returns the position of the first occurrence of SUBSTR in STR at or -after POSITION. If POSITION is omitted, starts searching from the -beginning of the string. The return value is based at 0, or whatever -you've set the $[ variable to. If the substring is not found, returns +Returns the position of the first occurrence of SUBSTR in STR at or after +POSITION. If POSITION is omitted, starts searching from the beginning of +the string. The return value is based at 0 (or whatever you've set the $[ +variable to--but don't do that). If the substring is not found, returns one less than the base, ordinarily -1. =item int EXPR @@ -1127,28 +1179,30 @@ Returns the integer portion of EXPR. If EXPR is omitted, uses $_. Implements the ioctl(2) function. You'll probably have to say - require "ioctl.ph"; # probably /usr/local/lib/perl/ioctl.ph + require "ioctl.ph"; # probably in /usr/local/lib/perl/ioctl.ph -first to get the correct function definitions. If ioctl.ph doesn't +first to get the correct function definitions. If F doesn't exist or doesn't have the correct definitions you'll have to roll your -own, based on your C header files such as . (There is a -Perl script called B that comes with the Perl kit which may help you -in this.) SCALAR will be read and/or written depending on the -FUNCTION--a pointer to the string value of SCALAR will be passed as the -third argument of the actual ioctl call. (If SCALAR has no string -value but does have a numeric value, that value will be passed rather -than a pointer to the string value. To guarantee this to be TRUE, add -a 0 to the scalar before using it.) The pack() and unpack() functions -are useful for manipulating the values of structures used by ioctl(). -The following example sets the erase character to DEL. +own, based on your C header files such as Fsys/ioctl.hE>. +(There is a Perl script called B that comes with the Perl kit which +may help you in this, but it's non-trivial.) SCALAR will be read and/or +written depending on the FUNCTION--a pointer to the string value of SCALAR +will be passed as the third argument of the actual ioctl call. (If SCALAR +has no string value but does have a numeric value, that value will be +passed rather than a pointer to the string value. To guarantee this to be +TRUE, add a 0 to the scalar before using it.) The pack() and unpack() +functions are useful for manipulating the values of structures used by +ioctl(). The following example sets the erase character to DEL. require 'ioctl.ph'; + $getp = &TIOCGETP; + die "NO TIOCGETP" if $@ || !$getp; $sgttyb_t = "ccccs"; # 4 chars and a short - if (ioctl(STDIN,$TIOCGETP,$sgttyb)) { + if (ioctl(STDIN,$getp,$sgttyb)) { @ary = unpack($sgttyb_t,$sgttyb); $ary[2] = 127; $sgttyb = pack($sgttyb_t,@ary); - ioctl(STDIN,$TIOCSETP,$sgttyb) + ioctl(STDIN,&TIOCSETP,$sgttyb) || die "Can't ioctl: $!"; } @@ -1197,20 +1251,27 @@ or how about sorted by key: print $key, '=', $ENV{$key}, "\n"; } +To sort an array by value, you'll need to use a C +function. Here's a descending numeric sort by value: + + foreach $key (sort { $hash{$b} <=> $hash{$a} } keys %hash)) { + printf "%4d %s\n", $hash{$key}, $key; + } + =item kill LIST -Sends a signal to a list of processes. The first element of the list -must be the signal to send. Returns the number of processes -successfully signaled. +Sends a signal to a list of processes. The first element of +the list must be the signal to send. Returns the number of +processes successfully signaled. $cnt = kill 1, $child1, $child2; kill 9, @goners; -Unlike in the shell, in Perl -if the I is negative, it kills process groups instead of processes. -(On System V, a negative I number will also kill process -groups, but that's not portable.) That means you usually want to use -positive not negative signals. You may also use a signal name in quotes. +Unlike in the shell, in Perl if the I is negative, it kills +process groups instead of processes. (On System V, a negative I +number will also kill process groups, but that's not portable.) That +means you usually want to use positive not negative signals. You may also +use a signal name in quotes. See the L man page for details. =item last LABEL @@ -1221,20 +1282,22 @@ loops); it immediately exits the loop in question. If the LABEL is omitted, the command refers to the innermost enclosing loop. The C block, if any, is not executed: - line: while () { - last line if /^$/; # exit when done with header + LINE: while () { + last LINE if /^$/; # exit when done with header ... } =item lc EXPR Returns an lowercased version of EXPR. This is the internal function -implementing the \L escape in double-quoted strings. +implementing the \L escape in double-quoted strings. +Should respect any POSIX setlocale() settings. =item lcfirst EXPR Returns the value of EXPR with the first character lowercased. This is the internal function implementing the \l escape in double-quoted strings. +Should respect any POSIX setlocale() settings. =item length EXPR @@ -1249,7 +1312,7 @@ success, 0 otherwise. =item listen SOCKET,QUEUESIZE Does the same thing that the listen system call does. Returns TRUE if -it succeeded, FALSE otherwise. See example in L. +it succeeded, FALSE otherwise. See example in L. =item local EXPR @@ -1371,13 +1434,13 @@ may produce zero, one, or more elements in the returned value. translates a list of numbers to the corresponding characters. And - %hash = map {&key($_), $_} @array; + %hash = map { getkey($_) => $_ } @array; is just a funny way to write %hash = (); foreach $_ (@array) { - $hash{&key($_)} = $_; + $hash{getkey($_)} = $_; } =item mkdir FILENAME,MODE @@ -1388,14 +1451,14 @@ it returns 0 and sets $! (errno). =item msgctl ID,CMD,ARG -Calls the System V IPC function msgctl. If CMD is &IPC_STAT, then ARG +Calls the System V IPC function msgctl(2). If CMD is &IPC_STAT, then ARG must be a variable which will hold the returned msqid_ds structure. Returns like ioctl: the undefined value for error, "0 but true" for zero, or the actual return value otherwise. =item msgget KEY,FLAGS -Calls the System V IPC function msgget. Returns the message queue id, +Calls the System V IPC function msgget(2). Returns the message queue id, or the undefined value if there is an error. =item msgsnd ID,MSG,FLAGS @@ -1417,18 +1480,20 @@ an error. =item my EXPR A "my" declares the listed variables to be local (lexically) to the -enclosing block, subroutine, eval or "do". If more than one value is +enclosing block, subroutine, C, or C'd file. If more than one value is listed, the list must be placed in parens. All the listed elements must be legal lvalues. Only alphanumeric identifiers may be lexically scoped--magical builtins like $/ must be localized with "local" -instead. In particular, you're not allowed to say +instead. You also cannot use my() on a package variable. +In particular, you're not allowed to say - my $_; # Illegal. + my $_; # Illegal! + my $pack::$var; # Illegal! Unlike the "local" declaration, variables declared with "my" are totally hidden from the outside world, including any called subroutines (even if it's the same subroutine--every call gets its own -copy). +copy). (An eval(), however, can see the lexical variables of the scope it is being evaluated in so long as the names aren't hidden by declarations within @@ -1505,6 +1570,40 @@ block must either refer to a lexical variable, or must be fully qualified with the package name. A compilation error results otherwise. An inner block may countermand this with S<"no strict 'vars'">. +Variables declared with "my" are not part of any package and +are therefore never fully qualified with the package name. +However, you may declare a "my" variable at the outer most +scope of a file to totally hide any such identifiers from the +outside world. This is similar to a C's static variables +at the file level. To do this with a subroutine requires the +use of a closure (anonymous function): + + my $secret_version = '1.001-beta'; + my $secret_sub = { print $secret_version }; + &$secret_sub(); + +This does not work with object methods, however; +all object methods have to be in the symbol table of some +package to be found. + +Just because the "my" variable is lexically scoped doesn't mean that +within a function it works like a C static. Here's a mechanism for giving +a function private variables with both lexical scoping and a static +lifetime. + + #!/usr/bin/perl -l + $var = "global"; + { my $count = 0; + my $var = "static"; + sub foo { + $count++; + print "$var (call # $count)"; + } + } + print $var; foo(); + print $var; foo(); + print $var; foo(); + =item next LABEL =item next @@ -1512,8 +1611,8 @@ otherwise. An inner block may countermand this with S<"no strict 'vars'">. The C command is like the C statement in C; it starts the next iteration of the loop: - line: while () { - next line if /^#/; # discard comments + LINE: while () { + next LINE if /^#/; # discard comments ... } @@ -1527,10 +1626,10 @@ See the "use" function, which "no" is the opposite of. =item oct EXPR -Returns the decimal value of EXPR interpreted as an octal string. (If -EXPR happens to start off with 0x, interprets it as a hex string -instead.) The following will handle decimal, octal, and hex in the -standard Perl or C notation: +Interprets EXPR as an octal string and returns the corresponding +decimal value. (If EXPR happens to start off with 0x, interprets it as +a hex string instead.) The following will handle decimal, octal, and +hex in the standard Perl or C notation: $val = oct($val) if $val =~ /^0/; @@ -1541,21 +1640,23 @@ If EXPR is omitted, uses $_. =item open FILEHANDLE Opens the file whose filename is given by EXPR, and associates it with -FILEHANDLE. If FILEHANDLE is an expression, its value is used as the -name of the real filehandle wanted. If EXPR is omitted, the scalar -variable of the same name as the FILEHANDLE contains the filename. If -the filename begins with "<" or nothing, the file is opened for input. -If the filename begins with ">", the file is opened for output. If the -filename begins with ">>", the file is opened for appending. (You can -put a '+' in front of the '>' or '<' to indicate that you want both -read and write access to the file.) If the filename begins with "|", -the filename is interpreted as a command to which output is to be -piped, and if the filename ends with a "|", the filename is interpreted -as command which pipes input to us. (You may not have a command that -pipes both in and out.) Opening '-' opens STDIN and opening '>-' -opens STDOUT. Open returns non-zero upon success, the undefined -value otherwise. If the open involved a pipe, the return value happens -to be the pid of the subprocess. Examples: +FILEHANDLE. If FILEHANDLE is an expression, its value is used as the name +of the real filehandle wanted. If EXPR is omitted, the scalar variable of +the same name as the FILEHANDLE contains the filename. If the filename +begins with "<" or nothing, the file is opened for input. If the filename +begins with ">", the file is opened for output. If the filename begins +with ">>", the file is opened for appending. (You can put a '+' in front +of the '>' or '<' to indicate that you want both read and write access to +the file.) If the filename begins with "|", the filename is interpreted +as a command to which output is to be piped, and if the filename ends with +a "|", the filename is interpreted See L +for more examples of this. as command which pipes input to us. (You may +not have a command that pipes both in and out, but see See L, +L, and L for alternatives.) +Opening '-' opens STDIN and opening '>-' opens STDOUT. Open returns +non-zero upon success, the undefined value otherwise. If the open +involved a pipe, the return value happens to be the pid of the +subprocess. Examples: $ARTICLE = 100; open ARTICLE or die "Can't find article $ARTICLE: $!\n"; @@ -1563,9 +1664,9 @@ to be the pid of the subprocess. Examples: open(LOG, '>>/usr/spool/news/twitlog'); # (log is reserved) - open(article, "caesar <$article |"); # decrypt article + open(ARTICLE, "caesar <$article |"); # decrypt article - open(extract, "|sort >/tmp/Tmp$$"); # $$ is our process id + open(EXTRACT, "|sort >/tmp/Tmp$$"); # $$ is our process id # process argument list of files along with any includes @@ -1622,7 +1723,8 @@ STDERR: If you specify "<&=N", where N is a number, then Perl will do an -equivalent of C's fdopen() of that file descriptor. For example: +equivalent of C's fdopen() of that file descriptor; this is more +parsimonious of file descriptors. For example: open(FILEHANDLE, "<&=$fd") @@ -1636,8 +1738,8 @@ In the child process the filehandle isn't opened--i/o happens from/to the new STDOUT or STDIN. Typically this is used like the normal piped open when you want to exercise more control over just how the pipe command gets executed, such as when you are running setuid, and -don't want to have to scan shell commands for metacharacters. The -following pairs are more or less equivalent: +don't want to have to scan shell commands for metacharacters. +The following pairs are more or less equivalent: open(FOO, "|tr '[a-z]' '[A-Z]'"); open(FOO, "|-") || exec 'tr', '[a-z]', '[A-Z]'; @@ -1645,6 +1747,8 @@ following pairs are more or less equivalent: open(FOO, "cat -n '$file'|"); open(FOO, "-|") || exec 'cat', '-n', $file; +See L for more examples of this. + Explicitly closing any piped filehandle causes the parent process to wait for the child to finish, and returns the status value in $?. Note: on any operation which may do a fork, unflushed buffers remain @@ -1770,6 +1874,9 @@ unless you are very careful. In addition, note that Perl's pipes use stdio buffering, so you may need to set $| to flush your WRITEHANDLE after each command, depending on the application. +See L, L, and L +for examples of such things. + =item pop ARRAY Pops and returns the last value of the array, shortening the array by @@ -1781,7 +1888,7 @@ If there are no elements in the array, returns the undefined value. =item pos SCALAR -Returns the offset of where the last m//g search left off for the variable +Returns the offset of where the last C search left off for the variable in question. May be modified to change that offset. =item print FILEHANDLE LIST @@ -1807,6 +1914,12 @@ keyword with a left parenthesis unless you want the corresponding right parenthesis to terminate the arguments to the print--interpose a + or put parens around all the arguments. +Note that if you're storing FILEHANDLES in an array or other expression, +you will have to use a block returning its value instead + + print { $files[$i] } "stuff\n"; + print { $OK ? STDOUT : STDERR } "stuff\n"; + =item printf FILEHANDLE LIST =item printf LIST @@ -1891,7 +2004,8 @@ data into variable SCALAR from the specified SOCKET filehandle. Actually does a C recvfrom(), so that it can returns the address of the sender. Returns the undefined value if there's an error. SCALAR will be grown or shrunk to the length actually read. Takes the same flags -as the system call of the same name. +as the system call of the same name. +See L for examples. =item redo LABEL @@ -1905,7 +2019,7 @@ themselves about what was just input: # a simpleminded Pascal comment stripper # (warning: assumes no { or } in strings) - line: while () { + LINE: while () { while (s|({.*}.*){.*}|$1 |) {} s|{.*}| |; if (s|{.*| |) { @@ -1913,7 +2027,7 @@ themselves about what was just input: while () { if (/}/) { # end of comment? s|^|$front{|; - redo line; + redo LINE; } } } @@ -2022,7 +2136,7 @@ so anymore you probably want to use them instead. See L. =item return LIST Returns from a subroutine or eval with the value specified. (Note that -in the absence of a return a subroutine or eval will automatically +in the absence of a return a subroutine or eval() will automatically return the value of the last expression evaluated.) =item reverse LIST @@ -2030,7 +2144,12 @@ return the value of the last expression evaluated.) In a list context, returns a list value consisting of the elements of LIST in the opposite order. In a scalar context, returns a string value consisting of the bytes of the first element of LIST in the -opposite order. +opposite order. + + print reverse <>; # line tac + + undef $/; + print scalar reverse scalar <>; # byte tac =item rewinddir DIRHANDLE @@ -2067,7 +2186,7 @@ call of stdio. FILEHANDLE may be an expression whose value gives the name of the filehandle. The values for WHENCE are 0 to set the file pointer to POSITION, 1 to set the it to current plus POSITION, and 2 to set it to EOF plus offset. You may use the values SEEK_SET, SEEK_CUR, and SEEK_END for -this is using the POSIX module. Returns 1 upon success, 0 otherwise. +this from POSIX module. Returns 1 upon success, 0 otherwise. =item seekdir DIRHANDLE,POS @@ -2098,15 +2217,15 @@ actual filehandle. Thus: $oldfh = select(STDERR); $| = 1; select($oldfh); -With Perl 5, filehandles are objects with methods, and the last example -is preferably written +Some programmers may prefer to think of filehandles as objects with +methods, preferring to write the last example as: use FileHandle; STDERR->autoflush(1); =item select RBITS,WBITS,EBITS,TIMEOUT -This calls the select system(2) call with the bitmasks specified, which +This calls the select(2) system call with the bitmasks specified, which can be constructed using fileno() and vec(), along these lines: $rin = $win = $ein = ''; @@ -2125,7 +2244,7 @@ subroutine: } $bits; } - $rin = &fhbits('STDIN TTY SOCK'); + $rin = fhbits('STDIN TTY SOCK'); The usual idiom is: @@ -2141,7 +2260,7 @@ in seconds, which may be fractional. Note: not all implementations are capable of returning the $timeleft. If not, they always return $timeleft equal to the supplied $timeout. -You can effect a 250 microsecond sleep this way: +You can effect a 250-microsecond sleep this way: select(undef, undef, undef, 0.25); @@ -2183,6 +2302,7 @@ of the same name. On unconnected sockets you must specify a destination to send TO, in which case it does a C sendto(). Returns the number of characters sent, or the undefined value if there is an error. +See L for examples. =item setpgrp PID,PGRP @@ -2265,7 +2385,7 @@ always sleep the full amount. Opens a socket of the specified kind and attaches it to filehandle SOCKET. DOMAIN, TYPE and PROTOCOL are specified the same as for the system call of the same name. You should "use Socket;" first to get -the proper definitions imported. See the example in L. +the proper definitions imported. See the example in L. =item socketpair SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL @@ -2377,15 +2497,14 @@ using C as the pattern delimiters, but it still returns the array value.) The use of implicit split to @_ is deprecated, however. If EXPR is omitted, splits the $_ string. If PATTERN is also omitted, -splits on whitespace (after skipping any leading whitespace). -Anything matching PATTERN is taken -to be a delimiter separating the fields. (Note that the delimiter may -be longer than one character.) If LIMIT is specified and is not -negative, splits into no more than that many fields (though it may -split into fewer). If LIMIT is unspecified, trailing null fields are -stripped (which potential users of pop() would do well to remember). -If LIMIT is negative, it is treated as if an arbitrarily large LIMIT -had been specified. +splits on whitespace (after skipping any leading whitespace). Anything +matching PATTERN is taken to be a delimiter separating the fields. (Note +that the delimiter may be longer than one character.) If LIMIT is +specified and is not negative, splits into no more than that many fields +(though it may split into fewer). If LIMIT is unspecified, trailing null +fields are stripped (which potential users of pop() would do well to +remember). If LIMIT is negative, it is treated as if an arbitrarily large +LIMIT had been specified. A pattern matching the null string (not to be confused with a null pattern C, which is just one member of the set of patterns @@ -2415,6 +2534,12 @@ produces the list value (1, '-', 10, ',', 20) +If you had the entire header of a normal Unix email message in $header, +you could split it up into fields and their values this way: + + $header =~ s/\n\s+/ /g; # fix continuation lines + %hdrs = (UNIX_FROM => split /^(.*?):\s*/m, $header); + The pattern C may be replaced with an expression to specify patterns that vary at runtime. (To do runtime compilation only once, use C.) @@ -2444,7 +2569,8 @@ L, and L.) Returns a string formatted by the usual printf conventions of the C language. (The * character for an indirectly specified length is not supported, but you can get the same effect by interpolating a variable -into the pattern.) +into the pattern.) Some C libraries' implementations of sprintf() can dump core +when fed ludiocrous arguments. =item sqrt EXPR @@ -2633,30 +2759,34 @@ Value may be given to seekdir() to access a particular location in a directory. Has the same caveats about possible directory compaction as the corresponding system library routine. -=item tie VARIABLE,PACKAGENAME,LIST +=item tie VARIABLE,CLASSNAME,LIST -This function binds a variable to a package that will provide the -implementation for the variable. VARIABLE is the name of the variable to -be enchanted. PACKAGENAME is the name of a package implementing objects -of correct type. Any additional arguments are passed to the "new" method -of the package (meaning TIESCALAR, TIEARRAY, or TIEHASH). Typically these -are arguments such as might be passed to the dbm_open() function of C. +This function binds a variable to a package class that will provide the +implementation for the variable. VARIABLE is the name of the variable +to be enchanted. CLASSNAME is the name of a class implementing objects +of correct type. Any additional arguments are passed to the "new" +method of the class (meaning TIESCALAR, TIEARRAY, or TIEHASH). +Typically these are arguments such as might be passed to the dbm_open() +function of C. The object returned by the "new" method +is also +returned by the tie() function, which would be useful if you +want to +access other methods in CLASSNAME. Note that functions such as keys() and values() may return huge array values when used on large objects, like DBM files. You may prefer to use the each() function to iterate over such. Example: # print out history file offsets + use NDBM_File; tie(%HIST, NDBM_File, '/usr/lib/news/history', 1, 0); while (($key,$val) = each %HIST) { print $key, ' = ', unpack('L',$val), "\n"; } untie(%HIST); -A package implementing an associative array should have the following +A class implementing an associative array should have the following methods: - TIEHASH objectname, LIST + TIEHASH classname, LIST DESTROY this FETCH this, key STORE this, key, value @@ -2665,21 +2795,25 @@ methods: FIRSTKEY this NEXTKEY this, lastkey -A package implementing an ordinary array should have the following methods: +A class implementing an ordinary array should have the following methods: - TIEARRAY objectname, LIST + TIEARRAY classname, LIST DESTROY this FETCH this, key STORE this, key, value [others TBD] -A package implementing a scalar should have the following methods: +A class implementing a scalar should have the following methods: - TIESCALAR objectname, LIST + TIESCALAR classname, LIST DESTROY this FETCH this, STORE this, value +Unlike dbmopen(), the tie() function will not use or require a module +for you--you need to do that explicitly yourself. See L +or the F module for interesting tie() implementations. + =item time Returns the number of non-leap seconds since 00:00:00 UTC, January 1, @@ -2708,11 +2842,13 @@ on your system. Returns an uppercased version of EXPR. This is the internal function implementing the \U escape in double-quoted strings. +Should respect any POSIX setlocale() settings. =item ucfirst EXPR Returns the value of EXPR with the first character uppercased. This is the internal function implementing the \u escape in double-quoted strings. +Should respect any POSIX setlocale() settings. =item umask EXPR @@ -2826,6 +2962,7 @@ Because this is a wide-open interface, pragmas (compiler directives) are also implemented this way. Currently implemented pragmas are: use integer; + use diagnostics; use sigtrap qw(SEGV BUS); use strict qw(subs vars refs); use subs qw(afunc blurfl); @@ -2913,7 +3050,7 @@ for a scalar. =item warn LIST Produces a message on STDERR just like die(), but doesn't exit or -throw an exception. +on an exception. =item write FILEHANDLE diff --git a/pod/perlipc.pod b/pod/perlipc.pod index 5a43660fb2..3166f1a75e 100644 --- a/pod/perlipc.pod +++ b/pod/perlipc.pod @@ -1,108 +1,751 @@ =head1 NAME -perlipc - Perl interprocess communication +perlipc - Perl interprocess communication (signals, fifos, pipes, safe +subprocceses, sockets, and semaphores) =head1 DESCRIPTION -The IPC facilities of Perl are built on the Berkeley socket mechanism. -If you don't have sockets, you can ignore this section. The calls have -the same names as the corresponding system calls, but the arguments -tend to differ, for two reasons. First, Perl file handles work -differently than C file descriptors. Second, Perl already knows the -length of its strings, so you don't need to pass that information. +The basic IPC facilities of Perl are built out of the good old Unix +signals, named pipes, pipe opens, the Berkeley socket routines, and SysV +IPC calls. Each is used in slightly different situations. + +=head1 Signals + +Perl uses a simple signal handling model: the %SIG hash contains names or +references of user-installed signal handlers. These handlers will be called +with an argument which is the name of the signal that triggered it. A +signal may be generated intentionally from a particular keyboard sequence like +control-C or control-Z, sent to you from an another process, or +triggered automatically by the kernel when special events transpire, like +a child process exiting, your process running out of stack space, or +hitting file size limit. + +For example, to trap an interrupt signal, set up a handler like this. +Notice how all we do is set with a global variable and then raise an +exception. That's because on most systems libraries are not +re-entrant, so calling any print() functions (or even anything that needs to +malloc(3) more memory) could in theory trigger a memory fault +and subsequent core dump. + + sub catch_zap { + my $signame = shift; + $shucks++; + die "Somebody sent me a SIG$signame"; + } + $SIG{INT} = 'catch_zap'; # could fail in modules + $SIG{INT} = \&catch_zap; # best strategy + +The names of the signals are the ones listed out by C on your +system, or you can retrieve them from the Config module. Set up an +@signame list indexed by number to get the name and a %signo table +indexed by name to get the number: + + use Config; + defined $Config{sig_name} || die "No sigs?"; + foreach $name (split(' ', $Config{sig_name})) { + $signo{$name} = $i; + $signame[$i] = $name; + $i++; + } + +So to check whether signal 17 and SIGALRM were the same, just do this: + + print "signal #17 = $signame[17]\n"; + if ($signo{ALRM}) { + print "SIGALRM is $signo{ALRM}\n"; + } + +You may also choose to assign the strings C<'IGNORE'> or C<'DEFAULT'> as +the handler, in which case Perl will try to discard the signal or do the +default thing. Some signals can be neither trapped nor ignored, such as +the KILL and STOP (but not the TSTP) signals. One strategy for +temporarily ignoring signals is to use a local() statement, which will be +automatically restored once your block is exited. (Remember that local() +values are "inherited" by functions called from within that block.) + + sub precious { + local $SIG{INT} = 'IGNORE'; + &more_functions; + } + sub more_functions { + # interrupts still ignored, for now... + } + +Sending a signal to a negative process ID means that you send the signal +to the entire Unix process-group. This code send a hang-up signal to all +processes in the current process group I the current process +itself: + + { + local $SIG{HUP} = 'IGNORE'; + kill HUP => -$$; + # snazzy writing of: kill('HUP', -$$) + } -=head2 Client/Server Communication +Another interesting signal to send is signal number zero. This doesn't +actually affect another process, but instead checks whether it's alive +or has changed its UID. -Here's a sample TCP client. + unless (kill 0 => $kid_pid) { + warn "something wicked happened to $kid_pid"; + } - ($them,$port) = @ARGV; - $port = 2345 unless $port; - $them = 'localhost' unless $them; +You might also want to employ anonymous functions for simple signal +handlers: - $SIG{'INT'} = 'dokill'; - sub dokill { kill 9,$child if $child; } + $SIG{INT} = sub { die "\nOutta here!\n" }; - use Socket; +But that will be problematic for the more complicated handlers that need +to re-install themselves. Because Perl's signal mechanism is currently +based on the signal(3) function from the C library, you may somtimes be so +misfortunate as to run on systems where that function is "broken", that +is, it behaves in the old unreliable SysV way rather than the newer, more +reasonable BSD and POSIX fashion. So you'll see defensive people writing +signal handlers like this: - $sockaddr = 'S n a4 x8'; - chop($hostname = `hostname`); + sub REAPER { + $SIG{CHLD} = \&REAPER; # loathe sysV + $waitedpid = wait; + } + $SIG{CHLD} = \&REAPER; + # now do something that forks... + +or even the more elaborate: + + use POSIX "wait_h"; + sub REAPER { + my $child; + $SIG{CHLD} = \&REAPER; # loathe sysV + while ($child = waitpid(-1,WNOHANG)) { + $Kid_Status{$child} = $?; + } + } + $SIG{CHLD} = \&REAPER; + # do something that forks... + +Signal handling is also used for timeouts in Unix, While safely +protected within an C block, you set a signal handler to trap +alarm signals and then schedule to have one delivered to you in some +number of seconds. Then try your blocking operation, clearing the alarm +when it's done but not before you've exited your C block. If it +goes off, you'll use die() to jump out of the block, much as you might +using longjmp() or throw() in other languages. + +Here's an example: + + eval { + local $SIG{ALRM} = sub { die "alarm clock restart" }; + alarm 10; + flock(FH, 2); # blocking write lock + alarm 0; + }; + if ($@ and $@ !~ /alarm clock restart/) { die } + +For more complex signal handling, you might see the standard POSIX +module. Lamentably, this is almost entirely undocumented, but +the F file from the Perl source distribution has some +examples in it. + +=head1 Named Pipes + +A named pipe (often referred to as a FIFO) is an old Unix IPC +mechanism for processes communicating on the same machine. It works +just like a regular, connected anonymous pipes, except that the +processes rendezvous using a filename and don't have to be related. + +To create a named pipe, use the Unix command mknod(1) or on some +systems, mkfifo(1). These may not be in your normal path. + + # system return val is backwards, so && not || + # + $ENV{PATH} .= ":/etc:/usr/etc"; + if ( system('mknod', $path, 'p') + && system('mkfifo', $path) ) + { + die "mk{nod,fifo} $path failed; + } + + +A fifo is convenient when you want to connect a process to an unrelated +one. When you open a fifo, the program will block until there's something +on the other end. + +For example, let's say you'd like to have your F<.signature> file be a +named pipe that has a Perl program on the other end. Now every time any +program (like a mailer, newsreader, finger program, etc.) tries to read +from that file, the reading program will block and your program will +supply the the new signature. We'll use the pipe-checking file test B<-p> +to find out whether anyone (or anything) has accidentally removed our fifo. + + chdir; # go home + $FIFO = '.signature'; + $ENV{PATH} .= ":/etc:/usr/games"; + + while (1) { + unless (-p $FIFO) { + unlink $FIFO; + system('mknod', $FIFO, 'p') + && die "can't mknod $FIFO: $!"; + } + + # next line blocks until there's a reader + open (FIFO, "> $FIFO") || die "can't write $FIFO: $!"; + print FIFO "John Smith (smith\@host.org)\n", `fortune -s`; + close FIFO; + sleep 2; # to avoid dup sigs + } - ($name, $aliases, $proto) = getprotobyname('tcp'); - ($name, $aliases, $port) = getservbyname($port, 'tcp') - unless $port =~ /^\d+$/; - ($name, $aliases, $type, $len, $thisaddr) = - gethostbyname($hostname); - ($name, $aliases, $type, $len, $thataddr) = gethostbyname($them); - $this = pack($sockaddr, AF_INET, 0, $thisaddr); - $that = pack($sockaddr, AF_INET, $port, $thataddr); +=head1 Using open() for IPC + +Perl's basic open() statement can also be used for unidirectional interprocess +communication by either appending or prepending a pipe symbol to the second +argument to open(). Here's how to start something up a child process you +intend to write to: + + open(SPOOLER, "| cat -v | lpr -h 2>/dev/null") + || die "can't fork: $!"; + local $SIG{PIPE} = sub { die "spooler pipe broke" }; + print SPOOLER "stuff\n"; + close SPOOLER || die "bad spool: $! $?"; + +And here's how to start up a child process you intend to read from: + + open(STATUS, "netstat -an 2>&1 |") + || die "can't fork: $!"; + while () { + next if /^(tcp|udp)/; + print; + } + close SPOOLER || die "bad netstat: $! $?"; + +If one can be sure that a particular program is a Perl script that is +expecting filenames in @ARGV, the clever programmer can write something +like this: + + $ program f1 "cmd1|" - f2 "cmd2|" f3 < tmpfile + +and irrespective of which shell it's called from, the Perl program will +read from the file F, the process F, standard input (F +in this case), the F file, the F command, and finally the F +file. Pretty nifty, eh? + +You might notice that you could use backticks for much the +same effect as opening a pipe for reading: + + print grep { !/^(tcp|udp)/ } `netstat -an 2>&1`; + die "bad netstat" if $?; + +While this is true on the surface, it's much more efficient to process the +file one line or record at a time because then you don't have to read the +whole thing into memory at once. It also gives you finer control of the +whole process, letting you to kill off the child process early if you'd +like. + +Be careful to check both the open() and the close() return values. If +you're I to a pipe, you should also trap SIGPIPE. Otherwise, +think of what happens when you start up a pipe to a command that doesn't +exist: the open() will in all likelihood succeed (it only reflects the +fork()'s success), but then your output will fail--spectacularly. Perl +can't know whether the command worked because your command is actually +running in a separate process whose exec() might have failed. Therefore, +while readers of bogus commands just return a quick end of file, writers +to bogus command will trigger a signal they'd better be prepared to +handle. Consider: + + open(FH, "|bogus"); + print FH "bang\n"; + close FH; + +=head2 Safe Pipe Opens + +Another interesting approach to IPC is making your single program go +multiprocess and communicate between (or even amongst) yourselves. The +open() function will accept a file argument of either C<"-|"> or C<"|-"> +to do a very interesting thing: it forks a child connected to the +filehandle you've opened. The child is running the same program as the +parent. This is useful for safely opening a file when running under an +assumed UID or GID, for example. If you open a pipe I minus, you can +write to the filehandle you opened and your kid will find it in his +STDIN. If you open a pipe I minus, you can read from the filehandle +you opened whatever your kid writes to his STDOUT. + + use English; + my $sleep_count = 0; + + do { + $pid = open(KID, "-|"); + unless (defined $pid) { + warn "cannot fork: $!"; + die "bailing out" if $sleep_count++ > 6; + sleep 10; + } + } until defined $pid; + + if ($pid) { # parent + print KID @some_data; + close(KID) || warn "kid exited $?"; + } else { # child + ($EUID, $EGID) = ($UID, $GID); # suid progs only + open (FILE, "> /safe/file") + || die "can't open /safe/file: $!"; + while () { + print FILE; # child's STDIN is parent's KID + } + exit; # don't forget this + } + +Another common use for this construct is when you need to execute +something without the shell's interference. With system(), it's +straigh-forward, but you can't use a pipe open or backticks safely. +That's because there's no way to stop the shell from getting its hands on +your arguments. Instead, use lower-level control to call exec() directly. + +Here's a safe backtick or pipe open for read: + + # add error processing as above + $pid = open(KID, "-|"); + + if ($pid) { # parent + while () { + # do something interesting + } + close(KID) || warn "kid exited $?"; + + } else { # child + ($EUID, $EGID) = ($UID, $GID); # suid only + exec($program, @options, @args) + || die "can't exec program: $!"; + # NOTREACHED + } + + +And here's a safe pipe open for writing: + + # add error processing as above + $pid = open(KID, "|-"); + $SIG{ALRM} = sub { die "whoops, $program pipe broke" }; + + if ($pid) { # parent + for (@data) { + print KID; + } + close(KID) || warn "kid exited $?"; + + } else { # child + ($EUID, $EGID) = ($UID, $GID); + exec($program, @options, @args) + || die "can't exec program: $!"; + # NOTREACHED + } + +Note that these operations are full Unix forks, which means they may not be +correctly implemented on alien systems. Additionally, these are not true +multithreading. If you'd like to learn more about threading, see the +F file mentioned below in the L section. + +=head2 Bidirectional Communication + +While this works reasonably well for unidirectional communication, what +about bidirectional communication? The obvious thing you'd like to do +doesn't actually work: + + open(KID, "| some program |") + +and if you forgot to use the B<-w> flag, then you'll miss out +entirely on the diagnostic message: + + Can't do bidirectional pipe at -e line 1. + +If you really want to, you can use the standard open2() library function +to catch both ends. There's also an open3() for tridirectional I/O so you +can also catch your child's STDERR, but doing so would then require an +awkward select() loop and wouldn't allow you to use normal Perl input +operations. + +If you look at its source, you'll see that open2() uses low-level +primitives like Unix pipe() and exec() to create all the connections. +While it might have been slightly more efficient by using socketpair(), it +would have then been even less portable than it already is. The open2() +and open3() functions are unlikely to work anywhere except on a Unix +system or some other one purporting to be POSIX compliant. + +Here's an example of using open2(): + + use FileHandle; + use IPC::Open2; + $pid = open2( \*Reader, \*Writer, "cat -u -n" ); + Writer->autoflush(); # default here, actually + print Writer "stuff\n"; + $got = ; + +The problem with this is that Unix buffering is going to really +ruin your day. Even though your C filehandle is autoflushed, +and the process on the other end will get your data in a timely manner, +you can't usually do anything to force it to actually give it back to you +in a similarly quick fashion. In this case, we could, because we +gave I a B<-u> flag to make it unbuffered. But very few Unix +commands are designed to operate over pipes, so this seldom works +unless you yourself wrote the program on the other end of the +double-ended pipe. + +A solution to this is the non-standard F library. It uses +pseudo-ttys to make your program behave more reasonably: + + require 'Comm.pl'; + $ph = open_proc('cat -n'); + for (1..10) { + print $ph "a line\n"; + print "got back ", scalar <$ph>; + } - socket(S, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; - bind(S, $this) || die "bind: $!"; - connect(S, $that) || die "connect: $!"; +This way you don't have to have control over the source code of the +program you're using. The F library also has expect() +and interact() functions. Find the library (and hopefully its +successor F) at your nearest CPAN archive as detailed +in the L section below. - select(S); $| = 1; select(stdout); +=head1 Sockets: Client/Server Communication - if ($child = fork) { - while (<>) { - print S; - } - sleep 3; - do dokill(); - } - else { - while () { - print; - } - } +While not limited to Unix-derived operating systems (e.g. WinSock on PCs +provides socket support, as do some VMS libraries), you may not have +sockets on your system, in which this section probably isn't going to do +you much good. With sockets, you can do both virtual circuits (i.e. TCP +streams) and datagrams (i.e. UDP packets). You may be able to do even more +depending on your system. + +The Perl function calls for dealing with sockets have the same names as +the corresponding system calls in C, but their arguments tend to differ +for two reasons: first, Perl filehandles work differently than C file +descriptors. Second, Perl already knows the length of its strings, so you +don't need to pass that information. -And here's a server: +One of the major problems with old socket code in Perl was that it used +hard-coded values for some of the constants, which severely hurt +portability. If you ever see code that does anything like explicitly +setting C<$AF_INET = 2>, you know you're in for big trouble: An +immeasurably superior approach is to use the C module, which more +reliably grants access to various constants and functions you'll need. - ($port) = @ARGV; - $port = 2345 unless $port; +=head2 Internet TCP Clients and Servers +Use Internet-domain sockets when you want to do client-server +communication that might extend to machines outside of your own system. + +Here's a sample TCP client using Internet-domain sockets: + + #!/usr/bin/perl -w + require 5.002; + use strict; + use Socket; + my ($remote,$port, $iaddr, $paddr, $proto, $line); + + $remote = shift || 'localhost'; + $port = shift || 2345; # random port + if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') } + die "No port" unless $port; + $iaddr = inet_aton($remote) || die "no host: $remote"; + $paddr = sockaddr_in($port, $iaddr); + + $proto = getprotobyname('tcp'); + socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; + connect(SOCK, $paddr) || die "connect: $!"; + while ($line = ) { + print $line; + } + + close (SOCK) || die "close: $!"; + exit; + +And here's a corresponding server to go along with it. We'll +leave the address as INADDR_ANY so that the kernel can choose +the appropriate interface on multihomed hosts: + + #!/usr/bin/perl -Tw + require 5.002; + use strict; + BEGIN { $ENV{PATH} = '/usr/ucb:/bin' } use Socket; + use Carp; - $sockaddr = 'S n a4 x8'; + sub spawn; # forward declaration + sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" } - ($name, $aliases, $proto) = getprotobyname('tcp'); - ($name, $aliases, $port) = getservbyname($port, 'tcp') - unless $port =~ /^\d+$/; + my $port = shift || 2345; + my $proto = getprotobyname('tcp'); + socket(SERVER, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; + setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR, 1) || die "setsockopt: $!"; + bind(SERVER, sockaddr_in($port, INADDR_ANY)) || die "bind: $!"; + listen(SERVER,5) || die "listen: $!"; - $this = pack($sockaddr, AF_INET, $port, "\0\0\0\0"); + logmsg "server started on port $port"; - select(NS); $| = 1; select(stdout); + my $waitedpid = 0; + my $paddr; - socket(S, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; - bind(S, $this) || die "bind: $!"; - listen(S, 5) || die "connect: $!"; + sub REAPER { + $SIG{CHLD} = \&REAPER; # loathe sysV + $waitedpid = wait; + logmsg "reaped $waitedpid" . ($? ? " with exit $?" : ''); + } + + $SIG{CHLD} = \&REAPER; + + for ( $waitedpid = 0; + ($paddr = accept(CLIENT,SERVER)) || $waitedpid; + $waitedpid = 0, close CLIENT) + { + next if $waitedpid; + my($port,$iaddr) = sockaddr_in($paddr); + my $name = gethostbyaddr($iaddr,AF_INET); + + logmsg "connection from $name [", + inet_ntoa($iaddr), "] + at port $port"; - select(S); $| = 1; select(stdout); + spawn sub { + print "Hello there, $name, it's now ", scalar localtime, "\n"; + exec '/usr/games/fortune' + or confess "can't exec fortune: $!"; + }; - for (;;) { - print "Listening again\n"; - ($addr = accept(NS,S)) || die $!; - print "accept ok\n"; + } - ($af,$port,$inetaddr) = unpack($sockaddr,$addr); - @inetaddr = unpack('C4',$inetaddr); - print "$af $port @inetaddr\n"; + sub spawn { + my $coderef = shift; - while () { - print; - print NS; + unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') { + confess "usage: spawn CODEREF"; } + + my $pid; + if (!defined($pid = fork)) { + logmsg "cannot fork: $!"; + return; + } elsif ($pid) { + logmsg "begat $pid"; + return; # i'm the parent + } + # else i'm the child -- go spawn + + open(STDIN, "<&CLIENT") || die "can't dup client to stdin"; + open(STDOUT, ">&CLIENT") || die "can't dup client to stdout"; + ## open(STDERR, ">&STDOUT") || die "can't dup stdout to stderr"; + exit &$coderef(); + } + +This server takes the trouble to clone off a child version via fork() for +each incoming request. That way it can handle many requests at once, +which you might not always want. Even if you don't fork(), the listen() +will allow that many pending connections. Forking servers have to be +particularly careful about cleaning up their dead children (called +"zombies" in Unix parlance), because otherwise you'll quickly fill up your +process table. + +We suggest that you use the B<-T> flag to use taint checking (see L) +even if we aren't running setuid or setgid. This is always a good idea +for servers and other programs run on behalf of someone else (like CGI +scripts), because it lessens the chances that people from the outside will +be able to compromise your system. + +Let's look at another TCP client. This one connects to the TCP "time" +service on a number of different machines and shows how far their clocks +differ from the system on which it's being run: + + #!/usr/bin/perl -w + require 5.002; + use strict; + use Socket; + + my $SECS_of_70_YEARS = 2208988800; + sub ctime { scalar localtime(shift) } + + my $iaddr = gethostbyname('localhost'); + my $proto = getprotobyname('tcp'); + my $port = getservbyname('time', 'tcp'); + my $paddr = sockaddr_in(0, $iaddr); + my($host); + + $| = 1; + printf "%-24s %8s %s\n", "localhost", 0, ctime(time()); + + foreach $host (@ARGV) { + printf "%-24s ", $host; + my $hisiaddr = inet_aton($host) || die "unknown host"; + my $hispaddr = sockaddr_in($port, $hisiaddr); + socket(SOCKET, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; + connect(SOCKET, $hispaddr) || die "bind: $!"; + my $rtime = ' '; + read(SOCKET, $rtime, 4); + close(SOCKET); + my $histime = unpack("N", $rtime) - $SECS_of_70_YEARS ; + printf "%8d %s\n", $histime - time, ctime($histime); } -=head2 SysV IPC +=head2 Unix-Domain TCP Clients and Servers + +That's fine for Internet-domain clients and servers, but what local +communications? While you can use the same setup, sometimes you don't +want to. Unix-domain sockets are local to the current host, and are often +used internally to implement pipes. Unlike Internet domain sockets, UNIX +domain sockets can show up in the file system with an ls(1) listing. + + $ ls -l /dev/log + srw-rw-rw- 1 root 0 Oct 31 07:23 /dev/log -Here's a small example showing shared memory usage: +You can test for these with Perl's B<-S> file test: + + unless ( -S '/dev/log' ) { + die "something's wicked with the print system"; + } + +Here's a sample Unix-domain client: + + #!/usr/bin/perl -w + require 5.002; + use Socket; + use strict; + my ($rendezvous, $line); + + $rendezvous = shift || '/tmp/catsock'; + socket(SOCK, PF_UNIX, SOCK_STREAM, 0) || die "socket: $!"; + connect(SOCK, sockaddr_un($remote)) || die "connect: $!"; + while ($line = ) { + print $line; + } + exit; + +And here's a corresponding server. + + #!/usr/bin/perl -Tw + require 5.002; + use strict; + use Socket; + use Carp; + + BEGIN { $ENV{PATH} = '/usr/ucb:/bin' } + + my $NAME = '/tmp/catsock'; + my $uaddr = sockaddr_un($NAME); + my $proto = getprotobyname('tcp'); + + socket(SERVER,PF_UNIX,SOCK_STREAM,0) || die "socket: $!"; + unlink($NAME); + bind (SERVER, $uaddr) || die "bind: $!"; + listen(SERVER,5) || die "listen: $!"; + + logmsg "server started on $NAME"; + + $SIG{CHLD} = \&REAPER; + + for ( $waitedpid = 0; + accept(CLIENT,SERVER) || $waitedpid; + $waitedpid = 0, close CLIENT) + { + next if $waitedpid; + logmsg "connection on $NAME"; + spawn sub { + print "Hello there, it's now ", scalar localtime, "\n"; + exec '/usr/games/fortune' or die "can't exec fortune: $!"; + }; + } + +As you see, it's remarkably similar to the Internet domain TCP server, so +much so, in fact, that we've omitted several duplicate functions--spawn(), +logmsg(), ctime(), and REAPER()--which are exactly the same as in the +other server. + +So why would you ever want to use a Unix domain socket instead of a +simpler named pipe? Because a named pipe doesn't give you sessions. You +can't tell one process's data from another's. With socket programming, +you get a separate session for each client: that's why accept() takes two +arguments. + +For example, let's say that you have a long running database server daemon +that you want folks from the World Wide Web to be able to access, but only +if they go through a CGI interface. You'd have a small, simple CGI +program that does whatever checks and logging you feel like, and then acts +as a Unix-domain client and connects to your private server. + +=head2 UDP: Message Passing + +Another kind of client-server setup is one that uses not connections, but +messages. UDP communications involve much lower overhead but also provide +less reliability, as there are no promises that messages will arrive at +all, let alone in order and unmangled. Still, UDP offers some advantages +over TCP, including being able to "broadcast" or "multicast" to a whole +bunch of destination hosts at once (usually on your local subnet). If you +find yourself overly concerned about reliability and start building checks +into your message system, then you probably should just use TCP to start +with. + +Here's a UDP program similar to the sample Internet TCP client given +above. However, instead of checking one host at a time, the UDP version +will check many of them asynchronously by simulating a multicast and then +using select() to do a timed-out wait for I/O. To do something similar +with TCP, you'd have to use a different socket handle for each host. + + #!/usr/bin/perl -w + use strict; + require 5.002; + use Socket; + use Sys::Hostname; + + my ( $count, $hisiaddr, $hispaddr, $histime, + $host, $iaddr, $paddr, $port, $proto, + $rin, $rout, $rtime, $SECS_of_70_YEARS); + + $SECS_of_70_YEARS = 2208988800; + + $iaddr = gethostbyname(hostname()); + $proto = getprotobyname('udp'); + $port = getservbyname('time', 'udp'); + $paddr = sockaddr_in(0, $iaddr); # 0 means let kernel pick + + socket(SOCKET, PF_INET, SOCK_DGRAM, $proto) || die "socket: $!"; + bind(SOCKET, $paddr) || die "bind: $!"; + + $| = 1; + printf "%-12s %8s %s\n", "localhost", 0, scalar localtime time; + $count = 0; + for $host (@ARGV) { + $count++; + $hisiaddr = inet_aton($host) || die "unknown host"; + $hispaddr = sockaddr_in($port, $hisiaddr); + defined(send(SOCKET, 0, 0, $hispaddr)) || die "send $host: $!"; + } + + $rin = ''; + vec($rin, fileno(SOCKET), 1) = 1; + + # timeout after 10.0 seconds + while ($count && select($rout = $rin, undef, undef, 10.0)) { + $rtime = ''; + ($hispaddr = recv(SOCKET, $rtime, 4, 0)) || die "recv: $!"; + ($port, $hisiaddr) = sockaddr_in($hispaddr); + $host = gethostbyaddr($hisiaddr, AF_INET); + $histime = unpack("N", $rtime) - $SECS_of_70_YEARS ; + printf "%-12s ", $host; + printf "%8d %s\n", $histime - time, scalar localtime($histime); + $count--; + } + +=head1 SysV IPC + +While System V IPC isn't so widely used as sockets, it still has some +interesting uses. You can't, however, effectively use SysV IPC or +Berkeley mmap() to have shared memory so as to share a variable amongst +several processes. That's because Perl would reallocate your string when +you weren't wanting it to. + + +Here's a small example showing shared memory usage. $IPC_PRIVATE = 0; $IPC_RMID = 0; $size = 2000; $key = shmget($IPC_PRIVATE, $size , 0777 ); - die if !defined($key); + die unless defined $key; $message = "Message #1"; shmwrite($key, $message, 0, 60 ) || die "$!"; @@ -149,7 +792,7 @@ Call the file F: Put this code in a separate file to be run in more that one process Call this file F: - #'give' the semaphore + # 'give' the semaphore # run this in the original process and you will see # that the second process continues @@ -166,3 +809,66 @@ Call this file F: semop($key,$opstring) || die "$!"; +=head1 WARNING + +The SysV IPC code above was written long ago, and it's definitely clunky +looking. It should at the very least be made to C and +C. Better yet, perhaps someone should create an +C module the way we have the C module for normal +client-server communications. + +(... time passes) + +Voila! Check out the IPC::SysV modules written by Jack Shirazi. You can +find them at a CPAN store near you. + +=head1 NOTES + +If you are running under version 5.000 (dubious) or 5.001, you can still +use most of the examples in this document. You may have to remove the +C and some of the my() statements for 5.000, and for both +you'll have to load in version 1.2 of the F module, which +was/is/shall-be included in I. + +Most of these routines quietly but politely return C when they fail +instead of causing your program to die right then and there due to an +uncaught exception. (Actually, some of the new I conversion +functions croak() on bad arguments.) It is therefore essential +that you should check the return values fo these functions. Always begin +your socket programs this way for optimal success, and don't forget to add +B<-T> taint checking flag to the pound-bang line for servers: + + #!/usr/bin/perl -w + require 5.002; + use strict; + use sigtrap; + use Socket; + +=head1 BUGS + +All these routines create system-specific portability problems. As noted +elsewhere, Perl is at the mercy of your C libraries for much of its system +behaviour. It's probably safest to assume broken SysV semantics for +signals and to stick with simple TCP and UDP socket operations; e.g. don't +try to pass open filedescriptors over a local UDP datagram socket if you +want your code to stand a chance of being portable. + +Because few vendors provide C libraries that are safely +re-entrant, the prudent programmer will do little else within +a handler beyond die() to raise an exception and longjmp(3) out. + +=head1 AUTHOR + +Tom Christiansen, with occasional vestiges of Larry Wall's original +version. + +=head1 SEE ALSO + +Besides the obvious functions in L, you should also check out +the F file at your nearest CPAN site. (See L or best +yet, the F for a description of what CPAN is and where to get it.) +Section 5 of the F file is devoted to "Networking, Device Control +(modems) and Interprocess Communication", and contains numerous unbundled +modules numerous networking modules, Chat and Expect operations, CGI +programming, DCE, FTP, IPC, NNTP, Proxy, Ptty, RPC, SNMP, SMTP, Telnet, +Threads, and ToolTalk--just to name a few. diff --git a/pod/perllol.pod b/pod/perllol.pod new file mode 100644 index 0000000000..4b58bee0b2 --- /dev/null +++ b/pod/perllol.pod @@ -0,0 +1,353 @@ +=head1 TITLE + +perlLoL - Manipulating Lists of Lists in Perl + +=head1 Declaration and Access + +The simplest thing to build is a list of lists (sometimes called an array +of arrays). It's reasonably easy to understand, and almost everything +that applies here will also be applicable later on with the fancier data +structures. + +A list of lists, or an array of an array if you would, is just a regular +old array @LoL that you can get at with two subscripts, like $LoL[3][2]. Here's +a declaration of the array: + + # assign to our array a list of list references + @LoL = ( + [ "fred", "barney" ], + [ "george", "jane", "elroy" ], + [ "homer", "marge", "bart" ], + ); + + print $LoL[2][2]; + bart + +Now you should be very careful that the outer bracket type +is a round one, that is, parentheses. That's because you're assigning to +an @list, so you need parens. If you wanted there I to be an @LoL, +but rather just a reference to it, you could do something more like this: + + # assign a reference to list of list references + $ref_to_LoL = [ + [ "fred", "barney", "pebbles", "bambam", "dino", ], + [ "homer", "bart", "marge", "maggie", ], + [ "george", "jane", "alroy", "judy", ], + ]; + + print $ref_to_LoL->[2][2]; + +Notice that the outer bracket type has changed, and so our access syntax +has also changed. That's because unlike C, in perl you can't freely +interchange arrays and references thereto. $ref_to_LoL is a reference to an +array, whereas @LoL is an array proper. Likewise, $LoL[2] is not an +array, but an array ref. So how come you can write these: + + $LoL[2][2] + $ref_to_LoL->[2][2] + +instead of having to write these: + + $LoL[2]->[2] + $ref_to_LoL->[2]->[2] + +Well, that's because the rule is that on adjacent brackets only (whether +square or curly), you are free to omit the pointer dereferencing array. +But you need not do so for the very first one if it's a scalar containing +a reference, which means that $ref_to_LoL always needs it. + +=head1 Growing Your Own + +That's all well and good for declaration of a fixed data structure, +but what if you wanted to add new elements on the fly, or build +it up entirely from scratch? + +First, let's look at reading it in from a file. This is something like +adding a row at a time. We'll assume that there's a flat file in which +each line is a row and each word an element. If you're trying to develop an +@LoL list containing all these, here's the right way to do that: + + while (<>) { + @tmp = split; + push @LoL, [ @tmp ]; + } + +You might also have loaded that from a function: + + for $i ( 1 .. 10 ) { + $LoL[$i] = [ somefunc($i) ]; + } + +Or you might have had a temporary variable sitting around with the +list in it. + + for $i ( 1 .. 10 ) { + @tmp = somefunc($i); + $LoL[$i] = [ @tmp ]; + } + +It's very important that you make sure to use the C<[]> list reference +constructor. That's because this will be very wrong: + + $LoL[$i] = @tmp; + +You see, assigning a named list like that to a scalar just counts the +number of elements in @tmp, which probably isn't what you want. + +If you are running under C, you'll have to add some +declarations to make it happy: + + use strict; + my(@LoL, @tmp); + while (<>) { + @tmp = split; + push @LoL, [ @tmp ]; + } + +Of course, you don't need the temporary array to have a name at all: + + while (<>) { + push @LoL, [ split ]; + } + +You also don't have to use push(). You could just make a direct assignment +if you knew where you wanted to put it: + + my (@LoL, $i, $line); + for $i ( 0 .. 10 ) + $line = <>; + $LoL[$i] = [ split ' ', $line ]; + } + +or even just + + my (@LoL, $i); + for $i ( 0 .. 10 ) + $LoL[$i] = [ split ' ', <> ]; + } + +You should in general be leary of using potential list functions +in a scalar context without explicitly stating such. +This would be clearer to the casual reader: + + my (@LoL, $i); + for $i ( 0 .. 10 ) + $LoL[$i] = [ split ' ', scalar(<>) ]; + } + +If you wanted to have a $ref_to_LoL variable as a reference to an array, +you'd have to do something like this: + + while (<>) { + push @$ref_to_LoL, [ split ]; + } + +Actually, if you were using strict, you'd not only have to declare $ref_to_LoL as +you had to declare @LoL, but you'd I having to initialize it to a +reference to an empty list. (This was a bug in 5.001m that's been fixed +for the 5.002 release.) + + my $ref_to_LoL = []; + while (<>) { + push @$ref_to_LoL, [ split ]; + } + +Ok, now you can add new rows. What about adding new columns? If you're +just dealing with matrices, it's often easiest to use simple assignment: + + for $x (1 .. 10) { + for $y (1 .. 10) { + $LoL[$x][$y] = func($x, $y); + } + } + + for $x ( 3, 7, 9 ) { + $LoL[$x][20] += func2($x); + } + +It doesn't matter whether those elements are already +there or not: it'll gladly create them for you, setting +intervening elements to C as need be. + +If you just wanted to append to a row, you'd have +to do something a bit funnier looking: + + # add new columns to an existing row + push @{ $LoL[0] }, "wilma", "betty"; + +Notice that I I just say: + + push $LoL[0], "wilma", "betty"; # WRONG! + +In fact, that wouldn't even compile. How come? Because the argument +to push() must be a real array, not just a reference to such. + +=head1 Access and Printing + +Now it's time to print your data structure out. How +are you going to do that? Well, if you only want one +of the elements, it's trivial: + + print $LoL[0][0]; + +If you want to print the whole thing, though, you can't +just say + + print @LoL; # WRONG + +because you'll just get references listed, and perl will never +automatically dereference things for you. Instead, you have to +roll yourself a loop or two. This prints the whole structure, +using the shell-style for() construct to loop across the outer +set of subscripts. + + for $aref ( @LoL ) { + print "\t [ @$aref ],\n"; + } + +If you wanted to keep track of subscripts, you might do this: + + for $i ( 0 .. $#LoL ) { + print "\t elt $i is [ @{$LoL[$i]} ],\n"; + } + +or maybe even this. Notice the inner loop. + + for $i ( 0 .. $#LoL ) { + for $j ( 0 .. $#{$LoL[$i]} ) { + print "elt $i $j is $LoL[$i][$j]\n"; + } + } + +As you can see, it's getting a bit complicated. That's why +sometimes is easier to take a temporary on your way through: + + for $i ( 0 .. $#LoL ) { + $aref = $LoL[$i]; + for $j ( 0 .. $#{$aref} ) { + print "elt $i $j is $LoL[$i][$j]\n"; + } + } + +Hm... that's still a bit ugly. How about this: + + for $i ( 0 .. $#LoL ) { + $aref = $LoL[$i]; + $n = @$aref - 1; + for $j ( 0 .. $n ) { + print "elt $i $j is $LoL[$i][$j]\n"; + } + } + +=head1 Slices + +If you want to get at a slide (part of a row) in a multidimensional +array, you're going to have to do some fancy subscripting. That's +because while we have a nice synonym for single elements via the +pointer arrow for dereferencing, no such convenience exists for slices. +(Remember, of course, that you can always write a loop to do a slice +operation.) + +Here's how to do one operation using a loop. We'll assume an @LoL +variable as before. + + @part = (); + $x = 4; + for ($y = 7; $y < 13; $y++) { + push @part, $LoL[$x][$y]; + } + +That same loop could be replaced with a slice operation: + + @part = @{ $LoL[4] } [ 7..12 ]; + +but as you might well imagine, this is pretty rough on the reader. + +Ah, but what if you wanted a I, such as having +$x run from 4..8 and $y run from 7 to 12? Hm... here's the simple way: + + @newLoL = (); + for ($startx = $x = 4; $x <= 8; $x++) { + for ($starty = $y = 7; $x <= 12; $y++) { + $newLoL[$x - $startx][$y - $starty] = $LoL[$x][$y]; + } + } + +We can reduce some of the looping through slices + + for ($x = 4; $x <= 8; $x++) { + push @newLoL, [ @{ $LoL[$x] } [ 7..12 ] ]; + } + +If you were into Schwartzian Transforms, you would probably +have selected map for that + + @newLoL = map { [ @{ $LoL[$_] } [ 7..12 ] ] } 4 .. 8; + +Although if your manager accused of seeking job security (or rapid +insecurity) through inscrutable code, it would be hard to argue. :-) +If I were you, I'd put that in a function: + + @newLoL = splice_2D( \@LoL, 4 => 8, 7 => 12 ); + sub splice_2D { + my $lrr = shift; # ref to list of list refs! + my ($x_lo, $x_hi, + $y_lo, $y_hi) = @_; + + return map { + [ @{ $lrr->[$_] } [ $y_lo .. $y_hi ] ] + } $x_lo .. $x_hi; + } + + +=head1 Passing Arguments + +One place where a list of lists crops up is when you pass +in several list references to a function. Consider: + + @tailings = popmany ( \@a, \@b, \@c, \@d ); + + sub popmany { + my $aref; + my @retlist = (); + foreach $aref ( @_ ) { + push @retlist, pop @$aref; + } + return @retlist; + } + +This function was designed to pop off the last element from each of +its arguments and return those in a list. In this function, +you can think of @_ as a list of lists. + +Just as a side note, what happens if the function is called with the +"wrong" types of arguments? Normally nothing, but in the case of +references, we can be a bit pickier. This isn't detectable at +compile-time (yet--Larry does have a prototype prototype in the works for +5.002), but you could check it at run time using the ref() function. + + use Carp; + for $i ( 0 .. $#_) { + if (ref($_[$i]) ne 'ARRAY') { + confess "popmany: arg $i not an array reference\n"; + } + } + +However, that's not usually necessary unless you want to trap it. It's +also dubious in that it would fail on a real array references blessed into +its own class (an object). But since you're all going to be using +C, it would raise an exception anyway even without the die. + +This will matter more to you later on when you start building up +more complex data structures that all aren't woven of the same +cloth, so to speak. + +=head1 SEE ALSO + +perldata(1), perlref(1), perldsc(1) + +=head1 AUTHOR + +Tom Christiansen + +Last udpate: Sat Oct 7 19:35:26 MDT 1995 diff --git a/pod/perlmod.pod b/pod/perlmod.pod index d557e68ff7..c5ab08a07c 100644 --- a/pod/perlmod.pod +++ b/pod/perlmod.pod @@ -66,7 +66,7 @@ name is thus C<%main::>, or C<%::> for short. Likewise the nested package mentioned earlier is named C<%OUTER::INNER::>. The value in each entry of the associative array is what you are -referring to when you use the C<*name> notation. In fact, the following +referring to when you use the C<*name> typeglob notation. In fact, the following have the same effect, though the first is more efficient because it does the symbol table lookups at compile time: @@ -108,7 +108,7 @@ Note that even though the subroutine is compiled in package C, the name of the subroutine is qualified so that its name is inserted into package C
. -Assignment to a symbol table entry performs an aliasing operation, +Assignment to a typeglob performs an aliasing operation, i.e., *dick = *richard; @@ -149,16 +149,16 @@ and C work just as they do in B, as a degenerate case. =head2 Perl Classes -There is no special class syntax in Perl 5, but a package may function +There is no special class syntax in Perl, but a package may function as a class if it provides subroutines that function as methods. Such a package may also derive some of its methods from another class package -by listing the other package name in its @ISA array. For more on -this, see L. +by listing the other package name in its @ISA array. + +For more on this, see L. =head2 Perl Modules -In Perl 5, the notion of packages has been extended into the notion of -modules. A module is a package that is defined in a library file of +A module is a just package that is defined in a library file of the same name, and is designed to be reusable. It may do this by providing a mechanism for exporting some of its symbols into the symbol table of any package using it. Or it may function as a class @@ -166,7 +166,21 @@ definition and make its semantics available implicitly through method calls on the class and its objects, without explicit exportation of any symbols. Or it can do a little of both. -Perl modules are included by saying +For example, to start a normal module called Fred, create +a file called Fred.pm and put this at the start of it: + + package Fred; + require Exporter; + @ISA = qw(Exporter); + @EXPORT = qw(func1 func2); + @EXPORT_OK = qw($sally @listabob %harry func3); + +Then go on to declare and use your variables in functions +without any qualifications. +See L and the I for details on +mechanics and style issues in module creation. + +Perl modules are included into your program by saying use Module; @@ -269,206 +283,204 @@ The following programs are defined (and have their own documentation). =over 12 +=item C + +Pragma to produce enhanced diagnostics + =item C -Perl pragma to compute arithmetic in integer instead of double +Pragma to compute arithmetic in integer instead of double =item C -Perl pragma to request less of something from the compiler +Pragma to request less of something from the compiler =item C -Perl pragma to enable stack backtrace on unexpected signals +Pragma to enable stack backtrace on unexpected signals =item C -Perl pragma to restrict unsafe constructs +Pragma to restrict unsafe constructs =item C -Perl pragma to predeclare sub names +Pragma to predeclare sub names =back =head2 Standard Modules -The following modules are all expected to behave in a well-defined +Standard, bundled modules are all expected to behave in a well-defined manner with respect to namespace pollution because they use the -Exporter module. -See their own documentation for details. - -=over 12 - -=item C - -create an abbreviation table from a list - -=item C - -provide framework for multiple DBMs - -=item C - -load functions only on demand - -=item C - -split a package for autoloading - -=item C - -parse file name and path from a specification - -=item C - -benchmark running times of code - -=item C - -warn or die of errors (from perspective of caller) +Exporter module. See their own documentation for details. -=item C +To find out all the modules installed on your system, do this: -run many filetest checks on a tree + find `perl -e 'print "@INC"'` -name '*.pm' -print -=item C +They should all have their own documentation installed and accessible via +your system man(1) command. If that fails, try the I program. -compare 8-bit scalar data according to the current locale - -=item C - -access Perl configuration option +=head2 Extension Modules -=item C +Extension modules are written in C (or a mix of Perl and C) and get +dynamically loaded into Perl if and when you need them. Supported +extension modules include the Socket, Fcntl, and POSIX modules. -get pathname of current working directory +Many popular C extension modules +do not come bundled (at least, not completely) +due to their size, volatility, or simply lack of time for adequate testing +and configuration across the multitude of platforms on which Perl was +beta-tested. You are encouraged to look for them in archie(1L), the Perl +FAQ or Meta-FAQ, the WWW page, and even with their authors before randomly +posting asking for their present condition and disposition. -=item C +=head2 CPAN -Dynamically load C libraries into Perl code +CPAN stands for the Comprehensive Perl Archive Network. This is a globally +replicated collection of all known Perl materials, including hundreds +of unbunded modules. Here are the major categories of modules: -=item C +=over -use nice English (or B) names for ugly punctuation variables +=item * +Language Extensions and Documentation Tools -=item C +=item * +Development Support -Perl module that imports environment variables +=item * +Operating System Interfaces -=item C +=item * +Networking, Device Control (modems) and InterProcess Communication -module to control namespace manipulations +=item * +Data Types and Data Type Utilities -=item C +=item * +Database Interfaces -load the C Fcntl.h defines +=item * +User Interfaces -=item C +=item * +Interfaces to / Emulations of Other Programming Languages -supply object methods for filehandles +=item * +File Names, File Systems and File Locking (see also File Handles) -=item C +=item * +String Processing, Language Text Processing, Parsing and Searching -traverse a file tree +=item * +Option, Argument, Parameter and Configuration File Processing -=item C +=item * +Internationalization and Locale -traverse a directory structure depth-first +=item * +Authentication, Security and Encryption -=item C +=item * +World Wide Web, HTML, HTTP, CGI, MIME -basic and extended getopt(3) processing +=item * +Server and Daemon Utilities -=item C +=item * +Archiving and Compression -generate a Makefile for Perl extension +=item * +Images, Pixmap and Bitmap Manipulation, Drawing and Graphing -=item C +=item * +Mail and Usenet News -open a process for both reading and writing +=item * +Control Flow Utilities (callbacks and exceptions etc) -=item C +=item * +File Handle and Input/Output Stream Utilities -open a process for reading, writing, and error handling +=item * +Miscellaneous Modules -=item C +=back -Perl interface to IEEE 1003.1 namespace +Some of the reguster CPAN sites as of this writing include the following. +You should try to choose one close to you: -=item C +=over -check a host for upness +=item * +ftp://ftp.sterling.com/programming/languages/perl/ -=item C +=item * +ftp://ftp.sedl.org/pub/mirrors/CPAN/ -load the C socket.h defines +=item * +ftp://ftp.uoknor.edu/mirrors/CPAN/ -=back +=item * +ftp://ftp.delphi.com/pub/mirrors/packages/perl/CPAN/ -=head2 Extension Modules +=item * +ftp://uiarchive.cso.uiuc.edu/pub/lang/perl/CPAN/ -Extension modules are written in C (or a mix of Perl and C) and get -dynamically loaded into Perl if and when you need them. Supported -extension modules include the Socket, Fcntl, and POSIX modules. +=item * +ftp://ftp.cis.ufl.edu/pub/perl/CPAN/ -The following are popular C extension modules, which while available at -Perl 5.0 release time, do not come bundled (at least, not completely) -due to their size, volatility, or simply lack of time for adequate testing -and configuration across the multitude of platforms on which Perl was -beta-tested. You are encouraged to look for them in archie(1L), the Perl -FAQ or Meta-FAQ, the WWW page, and even with their authors before randomly -posting asking for their present condition and disposition. There's no -guarantee that the names or addresses below have not changed since printing, -and in fact, they probably have! +=item * +ftp://ftp.switch.ch/mirror/CPAN/ -=over 12 +=item * +ftp://ftp.sunet.se/pub/lang/perl/CPAN/ -=item C +=item * +ftp://ftp.ci.uminho.pt/pub/lang/perl/ -Written by William Setzer >, while not -included with the standard distribution, this extension module ports to -most systems. FTP from your nearest Perl archive site, or try +=item * +ftp://ftp.cs.ruu.nl/pub/PERL/CPAN/ - ftp://ftp.ncsu.edu/pub/math/wsetzer/cursperl5??.tar.gz +=item * +ftp://ftp.demon.co.uk/pub/mirrors/perl/CPAN/ -It is currently in alpha test, so the name and ftp location may -change. +=item * +ftp://ftp.rz.ruhr-uni-bochum.de/pub/programming/languages/perl/CPAN/ +=item * +ftp://ftp.leo.org/pub/comp/programming/languages/perl/CPAN/ -=item C +=item * +ftp://ftp.pasteur.fr/pub/computing/unix/perl/CPAN/ -This is the portable database interface written by ->. This supersedes the many perl4 ports for -database extensions. The official archive for DBperl extensions is -F. This archive contains copies of perl4 -ports for Ingres, Oracle, Sybase, Informix, Unify, Postgres, and -Interbase, as well as rdb and shql and other non-SQL systems. +=item * +ftp://ftp.ibp.fr/pub/perl/CPAN/ -=item C +=item * +ftp://ftp.funet.fi/pub/languages/perl/CPAN/ -Fastest and most restriction-free of the DBM bindings, this extension module -uses the popular Berkeley DB to tie() into your hashes. This has a -standardly-distributed man page and dynamic loading extension module, but -you'll have to fetch the Berkeley code yourself. See L for -where. +=item * +ftp://ftp.tekotago.ac.nz/pub/perl/CPAN/ -=item C +=item * +ftp://ftp.mame.mu.oz.au/pub/perl/CPAN/ -This extension module is a front to the Athena and Xlib libraries for Perl -GUI programming, originally written by by Dominic Giampaolo ->, then and rewritten for Sx by FrEdEric -Chauveau >. It's available for FTP from +=item * +ftp://coombs.anu.edu.au/pub/perl/ - ftp.pasteur.fr:/pub/Perl/Sx.tar.gz +=item * +ftp://dongpo.math.ncu.edu.tw/perl/CPAN/ -=item C +=item * +ftp://ftp.lab.kdd.co.jp/lang/perl/CPAN/ -This extension module is an object-oriented Perl5 binding to the popular -tcl/tk X11 package. However, you need know no TCL to use it! -It was written by Malcolm Beattie >. -If you are unable to locate it using archie(1L) or a similar -tool, you may try retrieving it from F -from Malcolm's machine listed above. +=item * +ftp://ftp.is.co.za/programming/perl/CPAN/ =back + +For an up-to-date listing of CPAN sites, +see http://www.perl.com/perl/ or ftp://ftp.perl.com/perl/. diff --git a/pod/perlop.pod b/pod/perlop.pod index 574e9238d8..9e1e3f14d0 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -414,7 +414,7 @@ can assign to them): Note that this is not guaranteed to contribute to the readability of your program. -=head2 Assigment Operators +=head2 Assignment Operators "=" is the ordinary assignment operator. @@ -463,8 +463,9 @@ argument and returns that value. This is just like C's comma operator. In a list context, it's just the list argument separator, and inserts both its arguments into the list. -The => digraph is simply a synonym for the comma operator. It's useful -for documenting arguments that come in pairs. +The => digraph is mostly just a synonym for the comma operator. It's useful for +documenting arguments that come in pairs. As of 5.001, it also forces +any word to the left of it to be interpreted as a string. =head2 List Operators (Rightward) @@ -622,8 +623,8 @@ interpolating won't change over the life of the script. However, mentioning C constitutes a promise that you won't change the variables in the pattern. If you change them, Perl won't even notice. -If the PATTERN evaluates to a null string, the most recently executed -(and successfully compiled) regular expression is used instead. +If the PATTERN evaluates to a null string, the last +successfully executed regular expression is used instead. If used in a context that requires a list value, a pattern match returns a list consisting of the subexpressions matched by the parentheses in the @@ -745,7 +746,7 @@ PATTERN contains a $ that looks like a variable rather than an end-of-string test, the variable will be interpolated into the pattern at run-time. If you only want the pattern compiled once the first time the variable is interpolated, use the C option. If the pattern -evaluates to a null string, the most recently executed (and successfully compiled) regular +evaluates to a null string, the last successfully executed regular expression is used instead. See L for further explanation on these. Options are: @@ -797,9 +798,9 @@ Examples: # Delete C comments. $program =~ s { - /\* (?# Match the opening delimiter.) - .*? (?# Match a minimal number of characters.) - \*/ (?# Match the closing delimiter.) + /\* # Match the opening delimiter. + .*? # Match a minimal number of characters. + \*/ # Match the closing delimiter. } []gsx; s/^\s*(.*?)\s*$/$1/; # trim white space @@ -997,15 +998,16 @@ If the string inside the angle brackets is a reference to a scalar variable (e.g. <$foo>), then that variable contains the name of the filehandle to input from. -If the string inside angle brackets is not a filehandle, it is -interpreted as a filename pattern to be globbed, and either a list of -filenames or the next filename in the list is returned, depending on -context. One level of $ interpretation is done first, but you can't -say C$fooE> because that's an indirect filehandle as explained in the -previous paragraph. You could insert curly brackets to force -interpretation as a filename glob: C${foo}E>. (Alternately, you can -call the internal function directly as C, which is probably -the right way to have done it in the first place.) Example: +If the string inside angle brackets is not a filehandle, it is interpreted +as a filename pattern to be globbed, and either a list of filenames or the +next filename in the list is returned, depending on context. One level of +$ interpretation is done first, but you can't say C$fooE> +because that's an indirect filehandle as explained in the previous +paragraph. In older version of Perl, programmers would insert curly +brackets to force interpretation as a filename glob: C${foo}E>. +These days, it's consdired cleaner to call the internal function directly +as C, which is probably the right way to have done it in the +first place.) Example: while (<*.c>) { chmod 0644, $_; @@ -1030,6 +1032,30 @@ and just do your own grep() on the filenames. Furthermore, due to its current implementation of using a shell, the glob() routine may get "Arg list too long" errors (unless you've installed tcsh(1L) as F). +A glob only evaluates its (embedded) argument when it is starting a new +list. All values must be read before it will start over. In a list +context this isn't important, because you automatically get them all +anyway. In a scalar context, however, the operator returns the next value +each time it is called, or a FALSE value if you've just run out. Again, +FALSE is returned only once. So if you're expecting a single value from +a glob, it is much better to say + + ($file) = ; + +than + + $file = ; + +because the latter will alternate between returning a filename and +returning FALSE. + +It you're trying to do variable interpolation, it's definitely better +to use the glob() function, because the older notation can cause people +to become confused with the indirect filehandle notatin. + + @files = glob("$dir/*.[ch]"); + @files = glob($files[$i]); + =head2 Constant Folding Like C, Perl does a certain amount of expression evaluation at diff --git a/pod/perlpod.pod b/pod/perlpod.pod index 46693f1793..b51c9f8fc5 100644 --- a/pod/perlpod.pod +++ b/pod/perlpod.pod @@ -29,6 +29,7 @@ use however it pleases. Currently recognized commands are =item text =over N =back + =cut =item * @@ -75,6 +76,13 @@ book. I'm just trying to make an idiot-proof common source for nroff, TeX, and other markup languages, as used for online documentation. Both B and B translators exist. +=head1 Embedding Pods in Perl Modules + +You can embed pod documentation in your Perl scripts. Start your +documentation with a =head1 command at the beg, and end it with +an =cut command. Perl will ignore the pod text. See any of the +supplied library modules for examples. + =head1 Author Larry Wall diff --git a/pod/perlre.pod b/pod/perlre.pod index 295b6bd518..2f2d79b492 100644 --- a/pod/perlre.pod +++ b/pod/perlre.pod @@ -19,12 +19,13 @@ in question might not actually be a slash. In fact, any of these modifiers may also be embedded within the regular expression itself using the new C<(?...)> construct. See below. -The C modifier itself needs a little more explanation. It tells the -regular expression parser to ignore whitespace that is not backslashed -or within a character class. You can use this to break up your regular -expression into (slightly) more readable parts. Together with the -capability of embedding comments described later, this goes a long -way towards making Perl 5 a readable language. See the C comment +The C modifier itself needs a little more explanation. It tells +the regular expression parser to ignore whitespace that is not +backslashed or within a character class. You can use this to break up +your regular expression into (slightly) more readable parts. The C<#> +character is also treated as a metacharacter introducing a comment, +just as in ordinary Perl code. Taken together, these features go a +long way towards making Perl 5 a readable language. See the C comment deletion code in L. =head2 Regular Expressions @@ -147,7 +148,7 @@ When the bracketing construct C<( ... )> is used, \ matches the digit'th substring. (Outside of the pattern, always use "$" instead of "\" in front of the digit. The scope of $ (and C<$`>, C<$&>, and C<$')> extends to the end of the enclosing BLOCK or eval string, or to the -next pattern match with subexpressions. +next successful pattern match, whichever comes first. If you want to use parentheses to delimit subpattern (e.g. a set of alternatives) without saving it as a subpattern, follow the ( with a ?. diff --git a/pod/perlref.pod b/pod/perlref.pod index f12cad4554..62d99a8a28 100644 --- a/pod/perlref.pod +++ b/pod/perlref.pod @@ -1,3 +1,6 @@ +(Don't +convert references into strings though, or you'll break their referenceness.) + =head1 NAME perlref - Perl references and nested data structures diff --git a/pod/perlsyn.pod b/pod/perlsyn.pod index 252e679b72..4b1d607e7e 100644 --- a/pod/perlsyn.pod +++ b/pod/perlsyn.pod @@ -19,35 +19,43 @@ which lines you look at. (Actually, I'm lying--it is possible to do an implicit loop with either the B<-n> or B<-p> switch. It's just not the mandatory default like it is in B and B.) +=head2 Declarations + Perl is, for the most part, a free-form language. (The only exception to this is format declarations, for obvious reasons.) Comments are indicated by the "#" character, and extend to the end of the line. If you attempt to use C C-style comments, it will be interpreted either as division or pattern matching, depending on the context, and C++ -C comments just look like a null regular expression, So don't do +C comments just look like a null regular expression, so don't do that. A declaration can be put anywhere a statement can, but has no effect on the execution of the primary sequence of statements--declarations all take effect at compile time. Typically all the declarations are put at -the beginning or the end of the script. +the beginning or the end of the script. However, if you're using +lexically-scoped private variables created with my(), you'll have to make sure +your format or subroutine definition is within the same block scope +as the my if you expect to to be able to access those private variables. -As of Perl 5, declaring a subroutine allows a subroutine name to be used -as if it were a list operator from that point forward in the program. You -can declare a subroutine without defining it by saying just +Declaring a subroutine allows a subroutine name to be used as if it were a +list operator from that point forward in the program. You can declare a +subroutine without defining it by saying just sub myname; $me = myname $0 or die "can't get myname"; -Note that it functions as a list operator though, not a unary +Note that it functions as a list operator though, not as a unary operator, so be careful to use C instead of C<||> there. -Subroutines declarations can also be imported by a C statement. +Subroutines declarations can also be loaded up with the C statement +or both loaded and imported into your namespace with a C statement. +See L for details on this. -Also as of Perl 5, a statement sequence may contain declarations of -lexically scoped variables, but apart from declaring a variable name, -the declaration acts like an ordinary statement, and is elaborated within -the sequence of statements as if it were an ordinary statement. +A statement sequence may contain declarations of lexically-scoped +variables, but apart from declaring a variable name, the declaration acts +like an ordinary statement, and is elaborated within the sequence of +statements as if it were an ordinary statement. That means it actually +has both compile-time and run-time effects. =head2 Simple statements @@ -58,8 +66,7 @@ the semicolon is optional. (A semicolon is still encouraged there if the block takes up more than one line, since you may eventually add another line.) Note that there are some operators like C and C that look like compound statements, but aren't (they're just TERMs in an expression), -and thus need an explicit termination -if used as the last item in a statement. +and thus need an explicit termination if used as the last item in a statement. Any simple statement may optionally be followed by a I modifier, just before the terminating semicolon (or block ending). The possible @@ -79,14 +86,14 @@ executes once before the conditional is evaluated. This is so that you can write loops like: do { - $_ = ; + $line = ; ... - } until $_ eq ".\n"; + } until $line eq ".\n"; See L. Note also that the loop control statements described later will I work in this construct, since modifiers don't take loop labels. Sorry. You can always wrap -another block around it to do that sort of thing.) +another block around it to do that sort of thing. =head2 Compound statements @@ -128,14 +135,86 @@ the sense of the test is reversed. The C statement executes the block as long as the expression is true (does not evaluate to the null string or 0 or "0"). The LABEL is -optional, and if present, consists of an identifier followed by a -colon. The LABEL identifies the loop for the loop control statements -C, C, and C (see below). If there is a C -BLOCK, it is always executed just before the conditional is about to be -evaluated again, just like the third part of a C loop in C. -Thus it can be used to increment a loop variable, even when the loop -has been continued via the C statement (which is similar to the C -C statement). +optional, and if present, consists of an identifier followed by a colon. +The LABEL identifies the loop for the loop control statements C, +C, and C. If the LABEL is omitted, the loop control statement +refers to the innermost enclosing loop. This may include dynamically +looking back your call-stack at run time to find the LABEL. Such +desperate behavior triggers a warning if you use the B<-w> flag. + +If there is a C BLOCK, it is always executed just before the +conditional is about to be evaluated again, just like the third part of a +C loop in C. Thus it can be used to increment a loop variable, even +when the loop has been continued via the C statement (which is +similar to the C C statement). + +=head2 Loop Control + +The C command is like the C statement in C; it starts +the next iteration of the loop: + + LINE: while () { + next LINE if /^#/; # discard comments + ... + } + +The C command is like the C statement in C (as used in +loops); it immediately exits the loop in question. The +C block, if any, is not executed: + + LINE: while () { + last LINE if /^$/; # exit when done with header + ... + } + +The C command restarts the loop block without evaluating the +conditional again. The C block, if any, is I executed. +This command is normally used by programs that want to lie to themselves +about what was just input. + +For example, when processing a file like F. +If your input lines might end in backslashes to indicate continuation, you +want to skip ahead and get the next record. + + while (<>) { + chomp; + if (s/\\$//) { + $_ .= <>; + redo unless eof(); + } + # now process $_ + } + +which is Perl short-hand for the more explicitly written version: + + LINE: while ($line = ) { + chomp($line); + if ($line =~ s/\\$//) { + $line .= ; + redo LINE unless eof(); # not eof(ARGV)! + } + # now process $line + } + +Or here's a a simpleminded Pascal comment stripper (warning: assumes no { or } in strings) + + LINE: while () { + while (s|({.*}.*){.*}|$1 |) {} + s|{.*}| |; + if (s|{.*| |) { + $front = $_; + while () { + if (/}/) { # end of comment? + s|^|$front{|; + redo LINE; + } + } + } + print; + } + +Note that if there were a C block on the above code, it would get +executed even on discarded lines. If the word C is replaced by the word C, the sense of the test is reversed, but the conditional is still tested before the first @@ -143,11 +222,13 @@ iteration. In either the C or the C statement, you may replace "(EXPR)" with a BLOCK, and the conditional is true if the value of the last -statement in that block is true. (This feature continues to work in Perl -5 but is deprecated. Please change any occurrences of "if BLOCK" to -"if (do BLOCK)".) +statement in that block is true. While this "feature" continues to work in +version 5, it has been deprecated, so please change any occurrences of "if BLOCK" to +"if (do BLOCK)". + +=head2 For and Foreach -The C-style C loop works exactly like the corresponding C loop: +Perl's C-style C loop works exactly like the corresponding C loop: for ($i = 1; $i < 10; $i++) { ... @@ -162,38 +243,78 @@ is the same as $i++; } -The foreach loop iterates over a normal list value and sets the +The C loop iterates over a normal list value and sets the variable VAR to be each element of the list in turn. The variable is -implicitly local to the loop and regains its former value upon exiting -the loop. (If the variable was previously declared with C, it uses -that variable instead of the global one, but it's still localized to -the loop.) The C keyword is actually a synonym for the C -keyword, so you can use C for readability or C for -brevity. If VAR is omitted, $_ is set to each value. If LIST is an -actual array (as opposed to an expression returning a list value), you -can modify each element of the array by modifying VAR inside the loop. +implicitly local to the loop and regains its former value upon exiting the +loop. If the variable was previously declared with C, it uses that +variable instead of the global one, but it's still localized to the loop. +This can cause problems if you have subroutine or format declarations +within that block's scope. + +The C keyword is actually a synonym for the C keyword, so +you can use C for readability or C for brevity. If VAR is +omitted, $_ is set to each value. If LIST is an actual array (as opposed +to an expression returning a list value), you can modify each element of +the array by modifying VAR inside the loop. That's because the C +loop index variable is an implicit alias for each item in the list that +you're looping over. + Examples: - for (@ary) { s/foo/bar/; } + for (@ary) { s/foo/bar/ } foreach $elem (@elements) { $elem *= 2; } - for ((10,9,8,7,6,5,4,3,2,1,'BOOM')) { - print $_, "\n"; sleep(1); + for $count (10,9,8,7,6,5,4,3,2,1,'BOOM') { + print $count, "\n"; sleep(1); } for (1..15) { print "Merry Christmas\n"; } - foreach $item (split(/:[\\\n:]*/, $ENV{'TERMCAP'})) { + foreach $item (split(/:[\\\n:]*/, $ENV{TERMCAP})) { print "Item: $item\n"; } +Here's how a C programmer might code up a particular algorithm in Perl: + + for ($i = 0; $i < @ary1; $i++) { + for ($j = 0; $j < @ary2; $j++) { + if ($ary1[$i] > $ary2[$j]) { + last; # can't go to outer :-( + } + $ary1[$i] += $ary2[$j]; + } + } + +Whereas here's how a Perl programmer more confortable with the idiom might +do it this way: + + OUTER: foreach $i (@ary1) { + INNER: foreach $j (@ary2) { + next OUTER if $i > $j; + $i += $j; + } + } + +See how much easier this is? It's cleaner, safer, and faster. +It's cleaner because it's less noisy. +It's safer because if code gets added +between the inner and outer loops later, you won't accidentally excecute +it because you've explicitly asked to iterate the other loop rather than +merely terminating the inner one. +And it's faster because Perl exececute C statement more +rapidly than it would the equivalent C loop. + +=head2 Basic BLOCKs and Switch Statements + A BLOCK by itself (labeled or not) is semantically equivalent to a loop that executes once. Thus you can use any of the loop control statements in it to leave or restart the block. The C block -is optional. This construct is particularly nice for doing case +is optional. + +The BLOCK construct is particularly nice for doing case structures. SWITCH: { @@ -267,3 +388,48 @@ or even, horrors, else { $nothing = 1 } + +A common idiom for a switch statement is to use C's aliasing to make +a temporary assignment to $_ for convenient matching: + + SWITCH: for ($where) { + /In Card Names/ && do { push @flags, '-e'; last; }; + /Anywhere/ && do { push @flags, '-h'; last; }; + /In Rulings/ && do { last; }; + die "unknown value for form variable where: `$where'"; + } + +=head2 Goto + +Although not for the faint of heart, Perl does support a C statement. +A loop's LABEL is not actually a valid target for a C; +it's just the name of the loop. There are three forms: goto-LABEL, +goto-EXPR, and goto-&NAME. + +The goto-LABEL form finds the statement labeled with LABEL and resumes +execution there. It may not be used to go into any construct that +requires initialization, such as a subroutine or a foreach loop. It +also can't be used to go into a construct that is optimized away. It +can be used to go almost anywhere else within the dynamic scope, +including out of subroutines, but it's usually better to use some other +construct such as last or die. The author of Perl has never felt the +need to use this form of goto (in Perl, that is--C is another matter). + +The goto-EXPR form expects a label name, whose scope will be resolved +dynamically. This allows for computed gotos per FORTRAN, but isn't +necessarily recommended if you're optimizing for maintainability: + + goto ("FOO", "BAR", "GLARCH")[$i]; + +The goto-&NAME form is highly magical, and substitutes a call to the +named subroutine for the currently running subroutine. This is used by +AUTOLOAD() subroutines that wish to load another subroutine and then +pretend that the other subroutine had been called in the first place +(except that any modifications to @_ in the current subroutine are +propagated to the other subroutine.) After the C, not even caller() +will be able to tell that this routine was called first. + +In almost cases like this, it's usually a far, far better idea to use the +structured control flow mechanisms of C, C, or C insetad +resorting to a C. For certain applications, the catch and throw pair of +C and die() for exception processing can also be a prudent approach. diff --git a/pod/perltrap.pod b/pod/perltrap.pod index fa68a753c2..cfe964270c 100644 --- a/pod/perltrap.pod +++ b/pod/perltrap.pod @@ -191,7 +191,8 @@ in Perl 5 is the backslash, which creates a reference. =item * -C must be capitalized. +C must be capitalized. C<$ARGV[0]> is C's C, and C +ends up in C<$0>. =item * @@ -381,6 +382,28 @@ Because if that were to work, then this couldn't: =item * +The precedence of assignment operators is now the same as the precedence +of assignment. Perl 4 mistakenly gave them the precedence of the associated +operator. So you now must parenthesize them in expressions like + + /foo/ ? ($a += 2) : ($a -= 2); + +Otherwise + + /foo/ ? $a += 2 : $a -= 2; + +would be erroneously parsed as + + (/foo/ ? $a += 2 : $a) -= 2; + +On the other hand, + + $a += /foo/ ? 1 : 2; + +now works as a C programmer would expect. + +=item * + C is now incorrect. You need parens around the filehandle. While temporarily supported, using such a construct will generate a non-fatal (but non-suppressible) warning. diff --git a/pod/perlvar.pod b/pod/perlvar.pod index bfd04f74d4..e5d0091c85 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -139,12 +139,13 @@ Use of "C<$*>" is deprecated in Perl 5. =item $. -The current input line number of the last filehandle that was read. -This variable should be considered read-only. -Remember that only an explicit close on the filehandle -resets the line number. Since "CE>" never does an explicit close, line -numbers increase across ARGV files (but see examples under eof()). -(Mnemonic: many programs use "." to mean the current line number.) +The current input line number of the last filehandle that was read. An +explicit close on the filehandle resets the line number. Since +"CE>" never does an explicit close, line numbers increase +across ARGV files (but see examples under eof()). Localizing C<$.> has +the effect of also localizing Perl's notion of "the last read +filehandle". (Mnemonic: many programs use "." to mean the current line +number.) =item input_record_separator HANDLE EXPR diff --git a/pod/perlxs.pod b/pod/perlxs.pod index ffbaa6b1c3..df2aefa0b6 100644 --- a/pod/perlxs.pod +++ b/pod/perlxs.pod @@ -151,16 +151,6 @@ the variable, as is demonstrated in the rpcb_gettime() function above. See the section on typemaps for more about handling qualifiers and unary operators in C types. -The parameter list of a function must not have whitespace after the -open-parenthesis or before the close-parenthesis. (This restriction will be -relaxed in later versions of B.) - - INCORRECT CORRECT - - double double - sin( x ) sin(x) - double x double x - The function name and the return type must be placed on separate lines. @@ -552,6 +542,15 @@ then not push return values on the stack. } } +=head2 The REQUIRE: Keyword + +The REQUIRE: keyword is used to indicate the minimum version of the +B compiler needed to compile the XS module. An XS module which +contains the following statement will only compile with B version +1.922 or greater: + + REQUIRE: 1.922 + =head2 The CLEANUP: Keyword This keyword can be used when an XSUB requires special cleanup procedures diff --git a/pod/perlxstut.pod b/pod/perlxstut.pod new file mode 100644 index 0000000000..484f49dfc3 --- /dev/null +++ b/pod/perlxstut.pod @@ -0,0 +1,529 @@ +=head1 NAME + +perlXStut - Tutorial for XSUB's + +=head1 DESCRIPTION + +This tutorial will educate the reader on the steps involved in creating +a Perl 5 extension. The reader is assumed to have access to L and +L. + +This tutorial starts with very simple examples and becomes more complex, +bringing in more features that are available. Thus, certain statements +towards the beginning may be incomplete. The reader is encouraged to +read the entire document before lambasting the author about apparent +mistakes. + +This tutorial is still under construction. Constructive comments +are welcome. + +=head1 EXAMPLE 1 + +Our first extension will be very simple. When we call the routine in the +extension, it will print out a well-known message and terminate. + +Run "h2xs -A -n Test1". This creates a directory named Test1, possibly under +ext/ if it exists in the current working directory. Four files will be +created in the Test1 dir: MANIFEST, Makefile.PL, Test1.pm, Test1.xs. + +The MANIFEST file should contain the names of the four files created. + +The file Makefile.PL should look something like this: + + use ExtUtils::MakeMaker; + # See lib/ExtUtils/MakeMaker.pm for details of how to influence + # the contents of the Makefile that is written. + WriteMakefile( + 'NAME' => 'Test1', + 'VERSION' => '0.1', + 'LIBS' => [''], # e.g., '-lm' + 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' + 'INC' => '', # e.g., '-I/usr/include/other' + ); + +The file Test1.pm should look something like this: + + package Test1; + + require Exporter; + require DynaLoader; + + @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( + + ); + bootstrap Test1; + + # Preloaded methods go here. + + # Autoload methods go after __END__, and are processed by the autosplit program. + + 1; + __END__ + +And the Test1.xs file should look something like this: + + #include "EXTERN.h" + #include "perl.h" + #include "XSUB.h" + + MODULE = Test1 PACKAGE = Test1 + +Let's edit the .xs file by adding this to the end of the file: + + void + hello() + + CODE: + printf("Hello, world!\n"); + +Now we'll run "perl Makefile.PL". This will create a real Makefile, +which make needs. It's output looks something like: + + % perl Makefile.PL + Checking if your kit is complete... + Looks good + Writing Makefile for Test1 + % + +Now, running make will produce output that looks something like this: + + % make + mkdir ./blib + mkdir ./blib/auto + mkdir ./blib/auto/Test1 + perl xsubpp -typemap typemap Test1.xs >Test1.tc && mv Test1.tc Test1.c + cc -c Test1.c + Running Mkbootstrap for Test1 () + chmod 644 Test1.bs + LD_RUN_PATH="" ld -o ./blib/auto/Test1/Test1.sl -b Test1.o + chmod 755 ./blib/auto/Test1/Test1.sl + cp Test1.bs ./blib/auto/Test1/Test1.bs + chmod 644 ./blib/auto/Test1/Test1.bs + cp Test1.pm ./blib/Test1.pm + chmod 644 ./blib/Test1.pm + +Now we'll create a test script, test1.pl in the Test1 directory. It should +look like this: + + #! /usr/local/bin/perl + + BEGIN { unshift(@INC, "./blib") } + + use Test1; + + Test1::hello(); + +Now we run the script and we should see the following output: + + % perl test1.pl + Hello, world! + % + +=head1 EXAMPLE 2 + +Now let's create a simple extension that will take a single argument and +return 0 if the argument is even, 1 if the argument is odd. + +Run "h2xs -A -n Test2". This will create a Test2 directory with a file +Test2.xs underneath it. Add the following to the end of the XS file: + + int + is_even(input) + int input + + CODE: + RETVAL = input % 2; + + OUTPUT: + RETVAL + +(Note that the line after the declaration of is_even is indented one tab +stop. Although there is a tab between "int" and "input", this can be any +amount of white space. Also notice that there is no semi-colon following +the "declaration" of the variable input) + +Now perform the same steps before, generating a Makefile from the +Makefile.PL file, and running make. + +Our test file test2.pl will now look like: + + BEGIN { unshift(@INC, "./blib"); } + + use Test2; + + $a = &Test2::is_even(2); + $b = &Test2::is_even(3); + + print "\$a is $a, \$b is $b\n"; + +The output should look like: + + % perl test2.pl + $a is 0, $b is 1 + % + +=head1 WHAT HAS GONE ON? + +The program h2xs is the starting point for creating extensions. In later +examples, we'll see how we can use h2xs to read header files and generate +templates to connect to C routines. + +h2xs creates a number of files in the extension directory. The file +Makefile.PL is a perl script which will generate a true Makefile to build +the extension. We'll take a closer look at it later. + +The files .pm and .xs contain the meat of the extension. +The .xs file holds the C routines that make up the extension. The .pm file +contains routines that tells Perl how to load your extension. + +Generating the invoking the Makefile created a directory blib in the current +working directory. This directory will contain the shared library that we +will build. Once we have tested it, we can install it into its final location. + +Finally, our test scripts do two important things. First of all, they place +the directory "blib" at the head of the @INC array. Placing this inside a +BEGIN block assures us that Perl will look in the blib directory hierarchy +before looking in the system directories. This could be important if you are +upgrading an already-existing extension and do not want to disturb the system +version until you are ready to install it. + +Second, the test scripts tell Perl to C. When Perl sees this, +it searches for a .pm file of the same name in the various directories kept +in the @INC array. If it cannot be found, perl will die with an error that +will look something like: + + Can't locate Test2.pm in @INC at ./test2.pl line 5. + BEGIN failed--compilation aborted at ./test2.pl line 5. + +The .pm file tells perl that it will need the Exporter and Dynamic Loader +extensions. It then sets the @ISA array, which is used for looking up +methods that might not exist in the current package, and finally tells perl +to bootstrap the module. Perl will call its dynamic loader routine and load +the shared library. + +The @EXPORT array in the .pm file tells Perl which of the extension's +routines should be placed into the calling package's namespace. In our two +examples so far, we have not modified the @EXPORT array, so our test +scripts must call the routines by their complete name (e.g., Test1::hello). +If we placed the name of the routine in the @EXPORT array, so that the +.pm file looked like: + + @EXPORT = qw( hello ); + +Then the hello routine would also be callable from the "main" package. +We could therefore change test1.pl to look like: + + #! /usr/local/bin/perl + + BEGIN { unshift(@INC, "./blib") } + + use Test1; + + hello(); + +And we would get the same output, "Hello, world!". + +Most of the time you do not want to export the names of your extension's +subroutines, because they might accidentally clash with other subroutines +from other extensions or from the calling program itself. + +=head1 EXAMPLE 3 + +Our third extension will take one argument as its input, round off that +value, and set the argument to the rounded value. + +Run "h2xs -A -n Test3". This will create a Test3 directory with a file +Test3.xs underneath it. Add the following to the end of the XS file: + + void + round(arg) + double arg + + CODE: + if (arg > 0.0) { + arg = floor(arg + 0.5); + } else if (arg < 0.0) { + arg = ceil(arg - 0.5); + } else { + arg = 0.0; + } + OUTPUT: + arg + +Edit the file Makefile.PL so that the corresponding line looks like this: + + 'LIBS' => ['-lm'], # e.g., '-lm' + +Generate the Makefile and run make. The test script test3.pl looks like: + + #! /usr/local/bin/perl + + BEGIN { unshift(@INC, "./blib"); } + + use Test3; + + foreach $i (-1.4, -0.5, 0.0, 0.4, 0.5) { + $j = $i; + &Test3::round($j); + print "Rounding $i results in $j\n"; + } + + print STDERR "Trying to round a constant -- "; + &Test3::round(2.0); + +Notice the output from trying to send a constant in to the routine. Perl +reports: + + Modification of a read-only value attempted at ./test3.pl line 15. + +Perl won't let you change the value of two to, say, three, unlike a FORTRAN +compiler from long, long ago! + +=head1 WHAT'S NEW HERE? + +Two things are new here. First, we've made some changes to Makefile.PL. +In this case, we've specified an extra library to link in, in this case the +math library, libm. We'll talk later about how to write XSUBs that can call +every routine in a library. + +Second, the value of the function is being passed back not as the function's +return value, but through the same variable that was passed into the function. + +=head1 INPUT AND OUTPUT PARAMETERS + +You specify the parameters that will be passed into the XSUB just after you +declare the function return value and name. The list of parameters looks +very C-like, but the lines must be indented by a tab stop, and each line +may not have an ending semi-colon. + +The list of output parameters occurs after the OUTPUT: directive. The use +of RETVAL tells Perl that you wish to send this value back as the return +value of the XSUB function. Otherwise, you specify which variables used +in the XSUB function should be placed into the respective Perl variables +passed in. + +=head1 THE XSUBPP COMPILER + +The compiler xsubpp takes the XS code in the .xs file and converts it into +C code, placing it in a file whose suffix is .c. The C code created makes +heavy use of the C functions within Perl. + +=head1 THE TYPEMAP FILE + +The xsubpp compiler uses rules to convert from Perl's data types (scalar, +array, etc.) to C's data types (int, char *, etc.). These rules are stored +in the typemap file ($PERLLIB/ExtUtils/typemap). This file is split into +three parts. + +The first part attempts to map various C data types to a coded flag, which +has some correspondence with the various Perl types. The second part contains +C code which xsubpp uses for input parameters. The third part contains C +code which xsubpp uses for output parameters. We'll talk more about the +C code later. + +Let's now take a look at the .c file created for the Test3 extension. + + /* + * This file was generated automatically by xsubpp version 1.9 from the + * contents of Test3.xs. Don't edit this file, edit Test3.xs instead. + * + * ANY CHANGES MADE HERE WILL BE LOST! + * + */ + + #include "EXTERN.h" + #include "perl.h" + #include "XSUB.h" + + + XS(XS_Test3_round) + { + dXSARGS; + if (items != 1) { + croak("Usage: Test3::round(arg)"); + } + { + double arg = (double)SvNV(ST(0)); /* XXXXX */ + + if (arg > 0.0) { + arg = floor(arg + 0.5); + } else if (arg < 0.0) { + arg = ceil(arg - 0.5); + } + + sv_setnv(ST(0), (double)arg); /* XXXXX */ + } + XSRETURN(1); + } + + XS(boot_Test3) + { + dXSARGS; + char* file = __FILE__; + + newXS("Test3::round", XS_Test3_round, file); + ST(0) = &sv_yes; + XSRETURN(1); + } + +Notice the two lines marked with "XXXXX". If you check the first section of +the typemap file, you'll see that doubles are of type T_DOUBLE. In the +INPUT section, an argument that is T_DOUBLE is assigned to the variable +arg by calling the routine SvNV on something, then casting it to double, +then assigned to the variable arg. Similarly, in the OUTPUT section, +once arg has its final value, it is passed to the sv_setnv function to +be passed back to the calling subroutine. These two functions are explained +in perlguts; we'll talk more later about what that "ST(0)" means in the +section on the argument stack. + +=head1 WARNING + +In general, it's not agood idea to write extensions that modify their input +parameters, as in Example 3. However, in order to better accomodate calling +pre-existing C routines, which often do modify their input parameters, +this behavior is tolerated. The next example will show to do this. + +=head1 EXAMPLE 4 + +We'll now show how we can call routines in libraries, such as the curses +screen handling package, or a DBM module like GDBM. Each of these libraries +has a header file from which we will generate an XS template that we'll then +fine-tune. + +Rather than attempt to find a library that exists on all systems, we'll +first create our own C library, then create an XSUB to it. + +Let's create the files libtest4.h and libtest4.c as follows: + + /* libtest4.h */ + + #define TESTVAL 4 + + extern int test4(int, long, const char*); + + /* libtest4.c */ + + #include + #include "./libtest4.h" + + int + test4(a, b, c) + int a; + long b; + const char * c; + { + return (a + b + atof(c) + TESTVAL); + } + +Now let's compile it into a library. Since we'll be eventually using this +archive to create a shared library, be sure to use the correct flags to +generate position-independent code. In HP-UX, that's: + + % cc -Aa -D_HPUX_SOURCE -c +z libtest4.c + % ar cr libtest4.a libtest4.o + +Now let's move the libtest4.h and libtest.a files into a sub-directory under +/tmp, so we don't interfere with anything. + + % mkdir /tmp/test4 + % mkdir /tmp/test4/include + % mkdir /tmp/test4/lib + % cp libtest4.h /tmp/test4/include + % cp libtest4.a /tmp/test4/lib + +Okay, now that we have a header file and a library, let's begin actually +writing the extension. + +Run "h2xs -n Test4 /tmp/test4/include/libtest4.h" (notice we are no longer +specifying -A as an argument). This will create a Test4 directory with a file +Test4.xs underneath it. If we look at it now, we'll see some interesting +things have been added to the various files. + +=over 2 + +=item * + +In the .xs file, there's now a #include declaration with the full path to +the libtest4.h header file. + +=item * + +There's now some new C code that's been added to the .xs file. The purpose +of the C routine is to make the values that are #define'd in the +header file available to the Perl script by calling C<&main::TESTVAL>. +There's also some XS code to allow calls to the C routine. + +=item * + +The .pm file has exported the name TESTVAL in the @EXPORT array. This +could lead to name clashes. A good rule of thumb is that if the #define +is only going to be used by the C routines themselves, and not by the user, +they should be removed from the @EXPORT array. Alternately, if you don't +mind using the "fully qualified name" of a variable, you could remove most +or all of the items in the @EXPORT array. + +=back + +Let's now add a definition for the routine in our library. Add the following +code to the end of the .xs file: + + int + test4(a,b,c) + int a + long b + const char * c + +Now we also need to create a typemap file because the default Perl doesn't +currently support the const char * type. Create a file called typemap and +place the following in it: + + const char * T_PV + +Now we must tell our Makefile template where our new library is. Edit the +Makefile.PL and change the following line: + + 'LIBS' => ['-ltest4 -L/tmp/test4'], # e.g., '-lm' + +This specifies that we want the library test4 linked into our XSUB, and that +it should also look in the directory /tmp/test4. + +Let's also change the following line in the Makefile.PL to this: + + 'INC' => '-I/tmp/test/include', # e.g., '-I/usr/include/other' + +and also change the #include in test4.xs to be: + + #include + +Now we don't have to specify the absolute path of the header file in the +.xs file, relying on the Makefile to tell the compiler where to find the +header files. This is generally considered a Good Thing. + +Okay, let's create the Makefile, and run make. You can ignore a message that +may look like: + + Warning (non-fatal): No library found for -ltest4 + +If you forgot to create the typemap file, you might see output that looks +like this: + + Error: 'const char *' not in typemap in test4.xs, line 102 + +This error means that you have used a C datatype that xsubpp doesn't know +how to convert between Perl and C. You'll have to create a typemap file to +tell xsubpp how to do the conversions. + +=head1 Author + +Jeff Okamoto + +=head1 Last Changed + +1995/11/20 + +Jeff Okamoto +Fokamoto@hpcc123.corp.hp.comE> diff --git a/pod/pod2html.PL b/pod/pod2html.PL new file mode 100644 index 0000000000..aee400df34 --- /dev/null +++ b/pod/pod2html.PL @@ -0,0 +1,550 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir(dirname($0)); +($file = basename($0)) =~ s/\.PL$//; +$file =~ s/\.pl$// + if ($Config{'osname'} eq 'VMS' or + $Config{'osname'} eq 'OS2'); # "case-forgiving" + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{'startperl'} +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; +eval 'exec perl -S $0 ${1+"$@"}' + if $running_under_some_shell; +# +# pod2html - convert pod format to html +# Version 1.15 +# usage: pod2html [podfiles] +# Will read the cwd and parse all files with .pod extension +# if no arguments are given on the command line. +# +# Many helps, suggestions, and fixes from the perl5 porters, and all over. +# Bill Middleton - wjm@metronet.com +# +# Please send patches/fixes/features to me +# +# +# +*RS = */; +*ERRNO = *!; + +################################################################################ +# Invoke with various levels of debugging possible +################################################################################ +while ($ARGV[0] =~ /^-d(.*)/) { + shift; + $Debug{ lc($1 || shift) }++; +} + +# ck for podnames on command line +while ($ARGV[0]) { + push(@Pods,shift); +} + +################################################################################ +# CONFIGURE +# +# The beginning of the url for the anchors to the other sections. +# Edit $type to suit. It's configured for relative url's now. +# Other possibilities are: +# $type = '; + close($podfh); + $RS = "\n"; + + $all[0] =~ s/^=//; + for (@all) { s/=$// } + $Podnames{$pod} = 1; + $in_list = 0; + $html = $pod.".html"; + if ($count) { # give us a html and rcs header + open(HTML,">$html") || die "can't create $html: $ERRNO"; + print HTML '',"\n",'',"\n"; + print HTML "
" unless $NO_NS; + print HTML "$pod\n\n"; + print HTML "
" unless $NO_NS; + } + for ($i = 0; $i <= $#all; $i++) { # decide what to do with each chunk + $all[$i] =~ /^(\w+)\s*(.*)\n?([^\0]*)$/ ; + ($cmd, $title, $rest) = ($1,$2,$3); + if ($cmd eq "item") { + if ($count ) { # producing html + do_list("over",$all[$i],\$in_list,\$depth) unless $depth; + do_item($title,$rest,$in_list); + } + else { + # scan item + scan_thing("item",$title,$pod); + } + } + elsif ($cmd =~ /^head([12])/) { + $num = $1; + if ($count) { # producing html + do_hdr($num,$title,$rest,$depth); + } + else { + # header scan + scan_thing($cmd,$title,$pod); # skip head1 + } + } + elsif ($cmd =~ /^over/) { + $count and $depth and do_list("over",$all[$i+1],\$in_list,\$depth); + } + elsif ($cmd =~ /^back/) { + if ($count) { # producing html + ($depth) or next; # just skip it + do_list("back",$all[$i+1],\$in_list,\$depth); + do_rest("$title.$rest"); + } + } + elsif ($cmd =~ /^cut/) { + next; + } + elsif ($cmd =~ /^for/) { # experimental pragma html + if ($count) { # producing html + if ($title =~ s/^html//) { + $in_html =1; + do_rest("$title.$rest"); + } + } + } + elsif ($cmd =~ /^begin/) { # experimental pragma html + if ($count) { # producing html + if ($title =~ s/^html//) { + print HTML $title,"\n",$rest; + } + elsif ($title =~ /^end/) { + next; + } + } + } + elsif ($Debug{"misc"}) { + warn("unrecognized header: $cmd"); + } + } + # close open lists without '=back' stmts + if ($count) { # producing html + while ($depth) { + do_list("back",$all[$i+1],\$in_list,\$depth); + } + print HTML "\n\n\n"; + } + } +} + +sub do_list{ # setup a list type, depending on some grok logic + my($which,$next_one,$list_type,$depth) = @_; + my($key); + if ($which eq "over") { + unless ($next_one =~ /^item\s+(.*)/) { + warn "Bad list, $1\n" if $Debug{"misc"}; + } + $key = $1; + + if ($key =~ /^1\.?/) { + $$list_type = "OL"; + } elsif ($key =~ /\*\s*$/) { + $$list_type = "UL"; + } elsif ($key =~ /\*?\s*\w/) { + $$list_type = "DL"; + } else { + warn "unknown list type for item $key" if $Debug{"misc"}; + } + + print HTML qq{\n}; + print HTML $$list_type eq 'DL' ? qq{
} : qq{<$$list_type>}; + $$depth++; + } + elsif ($which eq "back") { + print HTML qq{\n\n}; + $$depth--; + } +} + +sub do_hdr{ # headers + my($num,$title,$rest,$depth) = @_; + print HTML qq{

\n} if $num == 1; + process_thing(\$title,"NAME"); + print HTML qq{\n }; + print HTML $title; + print HTML qq{\n}; + do_rest($rest); +} + +sub do_item{ # list items + my($title,$rest,$list_type) = @_; + my $bullet_only = $title eq '*' and $list_type eq 'UL'; + process_thing(\$title,"NAME"); + if ($list_type eq "DL") { + print HTML qq{\n
\n}; + print HTML $title; + print HTML qq{\n\n}; + print HTML qq{
\n}; + } + else { + print HTML qq{\n
  • }; + unless ($bullet_only or $list_type eq "OL") { + print HTML $title,"\n"; + } + } + do_rest($rest); +} + +sub do_rest{ # the rest of the chunk handled here + my($rest) = @_; + my(@lines,$p,$q,$line,,@paras,$inpre); + @paras = split(/\n\n\n*/,$rest); + for ($p = 0; $p <= $#paras; $p++) { + $paras[$p] =~ s/^\n//mg; + @lines = split(/\n/,$paras[$p]); + if ($in_html) { # handle =for html paragraphs + print HTML $paras[0]; + $in_html = 0; + next; + } + elsif ($lines[0] =~ /^\s+\w*\t.*/) { # listing or unordered list + print HTML qq{
      }; + foreach $line (@lines) { + ($line =~ /^\s+(\w*)\t(.*)/) && (($key,$rem) = ($1,$2)); + print HTML defined($Podnames{$key}) + ? "
    • $type$key.html\">$key<\/A>\t$rem
      • \n" + : "
    • $line
      • \n"; + } + print HTML qq{
    \n}; + } + elsif ($lines[0] =~ /^\s/) { # preformatted code + if ($paras[$p] =~/>>|<\n}; + $inpre=1; + } + else { # Still cant beat XMP. Yes, I know + print HTML qq{\n\n}; # it's been obsoleted... suggestions? + $inpre = 0; + } + while (defined($paras[$p])) { + @lines = split(/\n/,$paras[$p]); + foreach $q (@lines) { # mind your p's and q's here :-) + if ($paras[$p] =~ />>|<</) { + if ($inpre) { + process_thing(\$q,"HTML"); + } + else { + print HTML qq{\n\n}; + print HTML qq{
    \n};
+			    $inpre=1;
+			    process_thing(\$q,"HTML");
+			}
+		    }
+		    1 while $q =~  s/\t+/' 'x (length($&) * 8 - length($`) % 8)/e;
+		    print HTML  $q,"\n";
+		}
+		last if $paras[$p+1] !~ /^\s/;
+		$p++;
+	    }
+	    print HTML ($inpre==1) ? (qq{\n
    \n}) : (qq{\n\n}); + } + else { # other text + @lines = split(/\n/,$paras[$p]); + foreach $line (@lines) { + process_thing(\$line,"HTML"); + print HTML qq{$line\n}; + } + } + print HTML qq{

    }; + } +} + +sub process_thing{ # process a chunk, order important + my($thing,$htype) = @_; + pre_escapes($thing); + find_refs($thing,$htype); + post_escapes($thing); +} + +sub scan_thing{ # scan a chunk for later references + my($cmd,$title,$pod) = @_; + $_ = $title; + s/\n$//; + s/E<(.*?)>/&$1;/g; + # remove any formatting information for the headers + s/[SFCBI]<(.*?)>/$1/g; + # the "don't format me" thing + s/Z<>//g; + if ($cmd eq "item") { + /^\*/ and return; # skip bullets + /^\d+\./ and return; # skip numbers + s/(-[a-z]).*/$1/i; + trim($_); + return if defined $A->{$pod}->{"Items"}->{$_}; + $A->{$pod}->{"Items"}->{$_} = gensym($pod, $_); + $A->{$pod}->{"Items"}->{(split(' ',$_))[0]}=$A->{$pod}->{"Items"}->{$_}; + Debug("items", "item $_"); + if (!/^-\w$/ && /([%\$\@\w]+)/ && $1 ne $_ + && !defined($A->{$pod}->{"Items"}->{$_}) && ($_ ne $1)) + { + $A->{$pod}->{"Items"}->{$1} = $A->{$pod}->{"Items"}->{$_}; + Debug("items", "item $1 REF TO $_"); + } + if ( m{^(tr|y|s|m|q[qwx])/.*[^/]} ) { + my $pf = $1 . '//'; + $pf .= "/" if $1 eq "tr" || $1 eq "y" || $1 eq "s"; + if ($pf ne $_) { + $A->{$pod}->{"Items"}->{$pf} = $A->{$pod}->{"Items"}->{$_}; + Debug("items", "item $pf REF TO $_"); + } + } + } + elsif ($cmd =~ /^head[12]/) { + return if defined($A->{$pod}->{"Headers"}->{$_}); + $A->{$pod}->{"Headers"}->{$_} = gensym($pod, $_); + Debug("headers", "header $_"); + } + else { + warn "unrecognized header: $cmd" if $Debug; + } +} + + +sub picrefs { + my($char, $bigkey, $lilkey,$htype) = @_; + my($key,$ref,$podname); + for $podname ($pod,@inclusions) { + for $ref ( "Items", "Headers" ) { + if (defined $A->{$podname}->{$ref}->{$bigkey}) { + $value = $A->{$podname}->{$ref}->{$key = $bigkey}; + Debug("subs", "bigkey is $bigkey, value is $value\n"); + } + elsif (defined $A->{$podname}->{$ref}->{$lilkey}) { + $value = $A->{$podname}->{$ref}->{$key = $lilkey}; + return "" if $lilkey eq ''; + Debug("subs", "lilkey is $lilkey, value is $value\n"); + } + } + if (length($key)) { + ($pod2,$num) = split(/_/,$value,2); + if ($htype eq "NAME") { + return "\n\n$bigkey\n" + } + else { + return "\n$type$pod2.html\#".$value."\">$bigkey<\/A>\n"; + } + } + } + if ($char =~ /[IF]/) { + return "$bigkey"; + } elsif ($char =~ /C/) { + return "$bigkey"; + } else { + return "$bigkey"; + } +} + +sub find_refs { + my($thing,$htype) = @_; + my($orig) = $$thing; + # LREF: a manpage(3f) we don't know about + for ($$thing) { + #s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))>:the I<$1>$2 manpage:g; + s@(\S+?://\S*[^.,;!?\s])@noremap(qq{$1})@ge; + s,([a-z0-9_.-]+\@([a-z0-9_-]+\.)+([a-z0-9_-]+)),noremap(qq{$1}),gie; + s/L<([^>]*)>/lrefs($1,$htype)/ge; + s/([CIBF])<(\W*?(-?\w*).*?)>/picrefs($1, $2, $3, $htype)/ge; + s/(S)<([^\/]\W*?(-?\w*).*?)>/picrefs($1, $2, $3, $htype)/ge; + s/((\w+)\(\))/picrefs("I", $1, $2,$htype)/ge; + s/([\$\@%](?!&[gl]t)([\w:]+|\W\b))/varrefs($1,$htype)/ge; + } + if ($$thing eq $orig && $htype eq "NAME") { + $$thing = picrefs("I", $$thing, "", $htype); + } + +} + +sub lrefs { + my($page, $item) = split(m#/#, $_[0], 2); + my($htype) = $_[1]; + my($podname); + my($section) = $page =~ /\((.*)\)/; + my $selfref; + if ($page =~ /^[A-Z]/ && $item) { + $selfref++; + $item = "$page/$item"; + $page = $pod; + } elsif (!$item && $page =~ /[^a-z\-]/ && $page !~ /^\$.$/) { + $selfref++; + $item = $page; + $page = $pod; + } + $item =~ s/\(\)$//; + if (!$item) { + if (!defined $section && defined $Podnames{$page}) { + return "\n$type$page.html\">\nthe $page manpage<\/A>\n"; + } else { + (warn "Bizarre entry $page/$item") if $Debug; + return "the $_[0] manpage\n"; + } + } + + if ($item =~ s/"(.*)"/$1/ || ($item =~ /[^\w\/\-]/ && $item !~ /^\$.$/)) { + $text = "$item"; + $ref = "Headers"; + } else { + $text = "$item"; + $ref = "Items"; + } + for $podname ($pod, @inclusions) { + undef $value; + if ($ref eq "Items") { + if (defined($value = $A->{$podname}->{$ref}->{$item})) { + ($pod2,$num) = split(/_/,$value,2); + return (($pod eq $pod2) && ($htype eq "NAME")) + ? "\n\n$text\n" + : "\n$type$pod2.html\#".$value."\">$text<\/A>\n"; + } + } + elsif ($ref eq "Headers") { + if (defined($value = $A->{$podname}->{$ref}->{$item})) { + ($pod2,$num) = split(/_/,$value,2); + return (($pod eq $pod2) && ($htype eq "NAME")) + ? "\n\n$text\n" + : "\n$type$pod2.html\#".$value."\">$text<\/A>\n"; + } + } + } + warn "No $ref reference for $item (@_)" if $Debug; + return $text; +} + +sub varrefs { + my ($var,$htype) = @_; + for $podname ($pod,@inclusions) { + if ($value = $A->{$podname}->{"Items"}->{$var}) { + ($pod2,$num) = split(/_/,$value,2); + Debug("vars", "way cool -- var ref on $var"); + return (($pod eq $pod2) && ($htype eq "NAME")) # INHERIT $_, $pod + ? "\n\n$var\n" + : "\n$type$pod2.html\#".$value."\">$var<\/A>\n"; + } + } + Debug( "vars", "bummer, $var not a var"); + return "$var"; +} + +sub gensym { + my ($podname, $key) = @_; + $key =~ s/\s.*//; + ($key = lc($key)) =~ tr/a-z/_/cs; + my $name = "${podname}_${key}_0"; + $name =~ s/__/_/g; + while ($sawsym{$name}++) { + $name =~ s/_?(\d+)$/'_' . ($1 + 1)/e; + } + return $name; +} + +sub pre_escapes { # twiddle these, and stay up late :-) + my($thing) = @_; + for ($$thing) { + s/"(.*?)"/``$1''/gs; + s/&/noremap("&")/ge; + s/<]*)>/\&$1\;/g; # embedded special + } +} +sub noremap { # adding translator for hibit chars soon + my $hide = $_[0]; + $hide =~ tr/\000-\177/\200-\377/; + $hide; +} + + +sub post_escapes { + my($thing) = @_; + for ($$thing) { + s/([^GM])>>/$1\>\;\>\;/g; + s/([^D][^"MGA])>/$1\>\;/g; + tr/\200-\377/\000-\177/; + } +} + +sub Debug { + my $level = shift; + print STDERR @_,"\n" if $Debug{$level}; +} + +sub dumptable { + my $t = shift; + print STDERR "TABLE DUMP $t\n"; + foreach $k (sort keys %$t) { + printf STDERR "%-20s <%s>\n", $t->{$k}, $k; + } +} +sub trim { + for (@_) { + s/^\s+//; + s/\s\n?$//; + } +} +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; diff --git a/pod/pod2html.SH b/pod/pod2html.SH deleted file mode 100755 index af5161377d..0000000000 --- a/pod/pod2html.SH +++ /dev/null @@ -1,490 +0,0 @@ -case $CONFIG in -'') - if test -f config.sh; then TOP=.; - elif test -f ../config.sh; then TOP=..; - elif test -f ../../config.sh; then TOP=../..; - elif test -f ../../../config.sh; then TOP=../../..; - elif test -f ../../../../config.sh; then TOP=../../../..; - else - echo "Can't find config.sh."; exit 1 - fi - . $TOP/config.sh - ;; -esac -case "$0" in -*/*) cd `expr X$0 : 'X\(.*\)/'` ;; -esac -echo "Extracting pod/pod2html (with variable substitutions)" -rm -f pod2html -$spitshell >pod2html <>pod2html <<'!NO!SUBS!' -# -# pod2html - convert pod format to html -# -# usage: pod2html [podfiles] -# will read the cwd and parse all files with .pod extension -# if no arguments are given on the command line. -# -*RS = */; -*ERRNO = *!; - -use Carp; - -$gensym = 0; - -while ($ARGV[0] =~ /^-d(.*)/) { - shift; - $Debug{ lc($1 || shift) }++; -} - -# look in these pods for things not found within the current pod -@inclusions = qw[ - perlfunc perlvar perlrun perlop -]; - -# ck for podnames on command line -while ($ARGV[0]) { - push(@Pods,shift); -} -$A={}; - -# location of pods -$dir="."; - -# The beginning of the url for the anchors to the other sections. -# Edit $type to suit. It's configured for relative url's now. -$type='; - close($podfh); - $RS = "\n"; - $all[0]=~s/^=//; - for(@all){s/=$//;} - $Podnames{$pod} = 1; - $in_list=0; - $html=$pod.".html"; - if($count){ - open(HTML,">$html") || die "can't create $html: $ERRNO"; - print HTML <<'HTML__EOQ', <<"HTML__EOQQ"; - - - -HTML__EOQ - \U$pod\E -HTML__EOQQ - } - - for($i=0;$i<=$#all;$i++){ - - $all[$i] =~ /^(\w+)\s*(.*)\n?([^\0]*)$/ ; - ($cmd, $title, $rest) = ($1,$2,$3); - if ($cmd eq "item") { - if($count ){ - ($depth) or do_list("over",$all[$i],\$in_list,\$depth); - do_item($title,$rest,$in_list); - } - else{ - # scan item - scan_thing("item",$title,$pod); - } - } - elsif ($cmd =~ /^head([12])/){ - $num=$1; - if($count){ - do_hdr($num,$title,$rest,$depth); - } - else{ - # header scan - scan_thing($cmd,$title,$pod); # skip head1 - } - } - elsif ($cmd =~ /^over/) { - $count and $depth and do_list("over",$all[$i+1],\$in_list,\$depth); - } - elsif ($cmd =~ /^back/) { - if($count){ - ($depth) or next; # just skip it - do_list("back",$all[$i+1],\$in_list,\$depth); - do_rest("$title.$rest"); - } - } - elsif ($cmd =~ /^cut/) { - next; - } - elsif($Debug){ - (warn "unrecognized header: $cmd") if $Debug; - } - } - # close open lists without '=back' stmts - if($count){ - while($depth){ - do_list("back",$all[$i+1],\$in_list,\$depth); - } - print HTML "\n\n"; - } - } -} - -sub do_list{ - my($which,$next_one,$list_type,$depth)=@_; - my($key); - if($which eq "over"){ - ($next_one =~ /^item\s+(.*)/ ) or (warn "Bad list, $1\n") if $Debug; - $key=$1; - if($key =~ /^1\.?/){ - $$list_type = "OL"; - } - elsif($key =~ /\*\s*$/){ - $$list_type="UL"; - } - elsif($key =~ /\*?\s*\w/){ - $$list_type="DL"; - } - else{ - (warn "unknown list type for item $key") if $Debug; - } - print HTML qq{\n}; - print HTML qq{<$$list_type>}; - $$depth++; - } - elsif($which eq "back"){ - print HTML qq{\n\n}; - $$depth--; - } -} - -sub do_hdr{ - my($num,$title,$rest,$depth)=@_; - ($num == 1) and print HTML qq{

    \n}; - process_thing(\$title,"NAME"); - print HTML qq{\n }; - print HTML $title; - print HTML qq{\n}; - do_rest($rest); -} - -sub do_item{ - my($title,$rest,$list_type)=@_; - process_thing(\$title,"NAME"); - if($list_type eq "DL"){ - print HTML qq{\n
    \n}; - print HTML $title; - print HTML qq{\n
    \n}; - print HTML qq{
    \n}; - } - else{ - print HTML qq{\n
  • }; - ($list_type ne "OL") && (print HTML $title,"\n"); - } - do_rest($rest); - print HTML ($list_type eq "DL" )? qq{
    • } : qq{
    • }; -} - -sub do_rest{ - my($rest)=@_; - my(@lines,$p,$q,$line,,@paras,$inpre); - @paras=split(/\n\n+/,$rest); - for($p=0;$p<=$#paras;$p++){ - @lines=split(/\n/,$paras[$p]); - if($lines[0] =~ /^\s+\w*\t.*/){ # listing or unordered list - print HTML qq{
      }; - foreach $line (@lines){ - ($line =~ /^\s+(\w*)\t(.*)/) && (($key,$rem) = ($1,$2)); - print HTML defined($Podnames{$key}) ? - "
    • $type$key.html\">$key<\/A>\t$rem
      • \n" : - "
    • $line
      • \n"; - } - print HTML qq{
    \n}; - } - elsif($lines[0] =~ /^\s/){ # preformatted code - if($paras[$p] =~/>>|<\n}; - $inpre=1; - } - else{ - print HTML qq{\n\n}; - $inpre=0; - } -inner: - while(defined($paras[$p])){ - @lines=split(/\n/,$paras[$p]); - foreach $q (@lines){ - if($paras[$p]=~/>>|<</){ - if($inpre){ - process_thing(\$q,"HTML"); - } - else { - print HTML qq{\n\n}; - print HTML qq{
    \n};
-			    $inpre=1;
-			    process_thing(\$q,"HTML");
-			}
-		    }
-		    while($q =~  s/\t+/' 'x (length($&) * 8 - length($`) % 8)/e){
-			1;
-		    }
-		    print HTML  $q,"\n";
-		}
-		last if $paras[$p+1] !~ /^\s/;
-		$p++;
-	    }
-	    print HTML ($inpre==1) ? (qq{\n
    \n}) : (qq{\n\n}); - } - else{ # other text - @lines=split(/\n/,$paras[$p]); - foreach $line (@lines){ - process_thing(\$line,"HTML"); - print HTML qq{$line\n}; - } - } - print HTML qq{

    }; - } -} - -sub process_thing{ - my($thing,$htype)=@_; - pre_escapes($thing); - find_refs($thing,$htype); - post_escapes($thing); -} - -sub scan_thing{ - my($cmd,$title,$pod)=@_; - $_=$title; - s/\n$//; - s/E<(.*?)>/&$1;/g; - # remove any formatting information for the headers - s/[SFCBI]<(.*?)>/$1/g; - # the "don't format me" thing - s/Z<>//g; - if ($cmd eq "item") { - - if (/^\*/) { return } # skip bullets - if (/^\d+\./) { return } # skip numbers - s/(-[a-z]).*/$1/i; - trim($_); - return if defined $A->{$pod}->{"Items"}->{$_}; - $A->{$pod}->{"Items"}->{$_} = gensym($pod, $_); - $A->{$pod}->{"Items"}->{(split(' ',$_))[0]}=$A->{$pod}->{"Items"}->{$_}; - Debug("items", "item $_"); - if (!/^-\w$/ && /([%\$\@\w]+)/ && $1 ne $_ - && !defined($A->{$pod}->{"Items"}->{$_}) && ($_ ne $1)) - { - $A->{$pod}->{"Items"}->{$1} = $A->{$pod}->{"Items"}->{$_}; - Debug("items", "item $1 REF TO $_"); - } - if ( m{^(tr|y|s|m|q[qwx])/.*[^/]} ) { - my $pf = $1 . '//'; - $pf .= "/" if $1 eq "tr" || $1 eq "y" || $1 eq "s"; - if ($pf ne $_) { - $A->{$pod}->{"Items"}->{$pf} = $A->{$pod}->{"Items"}->{$_}; - Debug("items", "item $pf REF TO $_"); - } - } - } - elsif ($cmd =~ /^head[12]/){ - return if defined($Headers{$_}); - $A->{$pod}->{"Headers"}->{$_} = gensym($pod, $_); - Debug("headers", "header $_"); - } - else { - (warn "unrecognized header: $cmd") if $Debug; - } -} - - -sub picrefs { - my($char, $bigkey, $lilkey,$htype) = @_; - my($key,$ref,$podname); - for $podname ($pod,@inclusions){ - for $ref ( "Items", "Headers" ) { - if (defined $A->{$podname}->{$ref}->{$bigkey}) { - $value = $A->{$podname}->{$ref}->{$key=$bigkey}; - Debug("subs", "bigkey is $bigkey, value is $value\n"); - } - elsif (defined $A->{$podname}->{$ref}->{$lilkey}) { - $value = $A->{$podname}->{$ref}->{$key=$lilkey}; - return "" if $lilkey eq ''; - Debug("subs", "lilkey is $lilkey, value is $value\n"); - } - } - if (length($key)) { - ($pod2,$num) = split(/_/,$value,2); - if($htype eq "NAME"){ - return "\n\n$bigkey\n" - } - else{ - return "\n$type$pod2.html\#".$value."\">$bigkey<\/A>\n"; - } - } - } - if ($char =~ /[IF]/) { - return "$bigkey"; - } elsif($char =~ /C/) { - return "$bigkey"; - } else { - return "$bigkey"; - } -} - -sub find_refs { - my($thing,$htype)=@_; - my($orig) = $$thing; - # LREF: a manpage(3f) we don't know about - $$thing=~s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))>:the I<$1>$2 manpage:g; - $$thing=~s/L<([^>]*)>/lrefs($1,$htype)/ge; - $$thing=~s/([CIBF])<(\W*?(-?\w*).*?)>/picrefs($1, $2, $3, $htype)/ge; - $$thing=~s/((\w+)\(\))/picrefs("I", $1, $2,$htype)/ge; - $$thing=~s/([\$\@%](?!&[gl]t)([\w:]+|\W\b))/varrefs($1,$htype)/ge; - (($$thing eq $orig) && ($htype eq "NAME")) && - ($$thing=picrefs("I", $$thing, "", $htype)); -} - -sub lrefs { - my($page, $item) = split(m#/#, $_[0], 2); - my($htype)=$_[1]; - my($podname); - my($section) = $page =~ /\((.*)\)/; - my $selfref; - if ($page =~ /^[A-Z]/ && $item) { - $selfref++; - $item = "$page/$item"; - $page = $pod; - } elsif (!$item && $page =~ /[^a-z\-]/ && $page !~ /^\$.$/) { - $selfref++; - $item = $page; - $page = $pod; - } - $item =~ s/\(\)$//; - if (!$item) { - if (!defined $section && defined $Podnames{$page}) { - return "\n$type$page.html\">\nthe $page manpage<\/A>\n"; - } else { - (warn "Bizarre entry $page/$item") if $Debug; - return "the $_[0] manpage\n"; - } - } - - if ($item =~ s/"(.*)"/$1/ || ($item =~ /[^\w\/\-]/ && $item !~ /^\$.$/)) { - $text = "$item"; - $ref = "Headers"; - } else { - $text = "$item"; - $ref = "Items"; - } - for $podname ($pod, @inclusions){ - undef $value; - if ($ref eq "Items") { - if (defined($value = $A->{$podname}->{$ref}->{$item})) { - ($pod2,$num) = split(/_/,$value,2); - return (($pod eq $pod2) && ($htype eq "NAME")) - ? "\n\n$text\n" - : "\n$type$pod2.html\#".$value."\">$text<\/A>\n"; - } - } - elsif($ref eq "Headers") { - if (defined($value = $A->{$podname}->{$ref}->{$item})) { - ($pod2,$num) = split(/_/,$value,2); - return (($pod eq $pod2) && ($htype eq "NAME")) - ? "\n\n$text\n" - : "\n$type$pod2.html\#".$value."\">$text<\/A>\n"; - } - } - } - (warn "No $ref reference for $item (@_)") if $Debug; - return $text; -} - -sub varrefs { - my ($var,$htype) = @_; - for $podname ($pod,@inclusions){ - if ($value = $A->{$podname}->{"Items"}->{$var}) { - ($pod2,$num) = split(/_/,$value,2); - Debug("vars", "way cool -- var ref on $var"); - return (($pod eq $pod2) && ($htype eq "NAME")) # INHERIT $_, $pod - ? "\n\n$var\n" - : "\n$type$pod2.html\#".$value."\">$var<\/A>\n"; - } - } - Debug( "vars", "bummer, $var not a var"); - return "$var"; -} - -sub gensym { - my ($podname, $key) = @_; - $key =~ s/\s.*//; - ($key = lc($key)) =~ tr/a-z/_/cs; - my $name = "${podname}_${key}_0"; - $name =~ s/__/_/g; - while ($sawsym{$name}++) { - $name =~ s/_?(\d+)$/'_' . ($1 + 1)/e; - } - return $name; -} - -sub pre_escapes { - my($thing)=@_; - $$thing=~s/&/noremap("&")/ge; - $$thing=~s/<]*)>/\&$1\;/g; # embedded special -} - -sub noremap { - my $hide = $_[0]; - $hide =~ tr/\000-\177/\200-\377/; - $hide; -} - -sub post_escapes { - my($thing)=@_; - $$thing=~s/[^GM]>>/\>\;\>\;/g; - $$thing=~s/([^"MGAE])>/$1\>\;/g; - $$thing=~tr/\200-\377/\000-\177/; -} - -sub Debug { - my $level = shift; - print STDERR @_,"\n" if $Debug{$level}; -} - -sub dumptable { - my $t = shift; - print STDERR "TABLE DUMP $t\n"; - foreach $k (sort keys %$t) { - printf STDERR "%-20s <%s>\n", $t->{$k}, $k; - } -} -sub trim { - for (@_) { - s/^\s+//; - s/\s\n?$//; - } -} - - -!NO!SUBS! -chmod 755 pod2html -$eunicefix pod2html diff --git a/pod/pod2latex.PL b/pod/pod2latex.PL new file mode 100644 index 0000000000..bd6df71c74 --- /dev/null +++ b/pod/pod2latex.PL @@ -0,0 +1,673 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir(dirname($0)); +($file = basename($0)) =~ s/\.PL$//; +$file =~ s/\.pl$// + if ($Config{'osname'} eq 'VMS' or + $Config{'osname'} eq 'OS2'); # "case-forgiving" + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{'startperl'} + eval 'exec perl -S \$0 "\$@"' + if 0; +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; +# +# pod2latex, version 1.1 +# by Taro Kawagish (kawagish@imslab.co.jp), Jan 11, 1995. +# +# pod2latex filters Perl pod documents to LaTeX documents. +# +# What pod2latex does: +# 1. Pod file 'perl_doc_entry.pod' is filtered to 'perl_doc_entry.tex'. +# 2. Indented paragraphs are translated into +# '\begin{verbatim} ... \end{verbatim}'. +# 3. '=head1 heading' command is translated into '\section{heading}' +# 4. '=head2 heading' command is translated into '\subsection*{heading}' +# 5. '=over N' command is translated into +# '\begin{itemize}' if following =item starts with *, +# '\begin{enumerate}' if following =item starts with 1., +# '\begin{description}' if else. +# (indentation level N is ignored.) +# 6. '=item * heading' command is translated into '\item heading', +# '=item 1. heading' command is translated into '\item heading', +# '=item heading' command(other) is translated into '\item[heading]'. +# 7. '=back' command is translated into +# '\end{itemize}' if started with '\begin{itemize}', +# '\end{enumerate}' if started with '\begin{enumerate}', +# '\end{description}' if started with '\begin{description}'. +# 8. other paragraphs are translated into strings with TeX special characters +# escaped. +# 9. In heading text, and other paragraphs, the following translation of pod +# quotes are done, and then TeX special characters are escaped after that. +# I to {\em text\/}, +# B to {\bf text}, +# S to text1, +# where text1 is a string with blank characters replaced with ~, +# C to {\tt text2}, +# where text2 is a string with TeX special characters escaped to +# obtain a literal printout, +# E (HTML escape) to TeX escaped string, +# L to referencing string as is done by pod2man, +# F to {\em file\/}, +# Z<> to a null string, +# 10. those headings are indexed: +# '=head1 heading' => \section{heading}\index{heading} +# '=head2 heading' => \subsection*{heading}\index{heading} +# only when heading does not match frequent patterns such as +# DESCRIPTION, DIAGNOSTICS,... +# '=item heading' => \item{heading}\index{heading} +# +# Usage: +# pod2latex perl_doc_entry.pod +# this will write to a file 'perl_doc_entry.tex'. +# +# To LaTeX: +# The following commands need to be defined in the preamble of the LaTeX +# document: +# \def\C++{{\rm C\kern-.05em\raise.3ex\hbox{\footnotesize ++}}} +# \def\underscore{\leavevmode\kern.04em\vbox{\hrule width 0.4em height 0.3pt}} +# and \parindent should be set zero: +# \setlength{\parindent}{0pt} +# +# Note: +# This script was written modifing pod2man. +# +# Bug: +# If HTML escapes E other than E,E,E,E are used +# in C<>, translation will produce wrong character strings. +# Translation of HTML escapes of various European accents might be wrong. + + +$/ = ""; # record separator is blank lines +# TeX special characters. +##$tt_ables = "!@*()-=+|;:'\"`,./?<>"; +$backslash_escapables = "#\$%&{}_"; +$backslash_escapables2 = "#\$%&{}"; # except _ +##$nonverbables = "^\\~"; +##$bracketesc = "[]"; +##@tex_verb_fences = unpack("aaaaaaaaa","|#@!*+?:;"); + +@head1_freq_patterns # =head1 patterns which need not be index'ed + = ("AUTHOR","Author","BUGS","DATE","DESCRIPTION","DIAGNOSTICS", + "ENVIRONMENT","EXAMPLES","FILES","INTRODUCTION","NAME","NOTE", + "SEE ALSO","SYNOPSIS","WARNING"); + +$indent = 0; + +# parse the pods, produce LaTeX. + +open(POD,"<$ARGV[0]") || die "cant open $ARGV[0]"; +($pod=$ARGV[0]) =~ s/\.pod$//; +open(LATEX,">$pod.tex"); +&do_hdr(); + +$cutting = 1; +while () { + if ($cutting) { + next unless /^=/; + $cutting = 0; + } + chop; + length || (print LATEX "\n") && next; + + # translate indented lines as a verabatim paragraph + if (/^\s/) { + @lines = split(/\n/); + print LATEX "\\begin{verbatim}\n"; + for (@lines) { + 1 while s + {^( [^\t]* ) \t ( \t* ) } + { $1 . ' ' x (8 - (length($1)%8) + 8*(length($2))) }ex; + print LATEX $_,"\n"; + } + print LATEX "\\end{verbatim}\n"; + next; + } + + # preserve '=item' line with pod quotes as they are. + if (/^=item/) { + ($bareitem = $_) =~ s/^=item\s*//; + } + + # check for things that'll hosed our noremap scheme; affects $_ + &init_noremap(); + + # expand strings "func()" as pod quotes. + if (!/^=item/) { + # first hide pod escapes. + # escaped strings are mapped into the ones with the MSB's on. + s/([A-Z]<[^<>]*>)/noremap($1)/ge; + + # func() is a reference to a perl function + s{\b([:\w]+\(\))}{I<$1>}g; + # func(n) is a reference to a man page + s{(\w+)(\([^\s,\051]+\))}{I<$1>$2}g; + # convert simple variable references +# s/([\$\@%][\w:]+)/C<$1>/g; +# s/\$[\w:]+\[[0-9]+\]/C<$&>/g; + + if (m{ ([\-\w]+\([^\051]*?[\@\$,][^\051]*?\)) + }x && $` !~ /([LCI]<[^<>]*|-)$/ && !/^=\w/) + { + warn "``$1'' should be a [LCI]<$1> ref"; + } + while (/(-[a-zA-Z])\b/g && $` !~ /[\w\-]$/) { + warn "``$1'' should be [CB]<$1> ref"; + } + + # put back pod quotes so we get the inside of <> processed; + $_ = &clear_noremap($_); + } + + + # process TeX special characters + + # First hide HTML quotes E<> since they can be included in C<>. + s/(E<[^<>]+>)/noremap($1)/ge; + + # Then hide C<> type literal quotes. + # String inside of C<> will later be expanded into {\tt ..} strings + # with TeX special characters escaped as needed. + s/(C<[^<>]*>)/&noremap($1)/ge; + + # Next escape TeX special characters including other pod quotes B< >,... + # + # NOTE: s/re/&func($str)/e evaluates $str just once in perl5. + # (in perl4 evaluation takes place twice before getting passed to func().) + + # - hyphen => --- + s/(\S+)(\s+)-+(\s+)(\S+)/"$1".&noremap(" --- ")."$4"/ge; + # '-', '--', "-" => '{\tt -}', '{\tt --}', "{\tt -}" +## s/("|')(\s*)(-+)(\s*)\1/&noremap("$1$2\{\\tt $3\}$4$1")/ge; +## changed Wed Jan 25 15:26:39 JST 1995 + # '-', '--', "-" => '$-$', '$--$', "$-$" + s/(\s+)(['"])(-+)([^'"\-]*)\2(\s+|[,.])/"$1$2".&noremap("\$$3\$")."$4$2$5"/ge; + s/(\s+)(['"])([^'"\-]*)(-+)(\s*)\2(\s+|[,.])/"$1$2$3".&noremap("\$$4\$")."$5$2$6"/ge; + # (--|-) => ($--$|$-$) + s/(\s+)\((-+)([=@%\$\+\\\|\w]*)(-*)([=@%\$\+\\\|\w]*)\)(\s+|[,.])/"$1\(".&noremap("\$$2\$")."$3".&noremap("\$$4\$")."$5\)$6"/ge; + # numeral - => $-$ + s/(\(|[0-9]+|\s+)-(\s*\(?\s*[0-9]+)/&noremap("$1\$-\$$2")/ge; + # -- in quotes => two separate - + s/B<([^<>]*)--([^<>]*)>/&noremap("B<$1\{\\tt --\}$2>")/ge; + + # backslash escapable characters except _. + s/([$backslash_escapables2])/&noremap("\\$1")/ge; + s/_/&noremap("\\underscore{}")/ge; # a litle thicker than \_. + # quote TeX special characters |, ^, ~, \. + s/\|/&noremap("\$|\$")/ge; + s/\^/&noremap("\$\\hat{\\hspace{0.4em}}\$")/ge; + s/\~/&noremap("\$\\tilde{\\hspace{0.4em}}\$")/ge; + s/\\/&noremap("\$\\backslash{}\$")/ge; + # quote [ and ] to be used in \item[] + s/([\[\]])/&noremap("{\\tt $1}")/ge; + # characters need to be treated differently in TeX + # keep * if an item heading + s/^(=item[ \t]+)[*]((.|\n)*)/"$1" . &noremap("*") . "$2"/ge; + s/[*]/&noremap("\$\\ast\$")/ge; # other * + + # hide other pod quotes. + s/([ABD-Z]<[^<>]*>)/&noremap($1)/ge; + + # escape < and > as math strings, + # now that we are done with hiding pod <> quotes. + s//&noremap("\$>\$")/ge; + + # put it back so we get the <> processed again; + $_ = &clear_noremap($_); + + + # Expand pod quotes recursively: + # (1) type face directives [BIFS]<[^<>]*> to appropriate TeX commands, + # (2) L<[^<>]*> to reference strings, + # (3) C<[^<>]*> to TeX literal quotes, + # (4) HTML quotes E<> inside of C<> quotes. + + # Hide E<> again since they can be included in C<>. + s/(E<[^<>]+>)/noremap($1)/ge; + + $maxnest = 10; + while ($maxnest-- && /[A-Z]]*)>/"{\\bf $1}"/eg; + s#I<([^<>]*)>#"{\\em $1\\/}"#eg; + + # files and filelike refs in italics + s#F<([^<>]*)>#"{\\em $1\\/}"#eg; + + # no break quote -- usually we want C<> for this + s/S<([^<>]*)>/&nobreak($1)/eg; + + # LREF: a manpage(3f) + s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))?>:the {\\em $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 + (,?\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>" + } + }gex; + + s/Z<>/\\&/g; # the "don't format me" thing + + # comes last because not subject to reprocessing + s{ + C<([^<>]*)> + }{ + do { + ($str = $1) =~ tr/\200-\377/\000-\177/; #normalize hidden stuff + # expand HTML escapes if any; + # WARNING: if HTML escapes other than E,E,E, + # E are in C<>, they will not be printed correctly. + $str = &expand_HTML_escapes($str); + $strverb = &alltt($str); # Tex verbatim escape of a string. + &noremap("$strverb"); + } + }gex; + +# if ( /C<([^<>]*)/ ) { +# $str = $1; +# if ($str !~ /\|/) { # if includes | +# s/C<([^<>]*)>/&noremap("\\verb|$str|")/eg; +# } else { +# print STDERR "found \| in C<.*> at paragraph $.\n"; +# # find a character not contained in $str to use it as a +# # separator of the \verb +# ($chars = $str) =~ s/(\W)/\\$1/g; +# ## ($chars = $str) =~ s/([\$<>,\|"'\-^{}()*+?\\])/\\$1/g; +# @fence = grep(!/[ $chars]/,@tex_verb_fences); +# s/C<([^<>]*)>/&noremap("\\verb$fence[0]$str$fence[0]")/eg; +# } +# } + } + + + # process each pod command + if (s/^=//) { # if a command + s/\n/ /g; + ($cmd, $rest) = split(' ', $_, 2); + $rest =~ s/^\s*//; + $rest =~ s/\s*$//; + + if (defined $rest) { + &escapes; + } + + $rest = &clear_noremap($rest); + $rest = &expand_HTML_escapes($rest); + + if ($cmd eq 'cut') { + $cutting = 1; + $lastcmd = 'cut'; + } + elsif ($cmd eq 'head1') { # heading type 1 + $rest =~ s/^\s*//; $rest =~ s/\s*$//; + print LATEX "\n\\subsection*{$rest}"; + # put index entry + ($index = $rest) =~ s/^(An?\s+|The\s+)//i; # remove 'A' and 'The' + # index only those heads not matching the frequent patterns. + foreach $pat (@head1_freq_patterns) { + if ($index =~ /^$pat/) { + goto freqpatt; + } + } + print LATEX "%\n\\index{$index}\n" if ($index); + freqpatt: + $lastcmd = 'head1'; + } + elsif ($cmd eq 'head2') { # heading type 2 + $rest =~ s/^\s*//; $rest =~ s/\s*$//; + print LATEX "\n\\subsubsection*{$rest}"; + # put index entry + ($index = $rest) =~ s/^(An?\s+|The\s+)//i; # remove 'A' and 'The' + $index =~ s/^Example\s*[1-9][0-9]*\s*:\s*//; # remove 'Example :' + print LATEX "%\n\\index{$index}\n" if ($index); + $lastcmd = 'head2'; + } + elsif ($cmd eq 'over') { # 1 level within a listing environment + push(@indent,$indent); + $indent = $rest + 0; + $lastcmd = 'over'; + } + elsif ($cmd eq 'back') { # 1 level out of a listing environment + $indent = pop(@indent); + warn "Unmatched =back\n" unless defined $indent; + $listingcmd = pop(@listingcmd); + print LATEX "\n\\end{$listingcmd}\n" if ($listingcmd); + $lastcmd = 'back'; + } + elsif ($cmd eq 'item') { # an item paragraph starts + if ($lastcmd eq 'over') { # if we have just entered listing env + # see what type of list environment we are in. + if ($rest =~ /^[0-9]\.?/) { # if numeral heading + $listingcmd = 'enumerate'; + } elsif ($rest =~ /^\*\s*/) { # if * heading + $listingcmd = 'itemize'; + } elsif ($rest =~ /^[^*]/) { # if other headings + $listingcmd = 'description'; + } else { + warn "unknown list type for item $rest"; + } + print LATEX "\n\\begin{$listingcmd}\n"; + push(@listingcmd,$listingcmd); + } elsif ($lastcmd ne 'item') { + warn "Illegal '=item' command without preceding 'over':"; + warn "=item $bareitem"; + } + + if ($listingcmd eq 'enumerate') { + $rest =~ s/^[0-9]+\.?\s*//; # remove numeral heading + print LATEX "\n\\item"; + print LATEX "{\\bf $rest}" if $rest; + } elsif ($listingcmd eq 'itemize') { + $rest =~ s/^\*\s*//; # remove * heading + print LATEX "\n\\item"; + print LATEX "{\\bf $rest}" if $rest; + } else { # description item + print LATEX "\n\\item[$rest]"; + } + $lastcmd = 'item'; + $rightafter_item = 'yes'; + + # check if the item heading is short or long. + ($itemhead = $rest) =~ s/{\\bf (\S*)}/$1/g; + if (length($itemhead) < 4) { + $itemshort = "yes"; + } else { + $itemshort = "no"; + } + # write index entry + if ($pod =~ "perldiag") { # skip 'perldiag.pod' + goto noindex; + } + # strip out the item of pod quotes and get a plain text entry + $bareitem =~ s/\n/ /g; # remove newlines + $bareitem =~ s/\s*$//; # remove trailing space + $bareitem =~ s/[A-Z]<([^<>]*)>/$1/g; # remove <> quotes + ($index = $bareitem) =~ s/^\*\s+//; # remove leading '*' + $index =~ s/^(An?\s+|The\s+)//i; # remove 'A' and 'The' + $index =~ s/^\s*[1-9][0-9]*\s*[.]\s*$//; # remove numeral only + $index =~ s/^\s*\w\s*$//; # remove 1 char only's + # quote ", @ and ! with " to be used in makeindex. + $index =~ s/"/""/g; # quote " + $index =~ s/@/"@/g; # quote @ + $index =~ s/!/"!/g; # quote ! + ($rest2=$rest) =~ s/^\*\s+//; # remove * + $rest2 =~ s/"/""/g; # quote " + $rest2 =~ s/@/"@/g; # quote @ + $rest2 =~ s/!/"!/g; # quote ! + if ($pod =~ "(perlfunc|perlvar)") { # when doc is perlfunc,perlvar + # take only the 1st word of item heading + $index =~ s/^([^{}\s]*)({.*})?([^{}\s]*)\s+.*/\1\2\3/; + $rest2 =~ s/^([^{}\s]*)({.*})?([^{}\s]*)\s+.*/\1\2\3/; + } + if ($index =~ /[A-Za-z\$@%]/) { + # write \index{plain_text_entry@TeX_string_entry} + print LATEX "%\n\\index{$index\@$rest2}%\n"; + } + noindex: + ; + } + else { + warn "Unrecognized directive: $cmd\n"; + } + } + else { # if not command + &escapes; + $_ = &clear_noremap($_); + $_ = &expand_HTML_escapes($_); + + # if the present paragraphs follows an =item declaration, + # put a line break. + if ($lastcmd eq 'item' && + $rightafter_item eq 'yes' && $itemshort eq "no") { + print LATEX "\\hfil\\\\"; + $rightafter_item = 'no'; + } + print LATEX "\n",$_; + } +} + +print LATEX "\n"; +close(POD); +close(LATEX); + + +######################################################################### + +sub do_hdr { + print LATEX "% LaTeX document produced by pod2latex from \"$pod.pod\".\n"; + print LATEX "% The followings need be defined in the preamble of this document:\n"; + print LATEX "%\\def\\C++{{\\rm C\\kern-.05em\\raise.3ex\\hbox{\\footnotesize ++}}}\n"; + print LATEX "%\\def\\underscore{\\leavevmode\\kern.04em\\vbox{\\hrule width 0.4em height 0.3pt}}\n"; + print LATEX "%\\setlength{\\parindent}{0pt}\n"; + print LATEX "\n"; + $podq = &escape_tex_specials("\U$pod\E"); + print LATEX "\\section{$podq}%\n"; + print LATEX "\\index{$podq}"; + print LATEX "\n"; +} + +sub nobreak { + my $string = shift; + $string =~ s/ +/~/g; # TeX no line break + $string; +} + +sub noremap { + local($thing_to_hide) = shift; + $thing_to_hide =~ tr/\000-\177/\200-\377/; + return $thing_to_hide; +} + +sub init_noremap { + if ( /[\200-\377]/ ) { + warn "hit bit char in input stream"; + } +} + +sub clear_noremap { + local($tmp) = shift; + $tmp =~ tr/\200-\377/\000-\177/; + return $tmp; +} + +sub expand_HTML_escapes { + local($s) = $_[0]; + $s =~ s { E<([A-Za-z]+)> } + { + do { + exists $HTML_Escapes{$1} + ? do { $HTML_Escapes{$1} } + : do { + warn "Unknown escape: $& in $_"; + "E<$1>"; + } + } + }egx; + return $s; +} + +sub escapes { + # make C++ into \C++, which is to be defined as + # \def\C++{{\rm C\kern-.05em\raise.3ex\hbox{\footnotesize ++}}} + s/\bC\+\+/\\C++{}/g; +} + +# Translate a string into a TeX \tt string to obtain a verbatim print out. +# TeX special characters are escaped by \. +# This can be used inside of LaTeX command arguments. +# We don't use LaTeX \verb since it doesn't work inside of command arguments. +sub alltt { + local($str) = shift; + # other chars than #,\,$,%,&,{,},_,\,^,~ ([ and ] included). + $str =~ s/([^${backslash_escapables}\\\^\~]+)/&noremap("$&")/eg; + # chars #,\,$,%,&,{,} => \# , ... + $str =~ s/([$backslash_escapables2])/&noremap("\\$&")/eg; + # chars _,\,^,~ => \char`\_ , ... + $str =~ s/_/&noremap("\\char`\\_")/eg; + $str =~ s/\\/&noremap("\\char`\\\\")/ge; + $str =~ s/\^/\\char`\\^/g; + $str =~ s/\~/\\char`\\~/g; + + $str =~ tr/\200-\377/\000-\177/; # put back + $str = "{\\tt ".$str."}"; # make it a \tt string + return $str; +} + +sub escape_tex_specials { + local($str) = shift; + # other chars than #,\,$,%,&,{,}, _,\,^,~ ([ and ] included). + # backslash escapable characters #,\,$,%,&,{,} except _. + $str =~ s/([$backslash_escapables2])/&noremap("\\$1")/ge; + $str =~ s/_/&noremap("\\underscore{}")/ge; # \_ is too thin. + # quote TeX special characters |, ^, ~, \. + $str =~ s/\|/&noremap("\$|\$")/ge; + $str =~ s/\^/&noremap("\$\\hat{\\hspace{0.4em}}\$")/ge; + $str =~ s/\~/&noremap("\$\\tilde{\\hspace{0.4em}}\$")/ge; + $str =~ s/\\/&noremap("\$\\backslash{}\$")/ge; + # characters need to be treated differently in TeX + # * + $str =~ s/[*]/&noremap("\$\\ast\$")/ge; + # escape < and > as math string, + $str =~ s//&noremap("\$>\$")/ge; + $str =~ tr/\200-\377/\000-\177/; # put back + return $str; +} + +sub internal_lrefs { + 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; +} + +# map of HTML escapes to TeX escapes. +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" => '\\u{A}', # capital A, ring + "aring" => '\\u{a}', # 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{C}', # capital C, cedilla + "ccedil" => '\\c{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" => '\\OE', # capital Eth, Icelandic + "eth" => '\\oe', # 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" => '\\ss', # small sharp s, German (sz ligature) + "THORN" => '\\L', # capital THORN, Icelandic + "thorn" => '\\l',, # 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 +); +} +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; diff --git a/pod/pod2latex.SH b/pod/pod2latex.SH deleted file mode 100755 index 45f64232be..0000000000 --- a/pod/pod2latex.SH +++ /dev/null @@ -1,660 +0,0 @@ -case $CONFIG in -'') - if test -f config.sh; then TOP=.; - elif test -f ../config.sh; then TOP=..; - elif test -f ../../config.sh; then TOP=../..; - elif test -f ../../../config.sh; then TOP=../../..; - elif test -f ../../../../config.sh; then TOP=../../../..; - else - echo "Can't find config.sh."; exit 1 - fi - . $TOP/config.sh - ;; -esac -case "$0" in -*/*) cd `expr X$0 : 'X\(.*\)/'` ;; -esac -echo "Extracting pod/pod2latex (with variable substitutions)" -rm -f pod2latex -$spitshell >pod2latex <>pod2latex <<'!NO!SUBS!' -# -# pod2latex, version 1.1 -# by Taro Kawagish (kawagish@imslab.co.jp), Jan 11, 1995. -# -# pod2latex filters Perl pod documents to LaTeX documents. -# -# What pod2latex does: -# 1. Pod file 'perl_doc_entry.pod' is filtered to 'perl_doc_entry.tex'. -# 2. Indented paragraphs are translated into -# '\begin{verbatim} ... \end{verbatim}'. -# 3. '=head1 heading' command is translated into '\section{heading}' -# 4. '=head2 heading' command is translated into '\subsection*{heading}' -# 5. '=over N' command is translated into -# '\begin{itemize}' if following =item starts with *, -# '\begin{enumerate}' if following =item starts with 1., -# '\begin{description}' if else. -# (indentation level N is ignored.) -# 6. '=item * heading' command is translated into '\item heading', -# '=item 1. heading' command is translated into '\item heading', -# '=item heading' command(other) is translated into '\item[heading]'. -# 7. '=back' command is translated into -# '\end{itemize}' if started with '\begin{itemize}', -# '\end{enumerate}' if started with '\begin{enumerate}', -# '\end{description}' if started with '\begin{description}'. -# 8. other paragraphs are translated into strings with TeX special characters -# escaped. -# 9. In heading text, and other paragraphs, the following translation of pod -# quotes are done, and then TeX special characters are escaped after that. -# I to {\em text\/}, -# B to {\bf text}, -# S to text1, -# where text1 is a string with blank characters replaced with ~, -# C to {\tt text2}, -# where text2 is a string with TeX special characters escaped to -# obtain a literal printout, -# E (HTML escape) to TeX escaped string, -# L to referencing string as is done by pod2man, -# F to {\em file\/}, -# Z<> to a null string, -# 10. those headings are indexed: -# '=head1 heading' => \section{heading}\index{heading} -# '=head2 heading' => \subsection*{heading}\index{heading} -# only when heading does not match frequent patterns such as -# DESCRIPTION, DIAGNOSTICS,... -# '=item heading' => \item{heading}\index{heading} -# -# Usage: -# pod2latex perl_doc_entry.pod -# this will write to a file 'perl_doc_entry.tex'. -# -# To LaTeX: -# The following commands need to be defined in the preamble of the LaTeX -# document: -# \def\C++{{\rm C\kern-.05em\raise.3ex\hbox{\footnotesize ++}}} -# \def\underscore{\leavevmode\kern.04em\vbox{\hrule width 0.4em height 0.3pt}} -# and \parindent should be set zero: -# \setlength{\parindent}{0pt} -# -# Note: -# This script was written modifing pod2man. -# -# Bug: -# If HTML escapes E other than E,E,E,E are used -# in C<>, translation will produce wrong character strings. -# Translation of HTML escapes of various European accents might be wrong. - - -$/ = ""; # record separator is blank lines -# TeX special characters. -##$tt_ables = "!@*()-=+|;:'\"`,./?<>"; -$backslash_escapables = "#\$%&{}_"; -$backslash_escapables2 = "#\$%&{}"; # except _ -##$nonverbables = "^\\~"; -##$bracketesc = "[]"; -##@tex_verb_fences = unpack("aaaaaaaaa","|#@!*+?:;"); - -@head1_freq_patterns # =head1 patterns which need not be index'ed - = ("AUTHOR","Author","BUGS","DATE","DESCRIPTION","DIAGNOSTICS", - "ENVIRONMENT","EXAMPLES","FILES","INTRODUCTION","NAME","NOTE", - "SEE ALSO","SYNOPSIS","WARNING"); - -$indent = 0; - -# parse the pods, produce LaTeX. - -open(POD,"<$ARGV[0]") || die "cant open $ARGV[0]"; -($pod=$ARGV[0]) =~ s/\.pod$//; -open(LATEX,">$pod.tex"); -&do_hdr(); - -$cutting = 1; -while () { - if ($cutting) { - next unless /^=/; - $cutting = 0; - } - chop; - length || (print LATEX "\n") && next; - - # translate indented lines as a verabatim paragraph - if (/^\s/) { - @lines = split(/\n/); - print LATEX "\\begin{verbatim}\n"; - for (@lines) { - 1 while s - {^( [^\t]* ) \t ( \t* ) } - { $1 . ' ' x (8 - (length($1)%8) + 8*(length($2))) }ex; - print LATEX $_,"\n"; - } - print LATEX "\\end{verbatim}\n"; - next; - } - - # preserve '=item' line with pod quotes as they are. - if (/^=item/) { - ($bareitem = $_) =~ s/^=item\s*//; - } - - # check for things that'll hosed our noremap scheme; affects $_ - &init_noremap(); - - # expand strings "func()" as pod quotes. - if (!/^=item/) { - # first hide pod escapes. - # escaped strings are mapped into the ones with the MSB's on. - s/([A-Z]<[^<>]*>)/noremap($1)/ge; - - # func() is a reference to a perl function - s{\b([:\w]+\(\))}{I<$1>}g; - # func(n) is a reference to a man page - s{(\w+)(\([^\s,\051]+\))}{I<$1>$2}g; - # convert simple variable references -# s/([\$\@%][\w:]+)/C<$1>/g; -# s/\$[\w:]+\[[0-9]+\]/C<$&>/g; - - if (m{ ([\-\w]+\([^\051]*?[\@\$,][^\051]*?\)) - }x && $` !~ /([LCI]<[^<>]*|-)$/ && !/^=\w/) - { - warn "``$1'' should be a [LCI]<$1> ref"; - } - while (/(-[a-zA-Z])\b/g && $` !~ /[\w\-]$/) { - warn "``$1'' should be [CB]<$1> ref"; - } - - # put back pod quotes so we get the inside of <> processed; - $_ = &clear_noremap($_); - } - - - # process TeX special characters - - # First hide HTML quotes E<> since they can be included in C<>. - s/(E<[^<>]+>)/noremap($1)/ge; - - # Then hide C<> type literal quotes. - # String inside of C<> will later be expanded into {\tt ..} strings - # with TeX special characters escaped as needed. - s/(C<[^<>]*>)/&noremap($1)/ge; - - # Next escape TeX special characters including other pod quotes B< >,... - # - # NOTE: s/re/&func($str)/e evaluates $str just once in perl5. - # (in perl4 evaluation takes place twice before getting passed to func().) - - # - hyphen => --- - s/(\S+)(\s+)-+(\s+)(\S+)/"$1".&noremap(" --- ")."$4"/ge; - # '-', '--', "-" => '{\tt -}', '{\tt --}', "{\tt -}" -## s/("|')(\s*)(-+)(\s*)\1/&noremap("$1$2\{\\tt $3\}$4$1")/ge; -## changed Wed Jan 25 15:26:39 JST 1995 - # '-', '--', "-" => '$-$', '$--$', "$-$" - s/(\s+)(['"])(-+)([^'"\-]*)\2(\s+|[,.])/"$1$2".&noremap("\$$3\$")."$4$2$5"/ge; - s/(\s+)(['"])([^'"\-]*)(-+)(\s*)\2(\s+|[,.])/"$1$2$3".&noremap("\$$4\$")."$5$2$6"/ge; - # (--|-) => ($--$|$-$) - s/(\s+)\((-+)([=@%\$\+\\\|\w]*)(-*)([=@%\$\+\\\|\w]*)\)(\s+|[,.])/"$1\(".&noremap("\$$2\$")."$3".&noremap("\$$4\$")."$5\)$6"/ge; - # numeral - => $-$ - s/(\(|[0-9]+|\s+)-(\s*\(?\s*[0-9]+)/&noremap("$1\$-\$$2")/ge; - # -- in quotes => two separate - - s/B<([^<>]*)--([^<>]*)>/&noremap("B<$1\{\\tt --\}$2>")/ge; - - # backslash escapable characters except _. - s/([$backslash_escapables2])/&noremap("\\$1")/ge; - s/_/&noremap("\\underscore{}")/ge; # a litle thicker than \_. - # quote TeX special characters |, ^, ~, \. - s/\|/&noremap("\$|\$")/ge; - s/\^/&noremap("\$\\hat{\\hspace{0.4em}}\$")/ge; - s/\~/&noremap("\$\\tilde{\\hspace{0.4em}}\$")/ge; - s/\\/&noremap("\$\\backslash{}\$")/ge; - # quote [ and ] to be used in \item[] - s/([\[\]])/&noremap("{\\tt $1}")/ge; - # characters need to be treated differently in TeX - # keep * if an item heading - s/^(=item[ \t]+)[*]((.|\n)*)/"$1" . &noremap("*") . "$2"/ge; - s/[*]/&noremap("\$\\ast\$")/ge; # other * - - # hide other pod quotes. - s/([ABD-Z]<[^<>]*>)/&noremap($1)/ge; - - # escape < and > as math strings, - # now that we are done with hiding pod <> quotes. - s//&noremap("\$>\$")/ge; - - # put it back so we get the <> processed again; - $_ = &clear_noremap($_); - - - # Expand pod quotes recursively: - # (1) type face directives [BIFS]<[^<>]*> to appropriate TeX commands, - # (2) L<[^<>]*> to reference strings, - # (3) C<[^<>]*> to TeX literal quotes, - # (4) HTML quotes E<> inside of C<> quotes. - - # Hide E<> again since they can be included in C<>. - s/(E<[^<>]+>)/noremap($1)/ge; - - $maxnest = 10; - while ($maxnest-- && /[A-Z]]*)>/"{\\bf $1}"/eg; - s#I<([^<>]*)>#"{\\em $1\\/}"#eg; - - # files and filelike refs in italics - s#F<([^<>]*)>#"{\\em $1\\/}"#eg; - - # no break quote -- usually we want C<> for this - s/S<([^<>]*)>/&nobreak($1)/eg; - - # LREF: a manpage(3f) - s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))?>:the {\\em $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 - (,?\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>" - } - }gex; - - s/Z<>/\\&/g; # the "don't format me" thing - - # comes last because not subject to reprocessing - s{ - C<([^<>]*)> - }{ - do { - ($str = $1) =~ tr/\200-\377/\000-\177/; #normalize hidden stuff - # expand HTML escapes if any; - # WARNING: if HTML escapes other than E,E,E, - # E are in C<>, they will not be printed correctly. - $str = &expand_HTML_escapes($str); - $strverb = &alltt($str); # Tex verbatim escape of a string. - &noremap("$strverb"); - } - }gex; - -# if ( /C<([^<>]*)/ ) { -# $str = $1; -# if ($str !~ /\|/) { # if includes | -# s/C<([^<>]*)>/&noremap("\\verb|$str|")/eg; -# } else { -# print STDERR "found \| in C<.*> at paragraph $.\n"; -# # find a character not contained in $str to use it as a -# # separator of the \verb -# ($chars = $str) =~ s/(\W)/\\$1/g; -# ## ($chars = $str) =~ s/([\$<>,\|"'\-^{}()*+?\\])/\\$1/g; -# @fence = grep(!/[ $chars]/,@tex_verb_fences); -# s/C<([^<>]*)>/&noremap("\\verb$fence[0]$str$fence[0]")/eg; -# } -# } - } - - - # process each pod command - if (s/^=//) { # if a command - s/\n/ /g; - ($cmd, $rest) = split(' ', $_, 2); - $rest =~ s/^\s*//; - $rest =~ s/\s*$//; - - if (defined $rest) { - &escapes; - } - - $rest = &clear_noremap($rest); - $rest = &expand_HTML_escapes($rest); - - if ($cmd eq 'cut') { - $cutting = 1; - $lastcmd = 'cut'; - } - elsif ($cmd eq 'head1') { # heading type 1 - $rest =~ s/^\s*//; $rest =~ s/\s*$//; - print LATEX "\n\\subsection*{$rest}"; - # put index entry - ($index = $rest) =~ s/^(An?\s+|The\s+)//i; # remove 'A' and 'The' - # index only those heads not matching the frequent patterns. - foreach $pat (@head1_freq_patterns) { - if ($index =~ /^$pat/) { - goto freqpatt; - } - } - print LATEX "%\n\\index{$index}\n" if ($index); - freqpatt: - $lastcmd = 'head1'; - } - elsif ($cmd eq 'head2') { # heading type 2 - $rest =~ s/^\s*//; $rest =~ s/\s*$//; - print LATEX "\n\\subsubsection*{$rest}"; - # put index entry - ($index = $rest) =~ s/^(An?\s+|The\s+)//i; # remove 'A' and 'The' - $index =~ s/^Example\s*[1-9][0-9]*\s*:\s*//; # remove 'Example :' - print LATEX "%\n\\index{$index}\n" if ($index); - $lastcmd = 'head2'; - } - elsif ($cmd eq 'over') { # 1 level within a listing environment - push(@indent,$indent); - $indent = $rest + 0; - $lastcmd = 'over'; - } - elsif ($cmd eq 'back') { # 1 level out of a listing environment - $indent = pop(@indent); - warn "Unmatched =back\n" unless defined $indent; - $listingcmd = pop(@listingcmd); - print LATEX "\n\\end{$listingcmd}\n" if ($listingcmd); - $lastcmd = 'back'; - } - elsif ($cmd eq 'item') { # an item paragraph starts - if ($lastcmd eq 'over') { # if we have just entered listing env - # see what type of list environment we are in. - if ($rest =~ /^[0-9]\.?/) { # if numeral heading - $listingcmd = 'enumerate'; - } elsif ($rest =~ /^\*\s*/) { # if * heading - $listingcmd = 'itemize'; - } elsif ($rest =~ /^[^*]/) { # if other headings - $listingcmd = 'description'; - } else { - warn "unknown list type for item $rest"; - } - print LATEX "\n\\begin{$listingcmd}\n"; - push(@listingcmd,$listingcmd); - } elsif ($lastcmd ne 'item') { - warn "Illegal '=item' command without preceding 'over':"; - warn "=item $bareitem"; - } - - if ($listingcmd eq 'enumerate') { - $rest =~ s/^[0-9]+\.?\s*//; # remove numeral heading - print LATEX "\n\\item"; - print LATEX "{\\bf $rest}" if $rest; - } elsif ($listingcmd eq 'itemize') { - $rest =~ s/^\*\s*//; # remove * heading - print LATEX "\n\\item"; - print LATEX "{\\bf $rest}" if $rest; - } else { # description item - print LATEX "\n\\item[$rest]"; - } - $lastcmd = 'item'; - $rightafter_item = 'yes'; - - # check if the item heading is short or long. - ($itemhead = $rest) =~ s/{\\bf (\S*)}/$1/g; - if (length($itemhead) < 4) { - $itemshort = "yes"; - } else { - $itemshort = "no"; - } - # write index entry - if ($pod =~ "perldiag") { # skip 'perldiag.pod' - goto noindex; - } - # strip out the item of pod quotes and get a plain text entry - $bareitem =~ s/\n/ /g; # remove newlines - $bareitem =~ s/\s*$//; # remove trailing space - $bareitem =~ s/[A-Z]<([^<>]*)>/$1/g; # remove <> quotes - ($index = $bareitem) =~ s/^\*\s+//; # remove leading '*' - $index =~ s/^(An?\s+|The\s+)//i; # remove 'A' and 'The' - $index =~ s/^\s*[1-9][0-9]*\s*[.]\s*$//; # remove numeral only - $index =~ s/^\s*\w\s*$//; # remove 1 char only's - # quote ", @ and ! with " to be used in makeindex. - $index =~ s/"/""/g; # quote " - $index =~ s/@/"@/g; # quote @ - $index =~ s/!/"!/g; # quote ! - ($rest2=$rest) =~ s/^\*\s+//; # remove * - $rest2 =~ s/"/""/g; # quote " - $rest2 =~ s/@/"@/g; # quote @ - $rest2 =~ s/!/"!/g; # quote ! - if ($pod =~ "(perlfunc|perlvar)") { # when doc is perlfunc,perlvar - # take only the 1st word of item heading - $index =~ s/^([^{}\s]*)({.*})?([^{}\s]*)\s+.*/\1\2\3/; - $rest2 =~ s/^([^{}\s]*)({.*})?([^{}\s]*)\s+.*/\1\2\3/; - } - if ($index =~ /[A-Za-z\$@%]/) { - # write \index{plain_text_entry@TeX_string_entry} - print LATEX "%\n\\index{$index\@$rest2}%\n"; - } - noindex: - ; - } - else { - warn "Unrecognized directive: $cmd\n"; - } - } - else { # if not command - &escapes; - $_ = &clear_noremap($_); - $_ = &expand_HTML_escapes($_); - - # if the present paragraphs follows an =item declaration, - # put a line break. - if ($lastcmd eq 'item' && - $rightafter_item eq 'yes' && $itemshort eq "no") { - print LATEX "\\hfil\\\\"; - $rightafter_item = 'no'; - } - print LATEX "\n",$_; - } -} - -print LATEX "\n"; -close(POD); -close(LATEX); - - -######################################################################### - -sub do_hdr { - print LATEX "% LaTeX document produced by pod2latex from \"$pod.pod\".\n"; - print LATEX "% The followings need be defined in the preamble of this document:\n"; - print LATEX "%\\def\\C++{{\\rm C\\kern-.05em\\raise.3ex\\hbox{\\footnotesize ++}}}\n"; - print LATEX "%\\def\\underscore{\\leavevmode\\kern.04em\\vbox{\\hrule width 0.4em height 0.3pt}}\n"; - print LATEX "%\\setlength{\\parindent}{0pt}\n"; - print LATEX "\n"; - $podq = &escape_tex_specials("\U$pod\E"); - print LATEX "\\section{$podq}%\n"; - print LATEX "\\index{$podq}"; - print LATEX "\n"; -} - -sub nobreak { - my $string = shift; - $string =~ s/ +/~/g; # TeX no line break - $string; -} - -sub noremap { - local($thing_to_hide) = shift; - $thing_to_hide =~ tr/\000-\177/\200-\377/; - return $thing_to_hide; -} - -sub init_noremap { - if ( /[\200-\377]/ ) { - warn "hit bit char in input stream"; - } -} - -sub clear_noremap { - local($tmp) = shift; - $tmp =~ tr/\200-\377/\000-\177/; - return $tmp; -} - -sub expand_HTML_escapes { - local($s) = $_[0]; - $s =~ s { E<([A-Za-z]+)> } - { - do { - exists $HTML_Escapes{$1} - ? do { $HTML_Escapes{$1} } - : do { - warn "Unknown escape: $& in $_"; - "E<$1>"; - } - } - }egx; - return $s; -} - -sub escapes { - # make C++ into \C++, which is to be defined as - # \def\C++{{\rm C\kern-.05em\raise.3ex\hbox{\footnotesize ++}}} - s/\bC\+\+/\\C++{}/g; -} - -# Translate a string into a TeX \tt string to obtain a verbatim print out. -# TeX special characters are escaped by \. -# This can be used inside of LaTeX command arguments. -# We don't use LaTeX \verb since it doesn't work inside of command arguments. -sub alltt { - local($str) = shift; - # other chars than #,\,$,%,&,{,},_,\,^,~ ([ and ] included). - $str =~ s/([^${backslash_escapables}\\\^\~]+)/&noremap("$&")/eg; - # chars #,\,$,%,&,{,} => \# , ... - $str =~ s/([$backslash_escapables2])/&noremap("\\$&")/eg; - # chars _,\,^,~ => \char`\_ , ... - $str =~ s/_/&noremap("\\char`\\_")/eg; - $str =~ s/\\/&noremap("\\char`\\\\")/ge; - $str =~ s/\^/\\char`\\^/g; - $str =~ s/\~/\\char`\\~/g; - - $str =~ tr/\200-\377/\000-\177/; # put back - $str = "{\\tt ".$str."}"; # make it a \tt string - return $str; -} - -sub escape_tex_specials { - local($str) = shift; - # other chars than #,\,$,%,&,{,}, _,\,^,~ ([ and ] included). - # backslash escapable characters #,\,$,%,&,{,} except _. - $str =~ s/([$backslash_escapables2])/&noremap("\\$1")/ge; - $str =~ s/_/&noremap("\\underscore{}")/ge; # \_ is too thin. - # quote TeX special characters |, ^, ~, \. - $str =~ s/\|/&noremap("\$|\$")/ge; - $str =~ s/\^/&noremap("\$\\hat{\\hspace{0.4em}}\$")/ge; - $str =~ s/\~/&noremap("\$\\tilde{\\hspace{0.4em}}\$")/ge; - $str =~ s/\\/&noremap("\$\\backslash{}\$")/ge; - # characters need to be treated differently in TeX - # * - $str =~ s/[*]/&noremap("\$\\ast\$")/ge; - # escape < and > as math string, - $str =~ s//&noremap("\$>\$")/ge; - $str =~ tr/\200-\377/\000-\177/; # put back - return $str; -} - -sub internal_lrefs { - 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; -} - -# map of HTML escapes to TeX escapes. -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" => '\\u{A}', # capital A, ring - "aring" => '\\u{a}', # 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{C}', # capital C, cedilla - "ccedil" => '\\c{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" => '\\OE', # capital Eth, Icelandic - "eth" => '\\oe', # 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" => '\\ss', # small sharp s, German (sz ligature) - "THORN" => '\\L', # capital THORN, Icelandic - "thorn" => '\\l',, # 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 -); -} -!NO!SUBS! -chmod 755 pod2latex -$eunicefix pod2latex diff --git a/pod/pod2man.PL b/pod/pod2man.PL new file mode 100644 index 0000000000..3a8c5db2a8 --- /dev/null +++ b/pod/pod2man.PL @@ -0,0 +1,665 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir(dirname($0)); +($file = basename($0)) =~ s/\.PL$//; +$file =~ s/\.pl$// + if ($Config{'osname'} eq 'VMS' or + $Config{'osname'} eq 'OS2'); # "case-forgiving" + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{'startperl'} + eval 'exec perl -S \$0 "\$@"' + if 0; +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; + +$/ = ""; +$cutting = 1; + +$CFont = 'CW'; +if ($ARGV[0] =~ s/-fc(.*)//) { + shift; + $CFont = $1 || shift; +} + +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'"; +} + +$name = @ARGV ? $ARGV[0] : "something"; +$name =~ s/\..*//; + +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- +.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 L' ' +.ds R' ' +'br\\} +.el\\{\\ +.ds -- \\(em\\| +.tr \\*(Tr +.ds L" `` +.ds R" '' +.ds L' ` +.ds R' ' +.if t .ds PI \\(*p +.if n .ds PI PI +'br\\} +.TH \U$name\E 1 "\\*(RP" +.UC +END + +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 S 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; + +while (<>) { + if ($cutting) { + next unless /^=/; + $cutting = 0; + } + 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; + + # 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; + + # first hide the escapes in case we need to + # intuit something and get it wrong due to fmting + + s/([A-Z]<[^<>]*>)/noremap($1)/ge; + + # func() is a reference to a perl function + s{ + \b + ( + [:\w]+ \(\) + ) + } {I<$1>}gx; + + # func(n) is a reference to a man page + s{ + (\w+) + ( + \( + [^\s,\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 "``$1'' should be a [LCI]<$1> ref"; + } + + while (/(-[a-zA-Z])\b/g && $` !~ /[\w\-]$/) { + warn "``$1'' should be [CB]<$1> ref"; + } + + # 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]]*)>/font($1) . $2 . font('R')/eg; + + # files and filelike refs in italics + s/F<([^<>]*)>/I<$1>/g; + + # no break -- usually we want C<> for this + s/S<([^<>]*)>/nobreak($1)/eg; + + # 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>" + } + }gex; + + s/Z<>/\\&/g; + + # comes last because not subject to reprocessing + s/C<([^<>]*)>/noremap("${CFont_embed}${1}\\fR")/eg; + } + + if (s/^=//) { + $needspace = 0; # Assume this. + + s/\n/ /g; + + ($Cmd, $_) = split(' ', $_, 2); + + if (defined $_) { + &escapes; + s/"/""/g; + } + + clear_noremap(1); + + if ($Cmd eq 'cut') { + $cutting = 1; + } + elsif ($Cmd eq 'head1') { + print qq{.SH "$_"\n} + } + elsif ($Cmd eq 'head2') { + print qq{.Sh "$_"\n} + } + elsif ($Cmd eq 'over') { + push(@indent,$indent); + $indent = $_ + 0; + } + elsif ($Cmd eq 'back') { + $indent = pop(@indent); + warn "Unmatched =back\n" unless defined $indent; + $needspace = 1; + } + elsif ($Cmd eq 'item') { + s/^\*( |$)/\\(bu$1/g; + print STDOUT qq{.Ip "$_" $indent\n}; + } + else { + warn "Unrecognized directive: $Cmd\n"; + } + } + else { + if ($needspace) { + &makespace; + } + &escapes; + clear_noremap(1); + print $_, "\n"; + $needspace = 1; + } +} + +print <<"END"; + +.rn }` '' +END + +######################################################################### + +sub nobreak { + my $string = shift; + $string =~ s/ /\\ /g; + $string; +} + +sub escapes { + + # 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 + if (!/""/) { + s/(^|\s)(['"])/noremap("$1\\*(L$2")/ge; + s/(['"])($|[\-\s,;\\!?.])/noremap("\\*(R$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 \*(-- (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; + + } +} + +# 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) = @_; + if ( /^\W+$/ && !/^\$./ ) { + ($prev && "\n") . noremap(qq{.CQ $_ \n\\&}); + # what about $" ? + } else { + noremap(qq{${CFont_embed}$_\\fR}); + } + noremap(qq{.CQ "$_" \n\\&}); +} + +sub makespace { + if ($indent) { + print ".Sp\n"; + } + else { + print ".PP\n"; + } +} + +sub font { + local($font) = shift; + return '\\f' . noremap($font); +} + +sub noremap { + local($thing_to_hide) = shift; + $thing_to_hide =~ tr/\000-\177/\200-\377/; + return $thing_to_hide; +} + +sub init_noremap { + if ( /[\200-\377]/ ) { + warn "hit bit char in input stream"; + } +} + +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 + s { + E< + ( [A-Za-z]+ ) + > + } { + do { + exists $HTML_Escapes{$1} + ? do { $HTML_Escapes{$1} } + : do { + warn "Unknown escape: $& in $_"; + "E<$1>"; + } + } + }egx if $ready_to_print; +} + +sub internal_lrefs { + 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; + +} + +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 +); +} +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; diff --git a/pod/pod2man.SH b/pod/pod2man.SH deleted file mode 100755 index a1be14d4e5..0000000000 --- a/pod/pod2man.SH +++ /dev/null @@ -1,652 +0,0 @@ -case $CONFIG in -'') - if test -f config.sh; then TOP=.; - elif test -f ../config.sh; then TOP=..; - elif test -f ../../config.sh; then TOP=../..; - elif test -f ../../../config.sh; then TOP=../../..; - elif test -f ../../../../config.sh; then TOP=../../../..; - else - echo "Can't find config.sh."; exit 1 - fi - . $TOP/config.sh - ;; -esac -case "$0" in -*/*) cd `expr X$0 : 'X\(.*\)/'` ;; -esac -echo "Extracting pod/pod2man (with variable substitutions)" -rm -f pod2man -$spitshell >pod2man <>pod2man <<'!NO!SUBS!' - -$/ = ""; -$cutting = 1; - -$CFont = 'CW'; -if ($ARGV[0] =~ s/-fc(.*)//) { - shift; - $CFont = $1 || shift; -} - -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'"; -} - -$name = @ARGV ? $ARGV[0] : "something"; -$name =~ s/\..*//; - -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- -.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 L' ' -.ds R' ' -'br\\} -.el\\{\\ -.ds -- \\(em\\| -.tr \\*(Tr -.ds L" `` -.ds R" '' -.ds L' ` -.ds R' ' -.if t .ds PI \\(*p -.if n .ds PI PI -'br\\} -.TH \U$name\E 1 "\\*(RP" -.UC -END - -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 S 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; - -while (<>) { - if ($cutting) { - next unless /^=/; - $cutting = 0; - } - 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; - - # 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; - - # first hide the escapes in case we need to - # intuit something and get it wrong due to fmting - - s/([A-Z]<[^<>]*>)/noremap($1)/ge; - - # func() is a reference to a perl function - s{ - \b - ( - [:\w]+ \(\) - ) - } {I<$1>}gx; - - # func(n) is a reference to a man page - s{ - (\w+) - ( - \( - [^\s,\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 "``$1'' should be a [LCI]<$1> ref"; - } - - while (/(-[a-zA-Z])\b/g && $` !~ /[\w\-]$/) { - warn "``$1'' should be [CB]<$1> ref"; - } - - # 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]]*)>/font($1) . $2 . font('R')/eg; - - # files and filelike refs in italics - s/F<([^<>]*)>/I<$1>/g; - - # no break -- usually we want C<> for this - s/S<([^<>]*)>/nobreak($1)/eg; - - # 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>" - } - }gex; - - s/Z<>/\\&/g; - - # comes last because not subject to reprocessing - s/C<([^<>]*)>/noremap("${CFont_embed}${1}\\fR")/eg; - } - - if (s/^=//) { - $needspace = 0; # Assume this. - - s/\n/ /g; - - ($Cmd, $_) = split(' ', $_, 2); - - if (defined $_) { - &escapes; - s/"/""/g; - } - - clear_noremap(1); - - if ($Cmd eq 'cut') { - $cutting = 1; - } - elsif ($Cmd eq 'head1') { - print qq{.SH "$_"\n} - } - elsif ($Cmd eq 'head2') { - print qq{.Sh "$_"\n} - } - elsif ($Cmd eq 'over') { - push(@indent,$indent); - $indent = $_ + 0; - } - elsif ($Cmd eq 'back') { - $indent = pop(@indent); - warn "Unmatched =back\n" unless defined $indent; - $needspace = 1; - } - elsif ($Cmd eq 'item') { - s/^\*( |$)/\\(bu$1/g; - print STDOUT qq{.Ip "$_" $indent\n}; - } - else { - warn "Unrecognized directive: $Cmd\n"; - } - } - else { - if ($needspace) { - &makespace; - } - &escapes; - clear_noremap(1); - print $_, "\n"; - $needspace = 1; - } -} - -print <<"END"; - -.rn }` '' -END - -######################################################################### - -sub nobreak { - my $string = shift; - $string =~ s/ /\\ /g; - $string; -} - -sub escapes { - - # 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 - if (!/""/) { - s/(^|\s)(['"])/noremap("$1\\*(L$2")/ge; - s/(['"])($|[\-\s,;\\!?.])/noremap("\\*(R$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 \*(-- (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; - - } -} - -# 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) = @_; - if ( /^\W+$/ && !/^\$./ ) { - ($prev && "\n") . noremap(qq{.CQ $_ \n\\&}); - # what about $" ? - } else { - noremap(qq{${CFont_embed}$_\\fR}); - } - noremap(qq{.CQ "$_" \n\\&}); -} - -sub makespace { - if ($indent) { - print ".Sp\n"; - } - else { - print ".PP\n"; - } -} - -sub font { - local($font) = shift; - return '\\f' . noremap($font); -} - -sub noremap { - local($thing_to_hide) = shift; - $thing_to_hide =~ tr/\000-\177/\200-\377/; - return $thing_to_hide; -} - -sub init_noremap { - if ( /[\200-\377]/ ) { - warn "hit bit char in input stream"; - } -} - -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 - s { - E< - ( [A-Za-z]+ ) - > - } { - do { - exists $HTML_Escapes{$1} - ? do { $HTML_Escapes{$1} } - : do { - warn "Unknown escape: $& in $_"; - "E<$1>"; - } - } - }egx if $ready_to_print; -} - -sub internal_lrefs { - 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; - -} - -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 -); -} -!NO!SUBS! -chmod 755 pod2man -$eunicefix pod2man diff --git a/pp.c b/pp.c index 446ddb0f55..048af2e19d 100644 --- a/pp.c +++ b/pp.c @@ -126,7 +126,7 @@ PP(pp_rv2gv) GP *ogp = GvGP(sv); SSCHECK(3); - SSPUSHPTR(sv); + SSPUSHPTR(SvREFCNT_inc(sv)); SSPUSHPTR(ogp); SSPUSHINT(SAVEt_GP); @@ -200,6 +200,8 @@ PP(pp_rv2sv) if (SvGMAGICAL(sv)) mg_get(sv); if (!SvOK(sv)) { + if (SvREADONLY(sv)) + croak(no_modify); (void)SvUPGRADE(sv, SVt_RV); SvRV(sv) = (op->op_private & OPpDEREF_HV ? (SV*)newHV() : (SV*)newAV()); @@ -256,9 +258,12 @@ PP(pp_rv2cv) GV *gv; HV *stash; - /* We always try to add a non-existent subroutine in case of AUTOLOAD. */ - CV *cv = sv_2cv(TOPs, &stash, &gv, TRUE); + /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */ + /* (But not in defined().) */ + CV *cv = sv_2cv(TOPs, &stash, &gv, !(op->op_flags & OPf_SPECIAL)); + if (!cv) + cv = (CV*)&sv_undef; SETs((SV*)cv); RETURN; } @@ -329,7 +334,7 @@ PP(pp_ref) sv = POPs; if (!sv || !SvROK(sv)) - RETPUSHUNDEF; + RETPUSHNO; sv = SvRV(sv); pv = sv_reftype(sv,TRUE); @@ -539,16 +544,14 @@ PP(pp_undef) break; } default: - if (sv != GvSV(defgv)) { - if (SvPOK(sv) && SvLEN(sv)) { - (void)SvOOK_off(sv); - Safefree(SvPVX(sv)); - SvPV_set(sv, Nullch); - SvLEN_set(sv, 0); - } - (void)SvOK_off(sv); - SvSETMAGIC(sv); + if (SvPOK(sv) && SvLEN(sv)) { + (void)SvOOK_off(sv); + Safefree(SvPVX(sv)); + SvPV_set(sv, Nullch); + SvLEN_set(sv, 0); } + (void)SvOK_off(sv); + SvSETMAGIC(sv); } RETPUSHUNDEF; @@ -890,7 +893,7 @@ PP(pp_bit_and) { dSP; dATARGET; tryAMAGICbin(band,opASSIGN); { dPOPTOPssrl; - if (SvNIOK(left) || SvNIOK(right)) { + if (SvNIOKp(left) || SvNIOKp(right)) { unsigned long value = U_L(SvNV(left)); value = value & U_L(SvNV(right)); SETn((double)value); @@ -908,7 +911,7 @@ PP(pp_bit_xor) dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); { dPOPTOPssrl; - if (SvNIOK(left) || SvNIOK(right)) { + if (SvNIOKp(left) || SvNIOKp(right)) { unsigned long value = U_L(SvNV(left)); value = value ^ U_L(SvNV(right)); SETn((double)value); @@ -926,7 +929,7 @@ PP(pp_bit_or) dSP; dATARGET; tryAMAGICbin(bor,opASSIGN); { dPOPTOPssrl; - if (SvNIOK(left) || SvNIOK(right)) { + if (SvNIOKp(left) || SvNIOKp(right)) { unsigned long value = U_L(SvNV(left)); value = value | U_L(SvNV(right)); SETn((double)value); @@ -944,9 +947,11 @@ PP(pp_negate) dSP; dTARGET; tryAMAGICun(neg); { dTOPss; - if (SvNIOK(sv)) + if (SvGMAGICAL(sv)) + mg_get(sv); + if (SvNIOKp(sv)) SETn(-SvNV(sv)); - else if (SvPOK(sv)) { + else if (SvPOKp(sv)) { STRLEN len; char *s = SvPV(sv, len); if (isALPHA(*s) || *s == '_') { @@ -961,6 +966,8 @@ PP(pp_negate) sv_setnv(TARG, -SvNV(sv)); SETTARG; } + else + SETn(-SvNV(sv)); } RETURN; } @@ -981,7 +988,7 @@ PP(pp_complement) dTOPss; register I32 anum; - if (SvNIOK(sv)) { + if (SvNIOKp(sv)) { IV iv = ~SvIV(sv); if (iv < 0) SETn( (double) ~U_L(SvNV(sv)) ); @@ -1885,6 +1892,8 @@ PP(pp_lslice) SV **firstlelem = stack_base + POPMARK + 1; register SV **firstrelem = lastlelem + 1; I32 arybase = curcop->cop_arybase; + I32 lval = op->op_flags & OPf_MOD; + I32 is_something_there = lval; register I32 max = lastrelem - lastlelem; register SV **lelem; @@ -1923,8 +1932,13 @@ PP(pp_lslice) if (ix >= max || !(*lelem = firstrelem[ix])) *lelem = &sv_undef; } + if (!is_something_there && (SvOKp(*lelem) || SvGMAGICAL(*lelem))) + is_something_there = TRUE; } - SP = lastlelem; + if (is_something_there) + SP = lastlelem; + else + SP = firstlelem - 1; RETURN; } @@ -1947,8 +1961,6 @@ PP(pp_anonhash) SV* key = *++MARK; char *tmps; SV *val = NEWSV(46, 0); - if (dowarn && key && SvROK(key)) /* Tom's gripe */ - warn("Attempt to use reference as hash key"); if (MARK < SP) sv_setsv(val, *++MARK); else diff --git a/pp_ctl.c b/pp_ctl.c index 6a34798108..68628f164e 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -67,12 +67,18 @@ PP(pp_regcomp) { tmpstr = POPs; t = SvPV(tmpstr, len); - if (pm->op_pmregexp) { - pregfree(pm->op_pmregexp); - pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */ - } + /* JMR: Check against the last compiled regexp */ + if ( ! pm->op_pmregexp || ! pm->op_pmregexp->precomp + || strnNE(pm->op_pmregexp->precomp, t, len) + || pm->op_pmregexp->precomp[len]) { + if (pm->op_pmregexp) { + pregfree(pm->op_pmregexp); + pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */ + } - pm->op_pmregexp = pregcomp(t, t + len, pm); + pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */ + pm->op_pmregexp = pregcomp(t, t + len, pm); + } if (!pm->op_pmregexp->prelen && curpm) pm = curpm; @@ -114,6 +120,7 @@ PP(pp_substcont) SV *targ = cx->sb_targ; sv_catpvn(dstr, s, cx->sb_strend - s); + (void)SvOOK_off(targ); Safefree(SvPVX(targ)); SvPVX(targ) = SvPVX(dstr); SvCUR_set(targ, SvCUR(dstr)); @@ -124,6 +131,7 @@ PP(pp_substcont) (void)SvPOK_only(targ); SvSETMAGIC(targ); PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1))); + LEAVE_SCOPE(cx->sb_oldsave); POPSUBST(cx); RETURNOP(pm->op_next); } @@ -698,7 +706,7 @@ PP(pp_flop) register SV *sv; I32 max; - if (SvNIOK(left) || !SvPOK(left) || + if (SvNIOKp(left) || !SvPOKp(left) || (looks_like_number(left) && *SvPVX(left) != '0') ) { i = SvIV(left); max = SvIV(right); @@ -716,7 +724,7 @@ PP(pp_flop) char *tmps = SvPV(final, len); sv = sv_mortalcopy(left); - while (!SvNIOK(sv) && SvCUR(sv) <= len && + while (!SvNIOKp(sv) && SvCUR(sv) <= len && strNE(SvPVX(sv),tmps) ) { XPUSHs(sv); sv = sv_2mortal(newSVsv(sv)); @@ -942,12 +950,27 @@ char *message; register CONTEXT *cx; I32 gimme; SV **newsp; - SV *errsv; - - errsv = GvSV(gv_fetchpv("@",TRUE, SVt_PV)); - /* As destructors may produce errors we set $@ at the last moment */ - sv_setpv(errsv, ""); /* clear $@ before destroying */ + if (in_eval & 4) { + SV **svp; + STRLEN klen = strlen(message); + + svp = hv_fetch(GvHV(errgv), message, klen, TRUE); + if (svp) { + if (!SvIOK(*svp)) { + static char prefix[] = "\t(in cleanup) "; + sv_upgrade(*svp, SVt_IV); + (void)SvIOK_only(*svp); + SvGROW(GvSV(errgv), SvCUR(GvSV(errgv))+sizeof(prefix)+klen); + sv_catpvn(GvSV(errgv), prefix, sizeof(prefix)-1); + sv_catpvn(GvSV(errgv), message, klen); + } + sv_inc(*svp); + } + } + else + sv_catpv(GvSV(errgv), message); + cxix = dopoptoeval(cxstack_ix); if (cxix >= 0) { I32 optype; @@ -968,9 +991,8 @@ char *message; LEAVE; - sv_insert(errsv, 0, 0, message, strlen(message)); if (optype == OP_REQUIRE) - DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), na)); + DIE("%s", SvPVx(GvSV(errgv), na)); return pop_return(); } } @@ -1082,10 +1104,14 @@ PP(pp_caller) PUSHs(sv_2mortal(newSViv(0))); } PUSHs(sv_2mortal(newSViv((I32)cx->blk_gimme))); - if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) - PUSHs(cx->blk_eval.cur_text); - - if (cx->blk_sub.hasargs && curcop->cop_stash == debstash) { + if (cx->cx_type == CXt_EVAL) { + if (cx->blk_eval.old_op_type == OP_ENTEREVAL) + PUSHs(cx->blk_eval.cur_text); + } + else if (cx->cx_type == CXt_SUB && + cx->blk_sub.hasargs && + curcop->cop_stash == debstash) + { AV *ary = cx->blk_sub.argarray; int off = AvARRAY(ary) - AvALLOC(ary); @@ -1141,6 +1167,15 @@ const void *b; register SV *str2 = *(SV **) b; I32 retval; + if (!SvPOKp(str1)) { + if (!SvPOKp(str2)) + return 0; + else + return -1; + } + if (!SvPOKp(str2)) + return 1; + if (SvCUR(str1) < SvCUR(str2)) { /*SUPPRESS 560*/ if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str1))) @@ -1192,17 +1227,17 @@ PP(pp_dbstate) I32 hasargs; GV *gv; - ENTER; - SAVETMPS; - gv = DBgv; cv = GvCV(gv); if (!cv) DIE("No DB::DB routine defined"); - if (CvDEPTH(cv) >= 1 && !(debug & (1<<30))) /* don't do recursive DB::DB call */ + if (CvDEPTH(cv) >= 1) /* don't do recursive DB::DB call */ return NORMAL; + ENTER; + SAVETMPS; + SAVEI32(debug); SAVESPTR(stack_sp); debug = 0; @@ -1234,19 +1269,30 @@ PP(pp_enteriter) I32 gimme = GIMME; SV **svp; + ENTER; + SAVETMPS; + if (op->op_targ) svp = &curpad[op->op_targ]; /* "my" variable */ else svp = &GvSV((GV*)POPs); /* symbol table variable */ - ENTER; - SAVETMPS; + SAVESPTR(*svp); + ENTER; PUSHBLOCK(cx, CXt_LOOP, SP); PUSHLOOP(cx, svp, MARK); - cx->blk_loop.iterary = stack; - cx->blk_loop.iterix = MARK - stack_base; + if (op->op_flags & OPf_STACKED) { + AV* av = (AV*)POPs; + cx->blk_loop.iterary = av; + cx->blk_loop.iterix = -1; + } + else { + cx->blk_loop.iterary = stack; + AvFILL(stack) = sp - stack_base; + cx->blk_loop.iterix = MARK - stack_base; + } RETURN; } @@ -1572,8 +1618,8 @@ PP(pp_goto) Copy(AvARRAY(av), ++stack_sp, items, SV*); stack_sp += items; GvAV(defgv) = cx->blk_sub.savearray; - av_clear(av); AvREAL_off(av); + av_clear(av); } if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) SvREFCNT_dec(cx->blk_sub.cv); @@ -1926,7 +1972,7 @@ int gimme; rslen = 1; rschar = '\n'; rspara = 0; - sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),""); + sv_setpv(GvSV(errgv),""); if (yyparse() || error_count || !eval_root) { SV **newsp; I32 gimme; @@ -1944,7 +1990,7 @@ int gimme; lex_end(); LEAVE; if (optype == OP_REQUIRE) - DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), na)); + DIE("%s", SvPVx(GvSV(errgv), na)); rs = nrs; rslen = nrslen; rschar = nrschar; @@ -1981,7 +2027,7 @@ PP(pp_require) FILE *tryrsfp = 0; sv = POPs; - if (SvNIOK(sv) && !SvPOKp(sv)) { + if (SvNIOKp(sv) && !SvPOKp(sv)) { if (atof(patchlevel) + 0.000999 < SvNV(sv)) DIE("Perl %3.3f required--this is only version %s, stopped", SvNV(sv),patchlevel); @@ -1990,6 +2036,7 @@ PP(pp_require) name = SvPV(sv, na); if (!*name) DIE("Null filename used"); + TAINT_PROPER("require"); if (op->op_type == OP_REQUIRE && (svp = hv_fetch(GvHVn(incgv), name, SvCUR(sv), 0)) && *svp != &sv_undef) @@ -2002,9 +2049,12 @@ PP(pp_require) (*tmpname == '.' && (tmpname[1] == '/' || (tmpname[1] == '.' && tmpname[2] == '/'))) +#ifdef DOSISH + || (tmpname[0] && tmpname[1] == ':') +#endif #ifdef VMS - || ((*tmpname == '[' || *tmpname == '<') && - (tmpname[1] == '-' || tmpname[1] == ']' || tmpname[1] == '>')) + || (strchr(tmpname,':') || ((*tmpname == '[' || *tmpname == '<') && + (tmpname[1] == '-' || tmpname[1] == ']' || tmpname[1] == '>'))) #endif ) { @@ -2017,9 +2067,8 @@ PP(pp_require) for (i = 0; i <= AvFILL(ar); i++) { #ifdef VMS if (tounixpath_ts(SvPVx(*av_fetch(ar, i, TRUE), na),buf) == NULL) - croak("Error converting file specification %s", - SvPVx(*av_fetch(ar, i, TRUE), na)); - strcat(buf,name); + continue; + strcat(buf,name); #else (void)sprintf(buf, "%s/%s", SvPVx(*av_fetch(ar, i, TRUE), na), name); @@ -2182,7 +2231,7 @@ PP(pp_leaveeval) lex_end(); LEAVE; - sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),""); + sv_setpv(GvSV(errgv),""); RETURNOP(retop); } @@ -2202,7 +2251,7 @@ PP(pp_entertry) eval_root = op; /* Only needed so that goto works right. */ in_eval = 1; - sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),""); + sv_setpv(GvSV(errgv),""); RETURN; } @@ -2247,7 +2296,7 @@ PP(pp_leavetry) curpm = newpm; /* Don't pop $1 et al till now */ LEAVE; - sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),""); + sv_setpv(GvSV(errgv),""); RETURN; } @@ -2426,4 +2475,3 @@ SV *sv; Safefree(fops); SvCOMPILED_on(sv); } - diff --git a/pp_hot.c b/pp_hot.c index 086fc73b44..13e7c25b5a 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -150,8 +150,10 @@ PP(pp_concat) s = SvPV(left,len); sv_setpvn(TARG,s,len); } - else if (!SvOK(TARG)) + else if (!SvOK(TARG)) { + s = SvPV_force(TARG, len); sv_setpv(TARG, ""); /* Suppress warning. */ + } s = SvPV(right,len); sv_catpvn(TARG,s,len); SETTARG; @@ -163,8 +165,24 @@ PP(pp_padsv) { dSP; dTARGET; XPUSHs(TARG); - if (op->op_private & OPpLVAL_INTRO) - SAVECLEARSV(curpad[op->op_targ]); + if (op->op_flags & OPf_MOD) { + if (op->op_private & OPpLVAL_INTRO) + SAVECLEARSV(curpad[op->op_targ]); + else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV)) { + SV* sv = curpad[op->op_targ]; + if (SvGMAGICAL(sv)) + mg_get(sv); + if (!SvOK(sv)) { + if (SvREADONLY(sv)) + croak(no_modify); + (void)SvUPGRADE(sv, SVt_RV); + SvRV(sv) = (op->op_private & OPpDEREF_HV ? + (SV*)newHV() : (SV*)newAV()); + SvROK_on(sv); + SvSETMAGIC(sv); + } + } + } RETURN; } @@ -362,6 +380,8 @@ PP(pp_rv2av) if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "an ARRAY"); + if (GIMME == G_ARRAY) + RETURN; RETPUSHUNDEF; } sym = SvPV(sv,na); @@ -433,6 +453,10 @@ PP(pp_rv2hv) if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "a HASH"); + if (GIMME == G_ARRAY) { + SP--; + RETURN; + } RETSETUNDEF; } sym = SvPV(sv,na); @@ -504,6 +528,7 @@ PP(pp_aassign) ary = Null(AV*); hash = Null(HV*); while (lelem <= lastlelem) { + tainted = 0; /* Each item stands on its own, taintwise. */ sv = *lelem++; switch (SvTYPE(sv)) { case SVt_PVAV: @@ -520,9 +545,8 @@ PP(pp_aassign) (void)av_store(ary,i++,sv); if (magic) mg_set(sv); + tainted = 0; } - if (!i) - av_extend(ary, 0); break; case SVt_PVHV: { char *tmps; @@ -534,12 +558,9 @@ PP(pp_aassign) while (relem < lastrelem) { /* gobble up all the rest */ STRLEN len; - if (*relem) { + if (*relem) sv = *(relem++); - if (dowarn && SvROK(sv)) /* Tom's gripe */ - warn("Attempt to use reference as hash key"); - } - else + else sv = &sv_no, relem++; tmps = SvPV(sv, len); tmpstr = NEWSV(29,0); @@ -549,25 +570,7 @@ PP(pp_aassign) (void)hv_store(hash,tmps,len,tmpstr,0); if (magic) mg_set(tmpstr); - } - if (relem == lastrelem) { - warn("Odd number of elements in hash list"); - if (*relem) { - STRLEN len; - sv = *relem; - if (dowarn && SvROK(sv)) /* Tom's gripe */ - warn("Attempt to use reference as hash key"); - tmps = SvPV(sv, len); - tmpstr = NEWSV(29,0); - (void) hv_store(hash, tmps, len, tmpstr, 0); - if (magic) - mg_set(tmpstr); - } - relem++; /* allow for (%a,%b) = 1; */ - } - if (!HvARRAY(hash) && !magic) { - Newz(42, hash->sv_any->xhv_array, - sizeof(HE*) * (HvMAX(hash)+1), char); + tainted = 0; } } break; @@ -652,7 +655,7 @@ PP(pp_aassign) gid = (int)getgid(); egid = (int)getegid(); } - tainting |= (euid != uid || egid != gid); + tainting |= (uid && (euid != uid || egid != gid)); } delaymagic = 0; if (GIMME == G_ARRAY) { @@ -663,16 +666,11 @@ PP(pp_aassign) RETURN; } else { + dTARGET; SP = firstrelem; - for (relem = firstrelem; relem <= lastrelem; ++relem) { - if (SvOK(*relem)) { - dTARGET; - SETi(lastrelem - firstrelem + 1); - RETURN; - } - } - RETSETUNDEF; + SETi(lastrelem - firstrelem + 1); + RETURN; } } @@ -690,6 +688,7 @@ PP(pp_match) I32 gimme = GIMME; STRLEN len; I32 minmatch = 0; + I32 oldsave = savestack_ix; if (op->op_flags & OPf_STACKED) TARG = POPs; @@ -814,6 +813,7 @@ play_it_again: ++rx->endp[0]; goto play_it_again; } + LEAVE_SCOPE(oldsave); RETURN; } else { @@ -835,6 +835,7 @@ play_it_again: else mg->mg_len = -1; } + LEAVE_SCOPE(oldsave); RETPUSHYES; } @@ -861,6 +862,7 @@ yup: tmps = rx->startp[0] = tmps + (s - t); rx->endp[0] = tmps + SvCUR(pm->op_pmshort); } + LEAVE_SCOPE(oldsave); RETPUSHYES; nope: @@ -875,6 +877,7 @@ ret_no: mg->mg_len = -1; } } + LEAVE_SCOPE(oldsave); if (gimme == G_ARRAY) RETURN; RETPUSHNO; @@ -1021,7 +1024,7 @@ do_readline() SP--; } if (!fp) { - if (dowarn && !(IoFLAGS(io) & IOf_START)) + if (dowarn && io && !(IoFLAGS(io) & IOf_START)) warn("Read on closed filehandle <%s>", GvENAME(last_in_gv)); if (GIMME == G_SCALAR) { (void)SvOK_off(TARG); @@ -1226,16 +1229,20 @@ PP(pp_iter) dSP; register CONTEXT *cx; SV *sv; + AV* av; EXTEND(sp, 1); cx = &cxstack[cxstack_ix]; if (cx->cx_type != CXt_LOOP) DIE("panic: pp_iter"); + av = cx->blk_loop.iterary; + if (av == stack && cx->blk_loop.iterix >= cx->blk_oldsp) + RETPUSHNO; - if (cx->blk_loop.iterix >= cx->blk_oldsp) + if (cx->blk_loop.iterix >= AvFILL(av)) RETPUSHNO; - if (sv = AvARRAY(cx->blk_loop.iterary)[++cx->blk_loop.iterix]) { + if (sv = AvARRAY(av)[++cx->blk_loop.iterix]) { SvTEMP_off(sv); *cx->blk_loop.itervar = sv; } @@ -1266,6 +1273,7 @@ PP(pp_subst) register REGEXP *rx = pm->op_pmregexp; STRLEN len; int force_on_match = 0; + I32 oldsave = savestack_ix; if (pm->op_pmflags & PMf_CONST) /* known replacement string? */ dstr = POPs; @@ -1368,6 +1376,7 @@ PP(pp_subst) (void)SvPOK_only(TARG); SvSETMAGIC(TARG); PUSHs(&sv_yes); + LEAVE_SCOPE(oldsave); RETURN; } /*SUPPRESS 560*/ @@ -1383,6 +1392,7 @@ PP(pp_subst) (void)SvPOK_only(TARG); SvSETMAGIC(TARG); PUSHs(&sv_yes); + LEAVE_SCOPE(oldsave); RETURN; } else if (clen) { @@ -1392,6 +1402,7 @@ PP(pp_subst) (void)SvPOK_only(TARG); SvSETMAGIC(TARG); PUSHs(&sv_yes); + LEAVE_SCOPE(oldsave); RETURN; } else { @@ -1399,6 +1410,7 @@ PP(pp_subst) (void)SvPOK_only(TARG); SvSETMAGIC(TARG); PUSHs(&sv_yes); + LEAVE_SCOPE(oldsave); RETURN; } /* NOTREACHED */ @@ -1428,9 +1440,11 @@ PP(pp_subst) (void)SvPOK_only(TARG); SvSETMAGIC(TARG); PUSHs(sv_2mortal(newSViv((I32)iters))); + LEAVE_SCOPE(oldsave); RETURN; } PUSHs(&sv_no); + LEAVE_SCOPE(oldsave); RETURN; } } @@ -1473,7 +1487,7 @@ PP(pp_subst) safebase)); sv_catpvn(dstr, s, strend - s); - SvOOK_off(TARG); + (void)SvOOK_off(TARG); Safefree(SvPVX(TARG)); SvPVX(TARG) = SvPVX(dstr); SvCUR_set(TARG, SvCUR(dstr)); @@ -1484,14 +1498,17 @@ PP(pp_subst) (void)SvPOK_only(TARG); SvSETMAGIC(TARG); PUSHs(sv_2mortal(newSViv((I32)iters))); + LEAVE_SCOPE(oldsave); RETURN; } PUSHs(&sv_no); + LEAVE_SCOPE(oldsave); RETURN; nope: ++BmUSEFUL(pm->op_pmshort); PUSHs(&sv_no); + LEAVE_SCOPE(oldsave); RETURN; } @@ -1631,8 +1648,17 @@ PP(pp_entersub) if (!CvROOT(cv) && !CvXSUB(cv)) { if (gv = CvGV(cv)) { - SV *tmpstr = sv_newmortal(); + SV *tmpstr; GV *ngv; + if (SvFAKE(cv) && GvCV(gv) != cv) { /* autoloaded stub? */ + cv = GvCV(gv); + if (SvTYPE(sv) == SVt_PVGV) { + SvREFCNT_dec(GvCV((GV*)sv)); + GvCV((GV*)sv) = (CV*)SvREFCNT_inc((SV*)cv); + } + goto retry; + } + tmpstr = sv_newmortal(); gv_efullname(tmpstr, gv); ngv = gv_fetchmethod(GvESTASH(gv), "AUTOLOAD"); if (ngv && ngv != gv && (cv = GvCV(ngv))) { /* One more chance... */ @@ -1646,6 +1672,7 @@ PP(pp_entersub) DIE("Undefined subroutine called"); } + gimme = GIMME; if ((op->op_private & OPpDEREF_DB) && !CvXSUB(cv)) { sv = GvSV(DBsub); save_item(sv); @@ -1660,8 +1687,6 @@ PP(pp_entersub) DIE("No DBsub routine"); } - gimme = GIMME; - if (CvXSUB(cv)) { if (CvOLDSTYLE(cv)) { I32 (*fp3)_((int,int,int)); diff --git a/pp_sys.c b/pp_sys.c index e40665644d..d7a6574a1c 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -130,7 +130,7 @@ PP(pp_backtick) } } } - statusvalue = my_pclose(fp); + statusvalue = FIXSTATUS(my_pclose(fp)); } else { statusvalue = -1; @@ -192,7 +192,7 @@ PP(pp_warn) tmps = SvPV(TOPs, na); } if (!tmps || !*tmps) { - SV *error = GvSV(gv_fetchpv("@", TRUE, SVt_PV)); + SV *error = GvSV(errgv); (void)SvUPGRADE(error, SVt_PV); if (SvPOK(error) && SvCUR(error)) sv_catpv(error, "\t...caught"); @@ -218,7 +218,7 @@ PP(pp_die) tmps = SvPV(TOPs, na); } if (!tmps || !*tmps) { - SV *error = GvSV(gv_fetchpv("@", TRUE, SVt_PV)); + SV *error = GvSV(errgv); (void)SvUPGRADE(error, SVt_PV); if (SvPOK(error) && SvCUR(error)) sv_catpv(error, "\t...propagated"); @@ -241,8 +241,10 @@ PP(pp_open) if (MAXARG > 1) sv = POPs; - else + else if (SvTYPE(TOPs) == SVt_PVGV) sv = GvSV(TOPs); + else + DIE(no_usym, "filehandle"); gv = (GV*)POPs; tmps = SvPV(sv, len); if (do_open(gv, tmps, len,Nullfp)) { @@ -286,6 +288,8 @@ PP(pp_pipe_op) if (!rgv || !wgv) goto badexit; + if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV) + DIE(no_usym, "filehandle"); rstio = GvIOn(rgv); wstio = GvIOn(wgv); @@ -475,7 +479,7 @@ PP(pp_dbmopen) stash = gv_stashsv(sv, FALSE); if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")) || !GvCV(gv)) { PUTBACK; - perl_requirepv("AnyDBM_File.pm"); + perl_require_pv("AnyDBM_File.pm"); SPAGAIN; if (!(gv = gv_fetchmethod(stash, "TIEHASH")) || !GvCV(gv)) DIE("No dbm on this machine"); @@ -574,7 +578,11 @@ PP(pp_sselect) } #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 +#ifdef __linux__ + growsize = sizeof(fd_set); +#else growsize = maxlen; /* little endians can use vecs directly */ +#endif #else #ifdef NFDBITS @@ -664,17 +672,46 @@ PP(pp_sselect) #endif } +void +setdefout(gv) +GV *gv; +{ + if (gv) + (void)SvREFCNT_inc(gv); + if (defoutgv) + SvREFCNT_dec(defoutgv); + defoutgv = gv; +} + PP(pp_select) { dSP; dTARGET; - GV *oldgv = defoutgv; - if (op->op_private > 0) { - defoutgv = (GV*)POPs; - if (!GvIO(defoutgv)) - gv_IOadd(defoutgv); + GV *newdefout, *egv; + HV *hv; + + newdefout = (op->op_private > 0) ? ((GV *) POPs) : NULL; + + egv = GvEGV(defoutgv); + if (!egv) + egv = defoutgv; + hv = GvSTASH(egv); + if (! hv) + XPUSHs(&sv_undef); + else { + GV **gvp = hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE); + if (gvp && *gvp == egv) + gv_efullname(TARG, defoutgv); + else + sv_setsv(TARG, sv_2mortal(newRV(egv))); + XPUSHTARG; + } + + if (newdefout) { + if (!GvIO(newdefout)) + gv_IOadd(newdefout); + setdefout(newdefout); } - gv_efullname(TARG, oldgv); - XPUSHTARG; + RETURN; } @@ -723,7 +760,7 @@ OP *retop; SAVESPTR(curpad); curpad = AvARRAY((AV*)svp[1]); - defoutgv = gv; /* locally select filehandle so $% et al work */ + setdefout(gv); /* locally select filehandle so $% et al work */ return CvSTART(cv); } @@ -783,6 +820,8 @@ PP(pp_leavewrite) if (IoLINES_LEFT(io) < FmLINES(formtarget) && formtarget != toptarget) { + GV *fgv; + CV *cv; if (!IoTOP_GV(io)) { GV *topgv; char tmpbuf[256]; @@ -828,7 +867,16 @@ PP(pp_leavewrite) IoPAGE(io)++; formtarget = toptarget; IoFLAGS(io) |= IOf_DIDTOP; - return doform(GvFORM(IoTOP_GV(io)),gv,op); + fgv = IoTOP_GV(io); + if (!fgv) + DIE("bad top format reference"); + cv = GvFORM(fgv); + if (!cv) { + SV *tmpsv = sv_newmortal(); + gv_efullname(tmpsv, fgv); + DIE("Undefined top format \"%s\" called",SvPVX(tmpsv)); + } + return doform(cv,gv,op); } forget_top: @@ -1212,11 +1260,15 @@ PP(pp_ioctl) DIE("ioctl is not implemented"); #endif else -#ifdef DOSISH +#if defined(DOSISH) && !defined(OS2) DIE("fcntl is not implemented"); #else # ifdef HAS_FCNTL +# if defined(OS2) && defined(__EMX__) + retval = fcntl(fileno(IoIFP(io)), func, (int)s); +# else retval = fcntl(fileno(IoIFP(io)), func, s); +# endif # else DIE("fcntl is not implemented"); # endif @@ -1459,11 +1511,11 @@ PP(pp_accept) { dSP; dTARGET; #ifdef HAS_SOCKET - struct sockaddr_in saddr; /* use a struct to avoid alignment problems */ GV *ngv; GV *ggv; register IO *nstio; register IO *gstio; + struct sockaddr saddr; /* use a struct to avoid alignment problems */ int len = sizeof saddr; int fd; @@ -2129,6 +2181,7 @@ PP(pp_fttext) } /* now scan s to look for textiness */ + /* XXX ASCII dependent code */ for (i = 0; i < len; i++, s++) { if (!*s) { /* null never allowed in text */ @@ -2143,7 +2196,7 @@ PP(pp_fttext) odd++; } - if ((odd * 30 > len) == (op->op_type == OP_FTTEXT)) /* allow 30% odd */ + if ((odd * 3 > len) == (op->op_type == OP_FTTEXT)) /* allow 1/3 odd */ RETPUSHNO; else RETPUSHYES; @@ -2181,7 +2234,7 @@ PP(pp_chdir) #ifdef VMS /* Clear the DEFAULT element of ENV so we'll get the new value * in the future. */ - hv_delete(GvHVn(envgv),"DEFAULT",7); + hv_delete(GvHVn(envgv),"DEFAULT",7,G_DISCARD); #endif RETURN; } @@ -2733,6 +2786,7 @@ PP(pp_system) else { value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), na)); } + statusvalue = FIXSTATUS(value); do_execfree(); SP = ORIGMARK; PUSHi(value); @@ -2913,6 +2967,8 @@ PP(pp_tms) (void)times((tbuffer_t *)×buf); /* time.h uses different name for */ /* struct tms, though same data */ /* is returned. */ +#undef HZ +#define HZ CLK_TCK #endif PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_utime)/HZ))); diff --git a/proto.h b/proto.h index c59f172379..1cfa1f3dcc 100644 --- a/proto.h +++ b/proto.h @@ -190,9 +190,14 @@ int magic_setvec _((SV* sv, MAGIC* mg)); int magic_wipepack _((SV* sv, MAGIC* mg)); void magicname _((char* sym, char* name, I32 namlen)); int main _((int argc, char** argv, char** env)); -#ifndef STANDARD_C +#if !defined(STANDARD_C) Malloc_t malloc _((MEM_SIZE nbytes)); #endif +#if defined(MYMALLOC) && defined(HIDEMYMALLOC) +extern Malloc_t malloc _((MEM_SIZE nbytes)); +extern Malloc_t realloc _((Malloc_t, MEM_SIZE)); +extern Free_t free _((Malloc_t)); +#endif void markstack_grow _((void)); char* mess _((char* pat, va_list* args)); int mg_clear _((SV* sv)); @@ -230,7 +235,7 @@ long my_ntohl _((long l)); void my_unexec _((void)); OP* newANONLIST _((OP* op)); OP* newANONHASH _((OP* op)); -OP* newANONSUB _((I32 floor, OP* block)); +OP* newANONSUB _((I32 floor, OP* proto, OP* block)); OP* newASSIGNOP _((I32 flags, OP* left, I32 optype, OP* right)); OP* newCONDOP _((I32 flags, OP* expr, OP* trueop, OP* falseop)); void newFORM _((I32 floor, OP* op, OP* block)); @@ -245,7 +250,7 @@ void newPROG _((OP* op)); OP* newRANGE _((I32 flags, OP* left, OP* right)); OP* newSLICEOP _((I32 flags, OP* subscript, OP* list)); OP* newSTATEOP _((I32 flags, char* label, OP* o)); -CV* newSUB _((I32 floor, OP* op, OP* block)); +CV* newSUB _((I32 floor, OP* op, OP* proto, OP* block)); CV* newXS _((char *name, void (*subaddr)(CV* cv), char *filename)); #ifdef DEPRECATED CV* newXSUB _((char *name, I32 ix, I32 (*subaddr)(int,int,int), char *filename)); @@ -300,20 +305,17 @@ I32 perl_call_argv _((char* subname, I32 flags, char** argv)); I32 perl_call_method _((char* methname, I32 flags)); I32 perl_call_pv _((char* subname, I32 flags)); I32 perl_call_sv _((SV* sv, I32 flags)); -#ifdef DEPRECATED -I32 perl_callargv _((char* subname, I32 sp, I32 gimme, char** argv)); -I32 perl_callpv _((char* subname, I32 sp, I32 gimme, I32 hasargs, I32 numargs)); -I32 perl_callsv _((SV* sv, I32 sp, I32 gimme, I32 hasargs, I32 numargs)); -#endif void perl_construct _((PerlInterpreter* sv_interp)); void perl_destruct _((PerlInterpreter* sv_interp)); +I32 perl_eval_sv _((SV* sv, I32 flags)); void perl_free _((PerlInterpreter* sv_interp)); SV* perl_get_sv _((char* name, I32 create)); AV* perl_get_av _((char* name, I32 create)); HV* perl_get_hv _((char* name, I32 create)); CV* perl_get_cv _((char* name, I32 create)); int perl_parse _((PerlInterpreter* sv_interp, void(*xsinit)(void), int argc, char** argv, char** env)); -void perl_requirepv _((char* pv)); +void perl_require_pv _((char* pv)); +#define perl_requirepv perl_require_pv int perl_run _((PerlInterpreter* sv_interp)); void pidgone _((int pid, int status)); void pmflag _((U16* pmfl, int ch)); @@ -390,6 +392,7 @@ char* screaminstr _((SV* bigsv, SV* littlesv)); #ifndef VMS I32 setenv_getix _((char* nam)); #endif +void setdefout _((GV *gv)); Signal_t sighandler _((int sig)); SV** stack_grow _((SV** sp, SV**p, int n)); int start_subparse _((void)); @@ -400,6 +403,7 @@ IV sv_2iv _((SV* sv)); SV* sv_2mortal _((SV* sv)); double sv_2nv _((SV* sv)); char* sv_2pv _((SV* sv, STRLEN* lp)); +void sv_add_arena _((char* ptr, U32 size, U32 flags)); int sv_backoff _((SV* sv)); SV* sv_bless _((SV* sv, HV* stash)); void sv_catpv _((SV* sv, char* ptr)); @@ -414,6 +418,7 @@ void sv_dec _((SV* sv)); void sv_dump _((SV* sv)); I32 sv_eq _((SV* sv1, SV* sv2)); void sv_free _((SV* sv)); +void sv_free_arenas _((void)); char* sv_gets _((SV* sv, FILE* fp, I32 append)); #ifndef DOSISH char* sv_grow _((SV* sv, I32 newlen)); @@ -459,7 +464,6 @@ I32 wait4pid _((int pid, int* statusp, int flags)); void warn _((char* pat,...)) __attribute__((format(printf,1,2))); void watch _((char **addr)); I32 whichsig _((char* sig)); -char* whichsigname _((int sig)); int yyerror _((char* s)); int yylex _((void)); int yyparse _((void)); diff --git a/regcomp.c b/regcomp.c index 409d03d3b2..d120eb7bdf 100644 --- a/regcomp.c +++ b/regcomp.c @@ -499,7 +499,7 @@ I32 *flagp; } /* Check for proper termination. */ - if (paren && *nextchar() != ')') { + if (paren && (regparse >= regxend || *nextchar() != ')')) { FAIL("unmatched () in regexp"); } else if (!paren && regparse < regxend) { if (*regparse == ')') { @@ -868,6 +868,15 @@ tryagain: goto defchar; } break; + + case '#': + if (regflags & PMf_EXTENDED) { + while (regparse < regxend && *regparse != '\n') regparse++; + if (regparse < regxend) + goto tryagain; + } + /* FALL THROUGH */ + default: { register I32 len; register char ender; @@ -965,6 +974,11 @@ tryagain: break; } break; + case '#': + if (regflags & PMf_EXTENDED) { + while (p < regxend && *p != '\n') p++; + } + /* FALL THROUGH */ case ' ': case '\t': case '\n': case '\r': case '\f': case '\v': if (regflags & PMf_EXTENDED) { p++; @@ -1159,16 +1173,16 @@ nextchar() { char* retval = regparse++; - if (regflags & PMf_EXTENDED) { - for (;;) { - if (isSPACE(*regparse)) { + for (;;) { + if (*regparse == '(' && regparse[1] == '?' && + regparse[2] == '#') { + while (*regparse && *regparse != ')') regparse++; - continue; - } - else if (*regparse == '(' && regparse[1] == '?' && - regparse[2] == '#') { - while (*regparse && *regparse != ')') - regparse++; + regparse++; + continue; + } + if (regflags & PMf_EXTENDED) { + if (isSPACE(*regparse)) { regparse++; continue; } @@ -1178,10 +1192,9 @@ nextchar() regparse++; continue; } - break; } + return retval; } - return retval; } /* diff --git a/regexec.c b/regexec.c index c2cf06ef2c..6a29d7f032 100644 --- a/regexec.c +++ b/regexec.c @@ -171,6 +171,7 @@ I32 safebase; /* no need to remember string in subbase */ CURCUR cc; cc.cur = 0; + cc.oldcc = 0; regcc = &cc; #ifdef DEBUGGING @@ -576,14 +577,26 @@ char *prog; register char *s; /* operand or save */ register char *locinput = reginput; int minmod = 0; +#ifdef DEBUGGING + static int regindent = 0; + regindent++; +#endif nextchar = *locinput; scan = prog; while (scan != NULL) { #ifdef DEBUGGING - if (regnarrate) - fprintf(stderr, "%2d%-8.8s\t<%.10s>\n", +#define sayYES goto yes +#define sayNO goto no +#define saySAME(x) if (x) goto yes; else goto no + if (regnarrate) { + fprintf(stderr, "%*s%2d%-8.8s\t<%.10s>\n", regindent*2, "", scan - regprogram, regprop(scan), locinput); + } +#else +#define sayYES return 1 +#define sayNO return 0 +#define saySAME(x) return x #endif #ifdef REGALIGN @@ -603,7 +616,7 @@ char *prog; /* regtill = regbol; */ break; } - return 0; + sayNO; case MBOL: if (locinput == regbol ? regprev == '\n' @@ -611,15 +624,15 @@ char *prog; { break; } - return 0; + sayNO; case SBOL: if (locinput == regbol && regprev == '\n') break; - return 0; + sayNO; case GBOL: if (locinput == regbol) break; - return 0; + sayNO; case EOL: if (multiline) goto meol; @@ -628,23 +641,23 @@ char *prog; case MEOL: meol: if ((nextchar || locinput < regeol) && nextchar != '\n') - return 0; + sayNO; break; case SEOL: seol: if ((nextchar || locinput < regeol) && nextchar != '\n') - return 0; + sayNO; if (regeol - locinput > 1) - return 0; + sayNO; break; case SANY: if (!nextchar && locinput >= regeol) - return 0; + sayNO; nextchar = *++locinput; break; case ANY: if (!nextchar && locinput >= regeol || nextchar == '\n') - return 0; + sayNO; nextchar = *++locinput; break; case EXACTLY: @@ -652,11 +665,11 @@ char *prog; ln = *s++; /* Inline the first character, for speed. */ if (*s != nextchar) - return 0; + sayNO; if (regeol - locinput < ln) - return 0; + sayNO; if (ln > 1 && bcmp(s, locinput, ln) != 0) - return 0; + sayNO; locinput += ln; nextchar = *locinput; break; @@ -665,23 +678,23 @@ char *prog; if (nextchar < 0) nextchar = UCHARAT(locinput); if (s[nextchar >> 3] & (1 << (nextchar&7))) - return 0; + sayNO; if (!nextchar && locinput >= regeol) - return 0; + sayNO; nextchar = *++locinput; break; case ALNUM: if (!nextchar) - return 0; + sayNO; if (!isALNUM(nextchar)) - return 0; + sayNO; nextchar = *++locinput; break; case NALNUM: if (!nextchar && locinput >= regeol) - return 0; + sayNO; if (isALNUM(nextchar)) - return 0; + sayNO; nextchar = *++locinput; break; case NBOUND: @@ -692,51 +705,51 @@ char *prog; ln = isALNUM(locinput[-1]); n = isALNUM(nextchar); /* is next char in word? */ if ((ln == n) == (OP(scan) == BOUND)) - return 0; + sayNO; break; case SPACE: if (!nextchar && locinput >= regeol) - return 0; + sayNO; if (!isSPACE(nextchar)) - return 0; + sayNO; nextchar = *++locinput; break; case NSPACE: if (!nextchar) - return 0; + sayNO; if (isSPACE(nextchar)) - return 0; + sayNO; nextchar = *++locinput; break; case DIGIT: if (!isDIGIT(nextchar)) - return 0; + sayNO; nextchar = *++locinput; break; case NDIGIT: if (!nextchar && locinput >= regeol) - return 0; + sayNO; if (isDIGIT(nextchar)) - return 0; + sayNO; nextchar = *++locinput; break; case REF: n = ARG1(scan); /* which paren pair */ s = regstartp[n]; if (!s) - return 0; + sayNO; if (!regendp[n]) - return 0; + sayNO; if (s == regendp[n]) break; /* Inline the first character, for speed. */ if (*s != nextchar) - return 0; + sayNO; ln = regendp[n] - s; if (locinput + ln > regeol) - return 0; + sayNO; if (ln > 1 && bcmp(s, locinput, ln) != 0) - return 0; + sayNO; locinput += ln; nextchar = *locinput; break; @@ -774,7 +787,7 @@ char *prog; n = regmatch(PREVOPER(next)); /* start on the WHILEM */ regcpblow(cp); regcc = cc.oldcc; - return n; + saySAME(n); } /* NOT REACHED */ case WHILEM: { @@ -788,19 +801,25 @@ char *prog; */ CURCUR* cc = regcc; - n = cc->cur + 1; + n = cc->cur + 1; /* how many we know we matched */ reginput = locinput; +#ifdef DEBUGGING + if (regnarrate) + fprintf(stderr, "%*s %d %lx\n", regindent*2, "", + n, (long)cc); +#endif + /* If degenerate scan matches "", assume scan done. */ if (locinput == cc->lastloc) { regcc = cc->oldcc; ln = regcc->cur; if (regmatch(cc->next)) - return TRUE; + sayYES; regcc->cur = ln; regcc = cc; - return FALSE; + sayNO; } /* First just match a string of min scans. */ @@ -808,7 +827,10 @@ char *prog; if (n < cc->min) { cc->cur = n; cc->lastloc = locinput; - return regmatch(cc->scan); + if (regmatch(cc->scan)) + sayYES; + cc->cur = n - 1; + sayNO; } /* Prefer next over scan for minimal matching. */ @@ -817,18 +839,21 @@ char *prog; regcc = cc->oldcc; ln = regcc->cur; if (regmatch(cc->next)) - return TRUE; /* All done. */ + sayYES; /* All done. */ regcc->cur = ln; regcc = cc; if (n >= cc->max) /* Maximum greed exceeded? */ - return FALSE; + sayNO; /* Try scanning more and see if it helps. */ reginput = locinput; cc->cur = n; cc->lastloc = locinput; - return regmatch(cc->scan); + if (regmatch(cc->scan)) + sayYES; + cc->cur = n - 1; + sayNO; } /* Prefer scan over next for maximal matching. */ @@ -838,7 +863,7 @@ char *prog; cc->cur = n; cc->lastloc = locinput; if (regmatch(cc->scan)) - return TRUE; + sayYES; regcppop(); /* Restore some previous $s? */ reginput = locinput; } @@ -847,10 +872,11 @@ char *prog; regcc = cc->oldcc; ln = regcc->cur; if (regmatch(cc->next)) - return TRUE; + sayYES; regcc->cur = ln; regcc = cc; - return FALSE; + cc->cur = n - 1; + sayNO; } /* NOT REACHED */ case BRANCH: { @@ -861,7 +887,7 @@ char *prog; do { reginput = locinput; if (regmatch(NEXTOPER(scan))) - return 1; + sayYES; for (n = *reglastparen; n > lastparen; n--) regendp[n] = 0; *reglastparen = n; @@ -876,7 +902,7 @@ char *prog; scan = regnext(scan); #endif } while (scan != NULL && OP(scan) == BRANCH); - return 0; + sayNO; /* NOTREACHED */ } } @@ -911,12 +937,12 @@ char *prog; if (minmod) { minmod = 0; if (ln && regrepeat(scan, ln) < ln) - return 0; + sayNO; while (n >= ln || (n == 32767 && ln > 0)) { /* ln overflow ? */ /* If it could work, try it. */ if (nextchar == -1000 || *reginput == nextchar) if (regmatch(next)) - return 1; + sayYES; /* Couldn't or didn't -- back up. */ reginput = locinput + ln; if (regrepeat(scan, 1)) { @@ -924,7 +950,7 @@ char *prog; reginput = locinput + ln; } else - return 0; + sayNO; } } else { @@ -936,28 +962,28 @@ char *prog; /* If it could work, try it. */ if (nextchar == -1000 || *reginput == nextchar) if (regmatch(next)) - return 1; + sayYES; /* Couldn't or didn't -- back up. */ n--; reginput = locinput + n; } } - return 0; + sayNO; case SUCCEED: case END: reginput = locinput; /* put where regtry can find it */ - return 1; /* Success! */ + sayYES; /* Success! */ case IFMATCH: reginput = locinput; scan = NEXTOPER(scan); if (!regmatch(scan)) - return 0; + sayNO; break; case UNLESSM: reginput = locinput; scan = NEXTOPER(scan); if (regmatch(scan)) - return 0; + sayNO; break; default: fprintf(stderr, "%x %d\n",(unsigned)scan,scan[1]); @@ -972,6 +998,18 @@ char *prog; */ FAIL("corrupted regexp pointers"); /*NOTREACHED*/ + sayNO; + +yes: +#ifdef DEBUGGING + regindent--; +#endif + return 1; + +no: +#ifdef DEBUGGING + regindent--; +#endif return 0; } diff --git a/run.c b/run.c index 886a2aa71a..5d2255a4aa 100644 --- a/run.c +++ b/run.c @@ -16,8 +16,8 @@ * know. Run now! Hope is in speed!" --Gandalf */ -char **watchaddr = 0; -char *watchok; +dEXT char **watchaddr = 0; +dEXT char *watchok; #ifndef DEBUGGING diff --git a/scope.c b/scope.c index 7619c2b808..5ad043cdc1 100644 --- a/scope.c +++ b/scope.c @@ -152,7 +152,7 @@ GV *gv; GP *ogp = GvGP(gv); SSCHECK(3); - SSPUSHPTR(gv); + SSPUSHPTR(SvREFCNT_inc(gv)); SSPUSHPTR(ogp); SSPUSHINT(SAVEt_GP); @@ -525,6 +525,7 @@ I32 base; gv = (GV*)SSPOPPTR; gp_free(gv); GvGP(gv) = (GP*)ptr; + SvREFCNT_dec(gv); break; case SAVEt_FREESV: ptr = SSPOPPTR; diff --git a/sv.c b/sv.c index f980c2f20b..33a0449148 100644 --- a/sv.c +++ b/sv.c @@ -51,6 +51,16 @@ static void sv_unglob _((SV* sv)); #define new_SV() sv = (SV*)safemalloc(sizeof(SV)) #define del_SV(p) free((char*)p) +void +sv_add_arena(ptr, size, flags) +char* ptr; +U32 size; +U32 flags; +{ + if (!(flags & SVf_FAKE)) + free(ptr); +} + #else #define new_SV() \ @@ -90,11 +100,13 @@ del_sv(p) SV* p; { if (debug & 32768) { + SV* sva; SV* sv; SV* svend; int ok = 0; - for (sv = sv_arenaroot; sv; sv = (SV *) SvANY(svend)) { - svend = &sv[1008 / sizeof(SV)]; + for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { + sv = sva + 1; + svend = &sva[SvREFCNT(sva)]; if (p >= sv && p < svend) ok = 1; } @@ -115,24 +127,40 @@ SV* p; #endif -static SV* -more_sv() +void +sv_add_arena(ptr, size, flags) +char* ptr; +U32 size; +U32 flags; { + SV* sva = (SV*)ptr; register SV* sv; register SV* svend; - sv_root = (SV*)safemalloc(1012); - sv = sv_root; - Zero(sv, 1012, char); - svend = &sv[1008 / sizeof(SV) - 1]; + Zero(sva, size, char); + + /* The first SV in an arena isn't an SV. */ + SvANY(sva) = (void *) sv_arenaroot; /* ptr to next arena */ + SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */ + SvFLAGS(sva) = flags; /* FAKE if not to be freed */ + + sv_arenaroot = sva; + sv_root = sva + 1; + + svend = &sva[SvREFCNT(sva) - 1]; + sv = sva + 1; while (sv < svend) { SvANY(sv) = (void *)(SV*)(sv + 1); SvFLAGS(sv) = SVTYPEMASK; sv++; } SvANY(sv) = 0; - sv++; - SvANY(sv) = (void *) sv_arenaroot; - sv_arenaroot = sv_root; + SvFLAGS(sv) = SVTYPEMASK; +} + +static SV* +more_sv() +{ + sv_add_arena(safemalloc(1008), 1008, 0); return new_sv(); } #endif @@ -140,11 +168,13 @@ more_sv() void sv_report_used() { + SV* sva; SV* sv; register SV* svend; - for (sv = sv_arenaroot; sv; sv = (SV *) SvANY(sv)) { - svend = &sv[1008 / sizeof(SV)]; + for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { + sv = sva + 1; + svend = &sva[SvREFCNT(sva)]; while (sv < svend) { if (SvTYPE(sv) != SVTYPEMASK) { fprintf(stderr, "****\n"); @@ -158,12 +188,14 @@ sv_report_used() void sv_clean_objs() { + SV* sva; register SV* sv; register SV* svend; SV* rv; - for (sv = sv_arenaroot; sv; sv = (SV *) SvANY(sv)) { - svend = &sv[1008 / sizeof(SV)]; + for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { + sv = sva + 1; + svend = &sva[SvREFCNT(sva)]; while (sv < svend) { if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { DEBUG_D((fprintf(stderr, "Cleaning object ref:\n "), @@ -181,11 +213,13 @@ sv_clean_objs() void sv_clean_all() { + SV* sva; register SV* sv; register SV* svend; - for (sv = sv_arenaroot; sv; sv = (SV *) SvANY(sv)) { - svend = &sv[1008 / sizeof(SV)]; + for (sva = sv_arenaroot; sva; sva = (SV*) SvANY(sva)) { + sv = sva + 1; + svend = &sva[SvREFCNT(sva)]; while (sv < svend) { if (SvTYPE(sv) != SVTYPEMASK) { DEBUG_D((fprintf(stderr, "Cleaning loops:\n "), sv_dump(sv));) @@ -197,6 +231,25 @@ sv_clean_all() } } +void +sv_free_arenas() +{ + SV* sva; + SV* svanext; + + /* Free arenas here, but be careful about fake ones. (We assume + contiguity of the fake ones with the corresponding real ones.) */ + + for (sva = sv_arenaroot; sva; sva = svanext) { + svanext = (SV*) SvANY(sva); + while (svanext && SvFAKE(svanext)) + svanext = (SV*) SvANY(svanext); + + if (!SvFAKE(sva)) + Safefree(sva); + } +} + static XPVIV* new_xiv() { @@ -1412,7 +1465,8 @@ register SV *sstr; if (dtype == SVt_PVGV && (SvFLAGS(dstr) & SVf_FAKE)) { sv_unglob(dstr); /* so fake GLOB won't perpetuate */ - SvPOK_only(dstr); + sv_setpvn(dstr, "", 0); + (void)SvPOK_only(dstr); dtype = SvTYPE(dstr); } @@ -1461,9 +1515,28 @@ register SV *sstr; if (dtype < SVt_PVNV) sv_upgrade(dstr, SVt_PVNV); break; + + case SVt_PVLV: + sv_upgrade(dstr, SVt_PVNV); + break; + + case SVt_PVAV: + case SVt_PVHV: + case SVt_PVCV: + case SVt_PVFM: + case SVt_PVIO: + if (op) + croak("Bizarre copy of %s in %s", sv_reftype(sstr, 0), + op_name[op->op_type]); + else + croak("Bizarre copy of %s", sv_reftype(sstr, 0)); + break; + case SVt_PVGV: if (dtype <= SVt_PVGV) { - if (dtype < SVt_PVGV) { + if (dtype == SVt_PVGV) + GvFLAGS(sstr) |= GVf_IMPORTED; + else { char *name = GvNAME(sstr); STRLEN len = GvNAMELEN(sstr); sv_upgrade(dstr, SVt_PVGV); @@ -1474,12 +1547,6 @@ register SV *sstr; SvFAKE_on(dstr); /* can coerce to non-glob */ } (void)SvOK_off(dstr); - if (!GvAV(sstr)) - gv_AVadd(sstr); - if (!GvHV(sstr)) - gv_HVadd(sstr); - if (!GvIO(sstr)) - gv_IOadd(sstr); if (GvGP(dstr)) gp_free(dstr); GvGP(dstr) = gp_ref(GvGP(sstr)); @@ -1538,13 +1605,16 @@ register SV *sstr; SAVESPTR(GvCV(dstr)); else { CV* cv = GvCV(dstr); - dref = (SV*)cv; - if (dowarn && cv && sref != dref && - !GvCVGEN((GV*)dstr) && - (CvROOT(cv) || CvXSUB(cv)) ) - warn("Subroutine %s redefined", GvENAME((GV*)dstr)); + if (cv) { + dref = (SV*)cv; + if (dowarn && sref != dref && + !GvCVGEN((GV*)dstr) && + (CvROOT(cv) || CvXSUB(cv)) ) + warn("Subroutine %s redefined", + GvENAME((GV*)dstr)); + SvFAKE_on(cv); + } } - GvFLAGS(dstr) |= GVf_IMPORTED; GvCV(dstr) = (CV*)sref; break; default: @@ -1555,6 +1625,8 @@ register SV *sstr; GvSV(dstr) = sref; break; } + if (dref != sref) + GvFLAGS(dstr) |= GVf_IMPORTED; /* crude */ if (dref) SvREFCNT_dec(dref); if (intro) @@ -1769,6 +1841,8 @@ register STRLEN len; junk = SvPV_force(sv, tlen); SvGROW(sv, tlen + len + 1); + if (ptr == junk) + ptr = SvPVX(sv); Move(ptr,SvPVX(sv)+tlen,len,char); SvCUR(sv) += len; *SvEND(sv) = '\0'; @@ -1803,6 +1877,8 @@ register char *ptr; junk = SvPV_force(sv, tlen); len = strlen(ptr); SvGROW(sv, tlen + len + 1); + if (ptr == junk) + ptr = SvPVX(sv); Move(ptr,SvPVX(sv)+tlen,len+1,char); SvCUR(sv) += len; (void)SvPOK_only(sv); /* validate pointer */ @@ -1843,7 +1919,7 @@ I32 namlen; if (SvREADONLY(sv) && curcop != &compiling && !strchr("gB", how)) croak(no_modify); - if (SvMAGICAL(sv)) { + if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) { if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { if (how == 't') mg->mg_len |= 1; @@ -1943,7 +2019,11 @@ I32 namlen; case '.': mg->mg_virtual = &vtbl_pos; break; - case '~': /* reserved for extensions but multiple extensions may clash */ + case '~': /* Reserved for use by extensions not perl internals. */ + /* Useful for attaching extension internal data to perl vars. */ + /* Note that multiple extensions may clash if magical scalars */ + /* etc holding private data from one are passed to another. */ + SvRMAGICAL_on(sv); break; default: croak("Don't know how to handle magic of type '%c'", how); @@ -2129,11 +2209,13 @@ register SV *sv; PUSHMARK(SP); PUSHs(&ref); PUTBACK; - perl_call_sv((SV*)destructor, G_DISCARD|G_EVAL); + perl_call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR); del_XRV(SvANY(&ref)); } LEAVE; } + else + SvREFCNT_dec(SvSTASH(sv)); if (SvOBJECT(sv)) { SvOBJECT_off(sv); /* Curse the object. */ if (SvTYPE(sv) != SVt_PVIO) @@ -2553,7 +2635,8 @@ register SV *sv; return; } if (!(flags & SVp_POK) || !*SvPVX(sv)) { - sv_upgrade(sv, SVt_NV); + if ((flags & SVTYPEMASK) < SVt_PVNV) + sv_upgrade(sv, SVt_NV); SvNVX(sv) = 1.0; (void)SvNOK_only(sv); return; @@ -2622,7 +2705,8 @@ register SV *sv; return; } if (!(flags & SVp_POK)) { - sv_upgrade(sv, SVt_NV); + if ((flags & SVTYPEMASK) < SVt_PVNV) + sv_upgrade(sv, SVt_NV); SvNVX(sv) = -1.0; (void)SvNOK_only(sv); return; @@ -2897,13 +2981,17 @@ I32 lref; *st = GvESTASH(gv); fix_gv: if (lref && !GvCV(gv)) { + SV *tmpsv; ENTER; - sv = NEWSV(704,0); - gv_efullname(sv, gv); + tmpsv = NEWSV(704,0); + gv_efullname(tmpsv, gv); newSUB(start_subparse(), - newSVOP(OP_CONST, 0, sv), + newSVOP(OP_CONST, 0, tmpsv), + Nullop, Nullop); LEAVE; + if (!GvCV(gv)) + croak("Unable to create sub named \"%s\"", SvPV(sv,na)); } return GvCV(gv); } @@ -2993,17 +3081,17 @@ STRLEN *lp; } else { if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) { - if (SvTYPE(sv) == SVt_PVGV && SvFAKE(sv)) { + if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) { sv_unglob(sv); - s = SvPVX(sv); - *lp = SvCUR(sv); - } + s = SvPVX(sv); + *lp = SvCUR(sv); + } else croak("Can't coerce %s to string in %s", sv_reftype(sv,0), op_name[op->op_type]); } - else - s = sv_2pv(sv, lp); + else + s = sv_2pv(sv, lp); if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */ STRLEN len = *lp; @@ -3203,10 +3291,10 @@ SV* sv; SvRV(sv) = 0; SvROK_off(sv); - if (SvREFCNT(rv) == 1) - sv_2mortal(rv); + if (SvREFCNT(rv) != 1 || SvREADONLY(rv)) + SvREFCNT_dec(rv); else - SvREFCNT_dec(rv); + sv_2mortal(rv); /* Schedule for freeing later */ } #ifdef DEBUGGING @@ -3352,10 +3440,14 @@ SV* sv; fprintf(stderr, " FILL = %ld\n", (long)AvFILL(sv)); fprintf(stderr, " MAX = %ld\n", (long)AvMAX(sv)); fprintf(stderr, " ARYLEN = 0x%lx\n", (long)AvARYLEN(sv)); - if (AvREAL(sv)) - fprintf(stderr, " FLAGS = (REAL)\n"); - else - fprintf(stderr, " FLAGS = ()\n"); + flags = AvFLAGS(sv); + d = tmpbuf; + if (flags & AVf_REAL) strcat(d, "REAL,"); + if (flags & AVf_REIFY) strcat(d, "REIFY,"); + if (flags & AVf_REUSED) strcat(d, "REUSED,"); + if (*d) + d[strlen(d)-1] = '\0'; + fprintf(stderr, " FLAGS = (%s)\n", d); break; case SVt_PVHV: fprintf(stderr, " ARRAY = 0x%lx\n",(long)HvARRAY(sv)); diff --git a/t/TEST b/t/TEST index 79590c893c..dfe429a546 100755 --- a/t/TEST +++ b/t/TEST @@ -14,7 +14,10 @@ if ($ARGV[0] eq '-v') { chdir 't' if -f 't/TEST'; -die "You need to run \"make test\" first to set things up.\n" unless -e 'perl'; +die "You need to run \"make test\" first to set things up.\n" + unless -e 'perl' or -e 'perl.exe'; + +$ENV{EMXSHELL} = 'sh'; # For OS/2 if ($ARGV[0] eq '') { @ARGV = split(/[ \n]/, diff --git a/t/comp/cpp.aux b/t/comp/cpp.aux old mode 100644 new mode 100755 diff --git a/t/lib/socket.t b/t/lib/socket.t deleted file mode 100644 index 2b9b820144..0000000000 --- a/t/lib/socket.t +++ /dev/null @@ -1,62 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bSocket\b/ && $Config{'osname'} ne 'VMS') { - print STDERR "1..0\n"; - exit 0; - } -} - -use Socket; - -print "1..6\n"; - -if( socket(T,PF_INET,SOCK_STREAM,6) ){ - print "ok 1\n"; - - if( connect(T,pack_sockaddr_in(AF_INET,7,inet_aton("localhost")))){ - print "ok 2\n"; - - print "# Connected to ", - inet_ntoa((unpack_sockaddr_in(getpeername(T)))[2]),"\n"; - - syswrite(T,"hello",5); - sysread(T,$buff,10); - print $buff eq "hello" ? "ok 3\n" : "not ok 3\n"; - } - else{ - print "# $!\n"; - print "not ok 2\n"; - } -} -else{ - print "# $!\n"; - print "not ok 1\n"; -} - -if( socket(S,PF_INET,SOCK_STREAM,6) ){ - print "ok 4\n"; - - if( connect(S,pack_sockaddr_in(AF_INET,7,INADDR_LOOPBACK))){ - print "ok 5\n"; - - print "# Connected to ", - inet_ntoa((unpack_sockaddr_in(getpeername(S)))[2]),"\n"; - - syswrite(S,"olleh",5); - sysread(S,$buff,10); - print $buff eq "olleh" ? "ok 6\n" : "not ok 6\n"; - } - else{ - print "# $!\n"; - print "not ok 5\n"; - } -} -else{ - print "# $!\n"; - print "not ok 4\n"; -} - diff --git a/t/op/overload.t b/t/op/overload.t old mode 100755 new mode 100644 index ab76492141..183cb273f7 --- a/t/op/overload.t +++ b/t/op/overload.t @@ -5,10 +5,9 @@ BEGIN { unshift @INC, './lib', '../lib'; } package Oscalar; - -%OVERLOAD = ( +use overload ( # Anonymous subroutines: -'+' => sub {new Oscalar ${$_[0]}+$_[1]}, +'+' => sub {new Oscalar $ {$_[0]}+$_[1]}, '-' => sub {new Oscalar $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]}, '<=>' => sub {new Oscalar @@ -52,7 +51,8 @@ sub test { $a = new Oscalar "087"; $b= "$a"; -test (!defined ref $b); # 1 +# All test numbers in comments are off by 1. +# So much for hard-wiring them in :-) test ($b eq $a); # 2 test ($b eq "087"); # 3 test (ref $a eq "Oscalar"); # 4 @@ -92,7 +92,7 @@ test ( $a eq "087"); # 20 test ( $b eq "88"); # 21 test (ref $a eq "Oscalar"); # 22 -$Oscalar::OVERLOAD{'++'} = sub {${$_[0]}++;$_[0]}; +eval q[ package Oscalar; use overload ('++' => sub { $ {$_[0]}++;$_[0] } ) ]; $b=$a; @@ -118,7 +118,7 @@ test ( $b eq "88"); # 30 test (ref $a eq "Oscalar"); # 31 -$Oscalar::OVERLOAD{'++'} = sub {${$_[0]}+=2;$_[0]}; +eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ]; $b=$a; @@ -153,7 +153,10 @@ test (ref $a eq "Oscalar"); # 44 test ($b? 1:0); # 45 -$Oscalar::OVERLOAD{'='} = sub {$copies++; package Oscalar; local $new=${$_[0]};bless \$new}; +eval q[ package Oscalar; use overload ('=' => sub {$main::copies++; + package Oscalar; + local $new=$ {$_[0]}; + bless \$new } ) ]; $b=new Oscalar "$a"; @@ -196,7 +199,8 @@ test ( $b eq "89"); # 67 test (ref $a eq "Oscalar"); # 68 test ($copies == 1); # 69 -$Oscalar::OVERLOAD{'+='} = sub {${$_[0]}+=3*$_[1];$_[0]}; +eval q[package Oscalar; use overload ('+=' => sub {$ {$_[0]} += 3*$_[1]; + $_[0] } ) ]; $c=new Oscalar; # Cause rehash $b=$a; @@ -231,15 +235,18 @@ test (ref $b eq "Oscalar"); # 84 test ( $b eq "360"); # 85 test ($copies == 2); # 86 -$Oscalar::OVERLOAD{'x'} = sub {new Oscalar ($_[2]? "_.$_[1]._" x ${$_[0]}: - "_.${$_[0]}._" x $_[1])}; +eval q[package Oscalar; + use overload ('x' => sub {new Oscalar ( $_[2] ? "_.$_[1]._" x $ {$_[0]} + : "_.${$_[0]}._" x $_[1])}) ]; $a=new Oscalar "yy"; $a x= 3; test ($a eq "_.yy.__.yy.__.yy._"); # 87 -$Oscalar::OVERLOAD{'.'} = sub {new Oscalar ($_[2]? "_.$_[1].__.${$_[0]}._": - "_.${$_[0]}.__.$_[1]._")}; +eval q[package Oscalar; + use overload ('.' => sub {new Oscalar ( $_[2] ? + "_.$_[1].__.$ {$_[0]}._" + : "_.$ {$_[0]}.__.$_[1]._")}) ]; $a=new Oscalar "xx"; @@ -247,13 +254,14 @@ test ("b${a}c" eq "_._.b.__.xx._.__.c._"); # 88 # Here we test blessing to a package updates hash -delete $Oscalar::OVERLOAD{'.'}; +eval "package Oscalar; no overload '.'"; test ("b${a}" eq "_.b.__.xx._"); # 89 $x="1"; bless \$x, Oscalar; -test ("b${a}c" eq "bxxc"); # 90 +test ("b${a}c" eq "bxxc"); # 90 new Oscalar 1; -test ("b${a}c" eq "bxxc"); # 91 +test ("b${a}c" eq "bxxc"); # 91 -sub last {91} +# Last test is number 90. +sub last {90} diff --git a/t/op/stat.t b/t/op/stat.t index b361da2df9..cfaf043b08 100755 --- a/t/op/stat.t +++ b/t/op/stat.t @@ -34,6 +34,8 @@ if (($mtime && $mtime != $ctime) || $cwd =~ m#/afs/#) { } else { print "not ok 4\n"; + print '#4 If test op/stat.t fails test 4, check if you are on a tmpfs'; + print '#4 of some sort. Building in /tmp sometimes has this problem.'; } print "#4 :$mtime: != :$ctime:\n"; diff --git a/toke.c b/toke.c index cdb12a361f..2cfcefb0ce 100644 --- a/toke.c +++ b/toke.c @@ -1074,7 +1074,7 @@ filter_read(idx, buf_sv, maxlen) SvCUR_set(buf_sv, old_len + len) ; } else { /* Want a line */ - if (sv_gets(buf_sv, rsfp, (SvCUR(buf_sv)>0) ? 1 : 0) == NULL) + if (sv_gets(buf_sv, rsfp, SvCUR(buf_sv)) == NULL) return -1; /* end of file */ } return SvCUR(buf_sv); @@ -1689,7 +1689,7 @@ yylex() lex_state = LEX_INTERPEND; } } - TOKEN(']'); + TERM(']'); case '{': leftbracket: s++; @@ -1807,7 +1807,7 @@ yylex() AOPERATOR(ANDAND); s--; if (expect == XOPERATOR) { - if (isALPHA(*s) && bufptr == SvPVX(linestr)) { + if (dowarn && isALPHA(*s) && bufptr == SvPVX(linestr)) { curcop->cop_line--; warn(warn_nosemi); curcop->cop_line++; @@ -2003,25 +2003,20 @@ yylex() } else if (!strchr(tokenbuf,':')) { if (oldexpect != XREF || oldoldbufptr == last_lop) { - if (*s == '[') - tokenbuf[0] = '@'; - else if (*s == '{') - tokenbuf[0] = '%'; + if (intuit_more(s)) { + if (*s == '[') + tokenbuf[0] = '@'; + else if (*s == '{') + tokenbuf[0] = '%'; + } } if (tmp = pad_findmy(tokenbuf)) { nextval[nexttoke].opval = newOP(OP_PADANY, 0); nextval[nexttoke].opval->op_targ = tmp; force_next(PRIVATEREF); } - else { - if ((tainting || !euid) && - !isLOWER(tokenbuf[1]) && - (isDIGIT(tokenbuf[1]) || - strchr("&`'+", tokenbuf[1]) || - instr(tokenbuf,"MATCH") )) - hints |= HINT_BLOCK_SCOPE; /* Can't optimize block out*/ + else force_ident(tokenbuf+1, *tokenbuf); - } } else force_ident(tokenbuf+1, *tokenbuf); @@ -2051,8 +2046,10 @@ yylex() TERM('@'); } else if (!strchr(tokenbuf,':')) { - if (*s == '{') - tokenbuf[0] = '%'; + if (intuit_more(s)) { + if (*s == '{') + tokenbuf[0] = '%'; + } if (tmp = pad_findmy(tokenbuf)) { nextval[nexttoke].opval = newOP(OP_PADANY, 0); nextval[nexttoke].opval->op_targ = tmp; @@ -2062,7 +2059,7 @@ yylex() } /* Force them to make up their mind on "@foo". */ - if (lex_state != LEX_NORMAL && + if (lex_state != LEX_NORMAL && !lex_brackets && ( !(gv = gv_fetchpv(tokenbuf+1, FALSE, SVt_PVAV)) || (*tokenbuf == '@' ? !GvAV(gv) @@ -2168,7 +2165,13 @@ yylex() } if (!s) missingterm((char*)0); - yylval.ival = OP_STRINGIFY; + yylval.ival = OP_CONST; + for (d = SvPV(lex_stuff, len); len; len--, d++) { + if (*d == '$' || *d == '@' || *d == '\\') { + yylval.ival = OP_STRINGIFY; + break; + } + } TERM(sublex_start()); case '`': @@ -2228,6 +2231,9 @@ yylex() bufptr = s; s = scan_word(s, tokenbuf, FALSE, &len); + if (*s == ':' && s[1] == ':' && strNE(tokenbuf, "CORE")) + goto just_a_word; + tmp = keyword(tokenbuf, len); /* Is this a word before a => operator? */ @@ -2363,6 +2369,7 @@ yylex() /* Not a method, so call it a subroutine (if defined) */ if (gv && GvCV(gv)) { + CV* cv = GvCV(gv); nextval[nexttoke].opval = yylval.opval; if (*s == '(') { expect = XTERM; @@ -2374,6 +2381,19 @@ yylex() tokenbuf, tokenbuf); last_lop = oldbufptr; last_lop_op = OP_ENTERSUB; + /* Is there a prototype? */ + if (SvPOK(cv)) { + STRLEN len; + char *proto = SvPV((SV*)cv, len); + if (!len) + TERM(FUNC0SUB); + if (strEQ(proto, "$")) + OPERATOR(UNIOPSUB); + if (*proto == '&' && *s == '{') { + sv_setpv(subname,"__ANON__"); + PREBLOCK(LSTOPSUB); + } + } expect = XTERM; force_next(WORD); TOKEN(NOAMP); @@ -3150,13 +3170,10 @@ yylex() case KEY_sub: really_sub: s = skipspace(s); - if (*s == '{' && tmp == KEY_sub) { - sv_setpv(subname,"__ANON__"); - PRETERMBLOCK(ANONSUB); - } - expect = XBLOCK; + if (isIDFIRST(*s) || *s == '\'' || *s == ':') { char tmpbuf[128]; + expect = XBLOCK; d = scan_word(s, tmpbuf, TRUE, &len); if (strchr(tmpbuf, ':')) sv_setpv(subname, tmpbuf); @@ -3166,17 +3183,47 @@ yylex() sv_catpvn(subname,tmpbuf,len); } s = force_word(s,WORD,FALSE,TRUE,TRUE); + s = skipspace(s); } - else + else { + expect = XTERMBLOCK; sv_setpv(subname,"?"); + } + + if (tmp == KEY_format) { + s = skipspace(s); + if (*s == '=') + lex_formbrack = lex_brackets + 1; + OPERATOR(FORMAT); + } - if (tmp != KEY_format) - PREBLOCK(SUB); + /* Look for a prototype */ + if (*s == '(') { + s = scan_str(s); + if (!s) { + if (lex_stuff) + SvREFCNT_dec(lex_stuff); + lex_stuff = Nullsv; + croak("Prototype not terminated"); + } + nexttoke++; + nextval[1] = nextval[0]; + nexttype[1] = nexttype[0]; + nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, lex_stuff); + nexttype[0] = THING; + if (nexttoke == 1) { + lex_defer = lex_state; + lex_expect = expect; + lex_state = LEX_KNOWNEXT; + } + lex_stuff = Nullsv; + } - s = skipspace(s); - if (*s == '=') - lex_formbrack = lex_brackets + 1; - OPERATOR(FORMAT); + if (*SvPV(subname,na) == '?') { + sv_setpv(subname,"__ANON__"); + TOKEN(ANONSUB); + } + PREBLOCK(SUB); case KEY_system: set_csh(); @@ -3433,6 +3480,7 @@ I32 len; break; case 6: if (strEQ(d,"exists")) return KEY_exists; + if (strEQ(d,"elseif")) warn("elseif should be elsif"); break; case 8: if (strEQ(d,"endgrent")) return -KEY_endgrent; @@ -3951,7 +3999,7 @@ char *what; if (*s == ',') { int kw; *s = '\0'; - kw = keyword(w, s - w); + kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0; *s = ','; if (kw) return; @@ -4132,6 +4180,7 @@ char *start; while (*s && strchr("iogmsx", *s)) pmflag(&pm->op_pmflags,*s++); + pm->op_pmpermflags = pm->op_pmflags; lex_op = (OP*)pm; yylval.ival = OP_MATCH; return s; @@ -4194,6 +4243,7 @@ char *start; lex_repl = repl; } + pm->op_pmpermflags = pm->op_pmflags; lex_op = (OP*)pm; yylval.ival = OP_SUBST; return s; @@ -4303,12 +4353,15 @@ register char *s; SV *tmpstr; char term; register char *d; + char *peek; s += 2; d = tokenbuf; if (!rsfp) *d++ = '\n'; - if (*s && strchr("`'\"",*s)) { + for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ; + if (*peek && strchr("`'\"",*peek)) { + s = peek; term = *s++; s = cpytill(d,s,bufend,term,&len); if (s < bufend) @@ -4320,6 +4373,8 @@ register char *s; s++, term = '\''; else term = '"'; + if (!isALNUM(*s)) + deprecate("bare << to mean <<\"\""); while (isALNUM(*s)) *d++ = *s++; } /* assuming tokenbuf won't clobber */ @@ -4422,7 +4477,7 @@ char *start; else croak("Unterminated <> operator"); - if (*d == '$') d++; + if (*d == '$' && d[1]) d++; while (*d && (isALNUM(*d) || *d == '\'' || *d == ':')) d++; if (d - tokenbuf != len) { @@ -4833,6 +4888,8 @@ char *s; if (lex_state == LEX_NORMAL || (lex_state == LEX_KNOWNEXT && lex_defer == LEX_NORMAL)) (void)strcpy(tname,"at end of line"); + else if (lex_inpat) + (void)strcpy(tname,"within pattern"); else (void)strcpy(tname,"within string"); } @@ -4851,11 +4908,12 @@ char *s; if (in_eval & 2) warn("%s",buf); else if (in_eval) - sv_catpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),buf); + sv_catpv(GvSV(errgv),buf); else fputs(buf,stderr); if (++error_count >= 10) croak("%s has too many errors.\n", SvPVX(GvSV(curcop->cop_filegv))); + in_my = 0; return 0; } diff --git a/util.c b/util.c index 160a391b0b..9ffb43130b 100644 --- a/util.c +++ b/util.c @@ -1097,7 +1097,7 @@ register I32 len; } #endif /* HAS_MEMCMP */ -#ifdef I_VARARGS +#if defined(I_STDARG) || defined(I_VARARGS) #ifndef HAS_VPRINTF #ifdef USE_CHAR_VSPRINTF @@ -1134,7 +1134,7 @@ char *pat, *args; return 0; /* wrong, but perl doesn't use the return value */ } #endif /* HAS_VPRINTF */ -#endif /* I_VARARGS */ +#endif /* I_VARARGS || I_STDARGS */ #ifdef MYSWAP #if BYTEORDER != 0x4321 @@ -1363,7 +1363,7 @@ char *mode; return fdopen(p[this], mode); } #else -#ifdef atarist +#if defined(atarist) || defined(OS2) FILE *popen(); FILE * my_popen(cmd,mode) @@ -1420,8 +1420,7 @@ int newfd; } #endif -#ifndef DOSISH -#ifndef VMS /* VMS' my_pclose() is in VMS.c */ +#if !defined(DOSISH) && !defined(VMS) /* VMS' my_popen() is in VMS.c */ I32 my_pclose(ptr) FILE *ptr; @@ -1450,7 +1449,9 @@ FILE *ptr; signal(SIGQUIT, qstat); return(pid < 0 ? pid : status); } -#endif /* !VMS */ +#endif /* !DOSISH */ + +#if !defined(DOSISH) || defined(OS2) I32 wait4pid(pid,statusp,flags) int pid; @@ -1524,7 +1525,7 @@ int status; return; } -#ifdef atarist +#if defined(atarist) || defined(OS2) int pclose(); I32 my_pclose(ptr) diff --git a/vms/Makefile b/vms/Makefile index 9a953106a6..5c6deb13e8 100644 --- a/vms/Makefile +++ b/vms/Makefile @@ -3,7 +3,7 @@ #> conversion process. For more information, see mms2make.pl #> # Makefile. for perl5 on VMS -# Last revised 10-Mar-1995 by Charles Bailey bailey@genetics.upenn.edu +# Last revised 5-Jun-1995 by Charles Bailey bailey@genetics.upenn.edu # # # tidy -- purge files generated by executing this file @@ -26,8 +26,10 @@ OLB = .olb # File type to use for executable images E = .exe -ARCHCORE = [.lib.VMS_VAX.CORE] -ARCHAUTO = [.lib.auto.VMS_VAX] +ARCH = VMS_VAX +ARCHDIR = [.lib.$(ARCH)] +ARCHCORE = [.lib.$(ARCH).CORE] +ARCHAUTO = [.lib.$(ARCH).auto] # -fno-builtin avoids bug in gcc up to version 2.6.2 which can destroy @@ -38,6 +40,11 @@ ARCHAUTO = [.lib.auto.VMS_VAX] XTRAOBJS = LIBS1 = $(XTRAOBJS) DBGSPECFLAGS = /Show=(Source,Include,Expansion) +# Some versions of DECCRTL on AXP have a bug in chdir() which causes the change +# to persist after the image exits, even when this was not requested, iff +# SYSNAM is enabled. This is fixed in CSC Patch # AXPACRT04_061, but turning +# off SYSNAM for the MM[SK] subprocess doesn't hurt anything, so we do it +# just in case. XTRACCFLAGS = /Include=[]/Object=$(O) XTRADEF = LIBS2 = sys$$Share:VAXCRTL.Exe/Shareable @@ -57,6 +64,7 @@ SOCKH = SOCKCLIS = SOCKHLIS = SOCKOBJ = +SOCKPM = # C preprocessor manifest "DEBUGGING" ==> perl -D, not the VMS debugger CFLAGS = /Define=(DEBUGGING$(SOCKDEF)$(XTRADEF))$(XTRACCFLAGS)$(DBGCCFLAGS) @@ -69,15 +77,23 @@ NOOP = continue # Macros to invoke a copy of miniperl during the build. Targets which # are built using these macros should depend on $(MINIPERL_EXE) MINIPERL_EXE = sys$$Disk:[]miniperl$(E) -MINIPERL = MCR $(MINIPERL_EXE) +MINIPERL = MCR $(MINIPERL_EXE) "-Ilib" XSUBPP = $(MINIPERL) [.lib.extutils]xsubpp +# Macro to invoke a preexisting copy of Perl. This is used to regenerate +# some header files when rebuilding Perl, but premade versions are provided +# in the distribution, so it's OK if this doesn't work; it's here to make +# life easier for those who modify Perl and rebuild it. +INSTPERL = perl # Space-separated list of "static" extensions to build into perlshr (case counts). -EXT = DynaLoader +MYEXT = DynaLoader # object files for these extensions; the trailing comma is required if # there are any object files specified # These must be built separately, or you must add rules below to build them -extobj = [.ext.dynaloader]dl_vms$(O), +myextobj = [.ext.dynaloader]dl_vms$(O), +EXT = $(MYEXT) +extobj = $(myextobj) + #### End of system configuration section. #### @@ -130,7 +146,7 @@ CRTLOPTS =,$(CRTL)/Options all : base extras archcorefiles preplibrary @ $(NOOP) -base : miniperl$(E) perl$(E) [.lib]Config.pm +base : miniperl$(E) perl$(E) [.lib.$(ARCH)]Config.pm @ $(NOOP) extras : [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm [.lib.extutils]MM_VMS.pm @ $(NOOP) @@ -167,6 +183,10 @@ $(DBG)perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl $( @ If f$$Search("$(DBG)perlshr_xtras.ts").nes."" Then Delete/NoLog/NoConfirm $(DBG)perlshr_xtras.ts;* @ Copy NLA0: $(DBG)perlshr_xtras.ts +[.lib.$(ARCH)]config.pm : [.lib]config.pm + Create/Directory [.lib.$(ARCH)] + Copy [.lib]config.pm $@ + [.lib]config.pm : [.vms]config.vms [.vms]genconfig.pl $(MINIPERL_EXE) $(MINIPERL) [.VMS]GenConfig.Pl cc=$(CC)$(CFLAGS) ldflags=$(LINKFLAGS) $(MINIPERL) ConfigPM. @@ -187,28 +207,38 @@ $(DBG)perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl $( [.lib.ExtUtils]MM_VMS.pm : [.vms.ext]MM_VMS.pm Copy/Log/NoConfirm [.vms.ext]MM_VMS.pm $@ -preplibrary : $(MINIPERL_EXE) [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm [.lib.ExtUtils]MM_VMS.pm +preplibrary : $(MINIPERL_EXE) [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm [.lib.ExtUtils]MM_VMS.pm $(SOCKPM) @ Write sys$$Output "Autosplitting Perl library . . ." @ Create/Directory [.lib.auto] @ $(MINIPERL) "-Ilib" -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]*.pm [.lib.*]*.pm -#opcode.h : opcode.pl $(MINIPERL_EXE) -# $(MINIPERL) opcode.pl +opcode.h : opcode.pl + @ Write sys$$Output "Don't worry if this fails." + - $(INSTPERL) opcode.pl +keywords.h : keywords.pl + @ Write sys$$Output "Don't worry if this fails." + - $(INSTPERL) keywords.pl +embed.h : global.sym interp.sym + @ Write sys$$Output "Don't worry if this fails." + - $(INSTPERL) [.vms]embed_h.pl -perly.h : perly.c # Quick and dirty 'touch' - Copy/Log/NoConfirm perly.h; ; - Delete/Log/NoConfirm perly.h;-1 +# VMS uses modified perly.[ch] with tags for globaldefs if using DEC compiler +perly.c : [.vms]perly_c.vms + Copy/Log [.vms]perly_c.vms $@ +perly.h : [.vms]perly_h.vms + Copy/Log [.vms]perly_h.vms $@ # I now supply perly.c with the kits, so the following section is # commented out if you don't have byacc. - +# Altered for VMS by Charles Bailey bailey@genetics.upenn.edu # perly.c: -# @ echo 'Expect' 80 shift/reduce and 62 reduce/reduce conflicts +# @ Write Sys$Output 'Expect' 80 shift/reduce and 62 reduce/reduce conflicts # \$(BYACC) -d perly.y +# Has to be done by hand or by POSIX shell under VMS # sh \$(shellflags) ./perly.fixer y.tab.c perly.c -# mv y.tab.h perly.h -# echo 'extern YYSTYPE yylval;' >>perly.h +# rename y.tab.h perly.h +# $(INSTPERL) [.vms]vms_yfix.pl perly.c perly.h [.vms]perly_c.vms [.vms]perly_h.vms perly$(O) : perly.c, perly.h, $(h) $(CC) $(CFLAGS) perly.c @@ -328,6 +358,7 @@ av$(O) : mg.h av$(O) : op.h av$(O) : opcode.h av$(O) : perl.h +av$(O) : perly.h av$(O) : pp.h av$(O) : proto.h av$(O) : regexp.h @@ -349,6 +380,7 @@ scope$(O) : mg.h scope$(O) : op.h scope$(O) : opcode.h scope$(O) : perl.h +scope$(O) : perly.h scope$(O) : pp.h scope$(O) : proto.h scope$(O) : regexp.h @@ -372,6 +404,7 @@ op$(O) : op.c op$(O) : op.h op$(O) : opcode.h op$(O) : perl.h +op$(O) : perly.h op$(O) : pp.h op$(O) : proto.h op$(O) : regexp.h @@ -394,6 +427,7 @@ doop$(O) : mg.h doop$(O) : op.h doop$(O) : opcode.h doop$(O) : perl.h +doop$(O) : perly.h doop$(O) : pp.h doop$(O) : proto.h doop$(O) : regexp.h @@ -416,6 +450,7 @@ doio$(O) : mg.h doio$(O) : op.h doio$(O) : opcode.h doio$(O) : perl.h +doio$(O) : perly.h doio$(O) : pp.h doio$(O) : proto.h doio$(O) : regexp.h @@ -438,6 +473,7 @@ dump$(O) : mg.h dump$(O) : op.h dump$(O) : opcode.h dump$(O) : perl.h +dump$(O) : perly.h dump$(O) : pp.h dump$(O) : proto.h dump$(O) : regexp.h @@ -460,6 +496,7 @@ hv$(O) : mg.h hv$(O) : op.h hv$(O) : opcode.h hv$(O) : perl.h +hv$(O) : perly.h hv$(O) : pp.h hv$(O) : proto.h hv$(O) : regexp.h @@ -482,6 +519,7 @@ mg$(O) : mg.h mg$(O) : op.h mg$(O) : opcode.h mg$(O) : perl.h +mg$(O) : perly.h mg$(O) : pp.h mg$(O) : proto.h mg$(O) : regexp.h @@ -504,6 +542,7 @@ perl$(O) : op.h perl$(O) : opcode.h perl$(O) : perl.c perl$(O) : perl.h +perl$(O) : perly.h perl$(O) : pp.h perl$(O) : proto.h perl$(O) : regexp.h @@ -525,6 +564,7 @@ perly$(O) : mg.h perly$(O) : op.h perly$(O) : opcode.h perly$(O) : perl.h +perly$(O) : perly.h perly$(O) : perly.c perly$(O) : pp.h perly$(O) : proto.h @@ -547,6 +587,7 @@ pp$(O) : mg.h pp$(O) : op.h pp$(O) : opcode.h pp$(O) : perl.h +pp$(O) : perly.h pp$(O) : pp.c pp$(O) : pp.h pp$(O) : proto.h @@ -569,6 +610,7 @@ pp_ctl$(O) : mg.h pp_ctl$(O) : op.h pp_ctl$(O) : opcode.h pp_ctl$(O) : perl.h +pp_ctl$(O) : perly.h pp_ctl$(O) : pp_ctl.c pp_ctl$(O) : pp.h pp_ctl$(O) : proto.h @@ -591,6 +633,7 @@ pp_hot$(O) : mg.h pp_hot$(O) : op.h pp_hot$(O) : opcode.h pp_hot$(O) : perl.h +pp_hot$(O) : perly.h pp_hot$(O) : pp_hot.c pp_hot$(O) : pp.h pp_hot$(O) : proto.h @@ -613,6 +656,7 @@ pp_sys$(O) : mg.h pp_sys$(O) : op.h pp_sys$(O) : opcode.h pp_sys$(O) : perl.h +pp_sys$(O) : perly.h pp_sys$(O) : pp_sys.c pp_sys$(O) : pp.h pp_sys$(O) : proto.h @@ -636,6 +680,7 @@ regcomp$(O) : mg.h regcomp$(O) : op.h regcomp$(O) : opcode.h regcomp$(O) : perl.h +regcomp$(O) : perly.h regcomp$(O) : pp.h regcomp$(O) : proto.h regcomp$(O) : regcomp.c @@ -659,6 +704,7 @@ regexec$(O) : mg.h regexec$(O) : op.h regexec$(O) : opcode.h regexec$(O) : perl.h +regexec$(O) : perly.h regexec$(O) : pp.h regexec$(O) : proto.h regexec$(O) : regcomp.h @@ -683,6 +729,7 @@ gv$(O) : mg.h gv$(O) : op.h gv$(O) : opcode.h gv$(O) : perl.h +gv$(O) : perly.h gv$(O) : pp.h gv$(O) : proto.h gv$(O) : regexp.h @@ -727,6 +774,7 @@ taint$(O) : mg.h taint$(O) : op.h taint$(O) : opcode.h taint$(O) : perl.h +taint$(O) : perly.h taint$(O) : pp.h taint$(O) : proto.h taint$(O) : regexp.h @@ -773,6 +821,7 @@ util$(O) : mg.h util$(O) : op.h util$(O) : opcode.h util$(O) : perl.h +util$(O) : perly.h util$(O) : pp.h util$(O) : proto.h util$(O) : regexp.h @@ -796,6 +845,7 @@ deb$(O) : mg.h deb$(O) : op.h deb$(O) : opcode.h deb$(O) : perl.h +deb$(O) : perly.h deb$(O) : pp.h deb$(O) : proto.h deb$(O) : regexp.h @@ -817,6 +867,7 @@ run$(O) : mg.h run$(O) : op.h run$(O) : opcode.h run$(O) : perl.h +run$(O) : perly.h run$(O) : pp.h run$(O) : proto.h run$(O) : regexp.h @@ -839,6 +890,7 @@ vms$(O) : mg.h vms$(O) : op.h vms$(O) : opcode.h vms$(O) : perl.h +vms$(O) : perly.h vms$(O) : pp.h vms$(O) : proto.h vms$(O) : regexp.h @@ -847,7 +899,7 @@ vms$(O) : scope.h vms$(O) : sv.h vms$(O) : vmsish.h vms$(O) : util.h -miniperlmain$(O) : INTERN.h +miniperlmain$(O) : EXTERN.h miniperlmain$(O) : av.h miniperlmain$(O) : config.h miniperlmain$(O) : cop.h @@ -862,6 +914,7 @@ miniperlmain$(O) : miniperlmain.c miniperlmain$(O) : op.h miniperlmain$(O) : opcode.h miniperlmain$(O) : perl.h +miniperlmain$(O) : perly.h miniperlmain$(O) : pp.h miniperlmain$(O) : proto.h miniperlmain$(O) : regexp.h @@ -869,7 +922,7 @@ miniperlmain$(O) : scope.h miniperlmain$(O) : sv.h miniperlmain$(O) : vmsish.h miniperlmain$(O) : util.h -perlmain$(O) : INTERN.h +perlmain$(O) : EXTERN.h perlmain$(O) : av.h perlmain$(O) : config.h perlmain$(O) : cop.h @@ -883,6 +936,7 @@ perlmain$(O) : mg.h perlmain$(O) : op.h perlmain$(O) : opcode.h perlmain$(O) : perl.h +perlmain$(O) : perly.h perlmain$(O) : perlmain.c perlmain$(O) : pp.h perlmain$(O) : proto.h @@ -891,6 +945,29 @@ perlmain$(O) : scope.h perlmain$(O) : sv.h perlmain$(O) : vmsish.h perlmain$(O) : util.h +globals$(O) : INTERN.h +globals$(O) : av.h +globals$(O) : config.h +globals$(O) : cop.h +globals$(O) : cv.h +globals$(O) : embed.h +globals$(O) : form.h +globals$(O) : gv.h +globals$(O) : handy.h +globals$(O) : hv.h +globals$(O) : mg.h +globals$(O) : op.h +globals$(O) : opcode.h +globals$(O) : perl.h +globals$(O) : perly.h +globals$(O) : globals.c +globals$(O) : pp.h +globals$(O) : proto.h +globals$(O) : regexp.h +globals$(O) : scope.h +globals$(O) : sv.h +globals$(O) : vmsish.h +globals$(O) : util.h config.h : [.vms]config.vms Copy/Log/NoConfirm [.vms]config.vms []config.h @@ -916,6 +993,8 @@ tidy : cleanlis - If f$$Search("*$(E);-1").nes."" Then Purge/NoConfirm/Log *$(E) - If f$$Search("Config.H;-1").nes."" Then Purge/NoConfirm/Log Config.H - If f$$Search("Config.SH;-1").nes."" Then Purge/NoConfirm/Log Config.SH + - If f$$Search("perly.c;-1").nes."" Then Purge/NoConfirm/Log perly.c + - If f$$Search("perly.h;-1").nes."" Then Purge/NoConfirm/Log perly.h - If f$$Search("VMSish.H;-1").nes."" Then Purge/NoConfirm/Log VMSish.H - If f$$Search("VMS.C;-1") .nes."" Then Purge/NoConfirm/Log VMS.C - If f$$Search("Perlmain.C;-1") .nes."" Then Purge/NoConfirm/Log Perlmain.C @@ -938,6 +1017,8 @@ clean : tidy - If f$$Search("Config.SH").nes."" Then Delete/NoConfirm/Log Config.SH;* - If f$$Search(f$$Parse("sys$$Disk:[]","$(SOCKH)")).nes."" Then Delete/NoConfirm/Log $(SOCKH);* - If f$$Search(f$$Parse("sys$$Disk:[]","$(SOCKC)")).nes."" Then Delete/NoConfirm/Log $(SOCKC);* + - If f$$Search("perly.c").nes."" Then Delete/NoConfirm/Log perly.c;* + - If f$$Search("perly.h").nes."" Then Delete/NoConfirm/Log perly.h;* - If f$$Search("VMSish.H").nes."" Then Delete/NoConfirm/Log VMSish.H;* - If f$$Search("VMS.C") .nes."" Then Delete/NoConfirm/Log VMS.C;* - If f$$Search("Perlmain.C") .nes."" Then Delete/NoConfirm/Log Perlmain.C;* @@ -945,19 +1026,18 @@ clean : tidy - If f$$Search("*.TS").nes."" Then Delete/NoConfirm/Log *.TS;* - If f$$Search("[.Ext.DynaLoader]DL_VMS$(O)").nes."" Then Delete/NoConfirm/Log [.Ext.DynaLoader]DL_VMS$(O);* - If f$$Search("[.Ext.DynaLoader]DL_VMS.C").nes."" Then Delete/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C;* + - If f$$Search("[.Ext.Socket]Socket$(O)").nes."" Then Delete/NoConfirm/Log [.Ext.Socket]Socket$(O);* + - If f$$Search("[.Ext.Socket]Socket.C").nes."" Then Delete/NoConfirm/Log [.Ext.Socket]Socket.C;* - If f$$Search("[.VMS.Ext...]*.C").nes."" Then Delete/NoConfirm/Log [.VMS.Ext...]*.C;* - If f$$Search("[.VMS.Ext...]*$(O)").nes."" Then Delete/NoConfirm/Log [.VMS.Ext...]*$(O);* realclean : clean - - If f$$Search("*$(E)").nes."" Then Delete/NoConfirm/Log *$(E);* - If f$$Search("*$(OLB)").nes."" Then Delete/NoConfirm/Log *$(OLB);* - If f$$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;* - - If f$$Search("[.Lib.Auto...]*.al").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]*.al;* - - If f$$Search("[.Lib.Auto...]autosplit.ix;-1").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ix;* + - $(MINIPERL) -e "use File::Path; rmtree(['lib/auto','lib/VMS','lib/$(ARCH)'],1,0);" - If f$$Search("[.Lib]DynaLoader.pm").nes."" Then Delete/NoConfirm/Log [.Lib]DynaLoader.pm;* - - If f$$Search("[.Lib.VMS]*.*").nes."" Then Delete/NoConfirm/Log [.Lib.VMS...]*.*;* - If f$$Search("[.Lib.ExtUtils]MM_VMS.pm").nes."" Then Delete/NoConfirm/Log [.Lib.ExtUtils]MM_VMS.pm;* - - If f$$Search("$(ARCHCORE)*.*").nes."" Then Delete/NoConfirm/Log $(ARCHCORE)*.*;* + - If f$$Search("*$(E)").nes."" Then Delete/NoConfirm/Log *$(E);* cleansrc : clean - If f$$Search("*.C;-1").nes."" Then Purge/NoConfirm/Log *.C @@ -972,4 +1052,5 @@ cleansrc : clean - If f$$Search("[.VMS...]*.xs;-1").nes."" Then Purge/NoConfirm/Log [.VMS...]*.xs - If f$$Search("[.Lib.Auto...]*.al").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]*.al;* - If f$$Search("[.Lib.Auto...]autosplit.ts").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ts;* + - If f$$Search("[.Lib.$(ARCH)]Config.pm").nes."" Then Delete/NoConfirm/Log [.Lib.$(ARCH)]Config.pm;* - If f$$Search("[.Lib]Config.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;* diff --git a/vms/config.vms b/vms/config.vms index 60de301fd1..6381339734 100644 --- a/vms/config.vms +++ b/vms/config.vms @@ -8,9 +8,10 @@ * GenConfig.pl when producing Config.pm. * * config.h for VMS + * Version: 5.1.5 */ -/* Configuration time: 18-Apr-1995 17:00 +/* Configuration time: 8-Jun-1995 17:00 * Configured by: Charles Bailey bailey@genetics.upenn.edu * Target system: VMS */ @@ -39,7 +40,7 @@ * same as PRIVLIB_EXP, it is not defined, since presumably the * program already searches PRIVLIB_EXP. */ -#ifndef __ALPHA +#ifdef __ALPHA #define ARCHLIB_EXP "/perl_root/lib/VMS_AXP" /* config-skip */ #else #define ARCHLIB_EXP "/perl_root/lib/VMS_VAX" /* config-skip */ @@ -485,6 +486,10 @@ * to determine the number of bytes in the buffer. USE_STDIO_BASE * will never be defined unless USE_STDIO_PTR is. */ +/* VMS: + * Regular FILE * are pretty close to meeting these criteria, but socket + * I/O uses a summy FILE *, and Perl doesn't distinguish between socket + * and non-socket filehandles. */ #undef USE_STDIO_PTR /**/ #undef USE_STDIO_BASE /**/ @@ -493,13 +498,23 @@ * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_PTR is defined. */ +/* STDIO_PTR_LVALUE: + * This symbol is defined if the FILE_ptr macro can be used as an + * lvalue. + */ /* FILE_cnt: * This macro is used to access the _cnt field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be * defined if USE_STDIO_PTR is defined. */ -#ifdef USE_STDIO_PTR -#endif +/* STDIO_CNT_LVALUE: + * This symbol is defined if the FILE_cnt macro can be used as an + * lvalue. + */ +#undef FILE_ptr +#undef STDIO_PTR_LVALUE +#undef FILE_cnt +#undef STDIO_CNT_LVALUE /* FILE_base: * This macro is used to access the _base field (or equivalent) of the @@ -512,8 +527,8 @@ * structure pointed to its argument. This macro will always be defined * if USE_STDIO_BASE is defined. */ -#ifdef USE_STDIO_BASE -#endif +#undef FILE_base +#undef FILE_bufsiz /* USE_STRUCT_COPY: * This symbol, if defined, indicates that this C compiler knows how @@ -940,7 +955,7 @@ /* VMS: * This symbol, if defined, indicates that the program is running under - * VMS. It's symbol automagically defined by all VMS C compilers I've seen. + * VMS. It's a symbol automagically defined by all VMS C compilers I've seen. * Just in case, however . . . */ #ifndef VMS #define VMS /**/ diff --git a/vms/descrip.mms b/vms/descrip.mms index 1af44baa6c..00985a6222 100644 --- a/vms/descrip.mms +++ b/vms/descrip.mms @@ -1,5 +1,5 @@ # Descrip.MMS for perl5 on VMS -# Last revised 10-Mar-1995 by Charles Bailey bailey@genetics.upenn.edu +# Last revised 5-Jun-1995 by Charles Bailey bailey@genetics.upenn.edu # #: This file uses MMS syntax, and can be processed using DEC's MMS product, #: or the free MMK clone (available by ftp at ftp.spc.edu). If you want to @@ -59,12 +59,13 @@ E = .exe .ifdef __AXP__ DECC = 1 -ARCHCORE = [.lib.VMS_AXP.CORE] -ARCHAUTO = [.lib.auto.VMS_AXP] +ARCH = VMS_AXP .else -ARCHCORE = [.lib.VMS_VAX.CORE] -ARCHAUTO = [.lib.auto.VMS_VAX] +ARCH = VMS_VAX .endif +ARCHDIR = [.lib.$(ARCH)] +ARCHCORE = [.lib.$(ARCH).CORE] +ARCHAUTO = [.lib.$(ARCH).auto] #: >>>>>Compiler-specific options <<<<< @@ -88,8 +89,15 @@ XTRAOBJS = LIBS1 = $(XTRAOBJS) DBGSPECFLAGS = /Show=(Source,Include,Expansion) .ifdef decc +# Some versions of DECCRTL on AXP have a bug in chdir() which causes the change +# to persist after the image exits, even when this was not requested, iff +# SYSNAM is enabled. This is fixed in CSC Patch # AXPACRT04_061, but turning +# off SYSNAM for the MM[SK] subprocess doesn't hurt anything, so we do it +# just in case. +.first + @ Set Process/Privilege=(NoSYSNAM) LIBS2 = -XTRACCFLAGS = /Warning=Disable=(ADDRCONSTEXT,MISSINGRETURN)/Include=[]/Prefix=All/Obj=$(MMS$TARGET_NAME)$(O) +XTRACCFLAGS = /Include=[]/Prefix=All/Obj=$(MMS$TARGET_NAME)$(O) XTRADEF = .else # VAXC XTRACCFLAGS = /Include=[]/Object=$(O) @@ -125,6 +133,7 @@ SOCKH = sockadapt.h SOCKCLIS = ,$(SOCKC) SOCKHLIS = ,$(SOCKH) SOCKOBJ = ,sockadapt$(O) +SOCKPM = [.lib]Socket.pm .else SOCKDEF = SOCKLIB = @@ -133,6 +142,7 @@ SOCKH = SOCKCLIS = SOCKHLIS = SOCKOBJ = +SOCKPM = .endif # C preprocessor manifest "DEBUGGING" ==> perl -D, not the VMS debugger @@ -146,15 +156,31 @@ NOOP = continue # Macros to invoke a copy of miniperl during the build. Targets which # are built using these macros should depend on $(MINIPERL_EXE) MINIPERL_EXE = Sys$Disk:[]miniperl$(E) -MINIPERL = MCR $(MINIPERL_EXE) +MINIPERL = MCR $(MINIPERL_EXE) "-Ilib" XSUBPP = $(MINIPERL) [.lib.extutils]xsubpp +# Macro to invoke a preexisting copy of Perl. This is used to regenerate +# some header files when rebuilding Perl, but premade versions are provided +# in the distribution, so it's OK if this doesn't work; it's here to make +# life easier for those who modify Perl and rebuild it. +INSTPERL = perl # Space-separated list of "static" extensions to build into perlshr (case counts). -EXT = DynaLoader +MYEXT = DynaLoader # object files for these extensions; the trailing comma is required if # there are any object files specified # These must be built separately, or you must add rules below to build them -extobj = [.ext.dynaloader]dl_vms$(O), +myextobj = [.ext.dynaloader]dl_vms$(O), +#: We include the Socket extension by default if we're building with socket +#: support, since it's small and not really worth bothering to keep track +#: of separately. +.ifdef SOCKET +EXT = $(MYEXT) Socket +extobj = $(myextobj) [.ext.socket]socket$(O), +.else +EXT = $(MYEXT) +extobj = $(myextobj) +.endif + #### End of system configuration section. #### @@ -211,7 +237,7 @@ CRTLOPTS =,$(CRTL)/Options all : base extras archcorefiles preplibrary @ $(NOOP) -base : miniperl$(E) perl$(E) [.lib]Config.pm +base : miniperl$(E) perl$(E) [.lib.$(ARCH)]Config.pm @ $(NOOP) extras : [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm [.lib.extutils]MM_VMS.pm @ $(NOOP) @@ -257,6 +283,10 @@ $(DBG)perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl $( @ Copy NLA0: $(DBG)perlshr_xtras.ts .endif +[.lib.$(ARCH)]config.pm : [.lib]config.pm + Create/Directory [.lib.$(ARCH)] + Copy $(MMS$SOURCE) $(MMS$TARGET) + [.lib]config.pm : [.vms]config.vms [.vms]genconfig.pl $(MINIPERL_EXE) $(MINIPERL) [.VMS]GenConfig.Pl cc=$(CC)$(CFLAGS) ldflags=$(LINKFLAGS) $(MINIPERL) ConfigPM. @@ -277,7 +307,7 @@ $(DBG)perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl $( [.lib.ExtUtils]MM_VMS.pm : [.vms.ext]MM_VMS.pm Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET) -preplibrary : $(MINIPERL_EXE) [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm [.lib.ExtUtils]MM_VMS.pm +preplibrary : $(MINIPERL_EXE) [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm [.lib.ExtUtils]MM_VMS.pm $(SOCKPM) @ Write Sys$Output "Autosplitting Perl library . . ." @ Create/Directory [.lib.auto] @ $(MINIPERL) "-Ilib" -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]*.pm [.lib.*]*.pm @@ -292,24 +322,43 @@ $(SOCKC) : [.vms]$(SOCKC) $(SOCKH) : [.vms]$(SOCKH) Copy/Log/NoConfirm [.vms]$(SOCKH) []$(SOCKH) + +[.ext.Socket]Socket.c : [.ext.Socket]Socket.xs $(MINIPERL_EXE) + $(XSUBPP) $(MMS$SOURCE) >$(MMS$TARGET) + +[.ext.Socket]Socket$(O) : [.ext.Socket]Socket.c + $(CC) $(CFLAGS) /Object=$(MMS$TARGET) $(MMS$SOURCE) + +[.lib]Socket.pm : [.ext.Socket]Socket.pm + Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET) .endif -#opcode.h : opcode.pl $(MINIPERL_EXE) -# $(MINIPERL) opcode.pl +opcode.h : opcode.pl + @ Write Sys$Output "Don't worry if this fails." + - $(INSTPERL) opcode.pl +keywords.h : keywords.pl + @ Write Sys$Output "Don't worry if this fails." + - $(INSTPERL) keywords.pl +embed.h : global.sym interp.sym + @ Write Sys$Output "Don't worry if this fails." + - $(INSTPERL) [.vms]embed_h.pl -perly.h : perly.c # Quick and dirty 'touch' - Copy/Log/NoConfirm perly.h; ; - Delete/Log/NoConfirm perly.h;-1 +# VMS uses modified perly.[ch] with tags for globaldefs if using DEC compiler +perly.c : [.vms]perly_c.vms + Copy/Log $(MMS$SOURCE) $(MMS$TARGET) +perly.h : [.vms]perly_h.vms + Copy/Log $(MMS$SOURCE) $(MMS$TARGET) # I now supply perly.c with the kits, so the following section is # commented out if you don't have byacc. - +# Altered for VMS by Charles Bailey bailey@genetics.upenn.edu # perly.c: -# @ echo 'Expect' 80 shift/reduce and 62 reduce/reduce conflicts +# @ Write Sys$Output 'Expect' 80 shift/reduce and 62 reduce/reduce conflicts # \$(BYACC) -d perly.y +# Has to be done by hand or by POSIX shell under VMS # sh \$(shellflags) ./perly.fixer y.tab.c perly.c -# mv y.tab.h perly.h -# echo 'extern YYSTYPE yylval;' >>perly.h +# rename y.tab.h perly.h +# $(INSTPERL) [.vms]vms_yfix.pl perly.c perly.h [.vms]perly_c.vms [.vms]perly_h.vms perly$(O) : perly.c, perly.h, $(h) $(CC) $(CFLAGS) $(MMS$SOURCE) @@ -434,6 +483,7 @@ av$(O) : mg.h av$(O) : op.h av$(O) : opcode.h av$(O) : perl.h +av$(O) : perly.h av$(O) : pp.h av$(O) : proto.h av$(O) : regexp.h @@ -455,6 +505,7 @@ scope$(O) : mg.h scope$(O) : op.h scope$(O) : opcode.h scope$(O) : perl.h +scope$(O) : perly.h scope$(O) : pp.h scope$(O) : proto.h scope$(O) : regexp.h @@ -478,6 +529,7 @@ op$(O) : op.c op$(O) : op.h op$(O) : opcode.h op$(O) : perl.h +op$(O) : perly.h op$(O) : pp.h op$(O) : proto.h op$(O) : regexp.h @@ -500,6 +552,7 @@ doop$(O) : mg.h doop$(O) : op.h doop$(O) : opcode.h doop$(O) : perl.h +doop$(O) : perly.h doop$(O) : pp.h doop$(O) : proto.h doop$(O) : regexp.h @@ -522,6 +575,7 @@ doio$(O) : mg.h doio$(O) : op.h doio$(O) : opcode.h doio$(O) : perl.h +doio$(O) : perly.h doio$(O) : pp.h doio$(O) : proto.h doio$(O) : regexp.h @@ -544,6 +598,7 @@ dump$(O) : mg.h dump$(O) : op.h dump$(O) : opcode.h dump$(O) : perl.h +dump$(O) : perly.h dump$(O) : pp.h dump$(O) : proto.h dump$(O) : regexp.h @@ -566,6 +621,7 @@ hv$(O) : mg.h hv$(O) : op.h hv$(O) : opcode.h hv$(O) : perl.h +hv$(O) : perly.h hv$(O) : pp.h hv$(O) : proto.h hv$(O) : regexp.h @@ -588,6 +644,7 @@ mg$(O) : mg.h mg$(O) : op.h mg$(O) : opcode.h mg$(O) : perl.h +mg$(O) : perly.h mg$(O) : pp.h mg$(O) : proto.h mg$(O) : regexp.h @@ -610,6 +667,7 @@ perl$(O) : op.h perl$(O) : opcode.h perl$(O) : perl.c perl$(O) : perl.h +perl$(O) : perly.h perl$(O) : pp.h perl$(O) : proto.h perl$(O) : regexp.h @@ -631,6 +689,7 @@ perly$(O) : mg.h perly$(O) : op.h perly$(O) : opcode.h perly$(O) : perl.h +perly$(O) : perly.h perly$(O) : perly.c perly$(O) : pp.h perly$(O) : proto.h @@ -653,6 +712,7 @@ pp$(O) : mg.h pp$(O) : op.h pp$(O) : opcode.h pp$(O) : perl.h +pp$(O) : perly.h pp$(O) : pp.c pp$(O) : pp.h pp$(O) : proto.h @@ -675,6 +735,7 @@ pp_ctl$(O) : mg.h pp_ctl$(O) : op.h pp_ctl$(O) : opcode.h pp_ctl$(O) : perl.h +pp_ctl$(O) : perly.h pp_ctl$(O) : pp_ctl.c pp_ctl$(O) : pp.h pp_ctl$(O) : proto.h @@ -697,6 +758,7 @@ pp_hot$(O) : mg.h pp_hot$(O) : op.h pp_hot$(O) : opcode.h pp_hot$(O) : perl.h +pp_hot$(O) : perly.h pp_hot$(O) : pp_hot.c pp_hot$(O) : pp.h pp_hot$(O) : proto.h @@ -719,6 +781,7 @@ pp_sys$(O) : mg.h pp_sys$(O) : op.h pp_sys$(O) : opcode.h pp_sys$(O) : perl.h +pp_sys$(O) : perly.h pp_sys$(O) : pp_sys.c pp_sys$(O) : pp.h pp_sys$(O) : proto.h @@ -742,6 +805,7 @@ regcomp$(O) : mg.h regcomp$(O) : op.h regcomp$(O) : opcode.h regcomp$(O) : perl.h +regcomp$(O) : perly.h regcomp$(O) : pp.h regcomp$(O) : proto.h regcomp$(O) : regcomp.c @@ -765,6 +829,7 @@ regexec$(O) : mg.h regexec$(O) : op.h regexec$(O) : opcode.h regexec$(O) : perl.h +regexec$(O) : perly.h regexec$(O) : pp.h regexec$(O) : proto.h regexec$(O) : regcomp.h @@ -789,6 +854,7 @@ gv$(O) : mg.h gv$(O) : op.h gv$(O) : opcode.h gv$(O) : perl.h +gv$(O) : perly.h gv$(O) : pp.h gv$(O) : proto.h gv$(O) : regexp.h @@ -833,6 +899,7 @@ taint$(O) : mg.h taint$(O) : op.h taint$(O) : opcode.h taint$(O) : perl.h +taint$(O) : perly.h taint$(O) : pp.h taint$(O) : proto.h taint$(O) : regexp.h @@ -879,6 +946,7 @@ util$(O) : mg.h util$(O) : op.h util$(O) : opcode.h util$(O) : perl.h +util$(O) : perly.h util$(O) : pp.h util$(O) : proto.h util$(O) : regexp.h @@ -902,6 +970,7 @@ deb$(O) : mg.h deb$(O) : op.h deb$(O) : opcode.h deb$(O) : perl.h +deb$(O) : perly.h deb$(O) : pp.h deb$(O) : proto.h deb$(O) : regexp.h @@ -923,6 +992,7 @@ run$(O) : mg.h run$(O) : op.h run$(O) : opcode.h run$(O) : perl.h +run$(O) : perly.h run$(O) : pp.h run$(O) : proto.h run$(O) : regexp.h @@ -945,6 +1015,7 @@ vms$(O) : mg.h vms$(O) : op.h vms$(O) : opcode.h vms$(O) : perl.h +vms$(O) : perly.h vms$(O) : pp.h vms$(O) : proto.h vms$(O) : regexp.h @@ -953,7 +1024,7 @@ vms$(O) : scope.h vms$(O) : sv.h vms$(O) : vmsish.h vms$(O) : util.h -miniperlmain$(O) : INTERN.h +miniperlmain$(O) : EXTERN.h miniperlmain$(O) : av.h miniperlmain$(O) : config.h miniperlmain$(O) : cop.h @@ -968,6 +1039,7 @@ miniperlmain$(O) : miniperlmain.c miniperlmain$(O) : op.h miniperlmain$(O) : opcode.h miniperlmain$(O) : perl.h +miniperlmain$(O) : perly.h miniperlmain$(O) : pp.h miniperlmain$(O) : proto.h miniperlmain$(O) : regexp.h @@ -975,7 +1047,7 @@ miniperlmain$(O) : scope.h miniperlmain$(O) : sv.h miniperlmain$(O) : vmsish.h miniperlmain$(O) : util.h -perlmain$(O) : INTERN.h +perlmain$(O) : EXTERN.h perlmain$(O) : av.h perlmain$(O) : config.h perlmain$(O) : cop.h @@ -989,6 +1061,7 @@ perlmain$(O) : mg.h perlmain$(O) : op.h perlmain$(O) : opcode.h perlmain$(O) : perl.h +perlmain$(O) : perly.h perlmain$(O) : perlmain.c perlmain$(O) : pp.h perlmain$(O) : proto.h @@ -997,6 +1070,29 @@ perlmain$(O) : scope.h perlmain$(O) : sv.h perlmain$(O) : vmsish.h perlmain$(O) : util.h +globals$(O) : INTERN.h +globals$(O) : av.h +globals$(O) : config.h +globals$(O) : cop.h +globals$(O) : cv.h +globals$(O) : embed.h +globals$(O) : form.h +globals$(O) : gv.h +globals$(O) : handy.h +globals$(O) : hv.h +globals$(O) : mg.h +globals$(O) : op.h +globals$(O) : opcode.h +globals$(O) : perl.h +globals$(O) : perly.h +globals$(O) : globals.c +globals$(O) : pp.h +globals$(O) : proto.h +globals$(O) : regexp.h +globals$(O) : scope.h +globals$(O) : sv.h +globals$(O) : vmsish.h +globals$(O) : util.h config.h : [.vms]config.vms Copy/Log/NoConfirm [.vms]config.vms []config.h @@ -1022,6 +1118,8 @@ tidy : cleanlis - If F$Search("*$(E);-1").nes."" Then Purge/NoConfirm/Log *$(E) - If F$Search("Config.H;-1").nes."" Then Purge/NoConfirm/Log Config.H - If F$Search("Config.SH;-1").nes."" Then Purge/NoConfirm/Log Config.SH + - If F$Search("perly.c;-1").nes."" Then Purge/NoConfirm/Log perly.c + - If F$Search("perly.h;-1").nes."" Then Purge/NoConfirm/Log perly.h - If F$Search("VMSish.H;-1").nes."" Then Purge/NoConfirm/Log VMSish.H - If F$Search("VMS.C;-1") .nes."" Then Purge/NoConfirm/Log VMS.C - If F$Search("Perlmain.C;-1") .nes."" Then Purge/NoConfirm/Log Perlmain.C @@ -1044,6 +1142,8 @@ clean : tidy - If F$Search("Config.SH").nes."" Then Delete/NoConfirm/Log Config.SH;* - If F$Search(F$Parse("Sys$Disk:[]","$(SOCKH)")).nes."" Then Delete/NoConfirm/Log $(SOCKH);* - If F$Search(F$Parse("Sys$Disk:[]","$(SOCKC)")).nes."" Then Delete/NoConfirm/Log $(SOCKC);* + - If F$Search("perly.c").nes."" Then Delete/NoConfirm/Log perly.c;* + - If F$Search("perly.h").nes."" Then Delete/NoConfirm/Log perly.h;* - If F$Search("VMSish.H").nes."" Then Delete/NoConfirm/Log VMSish.H;* - If F$Search("VMS.C") .nes."" Then Delete/NoConfirm/Log VMS.C;* - If F$Search("Perlmain.C") .nes."" Then Delete/NoConfirm/Log Perlmain.C;* @@ -1051,19 +1151,18 @@ clean : tidy - If F$Search("*.TS").nes."" Then Delete/NoConfirm/Log *.TS;* - If F$Search("[.Ext.DynaLoader]DL_VMS$(O)").nes."" Then Delete/NoConfirm/Log [.Ext.DynaLoader]DL_VMS$(O);* - If F$Search("[.Ext.DynaLoader]DL_VMS.C").nes."" Then Delete/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C;* + - If F$Search("[.Ext.Socket]Socket$(O)").nes."" Then Delete/NoConfirm/Log [.Ext.Socket]Socket$(O);* + - If F$Search("[.Ext.Socket]Socket.C").nes."" Then Delete/NoConfirm/Log [.Ext.Socket]Socket.C;* - If F$Search("[.VMS.Ext...]*.C").nes."" Then Delete/NoConfirm/Log [.VMS.Ext...]*.C;* - If F$Search("[.VMS.Ext...]*$(O)").nes."" Then Delete/NoConfirm/Log [.VMS.Ext...]*$(O);* realclean : clean - - If F$Search("*$(E)").nes."" Then Delete/NoConfirm/Log *$(E);* - If F$Search("*$(OLB)").nes."" Then Delete/NoConfirm/Log *$(OLB);* - If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;* - - If F$Search("[.Lib.Auto...]*.al").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]*.al;* - - If F$Search("[.Lib.Auto...]autosplit.ix;-1").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ix;* + - $(MINIPERL) -e "use File::Path; rmtree(['lib/auto','lib/VMS','lib/$(ARCH)'],1,0);" - If F$Search("[.Lib]DynaLoader.pm").nes."" Then Delete/NoConfirm/Log [.Lib]DynaLoader.pm;* - - If F$Search("[.Lib.VMS]*.*").nes."" Then Delete/NoConfirm/Log [.Lib.VMS...]*.*;* - If F$Search("[.Lib.ExtUtils]MM_VMS.pm").nes."" Then Delete/NoConfirm/Log [.Lib.ExtUtils]MM_VMS.pm;* - - If F$Search("$(ARCHCORE)*.*").nes."" Then Delete/NoConfirm/Log $(ARCHCORE)*.*;* + - If F$Search("*$(E)").nes."" Then Delete/NoConfirm/Log *$(E);* cleansrc : clean - If F$Search("*.C;-1").nes."" Then Purge/NoConfirm/Log *.C @@ -1078,4 +1177,5 @@ cleansrc : clean - If F$Search("[.VMS...]*.xs;-1").nes."" Then Purge/NoConfirm/Log [.VMS...]*.xs - If F$Search("[.Lib.Auto...]*.al").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]*.al;* - If F$Search("[.Lib.Auto...]autosplit.ts").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ts;* + - If F$Search("[.Lib.$(ARCH)]Config.pm").nes."" Then Delete/NoConfirm/Log [.Lib.$(ARCH)]Config.pm;* - If F$Search("[.Lib]Config.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;* diff --git a/vms/ext/MM_VMS.pm b/vms/ext/MM_VMS.pm index 801f2f8587..4701245f52 100644 --- a/vms/ext/MM_VMS.pm +++ b/vms/ext/MM_VMS.pm @@ -3,9 +3,9 @@ # This package is inserted into @ISA of MakeMaker's MM before the # built-in MM_Unix methods if MakeMaker.pm is run under VMS. # -# Version: 4.03 +# Version: 4.15 # Author: Charles Bailey bailey@genetics.upenn.edu -# Revised: 30-Jan-1995 +# Revised: 11-Jun-1995 package ExtUtils::MM_VMS; @@ -18,17 +18,95 @@ Exporter::import('ExtUtils::MakeMaker', qw(%att %skip %Recognized_Att_Keys $Verbose &neatvalue)); -sub fixpath { - my($path) = @_; +sub eliminate_macros { + my($path) = unixify(@_); my($head,$macro,$tail); while (($head,$macro,$tail) = ($path =~ m#(.*?)\$\((\S+?)\)/(.*)#)) { ($macro = unixify($att{$macro})) =~ s#/$##; $path = "$head$macro/$tail"; } - vmsify($path); + $path; +} + +sub fixpath { + my($path) = @_; + return $path if $path =~ /^[^\)\/]+\)?[\w\-\.]*/; + vmsify(eliminate_macros(@_)); +} + +sub catdir { + my($self,$path,$dir) = @_; + vmspath(eliminate_macros($path).'/'.eliminate_macros($dir)); } +sub catfile { + my($self,$path,$file) = @_; + if ( $path =~ /^[^\)\]\/:>]+\)$/ ) { "$path$file"; } + else { vmsify(eliminate_macros($path)."/$file"); } +} + + +sub find_perl{ + my($self, $ver, $names, $dirs, $trace) = @_; + my($name, $dir,$vmsfile); + if ($trace){ + print "Looking for perl $ver by these names: "; + print "@$names, "; + print "in these dirs:"; + print "@$dirs"; + } + foreach $dir (@$dirs){ + next unless defined $dir; # $att{PERL_SRC} may be undefined + foreach $name (@$names){ + $name .= ".exe" unless -x "$dir/$name"; + $vmsfile = vmsify("$dir/$name"); + print "Checking $vmsfile" if ($trace >= 2); + next unless -x "$vmsfile"; + print "Executing $vmsfile" if ($trace >= 2); + if (`MCR $vmsfile -e "require $ver; print ""VER_OK\n"""` =~ /VER_OK/) { + print "Using PERL=MCR $vmsfile" if $trace; + return "MCR $vmsfile" + } + } + } + print STDOUT "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n"; + 0; # false and not empty +} + + +# $att{NAME} is taken from the directory name if it's not passed in. +# Since VMS filenames are case-insensitive, we actually look in the +# extension files to find the Mixed-case name +sub init_main { + my($self) = @_; + + if (!$att{NAME}) { + my($defname,$defpm); + local *PM; + $defname = $ENV{'DEFAULT'}; + $defname =~ s:.*?([^.\]]+)\]:$1: unless ($defname =~ s:.*[.\[]ext\.(.*)\]:$1:i); + $defname =~ s#[.\]]#::#g; + ($defpm = $defname) =~ s/.*:://; + if (open(PM,"${defpm}.pm")){ + while () { + if (/^\s*package\s+($defname)/oi) { + $att{NAME} = $1; + last; + } + } + close PM; + print STDOUT "Warning (non-fatal): Couldn't find package name in ${defpm}.pm;\n\t", + "defaulting package name to $defname\n" unless $att{NAME}; + } + else { + print STDOUT "Warning (non-fatal): Couldn't find ${defpm}.pm;\n\t", + "defaulting package name to $defname\n" unless $att{NAME}; + } + $att{NAME} = $defname unless $att{NAME}; + } + MM_Unix::init_main(@_); +} sub init_others { &MM_Unix::init_others; @@ -36,17 +114,20 @@ sub init_others { $att{MAKEFILE} = '$(MAKEFILE)'; $att{RM_F} = '$(PERL) -e "foreach (@ARGV) { -d $_ ? rmdir $_ : unlink $_}"'; $att{RM_RF} = '$(PERL) -e "use File::Path; use VMS::Filespec; @dirs = map(unixify($_),@ARGV); rmtree(\@dirs,0,0)"'; - $att{TOUCH} = '$(PERL) -e "$t=time; utime $t,$t,@ARGV"'; + $att{TOUCH} = '$(PERL) -e "$t=time; foreach (@ARGV) { -e $_ ? utime($t,$t,@ARGV) : (open(F,"">$_""),close F)"'; + $att{CHMOD} = '$(PERL) -e "chmod @ARGV"'; # expect Unix syntax from MakeMaker $att{CP} = 'Copy/NoConfirm'; $att{MV} = 'Rename/NoConfirm'; } sub constants { + my($self) = @_; my(@m,$def); push @m, " NAME = $att{NAME} DISTNAME = $att{DISTNAME} VERSION = $att{VERSION} +VERSION_SYM = $att{VERSION_SYM} # In which library should we install this extension? # This is typically the same as PERL_LIB. @@ -55,25 +136,38 @@ INST_LIB = ",vmspath($att{INST_LIB})," INST_ARCHLIB = ",vmspath($att{INST_ARCHLIB})," INST_EXE = ",vmspath($att{INST_EXE})," +# AFS users will want to set the installation directories for +# the final 'make install' early without setting INST_LIB, +# INST_ARCHLIB, and INST_EXE for the testing phase +INSTALLPRIVLIB = ",vmspath($att{INSTALLPRIVLIB}),' +INSTALLARCHLIB = ',vmspath($att{INSTALLARCHLIB}),' +INSTALLBIN = ',vmspath($att{INSTALLBIN}),' + # Perl library to use when building the extension -PERL_LIB = ",vmspath($att{PERL_LIB})," -PERL_ARCHLIB = ",vmspath($att{PERL_ARCHLIB})," -LIBPERL_A = ",vmsify($att{LIBPERL_A})," +PERL_LIB = ',vmspath($att{PERL_LIB}),' +PERL_ARCHLIB = ',vmspath($att{PERL_ARCHLIB}),' +LIBPERL_A = ',vmsify($att{LIBPERL_A}),' + +MAKEMAKER = ',vmsify(unixpath($att{PERL_LIB}).'ExtUtils/MakeMaker.pm')," +MM_VERSION = $ExtUtils::MakeMaker::Version "; -# Define I_PERL_LIBS to include the required -Ipaths -# To be cute we only include PERL_ARCHLIB if different -# To be portable we add quotes for VMS -my(@i_perl_libs) = qw{-I$(PERL_ARCHLIB) -I$(PERL_LIB)}; -shift(@i_perl_libs) if ($att{PERL_ARCHLIB} eq $att{PERL_LIB}); -push @m, "I_PERL_LIBS = \"".join('" "',@i_perl_libs)."\"\n"; + # Define I_PERL_LIBS to include the required -Ipaths + # To be cute we only include PERL_ARCHLIB if different + # To be portable we add quotes for VMS + #### Deprecated from Version 4.11: We want to avoid different + #### behavior for variables with make(1) and perl(1) + + my(@i_perl_libs) = qw{-I$(PERL_ARCHLIB) -I$(PERL_LIB)}; + shift(@i_perl_libs) if ($att{PERL_ARCHLIB} eq $att{PERL_LIB}); + push @m, "I_PERL_LIBS = \"".join('" "',@i_perl_libs)."\"\n"; -if ($att{PERL_SRC}) { - push @m, " + if ($att{PERL_SRC}) { + push @m, " # Where is the perl source code located? PERL_SRC = ",vmspath($att{PERL_SRC}); -} - push @m," + } + push @m," # Perl header files (will eventually be under PERL_LIB) PERL_INC = ",vmspath($att{PERL_INC})," # Perl binaries @@ -108,16 +202,22 @@ INC = "; $att{DEFINE} = join ',',@defs; } + $att{OBJECT} =~ s#\.o\b#\.obj#; + if ($att{OBJECT} =~ /\s/) { + $att{OBJECT} =~ s/(\\)?\n+\s+/ /g; + $att{OBJECT} = map(vmsify($_),split(/,?\s+/,$att{OBJECT})); + } + $att{LDFROM} = join(' ',map(fixpath($_),split(/,?\s+/,$att{LDFROM}))); push @m," DEFINE = $att{DEFINE} -OBJECT = ",vmsify($att{OBJECT})," -LDFROM = ",vmsify($att{LDFROM})," +OBJECT = $att{OBJECT} +LDFROM = $att{LDFROM}) LINKTYPE = $att{LINKTYPE} # Handy lists of source code files: XS_FILES = ",join(', ', sort keys %{$att{XS}})," C_FILES = ",join(', ', @{$att{C}})," -O_FILES = ",join(', ', @{$att{O_FILES}})," +O_FILES = ",join(', ', map { s#\.o\b#\.obj#; $_ } @{$att{O_FILES}} )," H_FILES = ",join(', ', @{$att{H}})," .SUFFIXES : .xs @@ -135,10 +235,23 @@ INST_ARCHLIBDIR = ",($att{'INST_ARCHLIBDIR'} = vmspath(unixpath($att{INST_ARCHLI INST_AUTODIR = ",($att{'INST_AUTODIR'} = vmspath(unixpath($att{INST_LIB}) . 'auto/' . unixpath($att{FULLEXT}))),' INST_ARCHAUTODIR = ',($att{'INST_ARCHAUTODIR'} = vmspath(unixpath($att{INST_ARCHLIB}) . 'auto/' . unixpath($att{FULLEXT}))),' +'; + if ($self->needs_linking) { + push @m,' INST_STATIC = $(INST_ARCHAUTODIR)$(BASEEXT).olb INST_DYNAMIC = $(INST_ARCHAUTODIR)$(BASEEXT).$(DLEXT) INST_BOOT = $(INST_ARCHAUTODIR)$(BASEEXT).bs +'; + } else { + push @m,' +INST_STATIC = +INST_DYNAMIC = +INST_BOOT = +'; + } + + push @m,' INST_PM = ',join(', ',map(fixpath($_),sort values %{$att{PM}})),' '; @@ -182,20 +295,36 @@ sub const_loadlibs{ my (@m); push @m, " # $att{NAME} might depend on some other libraries. +# (These comments may need revising:) # -# Dependent libraries are linked in either by the Link command -# at build time or by the DynaLoader at bootstrap time. +# Dependent libraries can be linked in one of three ways: # -# These comments may need revising: +# 1. (For static extensions) by the ld command when the perl binary +# is linked with the extension library. See EXTRALIBS below. # -# EXTRALIBS = Full list of libraries needed for static linking. +# 2. (For dynamic extensions) by the ld command when the shared +# object is built/linked. See LDLOADLIBS below. +# +# 3. (For dynamic extensions) by the DynaLoader when the shared +# object is loaded. See BSLOADLIBS below. +# +# EXTRALIBS = List of libraries that need to be linked with when +# linking a perl binary which includes this extension # Only those libraries that actually exist are included. +# These are written to a file and used when linking perl. # -# BSLOADLIBS = List of those libraries that are needed but can be -# linked in dynamically. +# LDLOADLIBS = List of those libraries which can or must be linked into +# the shared library when created using ld. These may be +# static or dynamic libraries. +# LD_RUN_PATH is a colon separated list of the directories +# in LDLOADLIBS. It is passed as an environment variable to +# the process that links the shared library. # -# LDLOADLIBS = List of those libraries which must be statically -# linked into the shared library. +# BSLOADLIBS = List of those libraries that are needed but can be +# linked in dynamically at run time on this platform. +# SunOS/Solaris does not need this because ld records +# the information (from LDLOADLIBS) into the object file. +# This list is used to create a .bs (bootstrap) file. # EXTRALIBS = ",map(vmsify($_) . ' ',$att{'EXTRALIBS'})," BSLOADLIBS = ",map(vmsify($_) . ' ',$att{'BSLOADLIBS'})," @@ -212,7 +341,7 @@ sub tool_autosplit{ $asl = "\$AutoSplit::Maxlen=$attribs{MAXLEN};" if $attribs{MAXLEN}; q{ # Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto -AUTOSPLITFILE = $(PERL) $(I_PERL_LIBS) -e "use AutoSplit;}.$asl.q{ AutoSplit::autosplit($ARGV[0], $ARGV[1], 0, 1, 1) ;" +AUTOSPLITFILE = $(PERL) "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)" -e "use AutoSplit;}.$asl.q{ AutoSplit::autosplit($ARGV[0], $ARGV[1], 0, 1, 1) ;" }; } @@ -234,6 +363,8 @@ XSUBPPARGS = @tmargs sub tools_other { " # Assumes \$(MMS) invokes MMS or MMK +# (It is assumed in some cases later that the default makefile name +# (Descrip.MMS for MM[SK]) is used.) USEMAKEFILE = /Descrip= USEMACROS = /Macro=( MACROEND = ) @@ -298,22 +429,27 @@ sub dlsyms { my(@m); push(@m,' -dynamic :: perlshr.opt $(BASEEXT).opt +dynamic :: $(INST_ARCHAUTODIR)perlshr.opt $(INST_ARCHAUTODIR)$(BASEEXT).opt ',$att{NOOP},' -perlshr.opt : makefile.PL +$(INST_ARCHAUTODIR)perlshr.opt : makefile.PL $(PERL) -e "open O,\'>perlshr.opt\'; print O ""PerlShr/Share\n""; close O" + @ $(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR).packlist\';print F \'$(MMS$TARGET)\';close F;" ') unless $skip{'dynamic'}; push(@m,' -static :: $(BASEEXT).opt +static :: $(INST_ARCHAUTODIR)$(BASEEXT).opt ',$att{NOOP},' ') unless $skip{'static'}; push(@m,' +$(INST_ARCHAUTODIR)$(BASEEXT).opt : $(BASEEXT).opt + $(CP) $(MMS$SOURCE) $(MMS$TARGET) + $(BASEEXT).opt : makefile.PL - $(PERL) $(I_PERL_LIBS) -e "use ExtUtils::MakeMaker; mksymlists(DL_FUNCS => ',neatvalue($att{DL_FUNCS}),', DL_VARS => ',neatvalue($att{DL_VARS}),',NAME => ',$att{NAME},')" - $(PERL) $(I_PERL_LIBS) -e "open OPT,\'>>$(MMS$TARGET)\'; print OPT ""$(INST_STATIC)/Include=$(BASEEXT)\n$(INST_STATIC)/Library\n"";close OPT" + $(PERL) "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)" -e "use ExtUtils::MakeMaker; mksymlists(DL_FUNCS => ',neatvalue($att{DL_FUNCS}),', DL_VARS => ',neatvalue($att{DL_VARS}),',NAME => \'',$att{NAME},'\')" + $(PERL) -e "open OPT,\'>>$(MMS$TARGET)\'; print OPT ""$(INST_STATIC)/Include=$(BASEEXT)\n$(INST_STATIC)/Library\n"";close OPT" + @ $(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR).packlist\';print F \'$(MMS$TARGET)\';close F;" '); join('',@m); @@ -332,9 +468,11 @@ OTHERLDFLAGS = $otherldflags "; push @m, ' -$(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt perlshr.opt $(BASEEXT).opt +$(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt $(INST_ARCHAUTODIR)perlshr.opt $(INST_ARCHAUTODIR)$(BASEEXT).opt @ $(MKPATH) $(INST_ARCHAUTODIR) - Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,perlshr.opt/Option,$(PERL_INC)perlshr_attr.opt/Option + Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(INST_ARCHAUTODIR)$(BASEEXT).opt/Option,perlshr.opt/Option,$(PERL_INC)perlshr_attr.opt/Option + $(CHMOD) 755 $(MMS$TARGET) + @ $(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR).packlist\';print F \'$(MMS$TARGET)\';close F;" '; join('',@m); @@ -348,25 +486,34 @@ BOOTSTRAP = '."$att{BASEEXT}.bs".' # As MakeMaker mkbootstrap might not write a file (if none is required) # we use touch to prevent make continually trying to remake it. # The DynaLoader only reads a non-empty file. -$(BOOTSTRAP): '."$att{MAKEFILE} $att{BOOTDEP}".' +$(BOOTSTRAP) : '."$att{MAKEFILE} $att{BOOTDEP}".' @ Write Sys$Output "Running mkbootstrap for $(NAME) ($(BSLOADLIBS))" - @ $(PERL) $(I_PERL_LIBS) -e "use ExtUtils::MakeMaker; &mkbootstrap(""$(BSLOADLIBS)"");" "INST_LIB=$(INST_LIB)" "INST_ARCHLIB=$(INST_ARCHLIB)" "PERL_SRC=$(PERL_SRC)" "NAME=$(NAME)" - @ $(TOUCH) $(BOOTSTRAP) + @ $(PERL) "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)" -e "use ExtUtils::Mkbootstrap; Mkbootstrap(\'$(BASEEXT)\',\'$(BSLOADLIBS)\');" + @ $(TOUCH) $(MMS$TARGET) + $(CHMOD) 644 $(MMS$TARGET) + @ $(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR).packlist\';print F \'$(MMS$TARGET)\';close F;" -$(INST_BOOT): $(BOOTSTRAP) +$(INST_BOOT) : $(BOOTSTRAP) @ '.$att{RM_RF}.' $(INST_BOOT) - - '.$att{CP}.' $(BOOTSTRAP) $(INST_BOOT) + - $(CP) $(BOOTSTRAP) $(INST_BOOT) + $(CHMOD) 644 $(MMS$TARGET) + @ $(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR).packlist\';print F \'$(MMS$TARGET)\';close F;" '; } # --- Static Loading Sections --- sub static_lib { - ' -$(INST_STATIC) : $(OBJECT), $(MYEXTLIB) - @ $(MKPATH) $(INST_ARCHAUTODIR) + my(@m); + push @m,' +$(INST_STATIC) : $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR).exists If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET) Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST) + $(CHMOD) 755 $(MMS$TARGET) + @ $(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR)extralibs.ld\';print F \'$(EXTRALIBS)\';close F;" + @ $(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR).packlist\';print F \'$(MMS$TARGET)\';close F;" '; + push @m, MM->dir_target('$(INST_ARCHAUTODIR)'); + join('',@m); } @@ -374,14 +521,15 @@ sub installpm_x { # called by installpm perl file my($self, $dist, $inst, $splitlib) = @_; $inst = fixpath($inst); $dist = vmsify($dist); - my($instdir) = dirname($inst); + my($instdir) = $inst =~ /([^\)]+\))[^\)]*$/ ? $1 : dirname($inst); my(@m); push(@m, " -$inst : $dist $att{MAKEFILE} -",' @ ',$att{RM_F},' $(MMS$TARGET);* - @ $(MKPATH) ',$instdir,' - @ ',$att{CP},' $(MMS$SOURCE) $(MMS$TARGET) +$inst : $dist $att{MAKEFILE} ${instdir}.exists +",' @ $(RM_F) $(MMS$TARGET);* + @ $(CP) $(MMS$SOURCE) $(MMS$TARGET) + $(CHMOD) 644 $(MMS$TARGET) + @ $(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR).packlist\';print F \'$(MMS$TARGET)\';close F;" '); if ($splitlib and $inst =~ /\.pm$/) { my($attdir) = $splitlib; @@ -389,46 +537,101 @@ $inst : $dist $att{MAKEFILE} $attdir = $att{$attdir} if $att{$attdir}; push(@m, ' $(AUTOSPLITFILE) $(MMS$TARGET) ', - vmspath(unixpath($attdir) . 'auto')."\n"); - push(@m,"\n"); + vmspath(unixpath($attdir) . 'auto')."\n\n"); } + push(@m,MM->dir_target($instdir)); join('',@m); } +sub processPL { + return "" unless $att{PL_FILES}; + my(@m, $plfile); + foreach $plfile (sort keys %{$att{PL_FILES}}) { + push @m, " +all :: $att{PL_FILES}->{$plfile} -# --- Sub-directory Sections --- +$att{PL_FILES}->{$plfile} :: $plfile +",' $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" '," $plfile +"; + } + join "", @m; +} + + +sub installbin { + return "" unless $att{EXE_FILES} && ref $att{EXE_FILES} eq "ARRAY"; + my(@m, $from, $to, %fromto, @to, $line); + for $from (@{$att{EXE_FILES}}) { + local($_)= '$(INST_EXE)' . basename($from); + $to = MY->exescan(); + print "exescan($from) => '$to'" if ($Verbose >=2); + $fromto{$from}=$to; + } + @to = values %fromto; + push @m, " +EXE_FILES = @{$att{EXE_FILES}} -sub exescan { - vmsify($_); +all :: @to + +realclean :: +"; + $line = ''; #avoid unitialized var warning + foreach $to (@to) { + if (length($line) + length($to) > 150) { + push @m, "\t\$(RM_F) $line\n"; + $line = $to; + } + else { $line .= " $to"; } + } + push @m, "\t\$(RM_F) $line\n\n"; + + while (($from,$to) = each %fromto) { + my $todir; + if ($to =~ m#[/>:\]]#) { $todir = dirname($to); } + else { ($todir = $to) =~ s/[^\)]+$//; } + $todir = fixpath($todir); + push @m, " +$to : $from $att{MAKEFILE} ${todir}.exists + \$(CP) \$(MMS\$SOURCE_LIST) \$(MMS\$TARGET) + +", MY->dir_target($todir); + } + join "", @m; } +# --- Sub-directory Sections --- + sub subdir_x { my($self, $subdir) = @_; my(@m); + $subdir = vmspath($subdir); # The intention is that the calling Makefile.PL should define the # $(SUBDIR_MAKEFILE_PL_ARGS) make macro to contain whatever # information needs to be passed down to the other Makefile.PL scripts. # If this does not suit your needs you'll need to write your own # MY::subdir_x() method to override this one. push @m, ' -config :: ',vmspath($subdir) . '$(MAKEFILE) - $(MMS) $(USEMAKEFILE) $(MMS$SOURCE) config $(USEMACROS)(INST_LIB=$(INST_LIB),INST_ARCHLIB=$(INST_ARCHLIB), \\ - LINKTYPE=$(LINKTYPE),INST_EXE=$(INST_EXE),LIBPERL_A=$(LIBPERL_A)$(MACROEND) $(SUBDIR_MAKEFILE_PL_ARGS) +config :: ',$subdir,'$(MAKEFILE) + olddef = F$Environment("Default") + Set Default ',$subdir,' + $(MMS) config $(PASTHRU1) $(SUBDIR_MAKEFILE_PL_ARGS) + Set Default \'olddef\' -',vmspath($subdir),'$(MAKEFILE) : ',vmspath($subdir),'Makefile.PL, $(CONFIGDEP) +',$subdir,'$(MAKEFILE) : ',$subdir,'Makefile.PL, $(CONFIGDEP) @Write Sys$Output "Rebuilding $(MMS$TARGET) ..." $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::MakeMaker; MM->runsubdirpl(qw('.$subdir.'))" \\ - $(SUBDIR_MAKEFILE_PL_ARGS) INST_LIB=$(INST_LIB) INST_ARCHLIB=$(INST_ARCHLIB) \\ - INST_EXE=$(INST_EXE) LIBPERL_A=$(LIBPERL_A) LINKTYPE=$(LINKTYPE) + $(PASTHRU1) $(SUBDIR_MAKEFILE_PL_ARGS) @Write Sys$Output "Rebuild of $(MMS$TARGET) complete." # The default clean, realclean and test targets in this Makefile # have automatically been given entries for $subdir. subdirs :: - Set Default ',vmspath($subdir),' - $(MMS) all $(USEMACROS)LINKTYPE=$(LINKTYPE)$(MACROEND) + olddef = F$Environment("Default") + Set Default ',$subdir,' + $(MMS) all $(PASTHRU2) + Set Default \'olddef\' '; join('',@m); } @@ -440,25 +643,34 @@ sub clean { my($self, %attribs) = @_; my(@m); push @m, ' -# Delete temporary files but do not touch installed files -# We don\'t delete the Makefile here so that a -# later make realclean still has a makefile to work from +# Delete temporary files but do not touch installed files. We don\'t delete +# the Descrip.MMS here so that a later make realclean still has it to use. clean :: '; foreach (@{$att{DIR}}) { # clean subdirectories first my($vmsdir) = vmspath($_); - push( @m, ' If F$Search("'.$vmsdir.'$(MAKEFILE)") Then $(MMS) $(USEMAKEFILE)'.$vmsdir.'$(MAKEFILE) clean'."\n"); + push( @m, ' If F$Search("'.$vmsdir.'$(MAKEFILE)") Then \\',"\n\t", + '$(PERL) -e "chdir ',"'$vmsdir'",'; print `$(MMS) clean`;"',"\n"); } - push @m, " - $att{RM_F} *.Map;* *.lis;* *.cpp;* *.Obj;* *.Olb;* \$(BOOTSTRAP);* \$(BASEEXT).bso;* -"; + push @m, ' $(RM_F) *.Map;* *.lis;* *.cpp;* *.Obj;* *.Olb;* $(BOOTSTRAP);* $(BASEEXT).bso;* +'; my(@otherfiles) = values %{$att{XS}}; # .c files from *.xs files push(@otherfiles, $attribs{FILES}) if $attribs{FILES}; push(@otherfiles, "blib.dir"); - push(@m, " $att{RM_F} ".join(";* ", map(fixpath($_),@otherfiles)),";*\n"); + my($file,$line); + $line = ''; #avoid unitialized var warning + foreach $file (@otherfiles) { + $file = fixpath($file); + if (length($line) + length($file) > 150) { + push @m, "\t\$(RM_F) $line\n"; + $line = "$file;*"; + } + else { $line .= " $file;*"; } + } + push @m, "\t\$(RM_F) $line\n\n"; # See realclean and ext/utils/make_ext for usage of Makefile.old - push(@m, " $att{MV} $att{MAKEFILE} $att{MAKEFILE}_old"); + push(@m, ' $(MV) $(MAKEFILE) $(MAKEFILE)_old'); push(@m, " $attribs{POSTOP}\n") if $attribs{POSTOP}; join('', @m); } @@ -473,37 +685,106 @@ realclean :: clean '); foreach(@{$att{DIR}}){ my($vmsdir) = vmspath($_); - push(@m, ' If F$Search("'."$vmsdir$att{MAKEFILE}".'").nes."" Then $(MMS) $(USEMAKEFILE)'."$vmsdir$att{MAKEFILE}".' realclean'."\n"); - push(@m, ' If F$Search("'."$vmsdir$att{MAKEFILE}".'_old").nes."" Then $(MMS) $(USEMAKEFILE)'."$vmsdir$att{MAKEFILE}".'_old realclean'."\n"); + push(@m, ' If F$Search("'."$vmsdir$att{MAKEFILE}".'").nes."" Then \\',"\n\t", + '$(PERL) -e "chdir ',"'$vmsdir'",'; print `$(MMS) realclean`;"',"\n"); + push(@m, ' If F$Search("'."$vmsdir$att{MAKEFILE}".'_old").nes."" \\',"\n\t", + '$(PERL) -e "chdir ',"'$vmsdir'",'; print `$(MMS) $(USEMAKEFILE)$(MAKEFILE)_old realclean`;"'."\n"); } - push @m,' - ',$att{RM_RF},' $(INST_AUTODIR) $(INST_ARCHAUTODIR) - ',$att{RM_F},' *.Opt;* $(INST_DYNAMIC);* $(INST_STATIC);* $(INST_BOOT);* $(INST_PM);* - ',$att{RM_F},' $(OBJECT);* $(MAKEFILE);* $(MAKEFILE)_old;* + push @m,' $(RM_RF) $(INST_AUTODIR) $(INST_ARCHAUTODIR) '; - push(@m, " $att{RM_RF} ".join(";* ", map(fixpath($_),$attribs{'FILES'})),";*\n") if $attribs{'FILES'}; + my($file,$line); + my(@files) = qw{ *.Opt $(INST_DYNAMIC) $(INST_STATIC) $(INST_BOOT) $(INST_PM) $(OBJECT) $(MAKEFILE) $(MAKEFILE)_old }; + $line = ''; #avoid unitialized var warning + foreach $file (@files) { + $file = fixpath($file); + if (length($line) + length($file) > 150) { + push @m, "\t\$(RM_F) $line\n"; + $line = "$file;*"; + } + else { $line .= " $file;*"; } + } + push @m, "\t\$(RM_F) $line\n"; + if ($attribs{FILES} && ref $attribs{FILES} eq 'ARRAY') { + foreach $file (@{$attribs{'FILES'}}) { + $file = unixify($file); + if (length($line) + length($file) > 150) { + push @m, "\t\$(RM_RF) $line\n"; + $line = "$file;*"; + } + else { $line .= " $file;*"; } + } + } + push @m, "\t\$(RM_RF) $line\n"; push(@m, " $attribs{POSTOP}\n") if $attribs{POSTOP}; join('', @m); } -sub distclean { +sub dist { my($self, %attribs) = @_; - my($preop) = $attribs{PREOP} || '@ !'; # e.g., update MANIFEST - my($zipname) = $attribs{TARNAME} || '$(DISTNAME)-$(VERSION)'; - my($zipflags) = $attribs{ZIPFLAGS} || '-Vu'; - my($postop) = $attribs{POSTOP} || ""; + my(@m); + if ($attribs{TARNAME}){ + print STDOUT "Error (fatal): Attribute TARNAME for target dist is deprecated +Please use DISTNAME and VERSION"; + } + my($name) = $attribs{NAME} || '$(DISTNAME)-$(VERSION)'; + my($zip) = $attribs{ZIP} || 'zip'; + my($zipflags) = $attribs{ZIPFLAGS} || '-Vu'; + my($suffix) = $attribs{SUFFIX} || ''; + my($shar) = $attribs{SHAR} || 'vms_share'; + my($preop) = $attribs{PREOP} || '@ !'; # e.g., update MANIFEST + my($postop) = $attribs{POSTOP} || '@ !'; + my($dist_default) = $attribs{DIST_DEFAULT} || 'zipdist'; my($mkfiles) = join(' ', map("$_\$(MAKEFILE) $_\$(MAKEFILE)_old",map(vmspath($_),@{$att{'DIR'}}))); - " -distclean : clean - $preop - $att{RM_F} $mkfiles - Zip \"$zipflags\" $zipname \$(BASEEXT).* Makefile.PL - $postop + my($src) = $name; + $src = "[.$src]" unless $src =~ /\[/; + $src =~ s#\]#...]#; + $src .= '*.*' if $src =~ /\]$/; + $suffix =~ s#\.#_#g; + push @m," +ZIP = $zip +ZIPFLAGS = $zipflags +SUFFIX = $suffix +SHARE = $shar +PREOP = $preop +POSTOP = $postop +DIST_DEFAULT = $dist_default "; -} + push @m, ' +distclean :: realclean distcheck + +distcheck : + $(PERL) "-I$(PERL_LIB)" -e "use ExtUtils:Manifest \'&fullcheck\'; &fullcheck;" + +manifest : + $(PERL) "-I$(PERL_LIB)" -e "use ExtUtils:Manifest \'&mkmanifest\'; &mkmanifest;" + +dist : $(DIST_DEFAULT) + +zipdist : ',"${name}.zip$suffix + +${name}.zip_$suffix : distdir + ",'$(PREOP) + $(ZIP) "$(ZIPFLAGS)" $(MMS$TARGET) ',$src,' + $(RM_RF) ',$name,' + $(POSTOP) + +shdist : distdir + $(PREOP) + $(SHARE) ',"$src ${name}.share$suffix",' + $(RM_RF) ',$name,' + $(POSTOP) + +distdir : + $(RM_RF) ',$name,' + $(PERL) "-I$(PERL_LIB)" -e use ExtUtils::Manifest \'/mani/\';" \\ + -e "manicopy(maniread(),',"'$name'",'); +'; + + join('',@m); +} # --- Test and Installation Sections --- @@ -512,16 +793,19 @@ sub test { my($tests) = $attribs{TESTS} || ( -d 't' ? 't/*.t' : ''); my(@m); push @m,' +TEST_VERBOSE = 0 + test : all -'; - push(@m,' $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" $(I_PERL_LIBS) -e "use Test::Harness; runtests @ARGV;" '.$tests."\n") +' if $tests; + push(@m,' $(FULLPERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)" \\',"\n\t", + '-e "use Test::Harness qw(&runtests $$verbose); $$verbose=$(TEST_VERBOSE); runtests @ARGV;" \\',"\n\t$tests\n") if $tests; - push(@m,' $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" $(I_PERL_LIBS) test.pl',"\n") + push(@m,' $(FULLPERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)" test.pl',"\n") if -f 'test.pl'; foreach(@{$att{DIR}}){ my($vmsdir) = vmspath($_); - push(@m, ' If F$Search("',$vmsdir,'$(MAKEFILE)").nes."" Then $(PERL) -e "chdir \'',$vmsdir, - '\'; print `$(MMS) $(USEMAKEFILE)$(MAKEFILE) $(USEMACRO)LINKTYPE=$(LINKTYPE)$(MACROEND) test`'."\n"); + push(@m, ' If F$Search("',$vmsdir,'$(MAKEFILE)").nes."" Then $(PERL) -e "chdir ',"'$vmsdir'", + '; print `$(MMS) $(PASTHRU2) test`'."\n"); } push(@m, "\t\@echo 'No tests defined for \$(NAME) extension.'\n") unless @m > 1; @@ -533,9 +817,10 @@ sub install { my(@m); push @m, q{ doc_install :: - @ $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" $(I_PERL_LIBS) \\ + @ $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_LIB)" "_I$(PERL_ARCHLIB)" \\ -e "use ExtUtils::MakeMaker; MM->writedoc('Module', '$(NAME)', \\ - 'LINKTYPE=$(LINKTYPE)', 'VERSION=$(VERSION)', 'EXE_FILES=$(EXE_FILES)')" + 'LINKTYPE=$(LINKTYPE)', 'VERSION=$(VERSION)', 'EXE_FILES=$(EXE_FILES)')" \\ + >>$(INSTALLARCHLIB)perllocal.pod }; push(@m, " @@ -546,15 +831,30 @@ pure_install :: all # install subdirectories first foreach(@{$att{DIR}}){ my($vmsdir) = vmspath($_); - push(@m, ' If F$Search("',$vmsdir,'$(MAKEFILE)").nes."" Then $(PERL) -e "chdir \'',$vmsdir, - '\'; print `$(MMS) $(USEMAKEFILE)$(MAKEFILE) install`'."\n"); + push(@m, ' If F$Search("',$vmsdir,'$(MAKEFILE)").nes."" Then $(PERL) -e "chdir ',"'$vmsdir'", + '; print `$(MMS) install`"'."\n"); } - push(@m, "\t! perl5.000 used to autosplit into INST_ARCHLIB, we delete these old files here - $att{RM_F} ",fixpath(unixpath($Config{'installarchlib'}).'auto/$(FULLEXT)/*.al'),';* ', - fixpath(unixpath($Config{'installarchlib'}).'auto/$(FULLEXT)/*.ix'),";* - \$(MMS) \$(USEMACROS)INST_LIB=$Config{'installprivlib'},INST_ARCHLIB=$Config{'installarchlib'},INST_EXE=$Config{'installbin'}\$(MACROEND) -"); + push(@m, ' + @ $(PERL) -e "foreach (@ARGV){die qq{You do not have permissions to install into $$_\n} unless -w $$_}" $(INSTALLPRIVLIB) $(INSTALLARCHLIB) + ! perl5.000 and MM pre 3.8 used to autosplit into INST_ARCHLIB, we delete these old files here + $(RM_F) ',fixpath('$(INSTALLARCHLIB)/auto/$(FULLEXT)/*.al;*'),' ', + fixpath('$(INSTALLARCHLIB)/auto/$(FULLEXT)/*.ix;*')," + \$(MMS) \$(USEMACROS)INST_LIB=$att{INSTALLPRIVLIB},INST_ARCHLIB=$att{INSTALLARCHLIB},INST_EXE=$att{INSTALLBIN}\$(MACROEND)",' + @ $(PERL) -i_bak -lne "print unless $seen{$_}++" $(INST_ARCHAUTODIR).packlist +'); + + push @m, ' +#### UNINSTALL IS STILL EXPERIMENTAL #### +uninstall :: +'; + foreach(@{$att{DIR}}){ + my($vmsdir) = vmspath($_); + push(@m, ' If F$Search("',$vmsdir,'$(MAKEFILE)").nes."" Then $(PERL) -e "chdir ',"'$vmsdir'", + '; print `$(MMS) uninstall`"'."\n"); + } + push @m, "\t".'$(PERL) -e "use File::Path; foreach (<>) {chomp;rmtree($_,1,0);}" $(INST_ARCHAUTODIR).packlist +'; join("",@m); } @@ -571,14 +871,20 @@ $(OBJECT) : $(PERL_INC)perl.h, $(PERL_INC)perly.h, $(PERL_INC)pp.h, $(PERL_INC)p $(OBJECT) : $(PERL_INC)regcomp.h, $(PERL_INC)regexp.h, $(PERL_INC)scope.h, $(PERL_INC)sv.h $(OBJECT) : $(PERL_INC)vmsish.h, $(PERL_INC)util.h, $(PERL_INC)config.h -'; - push(@m,' +' if $att{OBJECT}; -$(PERL_ARCHLIB)/Config.pm: $(PERL_SRC)/config.sh - @ Write Sys$Error "$(PERL_ARCHLIB)/Config.pm may be out of date with $(PERL_SRC)/config.sh" + push(@m,' +# Check for unpropogated config.sh changes. Should never happen. +# We do NOT just update config.h because that is not sufficient. +# An out of date config.h is not fatal but complains loudly! +$(PERL_INC)config.h : $(PERL_SRC)config.sh + @ Write Sys$Error "Warning: $(PERL_INC)config.h out of date with $(PERL_SRC)config.sh" + +$(PERL_ARCHLIB)Config.pm : $(PERL_SRC)config.sh + @ Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with $(PERL_SRC)config.sh" Set Default $(PERL_SRC) - $(MMS) $(USEMAKEFILE)[.VMS]$(MAKEFILE) [.lib]config.pm -'); + $(MMS) $(USEMAKEFILE)[.VMS]$(MAKEFILE) [.lib.',$Config{'arch'},']config.pm +') if $att{PERL_SRC}; push(@m, join(" ", map(vmsify($_),values %{$att{XS}}))." : \$(XSUBPPDEPS)\n") if %{$att{XS}}; @@ -588,24 +894,51 @@ $(PERL_ARCHLIB)/Config.pm: $(PERL_SRC)/config.sh sub makefile { my(@m,@cmd); - push(@m,' + # We do not know what target was originally specified so we + # must force a manual rerun to be sure. But as it should only + # happen very rarely it is not a significant problem. + push @m, ' +$(OBJECT) : $(MAKEFILE) # We take a very conservative approach here, but it\'s worth it. # We move $(MAKEFILE) to $(MAKEFILE)_old here to avoid gnu make looping. $(MAKEFILE) : Makefile.PL $(CONFIGDEP) - @ Write Sys$Output "',$att{MAKEFILE},' out-of-date with respect to $(MMS$SOURCE_LIST)" - @ Write Sys$Output "Cleaning current config before rebuilding ',$att{MAKEFILE},'... - - ',"$att{MV} $att{MAKEFILE} $att{MAKEFILE}_old",' - - $(MMS) $(USEMAKEFILE)',$att{MAKEFILE},'_old clean - $(PERL) $(I_PERL_LIBS) Makefile.PL + @ Write Sys$Output "$(MAKEFILE) out-of-date with respect to $(MMS$SOURCE_LIST)" + @ Write Sys$Output "Cleaning current config before rebuilding $(MAKEFILE) ..." + - $(MV) $(MAKEFILE) $(MAKEFILE)_old + - $(MMS) $(USEMAKEFILE)$(MAKEFILE)_old clean + $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" Makefile.PL ',join(' ',@ARGV),' @ Write Sys$Output "Now you must rerun $(MMS)." -'); +'; join('',@m); } +# --- Make-Directories section (internal method) --- +# dir_target(@array) returns a Makefile entry for the file .exists in each +# named directory. Returns nothing, if the entry has already been processed. +# We're helpless though, if the same directory comes as $(FOO) _and_ as "bar". +# Both of them get an entry, that's why we use "::". I chose '$(PERL)' as the +# prerequisite, because there has to be one, something that doesn't change +# too often :) +%Dir_Target = (); # package global + +sub dir_target { + my($self,@dirs) = @_; + my(@m,$dir); + foreach $dir (@dirs) { + next if $Dir_Target{$dir}; + my($vmsdir) = fixpath($dir); + push @m, " +${vmsdir}.exists :: \$(PERL_INC)perl.h + \@ \$(MKPATH) $vmsdir + \@ \$(TOUCH) ${vmsdir}.exists +"; + $Dir_Target{$dir}++; + } + join "", @m; +} -# --- Determine libraries to use and how to use them --- sub makeaperl { my($self, %attribs) = @_; @@ -621,6 +954,7 @@ sub makeaperl { # Which *.olb files could we make use of... local(%olbs); + $olbs{$att{INST_ARCHAUTODIR}} = "$att{BASEEXT}.olb"; File::Find::find(sub { return unless m/\.olb$/; return if m/^libperl/; @@ -749,13 +1083,6 @@ sub new_extliblist { '','','' } -# --- Write a DynaLoader bootstrap file if required - -# VMS doesn't require a bootstrap file as a rule -sub mkbootstrap { - 1; -} - sub mksymlists { my($self,%attribs) = @_; @@ -810,671 +1137,3 @@ sub nicetext { 1; __END__ -# MM_VMS.pm -# MakeMaker default methods for VMS -# This package is inserted into @ISA of MakeMaker's MM before the -# built-in MM_Unix methods if MakeMaker.pm is run under VMS. -# -# Version: 4.03 -# Author: Charles Bailey bailey@genetics.upenn.edu -# Revised: 30-Jan-1995 - -package ExtUtils::MM_VMS; - -use Config; -require Exporter; -use File::VMSspec; -use File::Basename; - -Exporter::import('ExtUtils::MakeMaker', - qw(%att %skip %Recognized_Att_Keys $Verbose &neatvalue)); - - -sub fixpath { - my($path) = @_; - my($head,$macro,$tail); - - while (($head,$macro,$tail) = ($path =~ m#(.*?)\$\((\S+?)\)/(.*)#)) { - ($macro = unixify($att{$macro})) =~ s#/$##; - $path = "$head$macro/$tail"; - } - vmsify($path); -} - - -sub init_others { - &MM_Unix::init_others; - $att{NOOP} = "\tContinue"; - $att{MAKEFILE} = '$(MAKEFILE)'; - $att{RM_F} = '$(PERL) -e "foreach (@ARGV) { -d $_ ? rmdir $_ : unlink $_}"'; - $att{RM_RF} = '$(FULLPERL) -e "use File::Path; use File::VMSspec; @dirs = map(unixify($_),@ARGV); rmtree(\@dirs,0,0)"'; - $att{TOUCH} = '$(PERL) -e "$t=time; utime $t,$t,@ARGV"'; - $att{CP} = 'Copy/NoConfirm'; - $att{MV} = 'Rename/NoConfirm'; -} - -sub constants { - my(@m,$def); - push @m, " -NAME = $att{NAME} -DISTNAME = $att{DISTNAME} -VERSION = $att{VERSION} - -# In which library should we install this extension? -# This is typically the same as PERL_LIB. -# (also see INST_LIBDIR and relationship to ROOTEXT) -INST_LIB = ",vmspath($att{INST_LIB})," -INST_ARCHLIB = ",vmspath($att{INST_ARCHLIB})," - -# Perl library to use when building the extension -PERL_LIB = ",vmspath($att{PERL_LIB})," -PERL_ARCHLIB = ",vmspath($att{PERL_ARCHLIB})," -"; - -# Define I_PERL_LIBS to include the required -Ipaths -# To be cute we only include PERL_ARCHLIB if different -# To be portable we add quotes for VMS -my(@i_perl_libs) = qw{-I$(PERL_ARCHLIB) -I$(PERL_LIB)}; -shift(@i_perl_libs) if ($att{PERL_ARCHLIB} eq $att{PERL_LIB}); -push @m, "I_PERL_LIBS = \"".join('" "',@i_perl_libs)."\"\n"; - - push @m, " -# Where is the perl source code located? (Eventually we should -# be able to build extensions without requiring the perl source -# but that's a long way off yet). -PERL_SRC = ",vmspath($att{PERL_SRC})," -# Perl header files (will eventually be under PERL_LIB) -PERL_INC = ",vmspath($att{PERL_INC})," -# Perl binaries -PERL = $att{PERL} -FULLPERL = $att{FULLPERL} - -# FULLEXT = Pathname for extension directory (eg DBD/Oracle). -# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. -# ROOTEXT = Directory part of FULLEXT with leading slash (e.g /DBD) -FULLEXT = ",vmsify($att{FULLEXT})," -BASEEXT = $att{BASEEXT} -ROOTEXT = ",$att{ROOTEXT} eq '' ? '[]' : vmspath($att{ROOTEXT})," - -INC = "; - - if ($att{'INC'}) { - push @m,'/Include=('; - my(@includes) = split(/\s+/,$att{INC}); - foreach (@includes) { - s/^-I//; - push @m,vmspath($_); - } - push @m, ")\n"; - } - - if ($att{DEFINE} ne '') { - my(@defs) = split(/\s+/,$att{DEFINE}); - foreach $def (@defs) { - $def =~ s/^-D//; - $def = "\"$def\"" if $def =~ /=/; - } - $att{DEFINE} = join ',',@defs; - } - - push @m," -DEFINE = $att{DEFINE} -OBJECT = ",vmsify($att{OBJECT})," -LDFROM = ",vmsify($att{LDFROM})," -LINKTYPE = $att{LINKTYPE} - -# Handy lists of source code files: -XS_FILES = ",join(', ', sort keys %{$att{XS}})," -C_FILES = ",join(', ', @{$att{C}})," -O_FILES = ",join(', ', @{$att{O_FILES}})," -H_FILES = ",join(', ', @{$att{H}})," - -.SUFFIXES : .xs - -# This extension may link to it's own library (see SDBM_File)"; - push @m," -MYEXTLIB = ",vmsify($att{MYEXTLIB})," - -# Here is the Config.pm that we are using/depend on -CONFIGDEP = \$(PERL_ARCHLIB)Config.pm, \$(PERL_INC)config.h - -# Where to put things: -INST_LIBDIR = ",($att{'INST_LIBDIR'} = vmspath(unixpath($att{INST_LIB}) . unixpath($att{ROOTEXT})))," -INST_ARCHLIBDIR = ",($att{'INST_ARCHLIBDIR'} = vmspath(unixpath($att{INST_ARCHLIB}) . unixpath($att{ROOTEXT})))," - -INST_AUTODIR = ",($att{'INST_AUTODIR'} = vmspath(unixpath($att{INST_LIB}) . 'auto/' . unixpath($att{FULLEXT}))),' -INST_ARCHAUTODIR = ',($att{'INST_ARCHAUTODIR'} = vmspath(unixpath($att{INST_ARCHLIB}) . 'auto/' . unixpath($att{FULLEXT}))),' - -INST_STATIC = $(INST_ARCHLIBDIR)$(BASEEXT).olb -INST_DYNAMIC = $(INST_ARCHAUTODIR)$(BASEEXT).$(DLEXT) -INST_BOOT = $(INST_ARCHAUTODIR)$(BASEEXT).bs -INST_PM = ',join(', ',map(fixpath($_),sort values %{$att{PM}})),' -'; - - join('',@m); -} - - -sub const_cccmd { - my($cmd) = $Config{'cc'}; - my($name,$sys,@m); - - ( $name = $att{NAME} . "_cflags" ) =~ s/:/_/g ; - warn "Unix shell script ".$Config{"$att{'BASEEXT'}_cflags"}. - " required to modify CC command for $att{'BASEEXT'}\n" - if ($Config{$name}); - - # Deal with $att{DEFINE} here since some C compilers pay attention - # to only one /Define clause on command line, so we have to - # conflate the ones from $Config{'cc'} and $att{DEFINE} - if ($att{DEFINE} ne '') { - if ($cmd =~ m:/define=\(?([^\(\/\)]+)\)?:i) { - $cmd = $` . "/Define=(" . $1 . ",$att{DEFINE})" . $'; - } - else { $cmd .= "/Define=($att{DEFINE})" } - } - - $sys = ($cmd =~ /^gcc/i) ? 'GNU_CC_Include:[VMS]' : 'Sys$Library'; - push @m,' -.FIRST - @ If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS ',$sys,' - -'; - push(@m, "CCCMD = $cmd\n"); - - join('',@m); -} - - - -sub const_loadlibs{ - my (@m); - push @m, " -# $att{NAME} might depend on some other libraries. -# -# Dependent libraries are linked in either by the Link command -# at build time or by the DynaLoader at bootstrap time. -# -# These comments may need revising: -# -# EXTRALIBS = Full list of libraries needed for static linking. -# Only those libraries that actually exist are included. -# -# BSLOADLIBS = List of those libraries that are needed but can be -# linked in dynamically. -# -# LDLOADLIBS = List of those libraries which must be statically -# linked into the shared library. -# -EXTRALIBS = ",map(vmsify($_) . ' ',$att{'EXTRALIBS'})," -BSLOADLIBS = ",map(vmsify($_) . ' ',$att{'BSLOADLIBS'})," -LDLOADLIBS = ",map(vmsify($_) . ' ',$att{'LDLOADLIBS'}),"\n"; - - join('',@m); -} - -# --- Tool Sections --- - -sub tool_autosplit{ - my($self, %attribs) = @_; - my($asl) = ""; - $asl = "\$AutoSplit::Maxlen=$attribs{MAXLEN};" if $attribs{MAXLEN}; - q{ -# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto -AUTOSPLITFILE = $(PERL) $(I_PERL_LIBS) -e "use AutoSplit;}.$asl.q{ AutoSplit::autosplit($ARGV[0], $ARGV[1], 0, 1, 1) ;" -}; -} - -sub tool_xsubpp{ - my($xsdir) = unixpath($att{PERL_LIB}).'ExtUtils'; - # drop back to old location if xsubpp is not in new location yet - $xsdir = unixpath($att{PERL_SRC}).'ext' unless (-f "$xsdir/xsubpp"); - my(@tmdeps) = '$(XSUBPPDIR)typemap'; - push(@tmdeps, "typemap") if -f "typemap"; - my(@tmargs) = map("-typemap $_", @tmdeps); - " -XSUBPPDIR = ".vmspath($xsdir)." -XSUBPP = \$(PERL) \$(XSUBPPDIR)xsubpp -XSUBPPDEPS = @tmdeps -XSUBPPARGS = @tmargs -"; -} - -sub tools_other { - " -# Assumes \$(MMS) invokes MMS or MMK -USEMAKEFILE = /Descrip= -USEMACROS = /Macro=( -MACROEND = ) -MAKEFILE = Descrip.MMS -SHELL = Posix -LD = $att{LD} -TOUCH = $att{TOUCH} -CP = $att{CP} -RM_F = $att{RM_F} -RM_RF = $att{RM_RF} -MKPATH = Create/Directory -"; -} - - -# --- Translation Sections --- - -sub c_o { - ' -.c.obj : - $(CCCMD) $(CCCDLFLAGS) /Include=($(PERL_INC)) $(INC) $(MMS$TARGET_NAME).c -'; -} - -sub xs_c { - ' -.xs.c : - $(XSUBPP) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET) -'; -} - -sub xs_o { # many makes are too dumb to use xs_c then c_o - ' -.xs.obj : - $(XSUBPP) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).c - $(CCCMD) $(CCCDLFLAGS) /Include=($(PERL_INC)) $(INC) $(MMS$TARGET_NAME).c -'; -} - - -# --- Target Sections --- - -sub top_targets{ - ' -all :: config linkext $(INST_PM) -'.$att{NOOP}.' - -config :: '.$att{MAKEFILE}.' - @ $(MKPATH) $(INST_LIBDIR), $(INST_ARCHAUTODIR) -'; -} - -sub dlsyms { - my($self,%attribs) = @_; - my($funcs) = $attribs{DL_FUNCS} || $att{DL_FUNCS} || {}; - my($vars) = $attribs{DL_VARS} || $att{DL_VARS} || []; - my(@m); - - push(@m,' -dynamic :: perlshr.opt $(BASEEXT).opt - ',$att{NOOP},' - -perlshr.opt : makefile.PL - $(FULLPERL) $(I_PERL_LIBS) -e "use ExtUtils::MakeMaker; mksymlists(DL_FUNCS => ', - %$funcs ? neatvalue($funcs) : "' '",', DL_VARS => ', - @$vars ? neatvalue($vars) : "' '",')" -') unless $skip{'dynamic'}; - - push(@m,' -static :: $(BASEEXT).opt - ',$att{NOOP},' -') unless $skip{'static'}; - - push(@m,' -$(BASEEXT).opt : makefile.PL - $(FULLPERL) $(I_PERL_LIBS) -e "use ExtUtils::MakeMaker; mksymlists(DL_FUNCS => ',neatvalue($att{DL_FUNCS}),', DL_VARS => ',neatvalue($att{DL_VARS}),')" -'); - - join('',@m); -} - - -# --- Dynamic Loading Sections --- - -sub dynamic_lib { - my($self, %attribs) = @_; - my($otherldflags) = $attribs{OTHERLDFLAGS} || ""; - my(@m); - push @m," - -OTHERLDFLAGS = $otherldflags - -"; - push @m, ' -$(INST_DYNAMIC) : $(OBJECT) $(MYEXTLIB) $(PERL_INC)perlshr_attr.opt $(PERL_INC)crtl.opt perlshr.opt $(BASEEXT).opt - @ $(MKPATH) $(INST_ARCHAUTODIR) - Link $(LDFLAGS) /Shareable/Executable=$(MMS$TARGET)$(OTHERLDFLAGS) $(OBJECT),$(PERL_INC)perlshr_attr.opt/Option,$(PERL_INC)crtl.opt/Option,[]perlshr.opt/Option,[]$(BASEEXT).opt/Option -'; - - join('',@m); -} - -# --- Static Loading Sections --- - -sub static_lib { - my(@m); - push @m, <<'END'; -$(INST_STATIC) : $(OBJECT), $(MYEXTLIB) - If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET) - Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST) -END - push @m," - $att{CP}",'$(MMS$SOURCE) $(INST_ARCHAUTODIR) - $(PERL) -e "print ""$(MMS$TARGET)\n""" >$(INST_ARCHAUTODIR)extralibs.ld -'; - push @m, <<'END' if $att{PERL_SRC}; - @! Old mechanism - still needed: - $(PERL) -e "print ""$(MMS$TARGET)\n""" >>$(PERL_SRC)ext.libs -END - - join('',@m); -} - - -sub installpm_x { # called by installpm perl file - my($self, $dist, $inst, $splitlib) = @_; - $inst = fixpath($inst); - $dist = vmsify($dist); - my($instdir) = dirname($inst); - my(@m); - - push(@m, " -$inst : $dist -",' @ ',$att{RM_F},' $(MMS$TARGET);* - @ $(MKPATH) ',$instdir,' - @ ',$att{CP},' $(MMS$SOURCE) $(MMS$TARGET) -'); - if ($splitlib and $inst =~ /\.pm$/) { - my($attdir) = $splitlib; - $attdir =~ s/\$\((.*)\)/$1/; - $attdir = $att{$attdir} if $att{$attdir}; - - push(@m, ' $(AUTOSPLITFILE) $(MMS$TARGET) ', - vmspath(unixpath($attdir) . 'auto')."\n"); - push(@m,"\n"); - } - - join('',@m); -} - - -# --- Sub-directory Sections --- - -sub subdir_x { - my($self, $subdir) = @_; - my(@m); - # The intention is that the calling Makefile.PL should define the - # $(SUBDIR_MAKEFILE_PL_ARGS) make macro to contain whatever - # information needs to be passed down to the other Makefile.PL scripts. - # If this does not suit your needs you'll need to write your own - # MY::subdir_x() method to override this one. - push @m, ' -config :: ',vmspath($subdir) . '$(MAKEFILE) - $(MMS) $(USEMAKEFILE) $(MMS$SOURCE) config $(USEMACROS)(INST_LIB=$(INST_LIB),INST_ARCHLIB=$(INST_ARCHLIB),LINKTYPE=$(LINKTYPE)$(MACROEND) - -',vmspath($subdir),'$(MAKEFILE) : ',vmspath($subdir),'Makefile.PL, $(CONFIGDEP) - @Write Sys$Output "Rebuilding $(MMS$TARGET) ..." - $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::MakeMaker; MM->runsubdirpl(qw('.$subdir.'))" \\ - $(SUBDIR_MAKEFILE_PL_ARGS) INST_LIB=$(INST_LIB) INST_ARCHLIB=$(INST_ARCHLIB) - @Write Sys$Output "Rebuild of $(MMS$TARGET) complete." - -# The default clean, realclean and test targets in this Makefile -# have automatically been given entries for $subdir. - -subdirs :: - Set Default ',vmspath($subdir),' - $(MMS) all $(USEMACROS)LINKTYPE=$(LINKTYPE)$(MACROEND) -'; - join('',@m); -} - - -# --- Cleanup and Distribution Sections --- - -sub clean { - my($self, %attribs) = @_; - my(@m); - push @m, ' -# Delete temporary files but do not touch installed files -# We don\'t delete the Makefile here so that a -# later make realclean still has a makefile to work from -clean :: -'; - foreach (@{$att{DIR}}) { # clean subdirectories first - my($vmsdir) = vmspath($_); - push( @m, ' If F$Search("'.$vmsdir.'$(MAKEFILE)") Then $(MMS) $(USEMAKEFILE)'.$vmsdir.'$(MAKEFILE) clean'."\n"); - } - push @m, " - $att{RM_F} *.Map;* *.lis;* *.cpp;* *.Obj;* *.Olb;* \$(BOOTSTRAP);* \$(BASEEXT).bso;* -"; - - my(@otherfiles) = values %{$att{XS}}; # .c files from *.xs files - push(@otherfiles, $attribs{FILES}) if $attribs{FILES}; - push(@otherfiles, "blib.dir"); - push(@m, " $att{RM_F} ".join(";* ", map(fixpath($_),@otherfiles)),";*\n"); - # See realclean and ext/utils/make_ext for usage of Makefile.old - push(@m, " $att{MV} $att{MAKEFILE} $att{MAKEFILE}_old"); - push(@m, " $attribs{POSTOP}\n") if $attribs{POSTOP}; - join('', @m); -} - - -sub realclean { - my($self, %attribs) = @_; - my(@m); - push(@m,' -# Delete temporary files (via clean) and also delete installed files -realclean :: clean -'); - foreach(@{$att{DIR}}){ - my($vmsdir) = vmspath($_); - push(@m, ' If F$Search("'."$vmsdir$att{MAKEFILE}".'").nes."" Then $(MMS) $(USEMAKEFILE)'."$vmsdir$att{MAKEFILE}".' realclean'."\n"); - push(@m, ' If F$Search("'."$vmsdir$att{MAKEFILE}".'_old").nes."" Then $(MMS) $(USEMAKEFILE)'."$vmsdir$att{MAKEFILE}".'_old realclean'."\n"); - } - push @m,' - ',$att{RM_RF},' $(INST_AUTODIR) $(INST_ARCHAUTODIR) - ',$att{RM_F},' *.Opt;* $(INST_DYNAMIC);* $(INST_STATIC);* $(INST_BOOT);* $(INST_PM);* - ',$att{RM_F},' $(OBJECT);* $(MAKEFILE);* $(MAKEFILE)_old;* -'; - push(@m, " $att{RM_RF} ".join(";* ", map(fixpath($_),$attribs{'FILES'})),";*\n") if $attribs{'FILES'}; - push(@m, " $attribs{POSTOP}\n") if $attribs{POSTOP}; - join('', @m); -} - - -sub distclean { - my($self, %attribs) = @_; - my($preop) = $attribs{PREOP} || '@ !'; # e.g., update MANIFEST - my($zipname) = $attribs{ZIPNAME} || '$(DISTNAME)-$(VERSION)'; - my($zipflags) = $attribs{ZIPFLAGS} || '-Vu'; - my($postop) = $attribs{POSTOP} || ""; - my(@mkfildirs) = map(vmspath($_),@{$att{'DIR'}}); - my(@m,$dir); - - push @m,' -distclean : realclean - ',$preop,' - If F$Search("$(MAKEFILE)").nes."" Then ',$att{RM_F},' $(MAKEFILE);* -'; - foreach $dir (@mkfildirs) { - push(@m,'If F$Search("',$dir,'$(MAKEFILE)") Then Delete/Log/NoConfirm ', - $dir,'$(MAKEFILE);*',"\n"); - } - - push(@m," Zip \"$zipflags\" $zipname \$(BASEEXT).* Makefile.PL - $postop -"); - - join('',@m); -} - - -# --- Test and Installation Sections --- - -sub test { - my($self, %attribs) = @_; - my($tests) = $attribs{TESTS} || ( -d 't' ? 't/*.t' : ''); - my(@m); - push @m,' -test : all -'; - push(@m,' $(FULLPERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" $(I_PERL_LIBS) -e "use Test::Harness; runtests @ARGV;" '.$tests."\n") - if $tests; - push(@m,' $(FULLPERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" test.pl',"\n") - if -f 'test.pl'; - foreach(@{$att{DIR}}){ - my($vmsdir) = vmspath($_); - push(@m, ' If F$Search("',$vmsdir,'$(MAKEFILE)").nes."" Then $(PERL) -e "chdir \'',$vmsdir, - '\'; print `$(MMS) $(USEMAKEFILE)$(MAKEFILE) $(USEMACRO)LINKTYPE=$(LINKTYPE)$(MACROEND) test`'."\n"); - } - push(@m, "\t\@echo 'No tests defined for \$(NAME) extension.'\n") unless @m > 1; - - join('',@m); -} - -sub install { - my($self, %attribs) = @_; - my(@m); - push(@m, " -install :: all -"); - # install subdirectories first - foreach(@{$att{DIR}}){ - my($vmsdir) = vmspath($_); - push(@m, ' If F$Search("',$vmsdir,'$(MAKEFILE)").nes."" Then $(PERL) -e "chdir \'',$vmsdir, - '\'; print `$(MMS) $(USEMAKEFILE)$(MAKEFILE) install`'."\n"); - } - - push(@m, "\t! perl5.000 used to autosplit into INST_ARCHLIB, we delete these old files here - $att{RM_F} ",fixpath('$(INST_ARCHLIB)/auto/$(FULLEXT)/*.al'),";*,",fixpath('$(INST_ARCHLIB)/auto/$(FULLEXT)/*.ix'),';* - $(MMS) $(USEMACROS)INST_LIB=\$(INST_PRIVLIB),INST_ARCHLIB=\$(INST_ARCHLIB)$(MACROEND) -'); - - join("",@m); -} - -sub perldepend { - my(@m); - - push @m, ' -$(OBJECT) : $(PERL_INC)EXTERN.h, $(PERL_INC)INTERN.h, $(PERL_INC)XSUB.h, $(PERL_INC)av.h -$(OBJECT) : $(PERL_INC)cop.h, $(PERL_INC)cv.h, $(PERL_INC)embed.h, $(PERL_INC)form.h -$(OBJECT) : $(PERL_INC)gv.h, $(PERL_INC)handy.h, $(PERL_INC)hv.h, $(PERL_INC)keywords.h -$(OBJECT) : $(PERL_INC)mg.h, $(PERL_INC)op.h, $(PERL_INC)opcode.h, $(PERL_INC)patchlevel.h -$(OBJECT) : $(PERL_INC)perl.h, $(PERL_INC)perly.h, $(PERL_INC)pp.h, $(PERL_INC)proto.h -$(OBJECT) : $(PERL_INC)regcomp.h, $(PERL_INC)regexp.h, $(PERL_INC)scope.h, $(PERL_INC)sv.h -$(OBJECT) : $(PERL_INC)vmsish.h, $(PERL_INC)util.h, $(PERL_INC)config.h -$(O_FILES) : $(H_FILES) - -'; - push(@m,' - -$(PERL_ARCHLIB)/Config.pm: $(PERL_SRC)/config.sh - @ Write Sys$Error "$(PERL_ARCHLIB)/Config.pm may be out of date with $(PERL_SRC)/config.sh" - Set Default $(PERL_SRC) - $(MMS) $(USEMAKEFILE)[.VMS]$(MAKEFILE) [.lib]config.pm -'); - - push(@m, join(" ", map(vmsify($_),values %{$att{XS}}))." : \$(XSUBPPDEPS)\n") - if %{$att{XS}}; - - join('',@m); -} - -sub makefile { - my(@m,@cmd); - @cmd = grep(/^\s/,split(/\n/,MY->c_o())); - push(@m,join("\n",@cmd)); - push(@m,' - -# We take a very conservative approach here, but it\'s worth it. -# We move $(MAKEFILE) to $(MAKEFILE)_old here to avoid gnu make looping. -$(MAKEFILE) : Makefile.PL $(CONFIGDEP) - @ Write Sys$Output "',$att{MAKEFILE},' out-of-date with respect to $(MMS$SOURCE_LIST)" - @ Write Sys$Output "Cleaning current config before rebuilding ',$att{MAKEFILE},'... - - ',"$att{MV} $att{MAKEFILE} $att{MAKEFILE}_old",' - - $(MMS) $(USEMAKEFILE)',$att{MAKEFILE},'_old clean - $(PERL) $(I_PERL_LIBS) Makefile.PL - @ Write Sys$Output "Now you must rerun $(MMS)." -'); - - join('',@m); -} - - -# --- Determine libraries to use and how to use them --- - -sub extliblist { - '','',''; -} - -sub old_extliblist { - '','','' -} - -sub new_extliblist { - '','','' -} - -# --- Write a DynaLoader bootstrap file if required - -# VMS doesn't require a bootstrap file as a rule -sub mkbootstrap { - 1; -} - -sub mksymlists { - my($self,%attribs) = @_; - - MY->init_main() unless $att{BASEEXT}; - - my($vars) = $attribs{DL_VARS} || $att{DL_VARS} || []; - my($procs) = $attribs{DL_FUNCS} || $att{DL_FUNCS}; - my($package,$packprefix,$sym); - if (!%$procs) { - $package = $attribs{NAME} || $att{NAME}; - $package =~ s/\W/_/g; - $procs = { $package => ["boot_$package"] }; - } - my($isvax) = $Config{'arch'} =~ /VAX/i; - # First, a short linker options file to specify PerlShr - # used only when linking dynamic extension - open OPT, ">PerlShr.Opt"; - print OPT "PerlShr/Share\n"; - close OPT; - - # Next, the options file declaring universal symbols - # Used when linking shareable image for dynamic extension, - # or when linking PerlShr into which we've added this package - # as a static extension - # We don't do anything to preserve order, so we won't relax - # the GSMATCH criteria for a dynamic extension - open OPT, ">$att{BASEEXT}.opt"; - foreach $package (keys %$procs) { - ($packprefix = $package) =~ s/\W/_/g; - foreach $sym (@{$$procs{$package}}) { - $sym = "XS_${packprefix}_$sym" unless $sym =~ /^boot_/; - if ($isvax) { print OPT "UNIVERSAL=$sym\n" } - else { print OPT "SYMBOL_VECTOR=($sym=PROCEDURE)\n"; } - } - } - foreach $sym (@$vars) { - print OPT "PSECT_ATTR=${sym},PIC,OVR,RD,NOEXE,WRT,NOSHR\n"; - if ($isvax) { print OPT "UNIVERSAL=$sym\n" } - else { print OPT "SYMBOL_VECTOR=($sym=DATA)\n"; } - } - close OPT; -} - -# --- Output postprocessing section --- - -sub nicetext { - # Insure that colons marking targets are preceded by space - - # most Unix Makes don't need this, but it's necessary under VMS - # to distinguish the target delimiter from a colon appearing as - # part of a filespec. - - my($self,$text) = @_; - $text =~ s/([^\s:])(:+\s)/$1 $2/gs; - $text; -} - -1; - -__END__ diff --git a/vms/gen_shrfls.pl b/vms/gen_shrfls.pl index 043faccb09..d3a8ab9140 100644 --- a/vms/gen_shrfls.pl +++ b/vms/gen_shrfls.pl @@ -34,14 +34,19 @@ # (i.e. /Define=DEBUGGING,EMBED,MULTIPLICITY)? # # Author: Charles Bailey bailey@genetics.upenn.edu -# Revised: 01-Mar-1995 +# Revised: 28-May-1995 require 5.000; $debug = $ENV{'GEN_SHRFLS_DEBUG'}; $cc_cmd = shift @ARGV; + +# Someday, we'll have $GetSyI built into perl . . . +$isvax = `\$ Write Sys\$Output F\$GetSyI(\"HW_MODEL\")` <= 1024; +print "\$isvax: \\$isvax\\\n" if $debug; + print "Input \$cc_cmd: \\$cc_cmd\\\n" if $debug; -$docc = ($cc_cmd !~ /~~NOCC~~/); +$docc = ($cc_cmd !~ /^~~/); print "\$docc = $docc\n" if $debug; if ($docc) { @@ -55,11 +60,30 @@ if ($docc) { } print "Filtered \$cc_cmd: \\$cc_cmd\\\n" if $debug; + # check for gcc - if present, we'll need to use MACRO hack to + # define global symbols for shared variables + $isvaxc = 0; + $isgcc = `$cc_cmd _nla0:/Version` =~ /GNU/ + or 0; # make debug output nice + $isvaxc = (!$isgcc && $isvax && `$cc_cmd /ansi_alias _nla0:` =~ /IVQUAL/) + or 0; # again, make debug output nice + print "\$isgcc: $isgcc\n" if $debug; + print "\$isvaxc: $isvaxc\n" if $debug; + if (-f 'perl.h') { $dir = '[]'; } elsif (-f '[-]perl.h') { $dir = '[-]'; } else { die "$0: Can't find perl.h\n"; } } -else { ($cpp_file) = ($cc_cmd =~ /~~NOCC~~(.*)/) } +else { + ($ccvers,$cpp_file) = ($cc_cmd =~ /^~~(\w+)~~(.*)/); + $isgcc = $ccvers =~ /GCC/ + or 0; # for nice debug output + $isvaxc = (!$isgcc && $ccvers =~ /VAXC/) + or 0; # again, for nice debug output + print "\$isgcc: \\$isgcc\\\n" if $debug; + print "\$isvaxc: \\$isvaxc\\\n" if $debug; + print "Not running cc, preprocesor output in \\$cpp_file\\\n" if $debug; +} $objsuffix = shift @ARGV; print "\$objsuffix: \\$objsuffix\\\n" if $debug; @@ -73,9 +97,32 @@ print "\$extnames: \\$extnames\\\n" if $debug; $rtlopt = shift @ARGV; print "\$rtlopt: \\$rtlopt\\\n" if $debug; -# Someday, we'll have $GetSyI built into perl . . . -$isvax = `\$ Write Sys\$Output F\$GetSyI(\"HW_MODEL\")` <= 1024; -print "\$isvax: \\$isvax\\\n" if $debug; +# This part gets tricky. VAXC creates creating global symbols for the +# constants in an enum if that enum is ever used as the data type of a +# global[dr]ef. We have to detect enums which are used in this way, so we +# can set up the constants as universal symbols, since anything which +# #includes perl.h will want to resolve these global symbols. +# We're using a weak test here - we basically know that the only enums +# we need to handle now are the big one in opcode.h, and the +# "typedef enum { ... } expectation" in perl.h, so we hard code +# appropriate tests below. Since we can't know in general whether a given +# enum will be used elsewhere in a globaldef, it's hard to decide a +# priori whether its constants need to be treated as global symbols. +sub scan_enum { + my($line) = @_; + + return unless $isvaxc; + + return unless /^\s+(OP|X)/; # we only want opcode and expectation enums + print "\tchecking for enum constant\n" if $debug > 1; + $line =~ s#/\*.+##; + $line =~ s/,?\s*\n?$//; + print "\tfiltered to \\$line\\\n" if $debug > 1; + if ($line =~ /(\w+)$/) { + print "\tvar name is \\$1\\\n" if $debug > 1; + $vars{$1}++; + } +} sub scan_var { my($line) = @_; @@ -101,7 +148,7 @@ sub scan_func { if ($1 eq 'main' || $1 eq 'perl_init_ext') { print "\tskipped\n" if $debug > 1; } - else { $funcs{$1}++ } + else { $fcns{$1}++ } } } @@ -128,6 +175,12 @@ LINE: while () { print "opcode.h>> $_" if $debug > 2; if (/^OP \*\s/) { &scan_func($_); } if (/^EXT/) { &scan_var($_); } + if (/^\s+OP_/) { &scan_enum($_); } + last LINE unless $_ = ; + } + while (/^typedef enum/ .. /^\}/) { + print "global enum>> $_" if $debug > 2; + &scan_enum($_); last LINE unless $_ = ; } while (/^#.*proto\.h/i .. /^#.*perl\.h/i) { @@ -143,6 +196,7 @@ close CPP; while () { next if /^#/; s/\s+#.*\n//; + next if /^\s*$/; ($key,$array) = split('=',$_); print "Adding $key to \%$array list\n" if $debug > 1; ${$array}{$key}++; @@ -150,8 +204,8 @@ while () { foreach (split /\s+/, $extnames) { my($pkgname) = $_; $pkgname =~ s/::/__/g; - $funcs{"boot_$pkgname"}++; - print "Adding boot_$pkgname to \%funcs (for extension $_)\n" if $debug; + $fcns{"boot_$pkgname"}++; + print "Adding boot_$pkgname to \%fcns (for extension $_)\n" if $debug; } # Eventually, we'll check against existing copies here, so we can add new @@ -160,19 +214,16 @@ foreach (split /\s+/, $extnames) { $marord++; open(OPTBLD,">${dir}${dbgprefix}perlshr_bld.opt") or die "$0: Can't write to ${dir}${dbgprefix}perlshr_bld.opt: $!\n"; -open(OPTATTR,">${dir}perlshr_attr.opt") - or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n"; if ($isvax) { open(MAR,">${dir}perlshr_gbl${marord}.mar") or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n"; print MAR "\t.title perlshr_gbl$marord\n"; } -print OPTATTR "PSECT_ATTR=\$CHAR_STRING_CONSTANTS,PIC,SHR,NOEXE,RD,NOWRT\n"; foreach $var (sort keys %vars) { - print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n"; if ($isvax) { print OPTBLD "UNIVERSAL=$var\n"; } else { print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n"; } - if ($isvax) { + # This hack brought to you by the lack of a globaldef in gcc. + if ($isgcc) { if ($count++ > 200) { # max 254 psects/file print MAR "\t.end\n"; close MAR; @@ -182,27 +233,35 @@ foreach $var (sort keys %vars) { print MAR "\t.title perlshr_gbl$marord\n"; $count = 0; } - # This hack brought to you by the lack of a globaldef in gcc. print MAR "\t.psect ${var},long,pic,ovr,rd,wrt,noexe,noshr\n"; print MAR "\t${var}:: .blkl 1\n"; } } print MAR "\t.psect \$transfer_vec,pic,rd,nowrt,exe,shr\n" if ($isvax); -foreach $func (sort keys %funcs) { +foreach $func (sort keys %fcns) { if ($isvax) { print MAR "\t.transfer $func\n"; print MAR "\t.mask $func\n"; - print MAR "\tjmp L\^${func}+2\n"; + print MAR "\tjmp G\^${func}+2\n"; } else { print OPTBLD "SYMBOL_VECTOR=($func=PROCEDURE)\n"; } } +if ($isvax) { + print MAR "\t.end\n"; + close MAR; +} +open(OPTATTR,">${dir}perlshr_attr.opt") + or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n"; +print OPTATTR "PSECT_ATTR=\$CHAR_STRING_CONSTANTS,PIC,SHR,NOEXE,RD,NOWRT\n"; +foreach $var (sort keys %vars) { + print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n"; +} close OPTATTR; + $incstr = 'perl,globals'; if ($isvax) { - print MAR "\t.end\n"; - close MAR; $drvrname = "Compile_shrmars.tmp_".time; open (DRVR,">$drvrname") or die "$0: Can't write to $drvrname: $!\n"; print DRVR "\$ Set NoOn\n"; diff --git a/vms/perlshr.c b/vms/perlshr.c deleted file mode 100644 index 92e6d44cf5..0000000000 --- a/vms/perlshr.c +++ /dev/null @@ -1,13 +0,0 @@ -/* perlshr.c - * - * Small stub to create object module containing global variables - * for use in PerlShr.C. Written as a separate file because some - * old Make implementations won't deal correctly with DCL Open/Write - * statements in the makefile. - * - */ - -#include "INTERN.h" -#include "perl.h" - -/* That's it. */ diff --git a/vms/perlvms.pod b/vms/perlvms.pod index c0cec10ef0..722c638dbc 100644 --- a/vms/perlvms.pod +++ b/vms/perlvms.pod @@ -422,8 +422,10 @@ order to delete all versions, you need to say You may need to make this change to scripts written for a Unix system which expect that after a call to C, no files with the names passed to C will exist. -(Note: This can be changed at compile time by including -C<#define UNLINK_ALL_VERSIONS> in config.h. +(Note: This can be changed at compile time; if you +C and C<$Config{'d_unlink_all_versions'}> is +C, then C will delete all versions of a +file on the first call.) C will delete a file if at all possible, even if it requires changing file protection (though it won't try to diff --git a/vms/perly_c.vms b/vms/perly_c.vms new file mode 100644 index 0000000000..4cc29e3ec8 --- /dev/null +++ b/vms/perly_c.vms @@ -0,0 +1,2224 @@ +#ifndef lint +static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91"; +#endif +#define YYBYACC 1 +#line 16 "perly.y" +#include "EXTERN.h" +#include "perl.h" + +static void +dep() +{ + deprecate("\"do\" to call subroutines"); +} + +#define YYERRCODE 256 +dEXT short yylhs[] = { -1, + 31, 0, 5, 3, 6, 6, 6, 7, 7, 7, + 7, 21, 21, 21, 21, 21, 21, 11, 11, 11, + 9, 9, 9, 9, 30, 30, 8, 8, 8, 8, + 8, 8, 8, 8, 10, 10, 25, 25, 29, 29, + 1, 1, 1, 1, 2, 2, 32, 32, 28, 28, + 4, 33, 33, 34, 13, 13, 13, 13, 12, 12, + 12, 26, 26, 26, 26, 26, 26, 26, 26, 27, + 27, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 22, 22, 23, 23, 23, 20, 15, + 16, 17, 18, 19, 24, 24, 24, 24, +}; +dEXT short yylen[] = { 2, + 0, 2, 4, 0, 0, 2, 2, 2, 1, 2, + 3, 1, 1, 3, 3, 3, 3, 0, 2, 6, + 6, 6, 4, 4, 0, 2, 7, 7, 5, 5, + 8, 7, 10, 3, 0, 1, 0, 1, 0, 1, + 1, 1, 1, 1, 4, 3, 5, 5, 0, 1, + 0, 3, 2, 4, 3, 3, 2, 1, 2, 3, + 1, 3, 5, 6, 3, 5, 2, 4, 4, 1, + 1, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 5, 3, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 3, 2, 3, 2, 4, + 3, 4, 1, 1, 4, 5, 4, 1, 1, 1, + 5, 6, 5, 6, 5, 4, 5, 1, 1, 3, + 4, 3, 2, 2, 4, 5, 4, 5, 1, 2, + 1, 2, 2, 2, 1, 3, 1, 3, 4, 4, + 6, 1, 1, 0, 1, 0, 1, 2, 2, 2, + 2, 2, 2, 2, 1, 1, 1, 1, +}; +dEXT short yydefred[] = { 1, + 0, 5, 0, 40, 51, 51, 0, 0, 6, 41, + 7, 9, 0, 42, 43, 44, 0, 0, 0, 53, + 0, 12, 4, 142, 0, 0, 118, 0, 51, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 137, 0, + 0, 0, 0, 0, 0, 0, 51, 0, 0, 0, + 0, 0, 0, 0, 0, 10, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 8, 0, 0, 0, 0, + 0, 108, 110, 104, 0, 0, 143, 0, 46, 0, + 52, 0, 0, 5, 155, 158, 157, 156, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 153, 0, 124, 0, + 0, 0, 0, 0, 0, 57, 0, 0, 67, 0, + 0, 132, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 99, 0, 149, 150, 151, 152, 154, + 0, 34, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 91, 92, 0, 0, 0, 0, + 0, 0, 0, 11, 45, 50, 0, 54, 0, 65, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 36, 0, 136, 138, 0, 0, + 0, 0, 0, 0, 101, 0, 122, 0, 0, 0, + 0, 98, 26, 0, 0, 0, 0, 0, 0, 55, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 70, 0, 71, 0, + 0, 0, 0, 0, 0, 120, 0, 48, 47, 3, + 0, 140, 0, 102, 0, 29, 0, 30, 0, 0, + 0, 23, 0, 24, 0, 0, 0, 139, 148, 68, + 0, 125, 0, 127, 0, 100, 69, 0, 0, 0, + 0, 0, 0, 0, 107, 0, 105, 0, 116, 121, + 66, 0, 0, 0, 0, 19, 0, 0, 0, 0, + 0, 63, 126, 128, 115, 0, 113, 0, 0, 106, + 0, 111, 117, 141, 27, 28, 21, 0, 22, 0, + 32, 0, 114, 112, 64, 0, 0, 31, 0, 0, + 20, 33, +}; +dEXT short yydgoto[] = { 1, + 9, 10, 84, 17, 87, 3, 11, 12, 66, 193, + 262, 67, 200, 69, 70, 71, 72, 73, 74, 75, + 195, 83, 201, 89, 185, 77, 240, 177, 13, 142, + 2, 14, 15, 16, +}; +dEXT short yysindex[] = { 0, + 0, 0, -105, 0, 0, 0, -47, -232, 0, 0, + 0, 0, 570, 0, 0, 0, -112, -217, 10, 0, + 2121, 0, 0, 0, -35, -35, 0, 46, 0, -3, + 1, 8, 14, 55, 2121, 56, 60, 63, 0, -35, + 1806, 2121, 941, -178, 1846, 997, 0, 1911, 2121, 2121, + 2121, 2121, 2121, 2121, 1272, 0, 2121, 2121, 1312, -35, + -35, -35, -35, -35, -183, 0, 71, 227, 3368, -55, + -49, 0, 0, 0, 89, 48, 0, 20, 0, -118, + 0, 71, 85, 0, 0, 0, 0, 0, 2121, 106, + 2121, -118, 1846, 20, 1846, 20, 1846, 20, 1846, 20, + 1371, 115, 3368, 116, 1411, 901, 0, 125, 0, 864, + -1, 864, 41, -53, 2121, 0, 0, -55, 0, 2121, + 20, 0, 864, 864, 510, 510, 510, -89, -89, 80, + -38, 510, 510, 0, -84, 0, 0, 0, 0, 0, + 20, 0, 2121, 1846, 1846, 1846, 1846, 1846, 1846, 1846, + 2121, 2121, 2121, 2121, 2121, 2121, 2121, 2121, 2121, 2121, + 2121, 2121, 2121, 2121, 0, 0, -21, 1846, 1846, 1846, + 1846, 1846, 1451, 0, 0, 0, -29, 0, -115, 0, + 1846, 614, 20, -187, 131, -183, -34, -183, -27, -140, + 4, -140, 114, 208, 0, 1846, 0, 0, 6, -6, + 135, 1846, 1726, 1766, 0, 57, 0, 71, 2121, 1846, + 94, 0, 0, 3368, -187, -187, -187, -187, -113, 0, + 67, 2023, 864, 1613, 445, 685, 3368, 3106, 363, 771, + 1082, 1235, 1465, 510, 510, 1846, 0, 1846, 0, 147, + -77, 88, -72, 95, -67, 0, 18, 0, 0, 0, + 148, 0, 2121, 0, 20, 0, 20, 0, 20, 20, + 150, 0, 20, 0, 1846, 20, 26, 0, 0, 0, + 32, 0, 69, 0, 82, 0, 0, -62, 1846, 66, + 2121, 97, -41, 1846, 0, 68, 0, 73, 0, 0, + 0, 2844, -183, -183, -140, 0, 1846, -140, 129, -183, + 20, 0, 0, 0, 0, 99, 0, 3756, 78, 0, + 153, 0, 0, 0, 0, 0, 0, 84, 0, 1371, + 0, -183, 0, 0, 0, 20, 155, 0, -140, 20, + 0, 0, +}; +dEXT short yyrindex[] = { 0, + 0, 0, 141, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 145, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 2299, 2164, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 2658, 0, 2703, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 13, 0, 58, 3, 170, 2748, + 2796, 0, 0, 0, 2209, 0, 0, 0, 0, -26, + 0, 2380, 0, 0, 0, 0, 0, 0, 2426, 0, + 0, 83, 166, 0, 0, 0, 0, 0, 0, 0, + 154, 0, 1341, 0, 0, 171, 0, 2254, 0, 3507, + 2748, 3552, 0, 0, 2426, 0, 431, 502, 0, 0, + 0, 0, 3585, 3630, 2980, 3028, 3073, 2890, 2935, 2471, + 0, 3152, 3197, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 2516, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 845, 0, + 171, 0, 0, 19, 0, 13, 0, 13, 0, 76, + 0, 76, 0, 158, 0, 0, 0, 0, 0, 177, + 0, 0, 0, 0, 0, 0, 0, 2564, 2426, 0, + 2612, 0, 0, 2080, 23, 30, 39, 52, 827, 0, + 0, -36, 3678, 1208, 3335, 3414, 2574, 0, 1049, 3739, + 3646, 3694, 3462, 3245, 3290, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 160, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 171, 0, 0, 0, 0, 0, 0, + 0, 0, 13, 13, 76, 0, 0, 76, 0, 13, + 0, 0, 0, 0, 0, 0, 0, 776, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 182, + 0, 13, 0, 0, 0, 0, 0, 0, 76, 0, + 0, 0, +}; +dEXT short yygindex[] = { 0, + 0, 0, 0, 37, -13, 157, 0, 0, 0, -82, + -168, 470, 360, 3971, 1933, 0, 0, 0, 0, 0, + 230, -14, -152, 1366, -20, 0, 0, 156, 0, -125, + 0, 0, 0, 0, +}; +#define YYTABLESIZE 4252 +dEXT short yytable[] = { 65, + 61, 168, 211, 79, 81, 206, 257, 81, 212, 250, + 23, 20, 25, 259, 61, 285, 94, 96, 98, 100, + 287, 81, 81, 264, 21, 289, 81, 109, 251, 248, + 305, 119, 49, 150, 122, 170, 93, 269, 204, 80, + 95, 172, 18, 13, 263, 25, 268, 97, 25, 25, + 25, 310, 25, 99, 25, 25, 81, 25, 290, 38, + 256, 13, 258, 16, 175, 92, 301, 169, 81, 238, + 17, 25, 302, 171, 180, 18, 25, 38, 115, 14, + 186, 16, 188, 121, 190, 91, 192, 23, 17, 170, + 61, 141, 15, 23, 101, 104, 49, 14, 58, 105, + 207, 236, 106, 25, 148, 149, 174, 209, 18, 303, + 15, 18, 18, 18, 143, 18, 58, 18, 18, 23, + 18, 169, 304, 23, 326, 280, 317, 213, 173, 319, + 23, 311, 260, 261, 18, 25, 23, 25, 25, 18, + 2, 176, 23, 178, 78, 181, 286, 4, 5, 6, + 58, 7, 8, 288, 196, 309, 197, 4, 5, 6, + 331, 7, 8, 249, 203, 205, 18, 315, 316, 254, + 210, 255, 265, 39, 321, 270, 39, 39, 39, 149, + 39, 276, 39, 39, 279, 39, 284, 320, 291, 297, + 307, 323, 312, 325, 277, 330, 328, 313, 18, 39, + 18, 18, 324, 144, 39, 49, 37, 148, 149, 19, + 61, 146, 35, 61, 148, 149, 13, 147, 37, 148, + 149, 85, 35, 167, 148, 149, 86, 61, 61, 148, + 149, 39, 81, 81, 81, 81, 237, 327, 148, 149, + 179, 293, 76, 294, 299, 295, 296, 183, 266, 298, + 148, 149, 300, 148, 149, 81, 81, 148, 149, 0, + 81, 0, 61, 39, 148, 149, 39, 0, 25, 25, + 25, 25, 25, 25, 0, 25, 25, 25, 25, 25, + 25, 25, 25, 25, 25, 148, 149, 322, 25, 25, + 0, 25, 25, 25, 25, 148, 149, 148, 149, 25, + 25, 25, 25, 25, 0, 0, 25, 25, 25, 148, + 149, 0, 329, 0, 25, 25, 332, 148, 149, 25, + 0, 25, 25, 148, 149, 0, 58, 58, 58, 58, + 0, 18, 18, 18, 18, 18, 18, 0, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 0, 58, + 58, 18, 18, 0, 18, 18, 18, 18, 148, 149, + 148, 149, 18, 18, 18, 18, 18, 0, 0, 18, + 18, 18, 68, 148, 149, 148, 149, 18, 18, 148, + 149, 0, 18, 0, 18, 18, 148, 149, 148, 149, + 148, 149, 0, 0, 0, 0, 39, 39, 39, 39, + 39, 39, 114, 0, 116, 0, 39, 0, 0, 39, + 39, 39, 39, 0, 131, 0, 39, 39, 135, 39, + 39, 39, 39, 0, 0, 0, 0, 39, 39, 39, + 39, 39, 0, 0, 39, 39, 39, 0, 61, 61, + 61, 61, 39, 39, 0, 0, 0, 39, 0, 39, + 39, 0, 184, 168, 187, 0, 189, 0, 191, 0, + 194, 61, 61, 155, 199, 0, 155, 155, 155, 0, + 155, 142, 155, 155, 142, 155, 144, 145, 146, 147, + 0, 0, 0, 0, 0, 150, 0, 0, 142, 142, + 82, 0, 0, 142, 155, 144, 145, 146, 147, 148, + 149, 0, 0, 215, 216, 217, 218, 219, 220, 221, + 0, 0, 0, 0, 0, 82, 0, 0, 148, 149, + 0, 142, 0, 142, 0, 0, 0, 241, 242, 243, + 244, 245, 247, 0, 156, 168, 0, 156, 156, 156, + 0, 156, 103, 156, 156, 103, 156, 0, 0, 0, + 0, 0, 0, 142, 0, 267, 155, 0, 82, 103, + 103, 271, 273, 275, 103, 156, 0, 150, 0, 278, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 82, 0, 0, 0, 0, 208, + 0, 0, 0, 0, 103, 282, 0, 283, 0, 0, + 168, 0, 50, 0, 0, 61, 63, 60, 0, 55, + 0, 64, 58, 0, 57, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 184, 0, 0, 156, 56, 0, + 0, 0, 150, 62, 0, 0, 0, 0, 306, 0, + 0, 0, 0, 0, 0, 152, 153, 154, 155, 0, + 0, 0, 0, 0, 252, 0, 318, 253, 0, 0, + 59, 159, 160, 161, 0, 0, 162, 163, 0, 0, + 164, 0, 0, 165, 166, 167, 157, 0, 82, 68, + 0, 0, 0, 0, 0, 0, 0, 155, 155, 155, + 155, 155, 23, 0, 0, 51, 155, 0, 0, 142, + 142, 142, 142, 0, 168, 0, 0, 155, 142, 155, + 155, 155, 155, 142, 142, 142, 142, 155, 155, 155, + 155, 155, 142, 142, 155, 155, 155, 142, 142, 142, + 142, 142, 155, 155, 142, 142, 150, 155, 142, 155, + 155, 142, 142, 142, 0, 0, 0, 0, 0, 163, + 0, 0, 164, 0, 0, 165, 166, 167, 156, 156, + 156, 156, 156, 0, 0, 0, 0, 156, 0, 0, + 103, 103, 103, 103, 0, 168, 0, 0, 156, 103, + 156, 156, 156, 156, 103, 103, 103, 103, 156, 156, + 156, 156, 156, 103, 103, 156, 156, 156, 103, 103, + 103, 103, 103, 156, 156, 103, 103, 150, 156, 103, + 156, 156, 103, 103, 103, 0, 84, 164, 0, 84, + 165, 166, 167, 0, 0, 22, 24, 25, 26, 27, + 28, 0, 0, 84, 84, 29, 0, 0, 30, 31, + 32, 33, 0, 0, 0, 34, 35, 0, 36, 37, + 38, 39, 0, 0, 0, 0, 40, 41, 42, 43, + 44, 168, 0, 45, 46, 47, 0, 56, 84, 0, + 56, 48, 49, 0, 0, 0, 52, 39, 53, 54, + 39, 39, 39, 0, 39, 56, 39, 39, 0, 39, + 0, 151, 0, 150, 0, 0, 152, 153, 154, 155, + 0, 0, 0, 39, 0, 0, 0, 0, 39, 0, + 156, 158, 159, 160, 161, 0, 0, 162, 163, 56, + 0, 164, 0, 0, 165, 166, 167, 0, 0, 0, + 0, 0, 0, 50, 0, 39, 61, 63, 60, 0, + 55, 0, 64, 58, 0, 57, 0, 0, 0, 0, + 0, 0, 0, 0, 168, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 62, 0, 0, 39, 0, 154, + 39, 0, 0, 50, 0, 0, 61, 63, 60, 0, + 55, 0, 64, 58, 0, 57, 150, 0, 0, 163, + 0, 59, 164, 0, 0, 165, 166, 167, 0, 113, + 0, 0, 0, 0, 62, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 23, 0, 0, 51, 0, 0, 50, + 0, 59, 61, 63, 60, 0, 55, 0, 64, 58, + 0, 57, 0, 0, 84, 84, 84, 84, 0, 0, + 0, 0, 0, 152, 153, 154, 155, 0, 0, 0, + 62, 0, 0, 0, 0, 0, 51, 84, 84, 0, + 160, 161, 84, 0, 162, 163, 0, 0, 164, 0, + 0, 165, 166, 167, 0, 0, 0, 59, 0, 83, + 0, 0, 83, 0, 0, 56, 56, 56, 56, 0, + 39, 39, 39, 39, 39, 39, 83, 83, 0, 0, + 39, 83, 0, 39, 39, 39, 39, 0, 56, 23, + 39, 39, 51, 39, 39, 39, 39, 0, 0, 0, + 0, 39, 39, 39, 39, 39, 0, 0, 39, 39, + 39, 83, 0, 0, 0, 0, 39, 39, 154, 155, + 0, 39, 0, 39, 39, 0, 0, 117, 25, 26, + 27, 28, 86, 0, 0, 0, 29, 162, 163, 0, + 0, 164, 168, 0, 165, 166, 167, 35, 0, 36, + 37, 38, 39, 0, 0, 0, 0, 40, 41, 42, + 43, 44, 0, 0, 45, 46, 47, 24, 25, 26, + 27, 28, 48, 49, 150, 0, 29, 52, 0, 53, + 54, 0, 0, 0, 0, 0, 0, 35, 0, 36, + 37, 38, 39, 0, 0, 0, 0, 40, 41, 42, + 43, 44, 0, 0, 45, 46, 47, 0, 0, 0, + 0, 0, 48, 49, 0, 0, 0, 52, 78, 53, + 54, 78, 0, 117, 25, 26, 27, 28, 86, 0, + 0, 0, 29, 0, 0, 78, 78, 0, 0, 0, + 78, 0, 0, 35, 0, 36, 37, 38, 39, 0, + 0, 0, 0, 40, 41, 42, 43, 44, 0, 0, + 0, 46, 47, 0, 0, 0, 0, 0, 48, 49, + 78, 0, 0, 52, 50, 53, 54, 61, 63, 60, + 0, 55, 130, 64, 58, 0, 57, 83, 83, 83, + 83, 0, 0, 0, 0, 168, 83, 0, 0, 0, + 0, 0, 0, 0, 0, 62, 0, 0, 0, 0, + 83, 83, 0, 0, 50, 83, 83, 61, 63, 60, + 0, 55, 0, 64, 58, 0, 57, 150, 0, 0, + 0, 0, 59, 0, 152, 153, 154, 155, 0, 0, + 0, 0, 0, 0, 0, 62, 0, 0, 0, 0, + 0, 130, 161, 0, 130, 162, 163, 0, 0, 164, + 0, 90, 165, 166, 167, 0, 0, 51, 130, 130, + 0, 0, 59, 50, 134, 107, 61, 63, 60, 0, + 55, 120, 64, 58, 0, 57, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 136, 137, 138, 139, 140, + 0, 0, 0, 130, 62, 0, 0, 51, 0, 0, + 0, 0, 0, 50, 0, 0, 61, 63, 60, 0, + 55, 198, 64, 58, 0, 57, 0, 0, 0, 0, + 0, 59, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 202, 0, 0, 62, 0, 78, 78, 78, 78, + 0, 0, 0, 50, 0, 78, 61, 63, 60, 0, + 55, 246, 64, 58, 0, 57, 51, 0, 0, 78, + 78, 59, 0, 0, 78, 78, 78, 78, 78, 0, + 0, 0, 0, 0, 62, 0, 0, 152, 153, 154, + 155, 0, 0, 0, 0, 0, 0, 0, 24, 25, + 26, 27, 28, 0, 0, 0, 51, 29, 162, 163, + 0, 59, 164, 0, 0, 165, 166, 167, 35, 0, + 36, 37, 38, 39, 0, 168, 0, 0, 40, 41, + 42, 43, 44, 0, 0, 45, 46, 47, 24, 25, + 26, 27, 28, 48, 49, 0, 51, 29, 52, 0, + 53, 54, 0, 0, 0, 0, 0, 150, 35, 0, + 36, 37, 38, 39, 0, 0, 0, 0, 40, 41, + 42, 43, 44, 0, 0, 45, 46, 47, 0, 130, + 130, 130, 130, 48, 49, 0, 0, 0, 52, 0, + 53, 54, 0, 0, 0, 0, 22, 24, 25, 26, + 27, 28, 130, 130, 0, 0, 29, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 35, 0, 36, + 37, 38, 39, 0, 0, 0, 0, 40, 41, 42, + 43, 44, 0, 0, 45, 46, 47, 24, 25, 26, + 27, 28, 48, 49, 0, 0, 29, 52, 0, 53, + 54, 0, 0, 0, 0, 0, 0, 35, 0, 36, + 37, 38, 39, 0, 0, 0, 0, 40, 41, 42, + 43, 44, 0, 168, 45, 46, 47, 24, 25, 26, + 27, 28, 48, 49, 0, 0, 29, 52, 0, 53, + 54, 0, 0, 0, 0, 0, 0, 35, 0, 36, + 37, 38, 39, 0, 0, 150, 0, 40, 41, 42, + 43, 44, 0, 0, 45, 46, 47, 0, 0, 154, + 155, 0, 48, 49, 0, 0, 0, 52, 50, 53, + 54, 61, 63, 60, 0, 55, 272, 64, 58, 163, + 57, 0, 164, 0, 0, 165, 166, 167, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 62, + 0, 0, 0, 0, 0, 0, 0, 0, 50, 0, + 0, 61, 63, 60, 0, 55, 274, 64, 58, 0, + 57, 0, 0, 0, 0, 0, 59, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 62, + 0, 0, 0, 0, 0, 0, 0, 0, 50, 0, + 0, 61, 63, 60, 0, 55, 0, 64, 58, 0, + 57, 51, 0, 0, 0, 0, 59, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 62, + 0, 0, 0, 0, 0, 0, 0, 0, 50, 0, + 0, 61, 63, 60, 0, 55, 0, 64, 58, 0, + 57, 51, 0, 0, 0, 152, 59, 154, 155, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 62, + 0, 0, 0, 0, 0, 0, 162, 163, 0, 0, + 164, 0, 0, 165, 166, 167, 0, 0, 23, 0, + 0, 51, 0, 0, 0, 0, 59, 0, 0, 0, + 0, 0, 0, 50, 0, 0, 61, 63, 60, 0, + 55, 0, 64, 58, 0, 57, 0, 88, 88, 0, + 0, 0, 0, 0, 0, 0, 102, 0, 0, 0, + 0, 51, 88, 111, 62, 0, 0, 0, 118, 0, + 0, 0, 24, 25, 26, 27, 28, 0, 0, 0, + 0, 29, 88, 88, 88, 88, 88, 0, 0, 0, + 0, 59, 35, 0, 36, 37, 38, 39, 0, 0, + 0, 0, 40, 41, 42, 43, 44, 0, 0, 45, + 46, 47, 24, 25, 26, 27, 28, 48, 49, 0, + 0, 29, 52, 23, 53, 54, 51, 0, 118, 0, + 0, 0, 35, 0, 36, 37, 38, 39, 0, 0, + 0, 0, 40, 41, 42, 43, 44, 0, 0, 45, + 46, 47, 108, 25, 26, 27, 28, 48, 49, 0, + 0, 29, 52, 0, 53, 54, 0, 0, 0, 0, + 0, 0, 35, 0, 36, 37, 38, 39, 0, 0, + 0, 0, 40, 41, 42, 43, 44, 0, 0, 239, + 46, 47, 24, 25, 26, 27, 28, 48, 49, 0, + 0, 29, 52, 168, 53, 54, 0, 0, 0, 0, + 60, 0, 35, 60, 36, 37, 38, 39, 0, 0, + 0, 0, 40, 41, 42, 43, 44, 60, 60, 45, + 46, 47, 0, 0, 0, 150, 0, 48, 49, 0, + 0, 0, 52, 50, 53, 54, 61, 63, 60, 0, + 55, 0, 64, 58, 0, 57, 0, 24, 25, 26, + 27, 28, 60, 0, 0, 0, 29, 0, 0, 0, + 0, 0, 0, 0, 62, 0, 0, 35, 0, 36, + 37, 38, 39, 0, 0, 0, 0, 40, 41, 42, + 43, 44, 0, 0, 135, 46, 47, 135, 0, 0, + 0, 59, 48, 49, 0, 0, 0, 52, 0, 53, + 54, 135, 135, 0, 0, 0, 135, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 51, 0, 0, 119, + 0, 0, 119, 0, 135, 0, 135, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 119, 119, 0, 0, + 0, 119, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 135, 0, 0, 0, + 0, 0, 0, 0, 142, 0, 0, 142, 0, 119, + 0, 119, 0, 0, 0, 152, 153, 154, 155, 0, + 0, 142, 142, 0, 0, 0, 142, 0, 0, 0, + 158, 159, 160, 161, 0, 0, 162, 163, 0, 0, + 164, 119, 0, 165, 166, 167, 0, 0, 0, 129, + 0, 0, 129, 0, 142, 0, 142, 0, 60, 60, + 60, 60, 0, 0, 0, 0, 129, 129, 0, 0, + 0, 129, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 60, 60, 0, 0, 0, 142, 24, 25, 26, + 27, 28, 0, 0, 0, 0, 29, 0, 0, 0, + 0, 129, 0, 0, 0, 0, 0, 35, 0, 36, + 37, 38, 39, 0, 0, 0, 0, 40, 41, 42, + 43, 44, 0, 0, 0, 46, 47, 0, 0, 0, + 145, 129, 48, 49, 0, 0, 0, 52, 0, 53, + 54, 0, 135, 135, 135, 135, 0, 145, 145, 0, + 0, 135, 145, 0, 0, 0, 135, 135, 135, 135, + 0, 0, 0, 0, 0, 135, 135, 0, 0, 0, + 135, 135, 135, 135, 135, 0, 144, 135, 135, 144, + 145, 135, 145, 0, 135, 135, 135, 119, 119, 119, + 119, 0, 0, 144, 144, 0, 119, 0, 144, 0, + 0, 119, 119, 119, 119, 0, 0, 0, 0, 0, + 119, 119, 145, 0, 0, 119, 119, 119, 119, 119, + 0, 97, 119, 119, 97, 0, 119, 0, 144, 119, + 119, 119, 142, 142, 142, 142, 0, 0, 97, 97, + 0, 142, 0, 97, 0, 0, 142, 142, 142, 142, + 0, 0, 0, 0, 0, 142, 142, 0, 144, 0, + 142, 142, 142, 142, 142, 0, 59, 142, 142, 59, + 0, 142, 0, 97, 142, 142, 142, 129, 129, 129, + 129, 0, 0, 59, 59, 0, 129, 0, 59, 0, + 0, 129, 129, 129, 129, 0, 0, 0, 0, 0, + 129, 129, 0, 97, 0, 129, 129, 129, 129, 129, + 0, 0, 129, 129, 62, 0, 129, 0, 59, 129, + 129, 129, 0, 0, 72, 0, 0, 72, 0, 0, + 0, 62, 62, 0, 0, 0, 62, 0, 0, 0, + 0, 72, 72, 0, 0, 0, 0, 0, 59, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 145, 145, + 145, 145, 96, 0, 62, 96, 62, 145, 0, 0, + 0, 0, 145, 145, 145, 145, 72, 0, 0, 96, + 96, 145, 145, 0, 96, 0, 145, 145, 145, 145, + 145, 0, 0, 145, 145, 0, 62, 145, 0, 0, + 145, 145, 145, 0, 144, 144, 144, 144, 144, 0, + 0, 144, 0, 144, 96, 0, 0, 0, 144, 144, + 144, 144, 0, 0, 0, 144, 144, 144, 144, 0, + 144, 0, 144, 144, 144, 144, 144, 0, 0, 144, + 144, 0, 0, 144, 96, 0, 144, 144, 144, 97, + 97, 97, 97, 131, 0, 0, 131, 0, 97, 0, + 144, 0, 0, 97, 97, 97, 97, 0, 0, 0, + 131, 131, 97, 97, 0, 131, 0, 97, 97, 97, + 97, 97, 0, 0, 97, 97, 0, 0, 97, 0, + 0, 97, 97, 97, 59, 59, 59, 59, 103, 0, + 0, 103, 0, 59, 0, 131, 0, 0, 59, 59, + 59, 59, 0, 0, 0, 103, 103, 59, 59, 0, + 103, 0, 59, 59, 59, 59, 59, 0, 0, 59, + 59, 0, 0, 59, 0, 0, 59, 59, 59, 0, + 0, 0, 62, 62, 62, 62, 109, 0, 0, 109, + 103, 62, 72, 72, 72, 72, 62, 62, 62, 62, + 0, 0, 0, 109, 109, 62, 62, 0, 109, 0, + 62, 62, 62, 62, 62, 72, 72, 62, 62, 0, + 0, 62, 0, 0, 62, 62, 62, 0, 0, 0, + 96, 96, 96, 96, 314, 0, 0, 0, 109, 96, + 0, 0, 0, 0, 96, 96, 96, 96, 0, 0, + 0, 0, 0, 96, 96, 0, 157, 0, 96, 96, + 96, 96, 96, 0, 0, 96, 96, 0, 0, 96, + 0, 0, 96, 96, 96, 0, 144, 144, 144, 144, + 93, 0, 0, 93, 168, 144, 0, 0, 0, 0, + 144, 144, 144, 144, 0, 0, 0, 93, 93, 144, + 144, 0, 93, 0, 144, 144, 144, 144, 144, 0, + 0, 144, 144, 0, 0, 144, 150, 0, 144, 144, + 144, 131, 131, 131, 131, 94, 0, 0, 94, 0, + 131, 0, 93, 0, 0, 131, 131, 131, 131, 0, + 0, 0, 94, 94, 131, 131, 0, 94, 0, 131, + 131, 131, 131, 131, 0, 0, 131, 131, 0, 0, + 131, 0, 0, 131, 131, 131, 103, 103, 103, 103, + 88, 0, 0, 88, 0, 103, 0, 94, 0, 0, + 103, 103, 103, 103, 0, 0, 0, 88, 88, 103, + 103, 0, 88, 0, 103, 103, 103, 103, 103, 0, + 0, 103, 103, 0, 0, 103, 0, 0, 103, 103, + 103, 0, 0, 0, 109, 109, 109, 109, 89, 0, + 0, 89, 88, 109, 0, 0, 0, 0, 109, 109, + 109, 109, 0, 0, 0, 89, 89, 109, 109, 0, + 89, 0, 109, 109, 109, 109, 109, 0, 0, 109, + 109, 0, 0, 109, 0, 0, 109, 109, 109, 0, + 0, 0, 0, 90, 0, 0, 90, 0, 0, 0, + 89, 151, 0, 0, 0, 0, 152, 153, 154, 155, + 90, 90, 0, 0, 0, 90, 0, 0, 0, 0, + 156, 158, 159, 160, 161, 0, 0, 162, 163, 0, + 0, 164, 0, 0, 165, 166, 167, 0, 93, 93, + 93, 93, 0, 281, 0, 90, 0, 93, 157, 0, + 0, 0, 93, 93, 93, 93, 0, 0, 0, 0, + 0, 93, 93, 0, 0, 0, 93, 93, 93, 93, + 93, 0, 86, 93, 93, 86, 168, 93, 0, 0, + 0, 0, 0, 94, 94, 94, 94, 0, 0, 86, + 86, 0, 94, 0, 86, 0, 0, 94, 94, 94, + 94, 0, 0, 0, 0, 0, 94, 94, 150, 0, + 0, 94, 94, 94, 94, 94, 0, 87, 94, 94, + 87, 0, 94, 0, 86, 0, 0, 0, 88, 88, + 88, 88, 0, 0, 87, 87, 0, 88, 0, 87, + 0, 0, 88, 88, 88, 88, 0, 0, 0, 0, + 0, 88, 88, 0, 0, 0, 88, 88, 88, 88, + 88, 0, 0, 88, 88, 85, 0, 0, 85, 87, + 0, 0, 0, 0, 0, 0, 89, 89, 89, 89, + 0, 0, 85, 85, 0, 89, 0, 85, 0, 0, + 89, 89, 89, 89, 0, 0, 0, 0, 0, 89, + 89, 0, 0, 0, 89, 89, 89, 89, 89, 0, + 73, 89, 89, 73, 0, 0, 0, 85, 0, 0, + 0, 90, 90, 90, 90, 0, 0, 73, 73, 0, + 90, 0, 73, 0, 0, 90, 90, 90, 90, 0, + 0, 0, 0, 0, 90, 90, 0, 0, 0, 90, + 90, 90, 90, 90, 0, 74, 90, 90, 74, 0, + 0, 0, 73, 151, 0, 0, 0, 0, 152, 153, + 154, 155, 74, 74, 0, 0, 0, 74, 0, 0, + 0, 0, 156, 158, 159, 160, 161, 0, 0, 162, + 163, 0, 0, 164, 0, 0, 165, 166, 167, 0, + 86, 86, 86, 86, 0, 0, 0, 74, 0, 86, + 157, 0, 0, 0, 86, 86, 86, 86, 0, 0, + 0, 0, 0, 86, 86, 0, 0, 0, 86, 86, + 86, 86, 86, 0, 75, 86, 86, 75, 168, 0, + 0, 0, 0, 0, 0, 87, 87, 87, 87, 0, + 0, 75, 75, 0, 87, 0, 75, 0, 0, 87, + 87, 87, 87, 0, 0, 0, 0, 0, 87, 87, + 150, 0, 0, 87, 87, 87, 87, 87, 0, 0, + 87, 87, 76, 0, 0, 76, 75, 0, 0, 0, + 0, 0, 0, 85, 85, 85, 85, 0, 0, 76, + 76, 0, 85, 0, 76, 0, 0, 85, 85, 85, + 85, 0, 0, 0, 0, 0, 85, 85, 0, 0, + 0, 85, 85, 85, 85, 85, 0, 123, 85, 85, + 123, 0, 0, 0, 76, 0, 0, 0, 73, 73, + 73, 73, 0, 0, 123, 123, 0, 73, 0, 123, + 0, 0, 73, 73, 73, 73, 0, 0, 0, 0, + 0, 73, 73, 0, 0, 0, 73, 73, 73, 73, + 73, 0, 95, 73, 73, 95, 0, 0, 0, 123, + 0, 0, 0, 74, 74, 74, 74, 0, 0, 95, + 95, 0, 74, 0, 95, 0, 0, 74, 74, 74, + 74, 0, 0, 0, 0, 133, 74, 74, 133, 0, + 0, 74, 74, 74, 74, 74, 0, 0, 74, 0, + 0, 0, 133, 133, 95, 151, 0, 133, 0, 0, + 152, 153, 154, 155, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 156, 158, 159, 160, 161, 0, + 134, 162, 163, 134, 0, 164, 0, 133, 165, 166, + 167, 0, 75, 75, 75, 75, 80, 134, 134, 80, + 0, 75, 134, 0, 0, 0, 75, 75, 0, 75, + 0, 0, 0, 80, 80, 75, 75, 0, 80, 0, + 75, 75, 75, 75, 75, 0, 0, 75, 77, 0, + 0, 77, 134, 0, 0, 0, 0, 0, 0, 0, + 76, 76, 76, 76, 79, 77, 77, 79, 80, 76, + 77, 0, 0, 0, 76, 76, 0, 0, 0, 0, + 0, 79, 79, 76, 76, 0, 79, 0, 76, 76, + 76, 76, 76, 0, 0, 76, 0, 0, 0, 0, + 77, 0, 0, 0, 0, 123, 123, 123, 123, 82, + 0, 0, 82, 0, 123, 0, 79, 0, 0, 123, + 123, 0, 0, 0, 0, 0, 82, 82, 123, 123, + 0, 82, 0, 123, 123, 123, 123, 123, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 157, 0, + 95, 95, 95, 95, 0, 0, 0, 0, 0, 95, + 0, 82, 0, 0, 95, 95, 0, 0, 0, 0, + 0, 0, 0, 95, 95, 0, 168, 0, 95, 95, + 95, 95, 95, 133, 133, 133, 133, 0, 0, 0, + 0, 0, 133, 0, 0, 0, 0, 133, 133, 0, + 0, 0, 0, 0, 0, 0, 133, 133, 150, 0, + 0, 133, 133, 133, 133, 133, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 134, 134, + 134, 134, 0, 0, 0, 0, 0, 134, 0, 0, + 0, 0, 134, 134, 80, 80, 80, 80, 0, 0, + 0, 134, 134, 80, 0, 0, 134, 134, 134, 134, + 134, 0, 0, 0, 0, 0, 0, 80, 80, 0, + 0, 0, 80, 80, 80, 80, 77, 77, 77, 77, + 0, 0, 0, 0, 0, 77, 0, 0, 0, 0, + 0, 77, 79, 79, 79, 79, 0, 0, 0, 77, + 77, 79, 0, 0, 77, 77, 77, 77, 77, 0, + 0, 0, 0, 0, 0, 79, 79, 0, 0, 0, + 79, 79, 79, 79, 79, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 103, 0, 82, 82, 82, + 82, 110, 112, 0, 0, 0, 82, 0, 123, 124, + 125, 126, 127, 128, 129, 0, 0, 132, 133, 0, + 82, 82, 0, 151, 0, 82, 82, 82, 152, 153, + 154, 155, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 158, 159, 160, 161, 0, 0, 162, + 163, 182, 0, 164, 0, 0, 165, 166, 167, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 214, 0, 0, 0, 0, 0, 0, + 0, 222, 223, 224, 225, 226, 227, 228, 229, 230, + 231, 232, 233, 234, 235, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 292, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 308, +}; +dEXT short yycheck[] = { 13, + 36, 91, 41, 17, 41, 59, 41, 44, 93, 125, + 123, 59, 0, 41, 36, 93, 30, 31, 32, 33, + 93, 58, 59, 192, 257, 93, 63, 41, 181, 59, + 93, 46, 59, 123, 48, 91, 40, 44, 40, 257, + 40, 91, 6, 41, 41, 33, 41, 40, 36, 37, + 38, 93, 40, 40, 42, 43, 93, 45, 41, 41, + 186, 59, 188, 41, 78, 29, 41, 123, 59, 91, + 41, 59, 41, 123, 89, 0, 64, 59, 257, 41, + 94, 59, 96, 47, 98, 40, 100, 123, 59, 91, + 36, 275, 41, 123, 40, 40, 123, 59, 41, 40, + 115, 123, 40, 91, 292, 293, 59, 121, 33, 41, + 59, 36, 37, 38, 44, 40, 59, 42, 43, 123, + 45, 123, 41, 123, 41, 59, 295, 141, 40, 298, + 123, 284, 273, 274, 59, 123, 123, 125, 126, 64, + 0, 260, 123, 59, 257, 40, 59, 263, 264, 265, + 93, 267, 268, 59, 40, 59, 41, 263, 264, 265, + 329, 267, 268, 177, 40, 125, 91, 293, 294, 183, + 91, 41, 59, 33, 300, 41, 36, 37, 38, 293, + 40, 125, 42, 43, 91, 45, 40, 59, 41, 40, + 125, 93, 125, 41, 209, 41, 322, 125, 123, 59, + 125, 126, 125, 59, 64, 123, 41, 292, 293, 257, + 41, 41, 59, 44, 292, 293, 59, 41, 59, 292, + 293, 257, 41, 313, 292, 293, 262, 58, 59, 292, + 293, 91, 269, 270, 271, 272, 258, 320, 292, 293, + 84, 255, 13, 257, 265, 259, 260, 92, 41, 263, + 292, 293, 266, 292, 293, 292, 293, 292, 293, -1, + 297, -1, 93, 123, 292, 293, 126, -1, 256, 257, + 258, 259, 260, 261, -1, 263, 264, 265, 266, 267, + 268, 269, 270, 271, 272, 292, 293, 301, 276, 277, + -1, 279, 280, 281, 282, 292, 293, 292, 293, 287, + 288, 289, 290, 291, -1, -1, 294, 295, 296, 292, + 293, -1, 326, -1, 302, 303, 330, 292, 293, 307, + -1, 309, 310, 292, 293, -1, 269, 270, 271, 272, + -1, 256, 257, 258, 259, 260, 261, -1, 263, 264, + 265, 266, 267, 268, 269, 270, 271, 272, -1, 292, + 293, 276, 277, -1, 279, 280, 281, 282, 292, 293, + 292, 293, 287, 288, 289, 290, 291, -1, -1, 294, + 295, 296, 13, 292, 293, 292, 293, 302, 303, 292, + 293, -1, 307, -1, 309, 310, 292, 293, 292, 293, + 292, 293, -1, -1, -1, -1, 256, 257, 258, 259, + 260, 261, 43, -1, 45, -1, 266, -1, -1, 269, + 270, 271, 272, -1, 55, -1, 276, 277, 59, 279, + 280, 281, 282, -1, -1, -1, -1, 287, 288, 289, + 290, 291, -1, -1, 294, 295, 296, -1, 269, 270, + 271, 272, 302, 303, -1, -1, -1, 307, -1, 309, + 310, -1, 93, 91, 95, -1, 97, -1, 99, -1, + 101, 292, 293, 33, 105, -1, 36, 37, 38, -1, + 40, 41, 42, 43, 44, 45, 269, 270, 271, 272, + -1, -1, -1, -1, -1, 123, -1, -1, 58, 59, + 21, -1, -1, 63, 64, 269, 270, 271, 272, 292, + 293, -1, -1, 144, 145, 146, 147, 148, 149, 150, + -1, -1, -1, -1, -1, 46, -1, -1, 292, 293, + -1, 91, -1, 93, -1, -1, -1, 168, 169, 170, + 171, 172, 173, -1, 33, 91, -1, 36, 37, 38, + -1, 40, 41, 42, 43, 44, 45, -1, -1, -1, + -1, -1, -1, 123, -1, 196, 126, -1, 89, 58, + 59, 202, 203, 204, 63, 64, -1, 123, -1, 210, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 115, -1, -1, -1, -1, 120, + -1, -1, -1, -1, 93, 236, -1, 238, -1, -1, + 91, -1, 33, -1, -1, 36, 37, 38, -1, 40, + -1, 42, 43, -1, 45, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 265, -1, -1, 126, 59, -1, + -1, -1, 123, 64, -1, -1, -1, -1, 279, -1, + -1, -1, -1, -1, -1, 283, 284, 285, 286, -1, + -1, -1, -1, -1, 41, -1, 297, 44, -1, -1, + 91, 299, 300, 301, -1, -1, 304, 305, -1, -1, + 308, -1, -1, 311, 312, 313, 63, -1, 209, 320, + -1, -1, -1, -1, -1, -1, -1, 257, 258, 259, + 260, 261, 123, -1, -1, 126, 266, -1, -1, 269, + 270, 271, 272, -1, 91, -1, -1, 277, 278, 279, + 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, + 290, 291, 292, 293, 294, 295, 296, 297, 298, 299, + 300, 301, 302, 303, 304, 305, 123, 307, 308, 309, + 310, 311, 312, 313, -1, -1, -1, -1, -1, 305, + -1, -1, 308, -1, -1, 311, 312, 313, 257, 258, + 259, 260, 261, -1, -1, -1, -1, 266, -1, -1, + 269, 270, 271, 272, -1, 91, -1, -1, 277, 278, + 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, + 289, 290, 291, 292, 293, 294, 295, 296, 297, 298, + 299, 300, 301, 302, 303, 304, 305, 123, 307, 308, + 309, 310, 311, 312, 313, -1, 41, 308, -1, 44, + 311, 312, 313, -1, -1, 256, 257, 258, 259, 260, + 261, -1, -1, 58, 59, 266, -1, -1, 269, 270, + 271, 272, -1, -1, -1, 276, 277, -1, 279, 280, + 281, 282, -1, -1, -1, -1, 287, 288, 289, 290, + 291, 91, -1, 294, 295, 296, -1, 41, 93, -1, + 44, 302, 303, -1, -1, -1, 307, 33, 309, 310, + 36, 37, 38, -1, 40, 59, 42, 43, -1, 45, + -1, 278, -1, 123, -1, -1, 283, 284, 285, 286, + -1, -1, -1, 59, -1, -1, -1, -1, 64, -1, + 297, 298, 299, 300, 301, -1, -1, 304, 305, 93, + -1, 308, -1, -1, 311, 312, 313, -1, -1, -1, + -1, -1, -1, 33, -1, 91, 36, 37, 38, -1, + 40, -1, 42, 43, -1, 45, -1, -1, -1, -1, + -1, -1, -1, -1, 91, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 64, -1, -1, 123, -1, 285, + 126, -1, -1, 33, -1, -1, 36, 37, 38, -1, + 40, -1, 42, 43, -1, 45, 123, -1, -1, 305, + -1, 91, 308, -1, -1, 311, 312, 313, -1, 59, + -1, -1, -1, -1, 64, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 123, -1, -1, 126, -1, -1, 33, + -1, 91, 36, 37, 38, -1, 40, -1, 42, 43, + -1, 45, -1, -1, 269, 270, 271, 272, -1, -1, + -1, -1, -1, 283, 284, 285, 286, -1, -1, -1, + 64, -1, -1, -1, -1, -1, 126, 292, 293, -1, + 300, 301, 297, -1, 304, 305, -1, -1, 308, -1, + -1, 311, 312, 313, -1, -1, -1, 91, -1, 41, + -1, -1, 44, -1, -1, 269, 270, 271, 272, -1, + 256, 257, 258, 259, 260, 261, 58, 59, -1, -1, + 266, 63, -1, 269, 270, 271, 272, -1, 292, 123, + 276, 277, 126, 279, 280, 281, 282, -1, -1, -1, + -1, 287, 288, 289, 290, 291, -1, -1, 294, 295, + 296, 93, -1, -1, -1, -1, 302, 303, 285, 286, + -1, 307, -1, 309, 310, -1, -1, 257, 258, 259, + 260, 261, 262, -1, -1, -1, 266, 304, 305, -1, + -1, 308, 91, -1, 311, 312, 313, 277, -1, 279, + 280, 281, 282, -1, -1, -1, -1, 287, 288, 289, + 290, 291, -1, -1, 294, 295, 296, 257, 258, 259, + 260, 261, 302, 303, 123, -1, 266, 307, -1, 309, + 310, -1, -1, -1, -1, -1, -1, 277, -1, 279, + 280, 281, 282, -1, -1, -1, -1, 287, 288, 289, + 290, 291, -1, -1, 294, 295, 296, -1, -1, -1, + -1, -1, 302, 303, -1, -1, -1, 307, 41, 309, + 310, 44, -1, 257, 258, 259, 260, 261, 262, -1, + -1, -1, 266, -1, -1, 58, 59, -1, -1, -1, + 63, -1, -1, 277, -1, 279, 280, 281, 282, -1, + -1, -1, -1, 287, 288, 289, 290, 291, -1, -1, + -1, 295, 296, -1, -1, -1, -1, -1, 302, 303, + 93, -1, -1, 307, 33, 309, 310, 36, 37, 38, + -1, 40, 41, 42, 43, -1, 45, 269, 270, 271, + 272, -1, -1, -1, -1, 91, 278, -1, -1, -1, + -1, -1, -1, -1, -1, 64, -1, -1, -1, -1, + 292, 293, -1, -1, 33, 297, 298, 36, 37, 38, + -1, 40, -1, 42, 43, -1, 45, 123, -1, -1, + -1, -1, 91, -1, 283, 284, 285, 286, -1, -1, + -1, -1, -1, -1, -1, 64, -1, -1, -1, -1, + -1, 41, 301, -1, 44, 304, 305, -1, -1, 308, + -1, 26, 311, 312, 313, -1, -1, 126, 58, 59, + -1, -1, 91, 33, 93, 40, 36, 37, 38, -1, + 40, 46, 42, 43, -1, 45, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 60, 61, 62, 63, 64, + -1, -1, -1, 93, 64, -1, -1, 126, -1, -1, + -1, -1, -1, 33, -1, -1, 36, 37, 38, -1, + 40, 41, 42, 43, -1, 45, -1, -1, -1, -1, + -1, 91, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 106, -1, -1, 64, -1, 269, 270, 271, 272, + -1, -1, -1, 33, -1, 278, 36, 37, 38, -1, + 40, 41, 42, 43, -1, 45, 126, -1, -1, 292, + 293, 91, -1, -1, 297, 298, 299, 300, 301, -1, + -1, -1, -1, -1, 64, -1, -1, 283, 284, 285, + 286, -1, -1, -1, -1, -1, -1, -1, 257, 258, + 259, 260, 261, -1, -1, -1, 126, 266, 304, 305, + -1, 91, 308, -1, -1, 311, 312, 313, 277, -1, + 279, 280, 281, 282, -1, 91, -1, -1, 287, 288, + 289, 290, 291, -1, -1, 294, 295, 296, 257, 258, + 259, 260, 261, 302, 303, -1, 126, 266, 307, -1, + 309, 310, -1, -1, -1, -1, -1, 123, 277, -1, + 279, 280, 281, 282, -1, -1, -1, -1, 287, 288, + 289, 290, 291, -1, -1, 294, 295, 296, -1, 269, + 270, 271, 272, 302, 303, -1, -1, -1, 307, -1, + 309, 310, -1, -1, -1, -1, 256, 257, 258, 259, + 260, 261, 292, 293, -1, -1, 266, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 277, -1, 279, + 280, 281, 282, -1, -1, -1, -1, 287, 288, 289, + 290, 291, -1, -1, 294, 295, 296, 257, 258, 259, + 260, 261, 302, 303, -1, -1, 266, 307, -1, 309, + 310, -1, -1, -1, -1, -1, -1, 277, -1, 279, + 280, 281, 282, -1, -1, -1, -1, 287, 288, 289, + 290, 291, -1, 91, 294, 295, 296, 257, 258, 259, + 260, 261, 302, 303, -1, -1, 266, 307, -1, 309, + 310, -1, -1, -1, -1, -1, -1, 277, -1, 279, + 280, 281, 282, -1, -1, 123, -1, 287, 288, 289, + 290, 291, -1, -1, 294, 295, 296, -1, -1, 285, + 286, -1, 302, 303, -1, -1, -1, 307, 33, 309, + 310, 36, 37, 38, -1, 40, 41, 42, 43, 305, + 45, -1, 308, -1, -1, 311, 312, 313, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 64, + -1, -1, -1, -1, -1, -1, -1, -1, 33, -1, + -1, 36, 37, 38, -1, 40, 41, 42, 43, -1, + 45, -1, -1, -1, -1, -1, 91, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 64, + -1, -1, -1, -1, -1, -1, -1, -1, 33, -1, + -1, 36, 37, 38, -1, 40, -1, 42, 43, -1, + 45, 126, -1, -1, -1, -1, 91, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 64, + -1, -1, -1, -1, -1, -1, -1, -1, 33, -1, + -1, 36, 37, 38, -1, 40, -1, 42, 43, -1, + 45, 126, -1, -1, -1, 283, 91, 285, 286, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 64, + -1, -1, -1, -1, -1, -1, 304, 305, -1, -1, + 308, -1, -1, 311, 312, 313, -1, -1, 123, -1, + -1, 126, -1, -1, -1, -1, 91, -1, -1, -1, + -1, -1, -1, 33, -1, -1, 36, 37, 38, -1, + 40, -1, 42, 43, -1, 45, -1, 25, 26, -1, + -1, -1, -1, -1, -1, -1, 34, -1, -1, -1, + -1, 126, 40, 41, 64, -1, -1, -1, 46, -1, + -1, -1, 257, 258, 259, 260, 261, -1, -1, -1, + -1, 266, 60, 61, 62, 63, 64, -1, -1, -1, + -1, 91, 277, -1, 279, 280, 281, 282, -1, -1, + -1, -1, 287, 288, 289, 290, 291, -1, -1, 294, + 295, 296, 257, 258, 259, 260, 261, 302, 303, -1, + -1, 266, 307, 123, 309, 310, 126, -1, 106, -1, + -1, -1, 277, -1, 279, 280, 281, 282, -1, -1, + -1, -1, 287, 288, 289, 290, 291, -1, -1, 294, + 295, 296, 257, 258, 259, 260, 261, 302, 303, -1, + -1, 266, 307, -1, 309, 310, -1, -1, -1, -1, + -1, -1, 277, -1, 279, 280, 281, 282, -1, -1, + -1, -1, 287, 288, 289, 290, 291, -1, -1, 167, + 295, 296, 257, 258, 259, 260, 261, 302, 303, -1, + -1, 266, 307, 91, 309, 310, -1, -1, -1, -1, + 41, -1, 277, 44, 279, 280, 281, 282, -1, -1, + -1, -1, 287, 288, 289, 290, 291, 58, 59, 294, + 295, 296, -1, -1, -1, 123, -1, 302, 303, -1, + -1, -1, 307, 33, 309, 310, 36, 37, 38, -1, + 40, -1, 42, 43, -1, 45, -1, 257, 258, 259, + 260, 261, 93, -1, -1, -1, 266, -1, -1, -1, + -1, -1, -1, -1, 64, -1, -1, 277, -1, 279, + 280, 281, 282, -1, -1, -1, -1, 287, 288, 289, + 290, 291, -1, -1, 41, 295, 296, 44, -1, -1, + -1, 91, 302, 303, -1, -1, -1, 307, -1, 309, + 310, 58, 59, -1, -1, -1, 63, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 126, -1, -1, 41, + -1, -1, 44, -1, 91, -1, 93, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 58, 59, -1, -1, + -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 123, -1, -1, -1, + -1, -1, -1, -1, 41, -1, -1, 44, -1, 91, + -1, 93, -1, -1, -1, 283, 284, 285, 286, -1, + -1, 58, 59, -1, -1, -1, 63, -1, -1, -1, + 298, 299, 300, 301, -1, -1, 304, 305, -1, -1, + 308, 123, -1, 311, 312, 313, -1, -1, -1, 41, + -1, -1, 44, -1, 91, -1, 93, -1, 269, 270, + 271, 272, -1, -1, -1, -1, 58, 59, -1, -1, + -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 292, 293, -1, -1, -1, 123, 257, 258, 259, + 260, 261, -1, -1, -1, -1, 266, -1, -1, -1, + -1, 93, -1, -1, -1, -1, -1, 277, -1, 279, + 280, 281, 282, -1, -1, -1, -1, 287, 288, 289, + 290, 291, -1, -1, -1, 295, 296, -1, -1, -1, + 41, 123, 302, 303, -1, -1, -1, 307, -1, 309, + 310, -1, 269, 270, 271, 272, -1, 58, 59, -1, + -1, 278, 63, -1, -1, -1, 283, 284, 285, 286, + -1, -1, -1, -1, -1, 292, 293, -1, -1, -1, + 297, 298, 299, 300, 301, -1, 41, 304, 305, 44, + 91, 308, 93, -1, 311, 312, 313, 269, 270, 271, + 272, -1, -1, 58, 59, -1, 278, -1, 63, -1, + -1, 283, 284, 285, 286, -1, -1, -1, -1, -1, + 292, 293, 123, -1, -1, 297, 298, 299, 300, 301, + -1, 41, 304, 305, 44, -1, 308, -1, 93, 311, + 312, 313, 269, 270, 271, 272, -1, -1, 58, 59, + -1, 278, -1, 63, -1, -1, 283, 284, 285, 286, + -1, -1, -1, -1, -1, 292, 293, -1, 123, -1, + 297, 298, 299, 300, 301, -1, 41, 304, 305, 44, + -1, 308, -1, 93, 311, 312, 313, 269, 270, 271, + 272, -1, -1, 58, 59, -1, 278, -1, 63, -1, + -1, 283, 284, 285, 286, -1, -1, -1, -1, -1, + 292, 293, -1, 123, -1, 297, 298, 299, 300, 301, + -1, -1, 304, 305, 41, -1, 308, -1, 93, 311, + 312, 313, -1, -1, 41, -1, -1, 44, -1, -1, + -1, 58, 59, -1, -1, -1, 63, -1, -1, -1, + -1, 58, 59, -1, -1, -1, -1, -1, 123, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 269, 270, + 271, 272, 41, -1, 91, 44, 93, 278, -1, -1, + -1, -1, 283, 284, 285, 286, 93, -1, -1, 58, + 59, 292, 293, -1, 63, -1, 297, 298, 299, 300, + 301, -1, -1, 304, 305, -1, 123, 308, -1, -1, + 311, 312, 313, -1, 269, 270, 271, 272, 41, -1, + -1, 44, -1, 278, 93, -1, -1, -1, 283, 284, + 285, 286, -1, -1, -1, 58, 59, 292, 293, -1, + 63, -1, 297, 298, 299, 300, 301, -1, -1, 304, + 305, -1, -1, 308, 123, -1, 311, 312, 313, 269, + 270, 271, 272, 41, -1, -1, 44, -1, 278, -1, + 93, -1, -1, 283, 284, 285, 286, -1, -1, -1, + 58, 59, 292, 293, -1, 63, -1, 297, 298, 299, + 300, 301, -1, -1, 304, 305, -1, -1, 308, -1, + -1, 311, 312, 313, 269, 270, 271, 272, 41, -1, + -1, 44, -1, 278, -1, 93, -1, -1, 283, 284, + 285, 286, -1, -1, -1, 58, 59, 292, 293, -1, + 63, -1, 297, 298, 299, 300, 301, -1, -1, 304, + 305, -1, -1, 308, -1, -1, 311, 312, 313, -1, + -1, -1, 269, 270, 271, 272, 41, -1, -1, 44, + 93, 278, 269, 270, 271, 272, 283, 284, 285, 286, + -1, -1, -1, 58, 59, 292, 293, -1, 63, -1, + 297, 298, 299, 300, 301, 292, 293, 304, 305, -1, + -1, 308, -1, -1, 311, 312, 313, -1, -1, -1, + 269, 270, 271, 272, 41, -1, -1, -1, 93, 278, + -1, -1, -1, -1, 283, 284, 285, 286, -1, -1, + -1, -1, -1, 292, 293, -1, 63, -1, 297, 298, + 299, 300, 301, -1, -1, 304, 305, -1, -1, 308, + -1, -1, 311, 312, 313, -1, 269, 270, 271, 272, + 41, -1, -1, 44, 91, 278, -1, -1, -1, -1, + 283, 284, 285, 286, -1, -1, -1, 58, 59, 292, + 293, -1, 63, -1, 297, 298, 299, 300, 301, -1, + -1, 304, 305, -1, -1, 308, 123, -1, 311, 312, + 313, 269, 270, 271, 272, 41, -1, -1, 44, -1, + 278, -1, 93, -1, -1, 283, 284, 285, 286, -1, + -1, -1, 58, 59, 292, 293, -1, 63, -1, 297, + 298, 299, 300, 301, -1, -1, 304, 305, -1, -1, + 308, -1, -1, 311, 312, 313, 269, 270, 271, 272, + 41, -1, -1, 44, -1, 278, -1, 93, -1, -1, + 283, 284, 285, 286, -1, -1, -1, 58, 59, 292, + 293, -1, 63, -1, 297, 298, 299, 300, 301, -1, + -1, 304, 305, -1, -1, 308, -1, -1, 311, 312, + 313, -1, -1, -1, 269, 270, 271, 272, 41, -1, + -1, 44, 93, 278, -1, -1, -1, -1, 283, 284, + 285, 286, -1, -1, -1, 58, 59, 292, 293, -1, + 63, -1, 297, 298, 299, 300, 301, -1, -1, 304, + 305, -1, -1, 308, -1, -1, 311, 312, 313, -1, + -1, -1, -1, 41, -1, -1, 44, -1, -1, -1, + 93, 278, -1, -1, -1, -1, 283, 284, 285, 286, + 58, 59, -1, -1, -1, 63, -1, -1, -1, -1, + 297, 298, 299, 300, 301, -1, -1, 304, 305, -1, + -1, 308, -1, -1, 311, 312, 313, -1, 269, 270, + 271, 272, -1, 58, -1, 93, -1, 278, 63, -1, + -1, -1, 283, 284, 285, 286, -1, -1, -1, -1, + -1, 292, 293, -1, -1, -1, 297, 298, 299, 300, + 301, -1, 41, 304, 305, 44, 91, 308, -1, -1, + -1, -1, -1, 269, 270, 271, 272, -1, -1, 58, + 59, -1, 278, -1, 63, -1, -1, 283, 284, 285, + 286, -1, -1, -1, -1, -1, 292, 293, 123, -1, + -1, 297, 298, 299, 300, 301, -1, 41, 304, 305, + 44, -1, 308, -1, 93, -1, -1, -1, 269, 270, + 271, 272, -1, -1, 58, 59, -1, 278, -1, 63, + -1, -1, 283, 284, 285, 286, -1, -1, -1, -1, + -1, 292, 293, -1, -1, -1, 297, 298, 299, 300, + 301, -1, -1, 304, 305, 41, -1, -1, 44, 93, + -1, -1, -1, -1, -1, -1, 269, 270, 271, 272, + -1, -1, 58, 59, -1, 278, -1, 63, -1, -1, + 283, 284, 285, 286, -1, -1, -1, -1, -1, 292, + 293, -1, -1, -1, 297, 298, 299, 300, 301, -1, + 41, 304, 305, 44, -1, -1, -1, 93, -1, -1, + -1, 269, 270, 271, 272, -1, -1, 58, 59, -1, + 278, -1, 63, -1, -1, 283, 284, 285, 286, -1, + -1, -1, -1, -1, 292, 293, -1, -1, -1, 297, + 298, 299, 300, 301, -1, 41, 304, 305, 44, -1, + -1, -1, 93, 278, -1, -1, -1, -1, 283, 284, + 285, 286, 58, 59, -1, -1, -1, 63, -1, -1, + -1, -1, 297, 298, 299, 300, 301, -1, -1, 304, + 305, -1, -1, 308, -1, -1, 311, 312, 313, -1, + 269, 270, 271, 272, -1, -1, -1, 93, -1, 278, + 63, -1, -1, -1, 283, 284, 285, 286, -1, -1, + -1, -1, -1, 292, 293, -1, -1, -1, 297, 298, + 299, 300, 301, -1, 41, 304, 305, 44, 91, -1, + -1, -1, -1, -1, -1, 269, 270, 271, 272, -1, + -1, 58, 59, -1, 278, -1, 63, -1, -1, 283, + 284, 285, 286, -1, -1, -1, -1, -1, 292, 293, + 123, -1, -1, 297, 298, 299, 300, 301, -1, -1, + 304, 305, 41, -1, -1, 44, 93, -1, -1, -1, + -1, -1, -1, 269, 270, 271, 272, -1, -1, 58, + 59, -1, 278, -1, 63, -1, -1, 283, 284, 285, + 286, -1, -1, -1, -1, -1, 292, 293, -1, -1, + -1, 297, 298, 299, 300, 301, -1, 41, 304, 305, + 44, -1, -1, -1, 93, -1, -1, -1, 269, 270, + 271, 272, -1, -1, 58, 59, -1, 278, -1, 63, + -1, -1, 283, 284, 285, 286, -1, -1, -1, -1, + -1, 292, 293, -1, -1, -1, 297, 298, 299, 300, + 301, -1, 41, 304, 305, 44, -1, -1, -1, 93, + -1, -1, -1, 269, 270, 271, 272, -1, -1, 58, + 59, -1, 278, -1, 63, -1, -1, 283, 284, 285, + 286, -1, -1, -1, -1, 41, 292, 293, 44, -1, + -1, 297, 298, 299, 300, 301, -1, -1, 304, -1, + -1, -1, 58, 59, 93, 278, -1, 63, -1, -1, + 283, 284, 285, 286, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 297, 298, 299, 300, 301, -1, + 41, 304, 305, 44, -1, 308, -1, 93, 311, 312, + 313, -1, 269, 270, 271, 272, 41, 58, 59, 44, + -1, 278, 63, -1, -1, -1, 283, 284, -1, 286, + -1, -1, -1, 58, 59, 292, 293, -1, 63, -1, + 297, 298, 299, 300, 301, -1, -1, 304, 41, -1, + -1, 44, 93, -1, -1, -1, -1, -1, -1, -1, + 269, 270, 271, 272, 41, 58, 59, 44, 93, 278, + 63, -1, -1, -1, 283, 284, -1, -1, -1, -1, + -1, 58, 59, 292, 293, -1, 63, -1, 297, 298, + 299, 300, 301, -1, -1, 304, -1, -1, -1, -1, + 93, -1, -1, -1, -1, 269, 270, 271, 272, 41, + -1, -1, 44, -1, 278, -1, 93, -1, -1, 283, + 284, -1, -1, -1, -1, -1, 58, 59, 292, 293, + -1, 63, -1, 297, 298, 299, 300, 301, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 63, -1, + 269, 270, 271, 272, -1, -1, -1, -1, -1, 278, + -1, 93, -1, -1, 283, 284, -1, -1, -1, -1, + -1, -1, -1, 292, 293, -1, 91, -1, 297, 298, + 299, 300, 301, 269, 270, 271, 272, -1, -1, -1, + -1, -1, 278, -1, -1, -1, -1, 283, 284, -1, + -1, -1, -1, -1, -1, -1, 292, 293, 123, -1, + -1, 297, 298, 299, 300, 301, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 269, 270, + 271, 272, -1, -1, -1, -1, -1, 278, -1, -1, + -1, -1, 283, 284, 269, 270, 271, 272, -1, -1, + -1, 292, 293, 278, -1, -1, 297, 298, 299, 300, + 301, -1, -1, -1, -1, -1, -1, 292, 293, -1, + -1, -1, 297, 298, 299, 300, 269, 270, 271, 272, + -1, -1, -1, -1, -1, 278, -1, -1, -1, -1, + -1, 284, 269, 270, 271, 272, -1, -1, -1, 292, + 293, 278, -1, -1, 297, 298, 299, 300, 301, -1, + -1, -1, -1, -1, -1, 292, 293, -1, -1, -1, + 297, 298, 299, 300, 301, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 35, -1, 269, 270, 271, + 272, 41, 42, -1, -1, -1, 278, -1, 48, 49, + 50, 51, 52, 53, 54, -1, -1, 57, 58, -1, + 292, 293, -1, 278, -1, 297, 298, 299, 283, 284, + 285, 286, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 298, 299, 300, 301, -1, -1, 304, + 305, 91, -1, 308, -1, -1, 311, 312, 313, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 143, -1, -1, -1, -1, -1, -1, + -1, 151, 152, 153, 154, 155, 156, 157, 158, 159, + 160, 161, 162, 163, 164, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 253, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 281, +}; +#define YYFINAL 1 +#ifndef YYDEBUG +#define YYDEBUG 0 +#endif +#define YYMAXTOKEN 313 +#if YYDEBUG +dEXT char * yyname[] = { +"end-of-file",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +"'!'",0,0,"'$'","'%'","'&'",0,"'('","')'","'*'","'+'","','","'-'",0,0,0,0,0,0,0, +0,0,0,0,0,"':'","';'",0,0,0,"'?'","'@'",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,"'['",0,"']'",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,"'{'",0,"'}'","'~'",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,"WORD","METHOD","FUNCMETH","THING", +"PMFUNC","PRIVATEREF","LABEL","FORMAT","SUB","ANONSUB","PACKAGE","USE","WHILE", +"UNTIL","IF","UNLESS","ELSE","ELSIF","CONTINUE","FOR","LOOPEX","DOTDOT","FUNC0", +"FUNC1","FUNC","FUNC0SUB","RELOP","EQOP","MULOP","ADDOP","DOLSHARP","DO", +"LOCAL","HASHBRACK","NOAMP","OROP","ANDOP","NOTOP","LSTOP","LSTOPSUB", +"ASSIGNOP","OROR","ANDAND","BITOROP","BITANDOP","UNIOP","UNIOPSUB","SHIFTOP", +"MATCHOP","UMINUS","REFGEN","POWOP","PREINC","PREDEC","POSTINC","POSTDEC", +"ARROW", +}; +dEXT char * yyrule[] = { +"$accept : prog", +"$$1 :", +"prog : $$1 lineseq", +"block : '{' remember lineseq '}'", +"remember :", +"lineseq :", +"lineseq : lineseq decl", +"lineseq : lineseq line", +"line : label cond", +"line : loop", +"line : label ';'", +"line : label sideff ';'", +"sideff : error", +"sideff : expr", +"sideff : expr IF expr", +"sideff : expr UNLESS expr", +"sideff : expr WHILE expr", +"sideff : expr UNTIL expr", +"else :", +"else : ELSE block", +"else : ELSIF '(' expr ')' block else", +"cond : IF '(' expr ')' block else", +"cond : UNLESS '(' expr ')' block else", +"cond : IF block block else", +"cond : UNLESS block block else", +"cont :", +"cont : CONTINUE block", +"loop : label WHILE '(' texpr ')' block cont", +"loop : label UNTIL '(' expr ')' block cont", +"loop : label WHILE block block cont", +"loop : label UNTIL block block cont", +"loop : label FOR scalar '(' expr ')' block cont", +"loop : label FOR '(' expr ')' block cont", +"loop : label FOR '(' nexpr ';' texpr ';' nexpr ')' block", +"loop : label block cont", +"nexpr :", +"nexpr : sideff", +"texpr :", +"texpr : expr", +"label :", +"label : LABEL", +"decl : format", +"decl : subrout", +"decl : package", +"decl : use", +"format : FORMAT startsub WORD block", +"format : FORMAT startsub block", +"subrout : SUB startsub WORD proto block", +"subrout : SUB startsub WORD proto ';'", +"proto :", +"proto : THING", +"startsub :", +"package : PACKAGE WORD ';'", +"package : PACKAGE ';'", +"use : USE WORD listexpr ';'", +"expr : expr ANDOP expr", +"expr : expr OROP expr", +"expr : NOTOP expr", +"expr : argexpr", +"argexpr : argexpr ','", +"argexpr : argexpr ',' term", +"argexpr : term", +"listop : LSTOP indirob argexpr", +"listop : FUNC '(' indirob expr ')'", +"listop : term ARROW method '(' listexprcom ')'", +"listop : METHOD indirob listexpr", +"listop : FUNCMETH indirob '(' listexprcom ')'", +"listop : LSTOP listexpr", +"listop : FUNC '(' listexprcom ')'", +"listop : LSTOPSUB startsub block listexpr", +"method : METHOD", +"method : scalar", +"term : term ASSIGNOP term", +"term : term POWOP term", +"term : term MULOP term", +"term : term ADDOP term", +"term : term SHIFTOP term", +"term : term RELOP term", +"term : term EQOP term", +"term : term BITANDOP term", +"term : term BITOROP term", +"term : term DOTDOT term", +"term : term ANDAND term", +"term : term OROR term", +"term : term '?' term ':' term", +"term : term MATCHOP term", +"term : '-' term", +"term : '+' term", +"term : '!' term", +"term : '~' term", +"term : REFGEN term", +"term : term POSTINC", +"term : term POSTDEC", +"term : PREINC term", +"term : PREDEC term", +"term : LOCAL term", +"term : '(' expr ')'", +"term : '(' ')'", +"term : '[' expr ']'", +"term : '[' ']'", +"term : HASHBRACK expr ';' '}'", +"term : HASHBRACK ';' '}'", +"term : ANONSUB startsub proto block", +"term : scalar", +"term : star", +"term : scalar '[' expr ']'", +"term : term ARROW '[' expr ']'", +"term : term '[' expr ']'", +"term : hsh", +"term : ary", +"term : arylen", +"term : scalar '{' expr ';' '}'", +"term : term ARROW '{' expr ';' '}'", +"term : term '{' expr ';' '}'", +"term : '(' expr ')' '[' expr ']'", +"term : '(' ')' '[' expr ']'", +"term : ary '[' expr ']'", +"term : ary '{' expr ';' '}'", +"term : THING", +"term : amper", +"term : amper '(' ')'", +"term : amper '(' expr ')'", +"term : NOAMP WORD listexpr", +"term : DO term", +"term : DO block", +"term : DO WORD '(' ')'", +"term : DO WORD '(' expr ')'", +"term : DO scalar '(' ')'", +"term : DO scalar '(' expr ')'", +"term : LOOPEX", +"term : LOOPEX term", +"term : UNIOP", +"term : UNIOP block", +"term : UNIOP term", +"term : UNIOPSUB term", +"term : FUNC0", +"term : FUNC0 '(' ')'", +"term : FUNC0SUB", +"term : FUNC1 '(' ')'", +"term : FUNC1 '(' expr ')'", +"term : PMFUNC '(' term ')'", +"term : PMFUNC '(' term ',' term ')'", +"term : WORD", +"term : listop", +"listexpr :", +"listexpr : argexpr", +"listexprcom :", +"listexprcom : expr", +"listexprcom : expr ','", +"amper : '&' indirob", +"scalar : '$' indirob", +"ary : '@' indirob", +"hsh : '%' indirob", +"arylen : DOLSHARP indirob", +"star : '*' indirob", +"indirob : WORD", +"indirob : scalar", +"indirob : block", +"indirob : PRIVATEREF", +}; +#endif +#define yyclearin (yychar=(-1)) +#define yyerrok (yyerrflag=0) +#ifdef YYSTACKSIZE +#ifndef YYMAXDEPTH +#define YYMAXDEPTH YYSTACKSIZE +#endif +#else +#ifdef YYMAXDEPTH +#define YYSTACKSIZE YYMAXDEPTH +#else +#define YYSTACKSIZE 500 +#define YYMAXDEPTH 500 +#endif +#endif +dEXT int yydebug; +dEXT int yynerrs; +dEXT int yyerrflag; +dEXT int yychar; +dEXT YYSTYPE yyval; +dEXT YYSTYPE yylval; +#line 562 "perly.y" + /* PROGRAM */ +#line 1307 "y.tab.c" +#define YYABORT goto yyabort +#define YYACCEPT goto yyaccept +#define YYERROR goto yyerrlab + +struct ysv { + short* yyss; + YYSTYPE* yyvs; + int oldyydebug; + int oldyynerrs; + int oldyyerrflag; + int oldyychar; + YYSTYPE oldyyval; + YYSTYPE oldyylval; +}; + +void +yydestruct(ptr) +void* ptr; +{ + struct ysv* ysave = (struct ysv*)ptr; + if (ysave->yyss) Safefree(ysave->yyss); + if (ysave->yyvs) Safefree(ysave->yyvs); + yydebug = ysave->oldyydebug; + yynerrs = ysave->oldyynerrs; + yyerrflag = ysave->oldyyerrflag; + yychar = ysave->oldyychar; + yyval = ysave->oldyyval; + yylval = ysave->oldyylval; + Safefree(ysave); +} + +int +yyparse() +{ + register int yym, yyn, yystate; + register short *yyssp; + register YYSTYPE *yyvsp; + short* yyss; + YYSTYPE* yyvs; + unsigned yystacksize = YYSTACKSIZE; + int retval = 0; +#if YYDEBUG + register char *yys; + extern char *getenv(); +#endif + + struct ysv *ysave = (struct ysv*)safemalloc(sizeof(struct ysv)); + SAVEDESTRUCTOR(yydestruct, ysave); + ysave->oldyydebug = yydebug; + ysave->oldyynerrs = yynerrs; + ysave->oldyyerrflag = yyerrflag; + ysave->oldyychar = yychar; + ysave->oldyyval = yyval; + ysave->oldyylval = yylval; + +#if YYDEBUG + if (yys = getenv("YYDEBUG")) + { + yyn = *yys; + if (yyn >= '0' && yyn <= '9') + yydebug = yyn - '0'; + } +#endif + + yynerrs = 0; + yyerrflag = 0; + yychar = (-1); + + /* + ** Initialize private stacks (yyparse may be called from an action) + */ + ysave->yyss = yyss = (short*)safemalloc(yystacksize*sizeof(short)); + ysave->yyvs = yyvs = (YYSTYPE*)safemalloc(yystacksize*sizeof(YYSTYPE)); + if (!yyvs || !yyss) + goto yyoverflow; + + yyssp = yyss; + yyvsp = yyvs; + *yyssp = yystate = 0; + +yyloop: + if (yyn = yydefred[yystate]) goto yyreduce; + if (yychar < 0) + { + if ((yychar = yylex()) < 0) yychar = 0; +#if YYDEBUG + if (yydebug) + { + yys = 0; + if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; + if (!yys) yys = "illegal-symbol"; + fprintf(stderr, "yydebug: state %d, reading %d (%s)\n", yystate, + yychar, yys); + } +#endif + } + if ((yyn = yysindex[yystate]) && (yyn += yychar) >= 0 && + yyn <= YYTABLESIZE && yycheck[yyn] == yychar) + { +#if YYDEBUG + if (yydebug) + fprintf(stderr, "yydebug: state %d, shifting to state %d\n", + yystate, yytable[yyn]); +#endif + if (yyssp >= yyss + yystacksize - 1) + { + /* + ** reallocate and recover. Note that pointers + ** have to be reset, or bad things will happen + */ + int yyps_index = (yyssp - yyss); + int yypv_index = (yyvsp - yyvs); + yystacksize += YYSTACKSIZE; + ysave->yyvs = yyvs = + (YYSTYPE*)realloc((char*)yyvs,yystacksize * sizeof(YYSTYPE)); + ysave->yyss = yyss = + (short*)realloc((char*)yyss,yystacksize * sizeof(short)); + if (!yyvs || !yyss) + goto yyoverflow; + yyssp = yyss + yyps_index; + yyvsp = yyvs + yypv_index; + } + *++yyssp = yystate = yytable[yyn]; + *++yyvsp = yylval; + yychar = (-1); + if (yyerrflag > 0) --yyerrflag; + goto yyloop; + } + if ((yyn = yyrindex[yystate]) && (yyn += yychar) >= 0 && + yyn <= YYTABLESIZE && yycheck[yyn] == yychar) + { + yyn = yytable[yyn]; + goto yyreduce; + } + if (yyerrflag) goto yyinrecovery; +#ifdef lint + goto yynewerror; +#endif +yynewerror: + yyerror("syntax error"); +#ifdef lint + goto yyerrlab; +#endif +yyerrlab: + ++yynerrs; +yyinrecovery: + if (yyerrflag < 3) + { + yyerrflag = 3; + for (;;) + { + if ((yyn = yysindex[*yyssp]) && (yyn += YYERRCODE) >= 0 && + yyn <= YYTABLESIZE && yycheck[yyn] == YYERRCODE) + { +#if YYDEBUG + if (yydebug) + fprintf(stderr, + "yydebug: state %d, error recovery shifting to state %d\n", + *yyssp, yytable[yyn]); +#endif + if (yyssp >= yyss + yystacksize - 1) + { + /* + ** reallocate and recover. Note that pointers + ** have to be reset, or bad things will happen + */ + int yyps_index = (yyssp - yyss); + int yypv_index = (yyvsp - yyvs); + yystacksize += YYSTACKSIZE; + ysave->yyvs = yyvs = (YYSTYPE*)realloc((char*)yyvs, + yystacksize * sizeof(YYSTYPE)); + ysave->yyss = yyss = (short*)realloc((char*)yyss, + yystacksize * sizeof(short)); + if (!yyvs || !yyss) + goto yyoverflow; + yyssp = yyss + yyps_index; + yyvsp = yyvs + yypv_index; + } + *++yyssp = yystate = yytable[yyn]; + *++yyvsp = yylval; + goto yyloop; + } + else + { +#if YYDEBUG + if (yydebug) + fprintf(stderr, + "yydebug: error recovery discarding state %d\n", + *yyssp); +#endif + if (yyssp <= yyss) goto yyabort; + --yyssp; + --yyvsp; + } + } + } + else + { + if (yychar == 0) goto yyabort; +#if YYDEBUG + if (yydebug) + { + yys = 0; + if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; + if (!yys) yys = "illegal-symbol"; + fprintf(stderr, + "yydebug: state %d, error recovery discards token %d (%s)\n", + yystate, yychar, yys); + } +#endif + yychar = (-1); + goto yyloop; + } +yyreduce: +#if YYDEBUG + if (yydebug) + fprintf(stderr, "yydebug: state %d, reducing by rule %d (%s)\n", + yystate, yyn, yyrule[yyn]); +#endif + yym = yylen[yyn]; + yyval = yyvsp[1-yym]; + switch (yyn) + { +case 1: +#line 83 "perly.y" +{ +#if defined(YYDEBUG) && defined(DEBUGGING) + yydebug = (debug & 1); +#endif + expect = XSTATE; + } +break; +case 2: +#line 90 "perly.y" +{ newPROG(yyvsp[0].opval); } +break; +case 3: +#line 94 "perly.y" +{ yyval.opval = block_end(yyvsp[-3].ival,yyvsp[-2].ival,yyvsp[-1].opval); } +break; +case 4: +#line 98 "perly.y" +{ yyval.ival = block_start(); } +break; +case 5: +#line 102 "perly.y" +{ yyval.opval = Nullop; } +break; +case 6: +#line 104 "perly.y" +{ yyval.opval = yyvsp[-1].opval; } +break; +case 7: +#line 106 "perly.y" +{ yyval.opval = append_list(OP_LINESEQ, + (LISTOP*)yyvsp[-1].opval, (LISTOP*)yyvsp[0].opval); + pad_reset_pending = TRUE; + if (yyvsp[-1].opval && yyvsp[0].opval) hints |= HINT_BLOCK_SCOPE; } +break; +case 8: +#line 113 "perly.y" +{ yyval.opval = newSTATEOP(0, yyvsp[-1].pval, yyvsp[0].opval); } +break; +case 10: +#line 116 "perly.y" +{ if (yyvsp[-1].pval != Nullch) { + yyval.opval = newSTATEOP(0, yyvsp[-1].pval, newOP(OP_NULL, 0)); + } + else { + yyval.opval = Nullop; + copline = NOLINE; + } + expect = XSTATE; } +break; +case 11: +#line 125 "perly.y" +{ yyval.opval = newSTATEOP(0, yyvsp[-2].pval, yyvsp[-1].opval); + expect = XSTATE; } +break; +case 12: +#line 130 "perly.y" +{ yyval.opval = Nullop; } +break; +case 13: +#line 132 "perly.y" +{ yyval.opval = yyvsp[0].opval; } +break; +case 14: +#line 134 "perly.y" +{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); } +break; +case 15: +#line 136 "perly.y" +{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); } +break; +case 16: +#line 138 "perly.y" +{ yyval.opval = newLOOPOP(OPf_PARENS, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); } +break; +case 17: +#line 140 "perly.y" +{ yyval.opval = newLOOPOP(OPf_PARENS, 1, invert(scalar(yyvsp[0].opval)), yyvsp[-2].opval);} +break; +case 18: +#line 144 "perly.y" +{ yyval.opval = Nullop; } +break; +case 19: +#line 146 "perly.y" +{ yyval.opval = scope(yyvsp[0].opval); } +break; +case 20: +#line 148 "perly.y" +{ copline = yyvsp[-5].ival; + yyval.opval = newSTATEOP(0, 0, + newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); + hints |= HINT_BLOCK_SCOPE; } +break; +case 21: +#line 155 "perly.y" +{ copline = yyvsp[-5].ival; + yyval.opval = newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval); } +break; +case 22: +#line 158 "perly.y" +{ copline = yyvsp[-5].ival; + yyval.opval = newCONDOP(0, + invert(scalar(yyvsp[-3].opval)), scope(yyvsp[-1].opval), yyvsp[0].opval); } +break; +case 23: +#line 162 "perly.y" +{ copline = yyvsp[-3].ival; + deprecate("if BLOCK BLOCK"); + yyval.opval = newCONDOP(0, scope(yyvsp[-2].opval), scope(yyvsp[-1].opval), yyvsp[0].opval); } +break; +case 24: +#line 166 "perly.y" +{ copline = yyvsp[-3].ival; + deprecate("unless BLOCK BLOCK"); + yyval.opval = newCONDOP(0, invert(scalar(scope(yyvsp[-2].opval))), + scope(yyvsp[-1].opval), yyvsp[0].opval); } +break; +case 25: +#line 173 "perly.y" +{ yyval.opval = Nullop; } +break; +case 26: +#line 175 "perly.y" +{ yyval.opval = scope(yyvsp[0].opval); } +break; +case 27: +#line 179 "perly.y" +{ copline = yyvsp[-5].ival; + yyval.opval = newSTATEOP(0, yyvsp[-6].pval, + newWHILEOP(0, 1, (LOOP*)Nullop, + yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval) ); } +break; +case 28: +#line 184 "perly.y" +{ copline = yyvsp[-5].ival; + yyval.opval = newSTATEOP(0, yyvsp[-6].pval, + newWHILEOP(0, 1, (LOOP*)Nullop, + invert(scalar(yyvsp[-3].opval)), yyvsp[-1].opval, yyvsp[0].opval) ); } +break; +case 29: +#line 189 "perly.y" +{ copline = yyvsp[-3].ival; + yyval.opval = newSTATEOP(0, yyvsp[-4].pval, + newWHILEOP(0, 1, (LOOP*)Nullop, + scope(yyvsp[-2].opval), yyvsp[-1].opval, yyvsp[0].opval) ); } +break; +case 30: +#line 194 "perly.y" +{ copline = yyvsp[-3].ival; + yyval.opval = newSTATEOP(0, yyvsp[-4].pval, + newWHILEOP(0, 1, (LOOP*)Nullop, + invert(scalar(scope(yyvsp[-2].opval))), yyvsp[-1].opval, yyvsp[0].opval)); } +break; +case 31: +#line 199 "perly.y" +{ yyval.opval = newFOROP(0, yyvsp[-7].pval, yyvsp[-6].ival, mod(yyvsp[-5].opval, OP_ENTERLOOP), + yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval); } +break; +case 32: +#line 202 "perly.y" +{ yyval.opval = newFOROP(0, yyvsp[-6].pval, yyvsp[-5].ival, Nullop, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval); } +break; +case 33: +#line 205 "perly.y" +{ copline = yyvsp[-8].ival; + yyval.opval = append_elem(OP_LINESEQ, + newSTATEOP(0, yyvsp[-9].pval, scalar(yyvsp[-6].opval)), + newSTATEOP(0, yyvsp[-9].pval, + newWHILEOP(0, 1, (LOOP*)Nullop, + scalar(yyvsp[-4].opval), yyvsp[0].opval, scalar(yyvsp[-2].opval)) )); } +break; +case 34: +#line 212 "perly.y" +{ yyval.opval = newSTATEOP(0, + yyvsp[-2].pval, newWHILEOP(0, 1, (LOOP*)Nullop, + Nullop, yyvsp[-1].opval, yyvsp[0].opval)); } +break; +case 35: +#line 218 "perly.y" +{ yyval.opval = Nullop; } +break; +case 37: +#line 223 "perly.y" +{ (void)scan_num("1"); yyval.opval = yylval.opval; } +break; +case 39: +#line 228 "perly.y" +{ yyval.pval = Nullch; } +break; +case 41: +#line 233 "perly.y" +{ yyval.ival = 0; } +break; +case 42: +#line 235 "perly.y" +{ yyval.ival = 0; } +break; +case 43: +#line 237 "perly.y" +{ yyval.ival = 0; } +break; +case 44: +#line 239 "perly.y" +{ yyval.ival = 0; } +break; +case 45: +#line 243 "perly.y" +{ newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } +break; +case 46: +#line 245 "perly.y" +{ newFORM(yyvsp[-1].ival, Nullop, yyvsp[0].opval); } +break; +case 47: +#line 249 "perly.y" +{ newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); } +break; +case 48: +#line 251 "perly.y" +{ newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, Nullop); expect = XSTATE; } +break; +case 49: +#line 255 "perly.y" +{ yyval.opval = Nullop; } +break; +case 51: +#line 260 "perly.y" +{ yyval.ival = start_subparse(); } +break; +case 52: +#line 264 "perly.y" +{ package(yyvsp[-1].opval); } +break; +case 53: +#line 266 "perly.y" +{ package(Nullop); } +break; +case 54: +#line 270 "perly.y" +{ utilize(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval); } +break; +case 55: +#line 274 "perly.y" +{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } +break; +case 56: +#line 276 "perly.y" +{ yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); } +break; +case 57: +#line 278 "perly.y" +{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } +break; +case 59: +#line 283 "perly.y" +{ yyval.opval = yyvsp[-1].opval; } +break; +case 60: +#line 285 "perly.y" +{ yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); } +break; +case 62: +#line 290 "perly.y" +{ yyval.opval = convert(yyvsp[-2].ival, OPf_STACKED, + prepend_elem(OP_LIST, newGVREF(yyvsp[-2].ival,yyvsp[-1].opval), yyvsp[0].opval) ); } +break; +case 63: +#line 293 "perly.y" +{ yyval.opval = convert(yyvsp[-4].ival, OPf_STACKED, + prepend_elem(OP_LIST, newGVREF(yyvsp[-4].ival,yyvsp[-2].opval), yyvsp[-1].opval) ); } +break; +case 64: +#line 296 "perly.y" +{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, + prepend_elem(OP_LIST, yyvsp[-5].opval, yyvsp[-1].opval), + newUNOP(OP_METHOD, 0, yyvsp[-3].opval))); } +break; +case 65: +#line 301 "perly.y" +{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, + prepend_elem(OP_LIST, yyvsp[-1].opval, yyvsp[0].opval), + newUNOP(OP_METHOD, 0, yyvsp[-2].opval))); } +break; +case 66: +#line 306 "perly.y" +{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, + prepend_elem(OP_LIST, yyvsp[-3].opval, yyvsp[-1].opval), + newUNOP(OP_METHOD, 0, yyvsp[-4].opval))); } +break; +case 67: +#line 311 "perly.y" +{ yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); } +break; +case 68: +#line 313 "perly.y" +{ yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); } +break; +case 69: +#line 315 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, + prepend_elem(OP_LIST, newANONSUB(yyvsp[-2].ival, 0, yyvsp[-1].opval), yyvsp[0].opval), + yyvsp[-3].ival)); } +break; +case 72: +#line 326 "perly.y" +{ yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); } +break; +case 73: +#line 328 "perly.y" +{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } +break; +case 74: +#line 330 "perly.y" +{ if (yyvsp[-1].ival != OP_REPEAT) + scalar(yyvsp[-2].opval); + yyval.opval = newBINOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, scalar(yyvsp[0].opval)); } +break; +case 75: +#line 334 "perly.y" +{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } +break; +case 76: +#line 336 "perly.y" +{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } +break; +case 77: +#line 338 "perly.y" +{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } +break; +case 78: +#line 340 "perly.y" +{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } +break; +case 79: +#line 342 "perly.y" +{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } +break; +case 80: +#line 344 "perly.y" +{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } +break; +case 81: +#line 346 "perly.y" +{ yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));} +break; +case 82: +#line 348 "perly.y" +{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } +break; +case 83: +#line 350 "perly.y" +{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); } +break; +case 84: +#line 352 "perly.y" +{ yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); } +break; +case 85: +#line 354 "perly.y" +{ yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); } +break; +case 86: +#line 357 "perly.y" +{ yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); } +break; +case 87: +#line 359 "perly.y" +{ yyval.opval = yyvsp[0].opval; } +break; +case 88: +#line 361 "perly.y" +{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } +break; +case 89: +#line 363 "perly.y" +{ yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));} +break; +case 90: +#line 365 "perly.y" +{ yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); } +break; +case 91: +#line 367 "perly.y" +{ yyval.opval = newUNOP(OP_POSTINC, 0, + mod(scalar(yyvsp[-1].opval), OP_POSTINC)); } +break; +case 92: +#line 370 "perly.y" +{ yyval.opval = newUNOP(OP_POSTDEC, 0, + mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); } +break; +case 93: +#line 373 "perly.y" +{ yyval.opval = newUNOP(OP_PREINC, 0, + mod(scalar(yyvsp[0].opval), OP_PREINC)); } +break; +case 94: +#line 376 "perly.y" +{ yyval.opval = newUNOP(OP_PREDEC, 0, + mod(scalar(yyvsp[0].opval), OP_PREDEC)); } +break; +case 95: +#line 379 "perly.y" +{ yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); } +break; +case 96: +#line 381 "perly.y" +{ yyval.opval = sawparens(yyvsp[-1].opval); } +break; +case 97: +#line 383 "perly.y" +{ yyval.opval = sawparens(newNULLLIST()); } +break; +case 98: +#line 385 "perly.y" +{ yyval.opval = newANONLIST(yyvsp[-1].opval); } +break; +case 99: +#line 387 "perly.y" +{ yyval.opval = newANONLIST(Nullop); } +break; +case 100: +#line 389 "perly.y" +{ yyval.opval = newANONHASH(yyvsp[-2].opval); } +break; +case 101: +#line 391 "perly.y" +{ yyval.opval = newANONHASH(Nullop); } +break; +case 102: +#line 393 "perly.y" +{ yyval.opval = newANONSUB(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } +break; +case 103: +#line 395 "perly.y" +{ yyval.opval = yyvsp[0].opval; } +break; +case 104: +#line 397 "perly.y" +{ yyval.opval = yyvsp[0].opval; } +break; +case 105: +#line 399 "perly.y" +{ yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); } +break; +case 106: +#line 401 "perly.y" +{ yyval.opval = newBINOP(OP_AELEM, 0, + ref(newAVREF(yyvsp[-4].opval),OP_RV2AV), + scalar(yyvsp[-1].opval));} +break; +case 107: +#line 405 "perly.y" +{ assertref(yyvsp[-3].opval); yyval.opval = newBINOP(OP_AELEM, 0, + ref(newAVREF(yyvsp[-3].opval),OP_RV2AV), + scalar(yyvsp[-1].opval));} +break; +case 108: +#line 409 "perly.y" +{ yyval.opval = yyvsp[0].opval; } +break; +case 109: +#line 411 "perly.y" +{ yyval.opval = yyvsp[0].opval; } +break; +case 110: +#line 413 "perly.y" +{ yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));} +break; +case 111: +#line 415 "perly.y" +{ yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval)); + expect = XOPERATOR; } +break; +case 112: +#line 418 "perly.y" +{ yyval.opval = newBINOP(OP_HELEM, 0, + ref(newHVREF(yyvsp[-5].opval),OP_RV2HV), + jmaybe(yyvsp[-2].opval)); + expect = XOPERATOR; } +break; +case 113: +#line 423 "perly.y" +{ assertref(yyvsp[-4].opval); yyval.opval = newBINOP(OP_HELEM, 0, + ref(newHVREF(yyvsp[-4].opval),OP_RV2HV), + jmaybe(yyvsp[-2].opval)); + expect = XOPERATOR; } +break; +case 114: +#line 428 "perly.y" +{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); } +break; +case 115: +#line 430 "perly.y" +{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); } +break; +case 116: +#line 432 "perly.y" +{ yyval.opval = prepend_elem(OP_ASLICE, + newOP(OP_PUSHMARK, 0), + newLISTOP(OP_ASLICE, 0, + list(yyvsp[-1].opval), + ref(yyvsp[-3].opval, OP_ASLICE))); } +break; +case 117: +#line 438 "perly.y" +{ yyval.opval = prepend_elem(OP_HSLICE, + newOP(OP_PUSHMARK, 0), + newLISTOP(OP_HSLICE, 0, + list(yyvsp[-2].opval), + ref(oopsHV(yyvsp[-4].opval), OP_HSLICE))); + expect = XOPERATOR; } +break; +case 118: +#line 445 "perly.y" +{ yyval.opval = yyvsp[0].opval; } +break; +case 119: +#line 447 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, 0, + scalar(yyvsp[0].opval)); } +break; +case 120: +#line 450 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); } +break; +case 121: +#line 452 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval))); } +break; +case 122: +#line 455 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, + yyvsp[0].opval, newCVREF(scalar(yyvsp[-1].opval)))); } +break; +case 123: +#line 459 "perly.y" +{ yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); } +break; +case 124: +#line 461 "perly.y" +{ yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); } +break; +case 125: +#line 463 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, + prepend_elem(OP_LIST, + scalar(newCVREF(scalar(yyvsp[-2].opval))), Nullop)); dep();} +break; +case 126: +#line 467 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, + append_elem(OP_LIST, + yyvsp[-1].opval, + scalar(newCVREF(scalar(yyvsp[-3].opval))))); dep();} +break; +case 127: +#line 472 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, + prepend_elem(OP_LIST, + scalar(newCVREF(scalar(yyvsp[-2].opval))), Nullop)); dep();} +break; +case 128: +#line 476 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, + prepend_elem(OP_LIST, + yyvsp[-1].opval, + scalar(newCVREF(scalar(yyvsp[-3].opval))))); dep();} +break; +case 129: +#line 481 "perly.y" +{ yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL); + hints |= HINT_BLOCK_SCOPE; } +break; +case 130: +#line 484 "perly.y" +{ yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); } +break; +case 131: +#line 486 "perly.y" +{ yyval.opval = newOP(yyvsp[0].ival, 0); } +break; +case 132: +#line 488 "perly.y" +{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } +break; +case 133: +#line 490 "perly.y" +{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } +break; +case 134: +#line 492 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].ival))); } +break; +case 135: +#line 495 "perly.y" +{ yyval.opval = newOP(yyvsp[0].ival, 0); } +break; +case 136: +#line 497 "perly.y" +{ yyval.opval = newOP(yyvsp[-2].ival, 0); } +break; +case 137: +#line 499 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, 0, + scalar(yyvsp[0].ival)); } +break; +case 138: +#line 502 "perly.y" +{ yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); } +break; +case 139: +#line 504 "perly.y" +{ yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); } +break; +case 140: +#line 506 "perly.y" +{ yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); } +break; +case 141: +#line 508 "perly.y" +{ yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); } +break; +case 144: +#line 514 "perly.y" +{ yyval.opval = Nullop; } +break; +case 145: +#line 516 "perly.y" +{ yyval.opval = yyvsp[0].opval; } +break; +case 146: +#line 520 "perly.y" +{ yyval.opval = Nullop; } +break; +case 147: +#line 522 "perly.y" +{ yyval.opval = yyvsp[0].opval; } +break; +case 148: +#line 524 "perly.y" +{ yyval.opval = yyvsp[-1].opval; } +break; +case 149: +#line 528 "perly.y" +{ yyval.opval = newCVREF(yyvsp[0].opval); } +break; +case 150: +#line 532 "perly.y" +{ yyval.opval = newSVREF(yyvsp[0].opval); } +break; +case 151: +#line 536 "perly.y" +{ yyval.opval = newAVREF(yyvsp[0].opval); } +break; +case 152: +#line 540 "perly.y" +{ yyval.opval = newHVREF(yyvsp[0].opval); } +break; +case 153: +#line 544 "perly.y" +{ yyval.opval = newAVREF(yyvsp[0].opval); } +break; +case 154: +#line 548 "perly.y" +{ yyval.opval = newGVREF(0,yyvsp[0].opval); } +break; +case 155: +#line 552 "perly.y" +{ yyval.opval = scalar(yyvsp[0].opval); } +break; +case 156: +#line 554 "perly.y" +{ yyval.opval = scalar(yyvsp[0].opval); } +break; +case 157: +#line 556 "perly.y" +{ yyval.opval = scope(yyvsp[0].opval); } +break; +case 158: +#line 559 "perly.y" +{ yyval.opval = yyvsp[0].opval; } +break; +#line 2139 "y.tab.c" + } + yyssp -= yym; + yystate = *yyssp; + yyvsp -= yym; + yym = yylhs[yyn]; + if (yystate == 0 && yym == 0) + { +#if YYDEBUG + if (yydebug) + fprintf(stderr, + "yydebug: after reduction, shifting from state 0 to state %d\n", + YYFINAL); +#endif + yystate = YYFINAL; + *++yyssp = YYFINAL; + *++yyvsp = yyval; + if (yychar < 0) + { + if ((yychar = yylex()) < 0) yychar = 0; +#if YYDEBUG + if (yydebug) + { + yys = 0; + if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; + if (!yys) yys = "illegal-symbol"; + fprintf(stderr, "yydebug: state %d, reading %d (%s)\n", + YYFINAL, yychar, yys); + } +#endif + } + if (yychar == 0) goto yyaccept; + goto yyloop; + } + if ((yyn = yygindex[yym]) && (yyn += yystate) >= 0 && + yyn <= YYTABLESIZE && yycheck[yyn] == yystate) + yystate = yytable[yyn]; + else + yystate = yydgoto[yym]; +#if YYDEBUG + if (yydebug) + fprintf(stderr, + "yydebug: after reduction, shifting from state %d to state %d\n", + *yyssp, yystate); +#endif + if (yyssp >= yyss + yystacksize - 1) + { + /* + ** reallocate and recover. Note that pointers + ** have to be reset, or bad things will happen + */ + int yyps_index = (yyssp - yyss); + int yypv_index = (yyvsp - yyvs); + yystacksize += YYSTACKSIZE; + ysave->yyvs = yyvs = + (YYSTYPE*)realloc((char*)yyvs,yystacksize * sizeof(YYSTYPE)); + ysave->yyss = yyss = + (short*)realloc((char*)yyss,yystacksize * sizeof(short)); + if (!yyvs || !yyss) + goto yyoverflow; + yyssp = yyss + yyps_index; + yyvsp = yyvs + yypv_index; + } + *++yyssp = yystate; + *++yyvsp = yyval; + goto yyloop; +yyoverflow: + yyerror("Out of memory for yacc stack"); +yyabort: + retval = 1; +yyaccept: + return retval; +} diff --git a/vms/perly_h.vms b/vms/perly_h.vms new file mode 100644 index 0000000000..17a3769ef4 --- /dev/null +++ b/vms/perly_h.vms @@ -0,0 +1,68 @@ +#define WORD 257 +#define METHOD 258 +#define FUNCMETH 259 +#define THING 260 +#define PMFUNC 261 +#define PRIVATEREF 262 +#define LABEL 263 +#define FORMAT 264 +#define SUB 265 +#define ANONSUB 266 +#define PACKAGE 267 +#define USE 268 +#define WHILE 269 +#define UNTIL 270 +#define IF 271 +#define UNLESS 272 +#define ELSE 273 +#define ELSIF 274 +#define CONTINUE 275 +#define FOR 276 +#define LOOPEX 277 +#define DOTDOT 278 +#define FUNC0 279 +#define FUNC1 280 +#define FUNC 281 +#define FUNC0SUB 282 +#define RELOP 283 +#define EQOP 284 +#define MULOP 285 +#define ADDOP 286 +#define DOLSHARP 287 +#define DO 288 +#define LOCAL 289 +#define HASHBRACK 290 +#define NOAMP 291 +#define OROP 292 +#define ANDOP 293 +#define NOTOP 294 +#define LSTOP 295 +#define LSTOPSUB 296 +#define ASSIGNOP 297 +#define OROR 298 +#define ANDAND 299 +#define BITOROP 300 +#define BITANDOP 301 +#define UNIOP 302 +#define UNIOPSUB 303 +#define SHIFTOP 304 +#define MATCHOP 305 +#define UMINUS 306 +#define REFGEN 307 +#define POWOP 308 +#define PREINC 309 +#define PREDEC 310 +#define POSTINC 311 +#define POSTDEC 312 +#define ARROW 313 +typedef union { + I32 ival; + char *pval; + OP *opval; + GV *gvval; +} YYSTYPE; +#ifndef vax11c + extern YYSTYPE yylval; +#else + globalref YYSTYPE yylval; +#endif diff --git a/vms/sockadapt.c b/vms/sockadapt.c index 9867d536a1..69f5def785 100644 --- a/vms/sockadapt.c +++ b/vms/sockadapt.c @@ -1,7 +1,7 @@ /* sockadapt.c * * Author: Charles Bailey bailey@genetics.upenn.edu - * Last Revised: 08-Feb-1995 + * Last Revised: 17-Mar-1995 * * This file should contain stubs for any of the TCP/IP functions perl5 * requires which are not supported by your TCP/IP stack. These stubs @@ -11,22 +11,24 @@ * This version is set up for perl5 with socketshr 0.9D TCP/IP support. */ -#include "sockadapt.h" +#include "EXTERN.h" +#include "perl.h" -#ifdef __STDC__ -#define STRINGIFY(a) #a /* config-skip */ -#else -#define STRINGIFY(a) "a" /* config-skip */ -#endif - -#define FATALSTUB(func) \ - void func() {\ - croak("Function %s not implemented in this version of perl",\ - STRINGIFY(func));\ - } - -FATALSTUB(endnetent); -FATALSTUB(getnetbyaddr); -FATALSTUB(getnetbyname); -FATALSTUB(getnetent); -FATALSTUB(setnetent); +void endnetent() { + croak("Function \"endnetent\" not implemented in this version of perl"); +} +struct netent *getnetbyaddr( long net, int type) { + croak("Function \"getnetbyaddr\" not implemented in this version of perl"); + return (struct netent *)NULL; /* Avoid MISSINGRETURN warning, not reached */ +} +struct netent *getnetbyname( char *name) { + croak("Function \"getnetbyname\" not implemented in this version of perl"); + return (struct netent *)NULL; /* Avoid MISSINGRETURN warning, not reached */ +} +struct netent *getnetent() { + croak("Function \"getnetent\" not implemented in this version of perl"); + return (struct netent *)NULL; /* Avoid MISSINGRETURN warning, not reached */ +} +void setnetent() { + croak("Function \"setnetent\" not implemented in this version of perl"); +} diff --git a/vms/sockadapt.h b/vms/sockadapt.h index 0d56285750..18f4002f12 100644 --- a/vms/sockadapt.h +++ b/vms/sockadapt.h @@ -2,7 +2,7 @@ * * Authors: Charles Bailey bailey@genetics.upenn.edu * David Denholm denholm@conmat.phys.soton.ac.uk - * Last Revised: 24-Feb-1995 + * Last Revised: 17-Mar-1995 * * This file should include any other header files and procide any * declarations, typedefs, and prototypes needed by perl for TCP/IP @@ -11,7 +11,18 @@ * This version is set up for perl5 with socketshr 0.9D TCP/IP support. */ -#include +/* SocketShr doesn't support these routines, but the DECC RTL contains + * stubs with these names, designed to be used with the UCX socket + * library. We avoid linker collisions by substituting new names. + */ +#define getnetbyaddr no_getnetbyaddr +#define getnetbyname no_getnetbyname +#define getnetent no_getnetent +#define setnetent no_setnetent +#define endnetent no_endnetent + + +#ifdef __GNU_CC__ /* we may not have netdb.h etc, so lets just do this here - div */ /* no harm doing this for all .c files - needed only by pp_sys.c */ @@ -50,6 +61,16 @@ struct sockaddr { char sa_data[14]; /* up to 14 bytes of direct address */ }; +/* + * Socket address, internet style. + */ +struct sockaddr_in { + short sin_family; + unsigned short sin_port; + struct in_addr sin_addr; + char sin_zero[8]; +}; + struct timeval { long tv_sec; long tv_usec; @@ -61,3 +82,61 @@ struct netent { int n_addrtype; long n_net; }; + +/* Since socketshr.h won't declare function prototypes unless it thinks + * the system headers have already been included, we convince it that + * this is the case. + */ + +#ifndef AF_INET +# define AF_INET 2 +#endif +#ifndef IPPROTO_TCP +# define IPPROTO_TCP 6 +#endif +#ifndef __INET_LOADED +# define __INET_LOADED +#endif +#ifndef __NETDB_LOADED +# define __NETDB_LOADED +#endif + +/* Finally, we provide prototypes for routines not supported by SocketShr, + * so that the stubs in sockadapt.c won't cause complaints about + * undeclared routines. + */ + +struct netent *getnetbyaddr( long net, int type); +struct netent *getnetbyname( char *name); +struct netent *getnetent(); +void setnetent(); +void endnetent(); + +#else /* !__GNU_CC__ */ + +/* DECC and VAXC have socket headers in the system set; they're for UCX, but + * we'll assume that the actual calling sequence is identical across the + * various TCP/IP stacks; these routines are pretty standard. + */ +#include +#include +#include +#include +/* However, we don't have these two in the system headers. */ +void setnetent(); +void endnetent(); + +#endif + +#include +/* socketshr.h from SocketShr 0.9D doesn't alias fileno; it's comments say + * that the CRTL version works OK. This isn't the case, at least with + * VAXC, so we use the SocketShr version. + * N.B. This means that sockadapt.h must be included *after* stdio.h. + * This is presently the case for Perl. + */ +#ifdef fileno +# undef fileno +#endif +#define fileno si_fileno +int si_fileno(FILE *); diff --git a/vms/test.com b/vms/test.com index a23245057f..43034a5cc9 100644 --- a/vms/test.com +++ b/vms/test.com @@ -5,13 +5,7 @@ $! Charles Bailey bailey@genetics.upenn.edu $ $! A little basic setup $ On Error Then Goto wrapup -$ olddef = F$Environment("Default") -$ If F$TrnLNm("Perl_Root").nes."" -$ Then -$ Set Default Perl_Root:[t] -$ Else -$ Set Default [.t] -$ EndIf +$ Set Default [.t] $ $! Pick up a copy of perl to use for the tests $ Delete/Log/NoConfirm Perl.;* @@ -185,5 +179,5 @@ print sprintf("u=%g s=%g cu=%g cs=%g files=%d tests=%d\n", $$END-OF-TEST$$ $ wrapup: $ If F$Search("Echo.Exe").nes."" Then Delete/Log/NoConfirm Echo.Exe;* -$ Set Default &olddef +$ Set Default [-] $ Exit diff --git a/vms/vms.c b/vms/vms.c index fd4ec3a760..fef054ae4c 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -2,7 +2,8 @@ * * VMS-specific routines for perl5 * - * Last revised: 09-Mar-1995 by Charles Bailey bailey@genetics.upenn.edu + * Last revised: 5-Jun-1995 by Charles Bailey bailey@genetics.upenn.edu + * Version: 5.1.5 */ #include @@ -279,8 +280,21 @@ int my_utime(char *file, struct utimbuf *utimes) char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS]; struct FAB myfab = cc$rms_fab; struct NAM mynam = cc$rms_nam; +#if defined (__DECC) && defined (__VAX) + /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr, + * at least through VMS V6.1, which causes a type-conversion warning. + */ +# pragma message save +# pragma message disable cvtdiftypes +#endif struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}}; struct fibdef myfib; +#if defined (__DECC) && defined (__VAX) + /* This should be right after the declaration of myatr, but due + * to a bug in VAX DEC C, this takes effect a statement early. + */ +# pragma message restore +#endif struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib}, devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0}, fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0}; @@ -686,12 +700,22 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) dirlen -= 1; /* to last element */ lastdir = strrchr(dir,'/'); } - else if (strstr(trndir,"..") != NULL) { - /* If we have a relative path, let do_tovmsspec figure it out, - * rather than repeating the code here */ - if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL; - if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL; - return do_tounixspec(trndir,buf,ts); + else if ((cp1 = strstr(trndir,"/.")) != NULL) { + do { + if (*(cp1+2) == '.') cp1++; + if (*(cp1+2) == '/' || *(cp1+2) == '\0') { + addmfd = 1; + break; + } + cp1++; + } while ((cp1 = strstr(cp1,"/.")) != NULL); + /* If we have a relative path, VMSify it and let the VMS code + * below expand it, rather than repeating the code here */ + if (addmfd) { + if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL; + if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL; + return do_tounixspec(trndir,buf,ts); + } } else { if (!(lastdir = cp1 = strrchr(dir,'/'))) cp1 = dir; @@ -726,7 +750,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) } } } - retlen = dirlen + addmfd ? 13 : 6; + retlen = dirlen + (addmfd ? 13 : 6); if (buf) retspec = buf; else if (ts) New(7009,retspec,retlen+6,char); else retspec = __fileify_retbuf; @@ -827,22 +851,30 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) } retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */ if (buf) retspec = buf; - else if (ts) New(7012,retspec,retlen+7,char); + else if (ts) New(7012,retspec,retlen+14,char); else retspec = __fileify_retbuf; cp1 = strstr(esa,"]["); dirlen = cp1 - esa; memcpy(retspec,esa,dirlen); if (!strncmp(cp1+2,"000000]",7)) { retspec[dirlen-1] = '\0'; - for (cp1 = retspec+dirlen-1; *cp1 != '.'; cp1--) ; - *cp1 = ']'; + for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ; + if (*cp1 == '.') *cp1 = ']'; + else { + memmove(cp1+8,cp1+1,retspec+dirlen-cp1); + memcpy(cp1+1,"000000]",7); + } } else { memcpy(retspec+dirlen,cp1+2,retlen-dirlen); retspec[retlen] = '\0'; /* Convert last '.' to ']' */ - for (cp1 = retspec+retlen-1; *cp1 != '.'; cp1--) ; - *cp1 = ']'; + for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ; + if (*cp1 == '.') *cp1 = ']'; + else { + memmove(cp1+8,cp1+1,retspec+dirlen-cp1); + memcpy(cp1+1,"000000]",7); + } } } else { /* This is a top-level dir. Add the MFD to the path. */ @@ -1146,13 +1178,18 @@ static char *do_tovmsspec(char *path, char *buf, int ts) { infront = 0; } else if (!infront && *cp2 == '.') { - if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */ + if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */ + else if (*(cp2+1) == '\0') { cp2++; break; } else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) { if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */ else if (*(cp1-2) == '[') *(cp1-1) = '-'; else { /* back up over previous directory name */ cp1--; while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--; + if (*(cp1-1) == '[') { + memcpy(cp1,"000000.",7); + cp1 += 7; + } } cp2 += 2; if (cp2 == dirend) { @@ -1922,11 +1959,29 @@ readdir(DIR *dd) res.dsc$w_length = sizeof buff - 2; res.dsc$b_dtype = DSC$K_DTYPE_T; res.dsc$b_class = DSC$K_CLASS_S; - dd->count++; tmpsts = lib$find_file(&dd->pat, &res, &dd->context); - if ( tmpsts == RMS$_NMF || tmpsts == RMS$_FNF || - dd->context == 0) return NULL; /* None left. */ - + if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */ + if (!(tmpsts & 1)) { + set_vaxc_errno(tmpsts); + switch (tmpsts) { + case RMS$_PRV: + set_errno(EACCES); + break; + case RMS$_DEV: + set_errno(ENODEV); + break; + case RMS$_DIR: + set_errno(ENOTDIR); + break; + case RMS$_FNF: + set_errno(ENOENT); + break; + default: + set_errno(EVMSERR); + } + return NULL; + } + dd->count++; /* Force the buffer to end with a NUL, and downcase name to match C convention. */ buff[sizeof buff - 1] = '\0'; for (p = buff; !isspace(*p); p++) *p = _tolower(*p); @@ -2027,19 +2082,37 @@ my_vfork() } /*}}}*/ + +static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch}; + static void -setup_argstr(SV *really, SV **mark, SV **sp, char **argstr) +vms_execfree() { + if (Cmd) { + safefree(Cmd); + Cmd = Nullch; + } + if (VMScmd.dsc$a_pointer) { + Safefree(VMScmd.dsc$a_pointer); + VMScmd.dsc$w_length = 0; + VMScmd.dsc$a_pointer = Nullch; + } +} + +static char * +setup_argstr(SV *really, SV **mark, SV **sp) { - char *tmps, *junk; + char *junk, *tmps = Nullch; register size_t cmdlen = 0; size_t rlen; register SV **idx; idx = mark; - tmps = SvPV(really,rlen); - if (really && *tmps) { - cmdlen += rlen + 1; - idx++; + if (really) { + tmps = SvPV(really,rlen); + if (*tmps) { + cmdlen += rlen + 1; + idx++; + } } for (idx++; idx <= sp; idx++) { @@ -2048,24 +2121,26 @@ setup_argstr(SV *really, SV **mark, SV **sp, char **argstr) cmdlen += rlen ? rlen + 1 : 0; } } - New(401,*argstr,cmdlen, char); + New(401,Cmd,cmdlen,char); - if (*tmps) { - strcpy(*argstr,tmps); + if (tmps && *tmps) { + strcpy(Cmd,tmps); mark++; } - else **argstr = '\0'; + else *Cmd = '\0'; while (++mark <= sp) { if (*mark) { - strcat(*argstr," "); - strcat(*argstr,SvPVx(*mark,na)); + strcat(Cmd," "); + strcat(Cmd,SvPVx(*mark,na)); } } + return Cmd; } /* end of setup_argstr() */ + static unsigned long int -setup_cmddsc(char *cmd, struct dsc$descriptor_s *cmddsc, int check_img) +setup_cmddsc(char *cmd, int check_img) { char resspec[NAM$C_MAXRSS+1]; $DESCRIPTOR(defdsc,".EXE"); @@ -2090,8 +2165,9 @@ setup_cmddsc(char *cmd, struct dsc$descriptor_s *cmddsc, int check_img) } else isdcl = 1; if (isdcl) { /* It's a DCL command, just do it. */ - cmddsc->dsc$a_pointer = cmd; - cmddsc->dsc$w_length = strlen(cmd); + VMScmd.dsc$a_pointer = cmd; + VMScmd.dsc$w_length = strlen(cmd); + if (cmd == Cmd) Cmd = Nullch; /* clear Cmd so vms_execfree isok */ } else { /* assume first token is an image spec */ cmd = s; @@ -2100,19 +2176,23 @@ setup_cmddsc(char *cmd, struct dsc$descriptor_s *cmddsc, int check_img) imgdsc.dsc$a_pointer = cmd; imgdsc.dsc$w_length = s - cmd; retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags); - if ((retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts; + if (!(retsts & 1)) { + /* just hand off status values likely to be due to user error */ + if (retsts == RMS$_FNF || retsts == RMS$_DNF || + retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN || + (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts; + else { _ckvmssts(retsts); } + } else { - _ckvmssts(retsts); _ckvmssts(lib$find_file_end(&cxt)); s = resspec; while (*s && !isspace(*s)) s++; *s = '\0'; - New(402,Cmd,6 + s - resspec + (rest ? strlen(rest) : 0),char); - strcpy(Cmd,"$ MCR "); - strcat(Cmd,resspec); - if (rest) strcat(Cmd,rest); - cmddsc->dsc$a_pointer = Cmd; - cmddsc->dsc$w_length = strlen(Cmd); + New(402,VMScmd.dsc$a_pointer,6 + s - resspec + (rest ? strlen(rest) : 0),char); + strcpy(VMScmd.dsc$a_pointer,"$ MCR "); + strcat(VMScmd.dsc$a_pointer,resspec); + if (rest) strcat(VMScmd.dsc$a_pointer,rest); + VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer); } } @@ -2123,7 +2203,6 @@ setup_cmddsc(char *cmd, struct dsc$descriptor_s *cmddsc, int check_img) bool vms_do_aexec(SV *really,SV **mark,SV **sp) { - if (sp > mark) { if (vfork_called) { /* this follows a vfork - act Unixish */ vfork_called--; @@ -2133,10 +2212,9 @@ vms_do_aexec(SV *really,SV **mark,SV **sp) } else return do_aexec(really,mark,sp); } + /* no vfork - act VMSish */ + return vms_do_exec(setup_argstr(really,mark,sp)); - /* no vfork - act VMSish */ - setup_argstr(really,mark,sp,Argv); - return vms_do_exec(*Argv); } return FALSE; @@ -2158,17 +2236,16 @@ vms_do_exec(char *cmd) } { /* no vfork - act VMSish */ - struct dsc$descriptor_s cmddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; unsigned long int retsts; - if ((retsts = setup_cmddsc(cmd,&cmddsc,1)) & 1) - retsts = lib$do_command(&cmddsc); + if ((retsts = setup_cmddsc(cmd,1)) & 1) + retsts = lib$do_command(&VMScmd); set_errno(EVMSERR); set_vaxc_errno(retsts); if (dowarn) - warn("Can't exec \"%s\": %s", cmddsc.dsc$a_pointer, Strerror(errno)); - do_execfree(); + warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno)); + vms_execfree(); } return FALSE; @@ -2182,11 +2259,7 @@ unsigned long int do_spawn(char *); unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) { - - if (sp > mark) { - setup_argstr(really,mark,sp,Argv); - return do_spawn(*Argv); - } + if (sp > mark) return do_spawn(setup_argstr(really,mark,sp)); return SS$_ABORT; } /* end of do_aspawn() */ @@ -2196,14 +2269,14 @@ do_aspawn(SV *really,SV **mark,SV **sp) unsigned long int do_spawn(char *cmd) { - struct dsc$descriptor_s cmddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; - unsigned long int substs; + unsigned long int substs, hadcmd = 1; if (!cmd || !*cmd) { - _ckvmssts(lib$spawn(0,0,0,0,0,&substs,0,0,0,0,0)); + hadcmd = 0; + _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0)); } - else if ((substs = setup_cmddsc(cmd,&cmddsc,0)) & 1) { - _ckvmssts(lib$spawn(&cmddsc,0,0,0,0,&substs,0,0,0,0,0)); + else if ((substs = setup_cmddsc(cmd,0)) & 1) { + _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0)); } if (!(substs&1)) { @@ -2211,8 +2284,9 @@ do_spawn(char *cmd) set_vaxc_errno(substs); if (dowarn) warn("Can't exec \"%s\": %s", - (cmd && *cmd) ? cmddsc.dsc$a_pointer : "", Strerror(errno)); + hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno)); } + vms_execfree(); return substs; } /* end of do_spawn() */ @@ -2292,8 +2366,8 @@ my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest) (uic).uic$v_member != UIC$K_WILD_MEMBER && \ (uic).uic$v_group != UIC$K_WILD_GROUP) -static const char __empty[]= ""; -static const struct passwd __passwd_empty= +static char __empty[]= ""; +static struct passwd __passwd_empty= {(char *) __empty, (char *) __empty, 0, 0, (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty}; static int contxt= 0; @@ -2334,7 +2408,7 @@ static int fillpasswd (const char *name, struct passwd *pwd) struct dsc$descriptor_s name_desc; int status; - static const struct itmlst_3 itmlst[]= { + static struct itmlst_3 itmlst[]= { {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner}, {sizeof(uic), UAI$_UIC, &uic, &luic}, {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev}, diff --git a/vms/vms_yfix.pl b/vms/vms_yfix.pl new file mode 100644 index 0000000000..323a40d792 --- /dev/null +++ b/vms/vms_yfix.pl @@ -0,0 +1,47 @@ +# This script takes the output produced from perly.y by byacc and +# the perly.fixer shell script (i.e. the perly.c and perly.h built +# for Unix systems) and patches them to produce copies containing +# appropriate declarations for VMS handling of global symbols. +# +# If it finds that the input files are already patches for VMS, +# it just copies the input to the output. +# +# Revised 26-May-1995 by Charles Bailey bailey@genetics.upenn.edu + +($cinfile,$hinfile,$coutfile,$houtfile) = @ARGV; + +open C,$cinfile or die "Can't read $cinfile: $!\n"; +open COUT, ">$coutfile" or die "Can't create $coutfile: $!\n"; +while () { + if (/^dEXT/) { # we've already got a fixed copy + print COUT $_,; + last; + } + # add the dEXT tag to definitions of global vars, so we'll insert + # a globaldef when perly.c is compiled + s/^(short|int|YYSTYPE|char \*)\s*yy/dEXT $1 yy/; + print COUT; +} +close C; +close COUT; + +open H,$hinfile or die "Can't read $hinfile: $!\n"; +open HOUT, ">$houtfile" or die "Can't create $houtfile: $!\n"; +$hfixed = 0; # keep -w happy +while () { + $hfixed = /globalref/ unless $hfixed; # we've already got a fixed copy + next if /^extern YYSTYPE yylval/; # we've got a Unix version, and this + # is what we want to replace + print HOUT; +} +close H; + +print HOUT <<'EODECL' unless $hfixed; +#ifndef vax11c + extern YYSTYPE yylval; +#else + globalref YYSTYPE yylval; +#endif +EODECL + +close HOUT; diff --git a/vms/vmsish.h b/vms/vmsish.h index ce6829060e..5e2bfbb13b 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -13,6 +13,15 @@ #include /* at which errno and vaxc$errno are */ #include /* explicitly set in the perl source code */ +/* Suppress compiler warnings from DECC for VMS-specific extensions: + * GLOBALEXT, NOSHAREEXT: global[dr]ef declarations + * ADDRCONSTEXT: initialization of data with non-constant values + * (e.g. pointer fields of descriptors) + */ +#ifdef __DECC +# pragma message disable (GLOBALEXT,NOSHAREEXT,ADDRCONSTEXT) +#endif + /* DEC's C compilers and gcc use incompatible definitions of _to(upp|low)er() */ #ifdef _toupper # undef _toupper @@ -22,6 +31,14 @@ # undef _tolower #endif #define _tolower(c) (((c) < 'A' || (c) > 'Z') ? (c) : (c) | 040) +/* DECC 1.3 has a funny definition of abs; it's fixed in DECC 4.0, so this + * can go away once DECC 1.3 isn't in use any more. */ +#if defined(__ALPHA) && defined(__DECC) +#undef abs +#define abs(__x) __ABS(__x) +#undef labs +#define labs(__x) __LABS(__x) +#endif /* __ALPHA && __DECC */ /* Assorted things to look like Unix */ #ifdef __GNUC__ diff --git a/writemain.SH b/writemain.SH index 2cd4704f08..c70ac20709 100644 --- a/writemain.SH +++ b/writemain.SH @@ -51,6 +51,26 @@ done sed '/Do not delete this line--writemain depends on it/q' miniperlmain.c + + +if test X"$args" != "X" ; then + for ext in $args ; do +: $ext will either be 'Name' or 'Name1/Name2' etc +: convert ext into cname and mname +mname=`echo $ext | sed 's!/!::!g'` +cname=`echo $mname | sed 's!:!_!g'` + +echo "EXTERN_C void boot_${cname} _((CV* cv));" + done +fi + +cat << 'EOP' + +static void +xs_init() +{ +EOP + if test X"$args" != "X" ; then echo " char *file = __FILE__;" ai='' @@ -62,7 +82,7 @@ if test X"$args" != "X" ; then mname=`echo $ext | sed 's!/!::!g'` cname=`echo $mname | sed 's!:!_!g'` - echo " { extern void boot_${cname} _((CV* cv));" + echo " {" if test "$ext" = "DynaLoader"; then : Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'! : boot_DynaLoader is called directly in DynaLoader.pm diff --git a/x2p/Makefile.SH b/x2p/Makefile.SH index bb26d4e5e4..d34caea22f 100755 --- a/x2p/Makefile.SH +++ b/x2p/Makefile.SH @@ -48,9 +48,13 @@ manpages = a2p.man s2p.man util = -sh = Makefile.SH cflags.SH find2perl.SH s2p.SH +sh = Makefile.SH cflags.SH +shextract = Makefile cflags -addedbyconf = Makefile cflags find2perl s2p +pl = find2perl.PL s2p.PL +plextract = find2perl s2p + +addedbyconf = $(shextract) $(plextract) h = EXTERN.h INTERN.h ../config.h handy.h hash.h a2p.h str.h util.h @@ -116,6 +120,11 @@ hlist: shlist: echo $(sh) | tr ' ' '\012' >.shlist +# These should be automatically generated + +$(plextract): + ../miniperl -I../lib $@.PL + malloc.c: ../malloc.c rm -f malloc.c sed <../malloc.c >malloc.c \ diff --git a/x2p/a2p.h b/x2p/a2p.h index 0f5a7edaff..77d55ced7a 100644 --- a/x2p/a2p.h +++ b/x2p/a2p.h @@ -79,6 +79,18 @@ # endif #endif +#ifdef DOSISH +# if defined(OS2) +# include "../os2ish.h" +# else +# include "../dosish.h" +# endif +#else +# if defined(VMS) +# include "../vmsish.h" +# endif +#endif + #ifndef STANDARD_C /* All of these are in stdlib.h or time.h for ANSI C */ Time_t time(); diff --git a/x2p/cflags.SH b/x2p/cflags.SH index e20c3a478b..531ef65805 100755 --- a/x2p/cflags.SH +++ b/x2p/cflags.SH @@ -49,7 +49,7 @@ case $# in 0) set *.c; echo "The current C flags are:" ;; esac -set `echo "$* " | sed 's/\.[oc] / /g'` +set `echo "$* " | sed -e 's/\.[oc] / /g' -e 's/\.obj / /g'` for file do diff --git a/x2p/find2perl.PL b/x2p/find2perl.PL new file mode 100644 index 0000000000..785ffa63ca --- /dev/null +++ b/x2p/find2perl.PL @@ -0,0 +1,607 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir(dirname($0)); +($file = basename($0)) =~ s/\.PL$//; +$file =~ s/\.pl$// + if ($Config{'osname'} eq 'VMS' or + $Config{'osname'} eq 'OS2'); # "case-forgiving" + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{'startperl'} + eval 'exec perl -S \$0 "\$@"' + if 0; +\$startperl = $Config{startperl}; +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; +# +# Modified September 26, 1993 to provide proper handling of years after 1999 +# Tom Link +# University of Pittsburgh + +while ($ARGV[0] =~ /^[^-!(]/) { + push(@roots, shift); +} +@roots = ('.') unless @roots; +for (@roots) { $_ = "e($_); } +$roots = join(',', @roots); + +$indent = 1; + +while (@ARGV) { + $_ = shift; + s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n"; + if ($_ eq '(') { + $out .= &tab . "(\n"; + $indent++; + next; + } + elsif ($_ eq ')') { + $indent--; + $out .= &tab . ")"; + } + elsif ($_ eq '!') { + $out .= &tab . "!"; + next; + } + elsif ($_ eq 'name') { + $out .= &tab; + $pat = &fileglob_to_re(shift); + $out .= '/' . $pat . "/"; + } + elsif ($_ eq 'perm') { + $onum = shift; + die "Malformed -perm argument: $onum\n" unless $onum =~ /^-?[0-7]+$/; + if ($onum =~ s/^-//) { + $onum = '0' . sprintf("%o", oct($onum) & 017777); # s/b 07777 ? + $out .= &tab . "((\$mode & $onum) == $onum)"; + } + else { + $onum = '0' . $onum unless $onum =~ /^0/; + $out .= &tab . "((\$mode & 0777) == $onum)"; + } + } + elsif ($_ eq 'type') { + ($filetest = shift) =~ tr/s/S/; + $out .= &tab . "-$filetest _"; + } + elsif ($_ eq 'print') { + $out .= &tab . 'print("$name\n")'; + } + elsif ($_ eq 'print0') { + $out .= &tab . 'print("$name\0")'; + } + elsif ($_ eq 'fstype') { + $out .= &tab; + $type = shift; + if ($type eq 'nfs') + { $out .= '($dev < 0)'; } + else + { $out .= '($dev >= 0)'; } + } + elsif ($_ eq 'user') { + $uname = shift; + $out .= &tab . "(\$uid == \$uid{'$uname'})"; + $inituser++; + } + elsif ($_ eq 'group') { + $gname = shift; + $out .= &tab . "(\$gid == \$gid{'$gname'})"; + $initgroup++; + } + elsif ($_ eq 'nouser') { + $out .= &tab . '!defined $uid{$uid}'; + $inituser++; + } + elsif ($_ eq 'nogroup') { + $out .= &tab . '!defined $gid{$gid}'; + $initgroup++; + } + elsif ($_ eq 'links') { + $out .= &tab . '($nlink ' . &n(shift); + } + elsif ($_ eq 'inum') { + $out .= &tab . '($ino ' . &n(shift); + } + elsif ($_ eq 'size') { + $out .= &tab . '(int(((-s _) + 511) / 512) ' . &n(shift); + } + elsif ($_ eq 'atime') { + $out .= &tab . '(int(-A _) ' . &n(shift); + } + elsif ($_ eq 'mtime') { + $out .= &tab . '(int(-M _) ' . &n(shift); + } + elsif ($_ eq 'ctime') { + $out .= &tab . '(int(-C _) ' . &n(shift); + } + elsif ($_ eq 'exec') { + for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { } + shift; + $_ = "@cmd"; + if (m#^(/bin/)?rm -f {}$#) { + if (!@ARGV) { + $out .= &tab . 'unlink($_)'; + } + else { + $out .= &tab . '(unlink($_) || 1)'; + } + } + elsif (m#^(/bin/)?rm {}$#) { + $out .= &tab . '(unlink($_) || warn "$name: $!\n")'; + } + else { + for (@cmd) { s/'/\\'/g; } + $" = "','"; + $out .= &tab . "&exec(0, '@cmd')"; + $" = ' '; + $initexec++; + } + } + elsif ($_ eq 'ok') { + for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { } + shift; + for (@cmd) { s/'/\\'/g; } + $" = "','"; + $out .= &tab . "&exec(1, '@cmd')"; + $" = ' '; + $initexec++; + } + elsif ($_ eq 'prune') { + $out .= &tab . '($prune = 1)'; + } + elsif ($_ eq 'xdev') { + $out .= &tab . '!($prune |= ($dev != $topdev))'; + } + elsif ($_ eq 'newer') { + $out .= &tab; + $file = shift; + $newername = 'AGE_OF' . $file; + $newername =~ s/[^\w]/_/g; + $newername = '$' . $newername; + $out .= "(-M _ < $newername)"; + $initnewer .= "$newername = -M " . "e($file) . ";\n"; + } + elsif ($_ eq 'eval') { + $prog = "e(shift); + $out .= &tab . "eval $prog"; + } + elsif ($_ eq 'depth') { + $depth++; + next; + } + elsif ($_ eq 'ls') { + $out .= &tab . "&ls"; + $initls++; + } + elsif ($_ eq 'tar') { + $out .= &tab; + die "-tar must have a filename argument\n" unless @ARGV; + $file = shift; + $fh = 'FH' . $file; + $fh =~ s/[^\w]/_/g; + $out .= "&tar($fh)"; + $file = '>' . $file; + $initfile .= "open($fh, " . "e($file) . + qq{) || die "Can't open $fh: \$!\\n";\n}; + $inittar++; + $flushall = "\n&tflushall;\n"; + } + elsif (/^n?cpio$/) { + $depth++; + $out .= &tab; + die "-$_ must have a filename argument\n" unless @ARGV; + $file = shift; + $fh = 'FH' . $file; + $fh =~ s/[^\w]/_/g; + $out .= "&cpio('" . substr($_,0,1) . "', $fh)"; + $file = '>' . $file; + $initfile .= "open($fh, " . "e($file) . + qq{) || die "Can't open $fh: \$!\\n";\n}; + $initcpio++; + $flushall = "\n&flushall;\n"; + } + else { + die "Unrecognized switch: -$_\n"; + } + if (@ARGV) { + if ($ARGV[0] eq '-o') { + { local($statdone) = 1; $out .= "\n" . &tab . "||\n"; } + $statdone = 0 if $indent == 1 && $delayedstat; + $saw_or++; + shift; + } + else { + $out .= " &&" unless $ARGV[0] eq ')'; + $out .= "\n"; + shift if $ARGV[0] eq '-a'; + } + } +} + +print <<"END"; +$startperl + +eval 'exec perl -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; + +END + +if ($initls) { + print <<'END'; +@rwx = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx'); +@moname = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec); + +END +} + +if ($inituser || $initls) { + print 'while (($name, $pw, $uid) = getpwent) {', "\n"; + print ' $uid{$name} = $uid{$uid} = $uid;', "\n" if $inituser; + print ' $user{$uid} = $name unless $user{$uid};', "\n" if $initls; + print "}\n\n"; +} + +if ($initgroup || $initls) { + print 'while (($name, $pw, $gid) = getgrent) {', "\n"; + print ' $gid{$name} = $gid{$gid} = $gid;', "\n" if $initgroup; + print ' $group{$gid} = $name unless $group{$gid};', "\n" if $initls; + print "}\n\n"; +} + +print $initnewer, "\n" if $initnewer; + +print $initfile, "\n" if $initfile; + +$find = $depth ? "finddepth" : "find"; +print <<"END"; +require "$find.pl"; + +# Traverse desired filesystems + +&$find($roots); +$flushall +exit; + +sub wanted { +$out; +} + +END + +if ($initexec) { + print <<'END'; +sub exec { + local($ok, @cmd) = @_; + foreach $word (@cmd) { + $word =~ s#{}#$name#g; + } + if ($ok) { + local($old) = select(STDOUT); + $| = 1; + print "@cmd"; + select($old); + return 0 unless =~ /^y/; + } + chdir $cwd; # sigh + system @cmd; + chdir $dir; + return !$?; +} + +END +} + +if ($initls) { + print <<'END'; +sub ls { + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm, + $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_); + + $pname = $name; + + if (defined $blocks) { + $blocks = int(($blocks + 1) / 2); + } + else { + $blocks = int(($size + 1023) / 1024); + } + + if (-f _) { $perms = '-'; } + elsif (-d _) { $perms = 'd'; } + elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; } + elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; } + elsif (-p _) { $perms = 'p'; } + elsif (-S _) { $perms = 's'; } + else { $perms = 'l'; $pname .= ' -> ' . readlink($_); } + + $tmpmode = $mode; + $tmp = $rwx[$tmpmode & 7]; + $tmpmode >>= 3; + $tmp = $rwx[$tmpmode & 7] . $tmp; + $tmpmode >>= 3; + $tmp = $rwx[$tmpmode & 7] . $tmp; + substr($tmp,2,1) =~ tr/-x/Ss/ if -u _; + substr($tmp,5,1) =~ tr/-x/Ss/ if -g _; + substr($tmp,8,1) =~ tr/-x/Tt/ if -k _; + $perms .= $tmp; + + $user = $user{$uid} || $uid; + $group = $group{$gid} || $gid; + + ($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime); + $moname = $moname[$mon]; + if (-M _ > 365.25 / 2) { + $timeyear = $year + 1900; + } + else { + $timeyear = sprintf("%02d:%02d", $hour, $min); + } + + printf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n", + $ino, + $blocks, + $perms, + $nlink, + $user, + $group, + $sizemm, + $moname, + $mday, + $timeyear, + $pname; + 1; +} + +sub sizemm { + sprintf("%3d, %3d", ($rdev >> 8) & 255, $rdev & 255); +} + +END +} + +if ($initcpio) { +print <<'END'; +sub cpio { + local($nc,$fh) = @_; + local($text); + + if ($name eq 'TRAILER!!!') { + $text = ''; + $size = 0; + } + else { + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_); + if (-f _) { + open(IN, "./$_\0") || do { + warn "Couldn't open $name: $!\n"; + return; + }; + } + else { + $text = readlink($_); + $size = 0 unless defined $text; + } + } + + ($nm = $name) =~ s#^\./##; + $nc{$fh} = $nc; + if ($nc eq 'n') { + $cpout{$fh} .= + sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0", + 070707, + $dev & 0777777, + $ino & 0777777, + $mode & 0777777, + $uid & 0777777, + $gid & 0777777, + $nlink & 0777777, + $rdev & 0177777, + $mtime, + length($nm)+1, + $size, + $nm); + } + else { + $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1; + $cpout{$fh} .= pack("SSSSSSSSLSLa*", + 070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime, + length($nm)+1, $size, $nm . (length($nm) & 1 ? "\0" : "\0\0")); + } + if ($text ne '') { + $cpout{$fh} .= $text; + } + elsif ($size) { + &flush($fh) while ($l = length($cpout{$fh})) >= 5120; + while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) { + &flush($fh); + $l = length($cpout{$fh}); + } + } + close IN; +} + +sub flush { + local($fh) = @_; + + while (length($cpout{$fh}) >= 5120) { + syswrite($fh,$cpout{$fh},5120); + ++$blocks{$fh}; + substr($cpout{$fh}, 0, 5120) = ''; + } +} + +sub flushall { + $name = 'TRAILER!!!'; + foreach $fh (keys %cpout) { + &cpio($nc{$fh},$fh); + $cpout{$fh} .= "0" x (5120 - length($cpout{$fh})); + &flush($fh); + print $blocks{$fh} * 10, " blocks\n"; + } +} + +END +} + +if ($inittar) { +print <<'END'; +sub tar { + local($fh) = @_; + local($linkname,$header,$l,$slop); + local($linkflag) = "\0"; + + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_); + $nm = $name; + if ($nlink > 1) { + if ($linkname = $linkseen{$fh,$dev,$ino}) { + $linkflag = 1; + } + else { + $linkseen{$fh,$dev,$ino} = $nm; + } + } + if (-f _) { + open(IN, "./$_\0") || do { + warn "Couldn't open $name: $!\n"; + return; + }; + $size = 0 if $linkflag ne "\0"; + } + else { + $linkname = readlink($_); + $linkflag = 2 if defined $linkname; + $nm .= '/' if -d _; + $size = 0; + } + + $header = pack("a100a8a8a8a12a12a8a1a100", + $nm, + sprintf("%6o ", $mode & 0777), + sprintf("%6o ", $uid & 0777777), + sprintf("%6o ", $gid & 0777777), + sprintf("%11o ", $size), + sprintf("%11o ", $mtime), + " ", + $linkflag, + $linkname); + $l = length($header) % 512; + substr($header, 148, 6) = sprintf("%6o", unpack("%16C*", $header)); + substr($header, 154, 1) = "\0"; # blech + $tarout{$fh} .= $header; + $tarout{$fh} .= "\0" x (512 - $l) if $l; + if ($size) { + &tflush($fh) while ($l = length($tarout{$fh})) >= 10240; + while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) { + $slop = length($tarout{$fh}) % 512; + $tarout{$fh} .= "\0" x (512 - $slop) if $slop; + &tflush($fh); + $l = length($tarout{$fh}); + } + } + close IN; +} + +sub tflush { + local($fh) = @_; + + while (length($tarout{$fh}) >= 10240) { + syswrite($fh,$tarout{$fh},10240); + ++$blocks{$fh}; + substr($tarout{$fh}, 0, 10240) = ''; + } +} + +sub tflushall { + local($len); + + foreach $fh (keys %tarout) { + $len = 10240 - length($tarout{$fh}); + $len += 10240 if $len < 1024; + $tarout{$fh} .= "\0" x $len; + &tflush($fh); + } +} + +END +} + +exit; + +############################################################################ + +sub tab { + local($tabstring); + + $tabstring = "\t" x ($indent / 2) . ' ' x ($indent % 2 * 4); + if (!$statdone) { + if ($_ =~ /^(name|print|prune|exec|ok|\(|\))/) { + $delayedstat++; + } + else { + if ($saw_or) { + $tabstring .= <<'ENDOFSTAT' . $tabstring; +($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && +ENDOFSTAT + } + else { + $tabstring .= <<'ENDOFSTAT' . $tabstring; +(($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && +ENDOFSTAT + } + $statdone = 1; + } + } + $tabstring =~ s/^\s+/ / if $out =~ /!$/; + $tabstring; +} + +sub fileglob_to_re { + local($tmp) = @_; + + $tmp =~ s#([./^\$()])#\\$1#g; + $tmp =~ s/([?*])/.$1/g; + "^$tmp\$"; +} + +sub n { + local($n) = @_; + + $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /; + $n =~ s/ 0*(\d)/ $1/; + $n . ')'; +} + +sub quote { + local($string) = @_; + $string =~ s/'/\\'/; + "'$string'"; +} +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; diff --git a/x2p/find2perl.SH b/x2p/find2perl.SH deleted file mode 100755 index 3652bde07c..0000000000 --- a/x2p/find2perl.SH +++ /dev/null @@ -1,604 +0,0 @@ -case $CONFIG in -'') - if test -f config.sh; then TOP=.; - elif test -f ../config.sh; then TOP=..; - elif test -f ../../config.sh; then TOP=../..; - elif test -f ../../../config.sh; then TOP=../../..; - elif test -f ../../../../config.sh; then TOP=../../../..; - else - echo "Can't find config.sh."; exit 1 - fi - . $TOP/config.sh - ;; -esac -: This forces SH files to create target in same directory as SH file. -: This is so that make depend always knows where to find SH derivatives. -case "$0" in -*/*) cd `expr X$0 : 'X\(.*\)/'` ;; -esac -echo "Extracting x2p/find2perl (with variable substitutions)" -: This section of the file will have variable substitutions done on it. -: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. -: Protect any dollar signs and backticks that you do not want interpreted -: by putting a backslash in front. You may delete these comments. -rm -f find2perl -$spitshell >find2perl < -# University of Pittsburgh - -eval 'exec $bin/perl -S \$0 \${1+"\$@"}' - if \$running_under_some_shell; - -\$bin = "$bin"; - -!GROK!THIS! - -: In the following dollars and backticks do not need the extra backslash. -$spitshell >>find2perl <<'!NO!SUBS!' - -while ($ARGV[0] =~ /^[^-!(]/) { - push(@roots, shift); -} -@roots = ('.') unless @roots; -for (@roots) { $_ = "e($_); } -$roots = join(',', @roots); - -$indent = 1; - -while (@ARGV) { - $_ = shift; - s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n"; - if ($_ eq '(') { - $out .= &tab . "(\n"; - $indent++; - next; - } - elsif ($_ eq ')') { - $indent--; - $out .= &tab . ")"; - } - elsif ($_ eq '!') { - $out .= &tab . "!"; - next; - } - elsif ($_ eq 'name') { - $out .= &tab; - $pat = &fileglob_to_re(shift); - $out .= '/' . $pat . "/"; - } - elsif ($_ eq 'perm') { - $onum = shift; - die "Malformed -perm argument: $onum\n" unless $onum =~ /^-?[0-7]+$/; - if ($onum =~ s/^-//) { - $onum = '0' . sprintf("%o", oct($onum) & 017777); # s/b 07777 ? - $out .= &tab . "((\$mode & $onum) == $onum)"; - } - else { - $onum = '0' . $onum unless $onum =~ /^0/; - $out .= &tab . "((\$mode & 0777) == $onum)"; - } - } - elsif ($_ eq 'type') { - ($filetest = shift) =~ tr/s/S/; - $out .= &tab . "-$filetest _"; - } - elsif ($_ eq 'print') { - $out .= &tab . 'print("$name\n")'; - } - elsif ($_ eq 'print0') { - $out .= &tab . 'print("$name\0")'; - } - elsif ($_ eq 'fstype') { - $out .= &tab; - $type = shift; - if ($type eq 'nfs') - { $out .= '($dev < 0)'; } - else - { $out .= '($dev >= 0)'; } - } - elsif ($_ eq 'user') { - $uname = shift; - $out .= &tab . "(\$uid == \$uid{'$uname'})"; - $inituser++; - } - elsif ($_ eq 'group') { - $gname = shift; - $out .= &tab . "(\$gid == \$gid{'$gname'})"; - $initgroup++; - } - elsif ($_ eq 'nouser') { - $out .= &tab . '!defined $uid{$uid}'; - $inituser++; - } - elsif ($_ eq 'nogroup') { - $out .= &tab . '!defined $gid{$gid}'; - $initgroup++; - } - elsif ($_ eq 'links') { - $out .= &tab . '($nlink ' . &n(shift); - } - elsif ($_ eq 'inum') { - $out .= &tab . '($ino ' . &n(shift); - } - elsif ($_ eq 'size') { - $out .= &tab . '(int(((-s _) + 511) / 512) ' . &n(shift); - } - elsif ($_ eq 'atime') { - $out .= &tab . '(int(-A _) ' . &n(shift); - } - elsif ($_ eq 'mtime') { - $out .= &tab . '(int(-M _) ' . &n(shift); - } - elsif ($_ eq 'ctime') { - $out .= &tab . '(int(-C _) ' . &n(shift); - } - elsif ($_ eq 'exec') { - for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { } - shift; - $_ = "@cmd"; - if (m#^(/bin/)?rm -f {}$#) { - if (!@ARGV) { - $out .= &tab . 'unlink($_)'; - } - else { - $out .= &tab . '(unlink($_) || 1)'; - } - } - elsif (m#^(/bin/)?rm {}$#) { - $out .= &tab . '(unlink($_) || warn "$name: $!\n")'; - } - else { - for (@cmd) { s/'/\\'/g; } - $" = "','"; - $out .= &tab . "&exec(0, '@cmd')"; - $" = ' '; - $initexec++; - } - } - elsif ($_ eq 'ok') { - for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { } - shift; - for (@cmd) { s/'/\\'/g; } - $" = "','"; - $out .= &tab . "&exec(1, '@cmd')"; - $" = ' '; - $initexec++; - } - elsif ($_ eq 'prune') { - $out .= &tab . '($prune = 1)'; - } - elsif ($_ eq 'xdev') { - $out .= &tab . '!($prune |= ($dev != $topdev))'; - } - elsif ($_ eq 'newer') { - $out .= &tab; - $file = shift; - $newername = 'AGE_OF' . $file; - $newername =~ s/[^\w]/_/g; - $newername = '$' . $newername; - $out .= "(-M _ < $newername)"; - $initnewer .= "$newername = -M " . "e($file) . ";\n"; - } - elsif ($_ eq 'eval') { - $prog = "e(shift); - $out .= &tab . "eval $prog"; - } - elsif ($_ eq 'depth') { - $depth++; - next; - } - elsif ($_ eq 'ls') { - $out .= &tab . "&ls"; - $initls++; - } - elsif ($_ eq 'tar') { - $out .= &tab; - die "-tar must have a filename argument\n" unless @ARGV; - $file = shift; - $fh = 'FH' . $file; - $fh =~ s/[^\w]/_/g; - $out .= "&tar($fh)"; - $file = '>' . $file; - $initfile .= "open($fh, " . "e($file) . - qq{) || die "Can't open $fh: \$!\\n";\n}; - $inittar++; - $flushall = "\n&tflushall;\n"; - } - elsif (/^n?cpio$/) { - $depth++; - $out .= &tab; - die "-$_ must have a filename argument\n" unless @ARGV; - $file = shift; - $fh = 'FH' . $file; - $fh =~ s/[^\w]/_/g; - $out .= "&cpio('" . substr($_,0,1) . "', $fh)"; - $file = '>' . $file; - $initfile .= "open($fh, " . "e($file) . - qq{) || die "Can't open $fh: \$!\\n";\n}; - $initcpio++; - $flushall = "\n&flushall;\n"; - } - else { - die "Unrecognized switch: -$_\n"; - } - if (@ARGV) { - if ($ARGV[0] eq '-o') { - { local($statdone) = 1; $out .= "\n" . &tab . "||\n"; } - $statdone = 0 if $indent == 1 && $delayedstat; - $saw_or++; - shift; - } - else { - $out .= " &&" unless $ARGV[0] eq ')'; - $out .= "\n"; - shift if $ARGV[0] eq '-a'; - } - } -} - -print <<"END"; -#!$bin/perl - -eval 'exec $bin/perl -S \$0 \${1+"\$@"}' - if \$running_under_some_shell; - -END - -if ($initls) { - print <<'END'; -@rwx = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx'); -@moname = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec); - -END -} - -if ($inituser || $initls) { - print 'while (($name, $pw, $uid) = getpwent) {', "\n"; - print ' $uid{$name} = $uid{$uid} = $uid;', "\n" if $inituser; - print ' $user{$uid} = $name unless $user{$uid};', "\n" if $initls; - print "}\n\n"; -} - -if ($initgroup || $initls) { - print 'while (($name, $pw, $gid) = getgrent) {', "\n"; - print ' $gid{$name} = $gid{$gid} = $gid;', "\n" if $initgroup; - print ' $group{$gid} = $name unless $group{$gid};', "\n" if $initls; - print "}\n\n"; -} - -print $initnewer, "\n" if $initnewer; - -print $initfile, "\n" if $initfile; - -$find = $depth ? "finddepth" : "find"; -print <<"END"; -require "$find.pl"; - -# Traverse desired filesystems - -&$find($roots); -$flushall -exit; - -sub wanted { -$out; -} - -END - -if ($initexec) { - print <<'END'; -sub exec { - local($ok, @cmd) = @_; - foreach $word (@cmd) { - $word =~ s#{}#$name#g; - } - if ($ok) { - local($old) = select(STDOUT); - $| = 1; - print "@cmd"; - select($old); - return 0 unless =~ /^y/; - } - chdir $cwd; # sigh - system @cmd; - chdir $dir; - return !$?; -} - -END -} - -if ($initls) { - print <<'END'; -sub ls { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm, - $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_); - - $pname = $name; - - if (defined $blocks) { - $blocks = int(($blocks + 1) / 2); - } - else { - $blocks = int(($size + 1023) / 1024); - } - - if (-f _) { $perms = '-'; } - elsif (-d _) { $perms = 'd'; } - elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; } - elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; } - elsif (-p _) { $perms = 'p'; } - elsif (-S _) { $perms = 's'; } - else { $perms = 'l'; $pname .= ' -> ' . readlink($_); } - - $tmpmode = $mode; - $tmp = $rwx[$tmpmode & 7]; - $tmpmode >>= 3; - $tmp = $rwx[$tmpmode & 7] . $tmp; - $tmpmode >>= 3; - $tmp = $rwx[$tmpmode & 7] . $tmp; - substr($tmp,2,1) =~ tr/-x/Ss/ if -u _; - substr($tmp,5,1) =~ tr/-x/Ss/ if -g _; - substr($tmp,8,1) =~ tr/-x/Tt/ if -k _; - $perms .= $tmp; - - $user = $user{$uid} || $uid; - $group = $group{$gid} || $gid; - - ($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime); - $moname = $moname[$mon]; - if (-M _ > 365.25 / 2) { - $timeyear = $year + 1900; - } - else { - $timeyear = sprintf("%02d:%02d", $hour, $min); - } - - printf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n", - $ino, - $blocks, - $perms, - $nlink, - $user, - $group, - $sizemm, - $moname, - $mday, - $timeyear, - $pname; - 1; -} - -sub sizemm { - sprintf("%3d, %3d", ($rdev >> 8) & 255, $rdev & 255); -} - -END -} - -if ($initcpio) { -print <<'END'; -sub cpio { - local($nc,$fh) = @_; - local($text); - - if ($name eq 'TRAILER!!!') { - $text = ''; - $size = 0; - } - else { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_); - if (-f _) { - open(IN, "./$_\0") || do { - warn "Couldn't open $name: $!\n"; - return; - }; - } - else { - $text = readlink($_); - $size = 0 unless defined $text; - } - } - - ($nm = $name) =~ s#^\./##; - $nc{$fh} = $nc; - if ($nc eq 'n') { - $cpout{$fh} .= - sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0", - 070707, - $dev & 0777777, - $ino & 0777777, - $mode & 0777777, - $uid & 0777777, - $gid & 0777777, - $nlink & 0777777, - $rdev & 0177777, - $mtime, - length($nm)+1, - $size, - $nm); - } - else { - $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1; - $cpout{$fh} .= pack("SSSSSSSSLSLa*", - 070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime, - length($nm)+1, $size, $nm . (length($nm) & 1 ? "\0" : "\0\0")); - } - if ($text ne '') { - $cpout{$fh} .= $text; - } - elsif ($size) { - &flush($fh) while ($l = length($cpout{$fh})) >= 5120; - while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) { - &flush($fh); - $l = length($cpout{$fh}); - } - } - close IN; -} - -sub flush { - local($fh) = @_; - - while (length($cpout{$fh}) >= 5120) { - syswrite($fh,$cpout{$fh},5120); - ++$blocks{$fh}; - substr($cpout{$fh}, 0, 5120) = ''; - } -} - -sub flushall { - $name = 'TRAILER!!!'; - foreach $fh (keys %cpout) { - &cpio($nc{$fh},$fh); - $cpout{$fh} .= "0" x (5120 - length($cpout{$fh})); - &flush($fh); - print $blocks{$fh} * 10, " blocks\n"; - } -} - -END -} - -if ($inittar) { -print <<'END'; -sub tar { - local($fh) = @_; - local($linkname,$header,$l,$slop); - local($linkflag) = "\0"; - - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_); - $nm = $name; - if ($nlink > 1) { - if ($linkname = $linkseen{$fh,$dev,$ino}) { - $linkflag = 1; - } - else { - $linkseen{$fh,$dev,$ino} = $nm; - } - } - if (-f _) { - open(IN, "./$_\0") || do { - warn "Couldn't open $name: $!\n"; - return; - }; - $size = 0 if $linkflag ne "\0"; - } - else { - $linkname = readlink($_); - $linkflag = 2 if defined $linkname; - $nm .= '/' if -d _; - $size = 0; - } - - $header = pack("a100a8a8a8a12a12a8a1a100", - $nm, - sprintf("%6o ", $mode & 0777), - sprintf("%6o ", $uid & 0777777), - sprintf("%6o ", $gid & 0777777), - sprintf("%11o ", $size), - sprintf("%11o ", $mtime), - " ", - $linkflag, - $linkname); - $l = length($header) % 512; - substr($header, 148, 6) = sprintf("%6o", unpack("%16C*", $header)); - substr($header, 154, 1) = "\0"; # blech - $tarout{$fh} .= $header; - $tarout{$fh} .= "\0" x (512 - $l) if $l; - if ($size) { - &tflush($fh) while ($l = length($tarout{$fh})) >= 10240; - while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) { - $slop = length($tarout{$fh}) % 512; - $tarout{$fh} .= "\0" x (512 - $slop) if $slop; - &tflush($fh); - $l = length($tarout{$fh}); - } - } - close IN; -} - -sub tflush { - local($fh) = @_; - - while (length($tarout{$fh}) >= 10240) { - syswrite($fh,$tarout{$fh},10240); - ++$blocks{$fh}; - substr($tarout{$fh}, 0, 10240) = ''; - } -} - -sub tflushall { - local($len); - - foreach $fh (keys %tarout) { - $len = 10240 - length($tarout{$fh}); - $len += 10240 if $len < 1024; - $tarout{$fh} .= "\0" x $len; - &tflush($fh); - } -} - -END -} - -exit; - -############################################################################ - -sub tab { - local($tabstring); - - $tabstring = "\t" x ($indent / 2) . ' ' x ($indent % 2 * 4); - if (!$statdone) { - if ($_ =~ /^(name|print|prune|exec|ok|\(|\))/) { - $delayedstat++; - } - else { - if ($saw_or) { - $tabstring .= <<'ENDOFSTAT' . $tabstring; -($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && -ENDOFSTAT - } - else { - $tabstring .= <<'ENDOFSTAT' . $tabstring; -(($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && -ENDOFSTAT - } - $statdone = 1; - } - } - $tabstring =~ s/^\s+/ / if $out =~ /!$/; - $tabstring; -} - -sub fileglob_to_re { - local($tmp) = @_; - - $tmp =~ s#([./^\$()])#\\$1#g; - $tmp =~ s/([?*])/.$1/g; - "^$tmp\$"; -} - -sub n { - local($n) = @_; - - $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /; - $n =~ s/ 0*(\d)/ $1/; - $n . ')'; -} - -sub quote { - local($string) = @_; - $string =~ s/'/\\'/; - "'$string'"; -} -!NO!SUBS! -chmod 755 find2perl -$eunicefix find2perl diff --git a/x2p/s2p.PL b/x2p/s2p.PL new file mode 100644 index 0000000000..fe82b02325 --- /dev/null +++ b/x2p/s2p.PL @@ -0,0 +1,782 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir(dirname($0)); +($file = basename($0)) =~ s/\.PL$//; +$file =~ s/\.pl$// + if ($Config{'osname'} eq 'VMS' or + $Config{'osname'} eq 'OS2'); # "case-forgiving" + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{'startperl'} + eval 'exec perl -S \$0 "\$@"' + if 0; +\$startperl = $Config{startperl}; +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; + +# $RCSfile: s2p.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:23 $ +# +# $Log: s2p.SH,v $ + +$indent = 4; +$shiftwidth = 4; +$l = '{'; $r = '}'; + +while ($ARGV[0] =~ /^-/) { + $_ = shift; + last if /^--/; + if (/^-D/) { + $debug++; + open(BODY,'>-'); + next; + } + if (/^-n/) { + $assumen++; + next; + } + if (/^-p/) { + $assumep++; + next; + } + die "I don't recognize this switch: $_\n"; +} + +unless ($debug) { + open(BODY,">/tmp/sperl$$") || + &Die("Can't open temp file: $!\n"); +} + +if (!$assumen && !$assumep) { + print BODY &q(<<'EOT'); +: while ($ARGV[0] =~ /^-/) { +: $_ = shift; +: last if /^--/; +: if (/^-n/) { +: $nflag++; +: next; +: } +: die "I don't recognize this switch: $_\\n"; +: } +: +EOT +} + +print BODY &q(<<'EOT'); +: #ifdef PRINTIT +: #ifdef ASSUMEP +: $printit++; +: #else +: $printit++ unless $nflag; +: #endif +: #endif +: <><> +: $\ = "\n"; # automatically add newline on print +: <><> +: #ifdef TOPLABEL +: LINE: +: while (chop($_ = <>)) { +: #else +: LINE: +: while (<>) { +: chop; +: #endif +EOT + +LINE: +while (<>) { + + # Wipe out surrounding whitespace. + + s/[ \t]*(.*)\n$/$1/; + + # Perhaps it's a label/comment. + + if (/^:/) { + s/^:[ \t]*//; + $label = &make_label($_); + if ($. == 1) { + $toplabel = $label; + if (/^(top|(re)?start|redo|begin(ning)|again|input)$/i) { + $_ = <>; + redo LINE; # Never referenced, so delete it if not a comment. + } + } + $_ = "$label:"; + if ($lastlinewaslabel++) { + $indent += 4; + print BODY &tab, ";\n"; + $indent -= 4; + } + if ($indent >= 2) { + $indent -= 2; + $indmod = 2; + } + next; + } else { + $lastlinewaslabel = ''; + } + + # Look for one or two address clauses + + $addr1 = ''; + $addr2 = ''; + if (s/^([0-9]+)//) { + $addr1 = "$1"; + $addr1 = "\$. == $addr1" unless /^,/; + } + elsif (s/^\$//) { + $addr1 = 'eof()'; + } + elsif (s|^/||) { + $addr1 = &fetchpat('/'); + } + if (s/^,//) { + if (s/^([0-9]+)//) { + $addr2 = "$1"; + } elsif (s/^\$//) { + $addr2 = "eof()"; + } elsif (s|^/||) { + $addr2 = &fetchpat('/'); + } else { + &Die("Invalid second address at line $.\n"); + } + if ($addr2 =~ /^\d+$/) { + $addr1 .= "..$addr2"; + } + else { + $addr1 .= "...$addr2"; + } + } + + # Now we check for metacommands {, }, and ! and worry + # about indentation. + + s/^[ \t]+//; + # a { to keep vi happy + if ($_ eq '}') { + $indent -= 4; + next; + } + if (s/^!//) { + $if = 'unless'; + $else = "$r else $l\n"; + } else { + $if = 'if'; + $else = ''; + } + if (s/^{//) { # a } to keep vi happy + $indmod = 4; + $redo = $_; + $_ = ''; + $rmaybe = ''; + } else { + $rmaybe = "\n$r"; + if ($addr2 || $addr1) { + $space = ' ' x $shiftwidth; + } else { + $space = ''; + } + $_ = &transmogrify(); + } + + # See if we can optimize to modifier form. + + if ($addr1) { + if ($_ !~ /[\n{}]/ && $rmaybe && !$change && + $_ !~ / if / && $_ !~ / unless /) { + s/;$/ $if $addr1;/; + $_ = substr($_,$shiftwidth,1000); + } else { + $_ = "$if ($addr1) $l\n$change$_$rmaybe"; + } + $change = ''; + next LINE; + } +} continue { + @lines = split(/\n/,$_); + for (@lines) { + unless (s/^ *<<--//) { + print BODY &tab; + } + print BODY $_, "\n"; + } + $indent += $indmod; + $indmod = 0; + if ($redo) { + $_ = $redo; + $redo = ''; + redo LINE; + } +} +if ($lastlinewaslabel++) { + $indent += 4; + print BODY &tab, ";\n"; + $indent -= 4; +} + +if ($appendseen || $tseen || !$assumen) { + $printit++ if $dseen || (!$assumen && !$assumep); + print BODY &q(<<'EOT'); +: #ifdef SAWNEXT +: } +: continue { +: #endif +: #ifdef PRINTIT +: #ifdef DSEEN +: #ifdef ASSUMEP +: print if $printit++; +: #else +: if ($printit) +: { print; } +: else +: { $printit++ unless $nflag; } +: #endif +: #else +: print if $printit; +: #endif +: #else +: print; +: #endif +: #ifdef TSEEN +: $tflag = 0; +: #endif +: #ifdef APPENDSEEN +: if ($atext) { chop $atext; print $atext; $atext = ''; } +: #endif +EOT + +print BODY &q(<<'EOT'); +: } +EOT +} + +close BODY; + +unless ($debug) { + open(HEAD,">/tmp/sperl2$$.c") + || &Die("Can't open temp file 2: $!\n"); + print HEAD "#define PRINTIT\n" if $printit; + print HEAD "#define APPENDSEEN\n" if $appendseen; + print HEAD "#define TSEEN\n" if $tseen; + print HEAD "#define DSEEN\n" if $dseen; + print HEAD "#define ASSUMEN\n" if $assumen; + print HEAD "#define ASSUMEP\n" if $assumep; + print HEAD "#define TOPLABEL\n" if $toplabel; + print HEAD "#define SAWNEXT\n" if $sawnext; + if ($opens) {print HEAD "$opens\n";} + open(BODY,"/tmp/sperl$$") + || &Die("Can't reopen temp file: $!\n"); + while () { + print HEAD $_; + } + close HEAD; + + print &q(<<"EOT"); +: $startperl +: eval 'exec perl -S \$0 \${1+"\$@"}' +: if \$running_under_some_shell; +: +EOT + open(BODY,"cc -E /tmp/sperl2$$.c |") || + &Die("Can't reopen temp file: $!\n"); + while () { + /^# [0-9]/ && next; + /^[ \t]*$/ && next; + s/^<><>//; + print; + } +} + +&Cleanup; +exit; + +sub Cleanup { + chdir "/tmp"; + unlink "sperl$$", "sperl2$$", "sperl2$$.c"; +} +sub Die { + &Cleanup; + die $_[0]; +} +sub tab { + "\t" x ($indent / 8) . ' ' x ($indent % 8); +} +sub make_filehandle { + local($_) = $_[0]; + local($fname) = $_; + if (!$seen{$fname}) { + $_ = "FH_" . $_ if /^\d/; + s/[^a-zA-Z0-9]/_/g; + s/^_*//; + $_ = "\U$_"; + if ($fhseen{$_}) { + for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {} + $_ .= $tmp; + } + $fhseen{$_} = 1; + $opens .= &q(<<"EOT"); +: open($_, '>$fname') || die "Can't create $fname: \$!"; +EOT + $seen{$fname} = $_; + } + $seen{$fname}; +} + +sub make_label { + local($label) = @_; + $label =~ s/[^a-zA-Z0-9]/_/g; + if ($label =~ /^[0-9_]/) { $label = 'L' . $label; } + $label = substr($label,0,8); + + # Could be a reserved word, so capitalize it. + substr($label,0,1) =~ y/a-z/A-Z/ + if $label =~ /^[a-z]/; + + $label; +} + +sub transmogrify { + { # case + if (/^d/) { + $dseen++; + chop($_ = &q(<<'EOT')); +: <<--#ifdef PRINTIT +: $printit = 0; +: <<--#endif +: next LINE; +EOT + $sawnext++; + next; + } + + if (/^n/) { + chop($_ = &q(<<'EOT')); +: <<--#ifdef PRINTIT +: <<--#ifdef DSEEN +: <<--#ifdef ASSUMEP +: print if $printit++; +: <<--#else +: if ($printit) +: { print; } +: else +: { $printit++ unless $nflag; } +: <<--#endif +: <<--#else +: print if $printit; +: <<--#endif +: <<--#else +: print; +: <<--#endif +: <<--#ifdef APPENDSEEN +: if ($atext) {chop $atext; print $atext; $atext = '';} +: <<--#endif +: $_ = <>; +: chop; +: <<--#ifdef TSEEN +: $tflag = 0; +: <<--#endif +EOT + next; + } + + if (/^a/) { + $appendseen++; + $command = $space . "\$atext .= <<'End_Of_Text';\n<<--"; + $lastline = 0; + while (<>) { + s/^[ \t]*//; + s/^[\\]//; + unless (s|\\$||) { $lastline = 1;} + s/^([ \t]*\n)/<><>$1/; + $command .= $_; + $command .= '<<--'; + last if $lastline; + } + $_ = $command . "End_Of_Text"; + last; + } + + if (/^[ic]/) { + if (/^c/) { $change = 1; } + $addr1 = 1 if $addr1 eq ''; + $addr1 = '$iter = (' . $addr1 . ')'; + $command = $space . + " if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--"; + $lastline = 0; + while (<>) { + s/^[ \t]*//; + s/^[\\]//; + unless (s/\\$//) { $lastline = 1;} + s/'/\\'/g; + s/^([ \t]*\n)/<><>$1/; + $command .= $_; + $command .= '<<--'; + last if $lastline; + } + $_ = $command . "End_Of_Text"; + if ($change) { + $dseen++; + $change = "$_\n"; + chop($_ = &q(<<"EOT")); +: <<--#ifdef PRINTIT +: $space\$printit = 0; +: <<--#endif +: ${space}next LINE; +EOT + $sawnext++; + } + last; + } + + if (/^s/) { + $delim = substr($_,1,1); + $len = length($_); + $repl = $end = 0; + $inbracket = 0; + for ($i = 2; $i < $len; $i++) { + $c = substr($_,$i,1); + if ($c eq $delim) { + if ($inbracket) { + substr($_, $i, 0) = '\\'; + $i++; + $len++; + } + else { + if ($repl) { + $end = $i; + last; + } else { + $repl = $i; + } + } + } + elsif ($c eq '\\') { + $i++; + if ($i >= $len) { + $_ .= 'n'; + $_ .= <>; + $len = length($_); + $_ = substr($_,0,--$len); + } + elsif (substr($_,$i,1) =~ /^[n]$/) { + ; + } + elsif (!$repl && + substr($_,$i,1) =~ /^[(){}\w]$/) { + $i--; + $len--; + substr($_, $i, 1) = ''; + } + elsif (!$repl && + substr($_,$i,1) =~ /^[<>]$/) { + substr($_,$i,1) = 'b'; + } + elsif ($repl && substr($_,$i,1) =~ /^\d$/) { + substr($_,$i-1,1) = '$'; + } + } + elsif ($c eq '&' && $repl) { + substr($_, $i, 0) = '$'; + $i++; + $len++; + } + elsif ($c eq '$' && $repl) { + substr($_, $i, 0) = '\\'; + $i++; + $len++; + } + elsif ($c eq '[' && !$repl) { + $i++ if substr($_,$i,1) eq '^'; + $i++ if substr($_,$i,1) eq ']'; + $inbracket = 1; + } + elsif ($c eq ']') { + $inbracket = 0; + } + elsif ($c eq "\t") { + substr($_, $i, 1) = '\\t'; + $i++; + $len++; + } + elsif (!$repl && index("()+",$c) >= 0) { + substr($_, $i, 0) = '\\'; + $i++; + $len++; + } + } + &Die("Malformed substitution at line $.\n") + unless $end; + $pat = substr($_, 0, $repl + 1); + $repl = substr($_, $repl+1, $end-$repl-1); + $end = substr($_, $end + 1, 1000); + &simplify($pat); + $dol = '$'; + $subst = "$pat$repl$delim"; + $cmd = ''; + while ($end) { + if ($end =~ s/^g//) { + $subst .= 'g'; + next; + } + if ($end =~ s/^p//) { + $cmd .= ' && (print)'; + next; + } + if ($end =~ s/^w[ \t]*//) { + $fh = &make_filehandle($end); + $cmd .= " && (print $fh \$_)"; + $end = ''; + next; + } + &Die("Unrecognized substitution command". + "($end) at line $.\n"); + } + chop ($_ = &q(<<"EOT")); +: <<--#ifdef TSEEN +: $subst && \$tflag++$cmd; +: <<--#else +: $subst$cmd; +: <<--#endif +EOT + next; + } + + if (/^p/) { + $_ = 'print;'; + next; + } + + if (/^w/) { + s/^w[ \t]*//; + $fh = &make_filehandle($_); + $_ = "print $fh \$_;"; + next; + } + + if (/^r/) { + $appendseen++; + s/^r[ \t]*//; + $file = $_; + $_ = "\$atext .= `cat $file 2>/dev/null`;"; + next; + } + + if (/^P/) { + $_ = 'print $1 if /^(.*)/;'; + next; + } + + if (/^D/) { + chop($_ = &q(<<'EOT')); +: s/^.*\n?//; +: redo LINE if $_; +: next LINE; +EOT + $sawnext++; + next; + } + + if (/^N/) { + chop($_ = &q(<<'EOT')); +: $_ .= "\n"; +: $len1 = length; +: $_ .= <>; +: chop if $len1 < length; +: <<--#ifdef TSEEN +: $tflag = 0; +: <<--#endif +EOT + next; + } + + if (/^h/) { + $_ = '$hold = $_;'; + next; + } + + if (/^H/) { + $_ = '$hold .= "\n"; $hold .= $_;'; + next; + } + + if (/^g/) { + $_ = '$_ = $hold;'; + next; + } + + if (/^G/) { + $_ = '$_ .= "\n"; $_ .= $hold;'; + next; + } + + if (/^x/) { + $_ = '($_, $hold) = ($hold, $_);'; + next; + } + + if (/^b$/) { + $_ = 'next LINE;'; + $sawnext++; + next; + } + + if (/^b/) { + s/^b[ \t]*//; + $lab = &make_label($_); + if ($lab eq $toplabel) { + $_ = 'redo LINE;'; + } else { + $_ = "goto $lab;"; + } + next; + } + + if (/^t$/) { + $_ = 'next LINE if $tflag;'; + $sawnext++; + $tseen++; + next; + } + + if (/^t/) { + s/^t[ \t]*//; + $lab = &make_label($_); + $_ = q/if ($tflag) {$tflag = 0; /; + if ($lab eq $toplabel) { + $_ .= 'redo LINE;}'; + } else { + $_ .= "goto $lab;}"; + } + $tseen++; + next; + } + + if (/^y/) { + s/abcdefghijklmnopqrstuvwxyz/a-z/g; + s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g; + s/abcdef/a-f/g; + s/ABCDEF/A-F/g; + s/0123456789/0-9/g; + s/01234567/0-7/g; + $_ .= ';'; + } + + if (/^=/) { + $_ = 'print $.;'; + next; + } + + if (/^q/) { + chop($_ = &q(<<'EOT')); +: close(ARGV); +: @ARGV = (); +: next LINE; +EOT + $sawnext++; + next; + } + } continue { + if ($space) { + s/^/$space/; + s/(\n)(.)/$1$space$2/g; + } + last; + } + $_; +} + +sub fetchpat { + local($outer) = @_; + local($addr) = $outer; + local($inbracket); + local($prefix,$delim,$ch); + + # Process pattern one potential delimiter at a time. + + DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) { + $prefix = $1; + $delim = $2; + if ($delim eq '\\') { + s/(.)//; + $ch = $1; + $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/; + $ch = 'b' if $ch =~ /^[<>]$/; + $delim .= $ch; + } + elsif ($delim eq '[') { + $inbracket = 1; + s/^\^// && ($delim .= '^'); + s/^]// && ($delim .= ']'); + } + elsif ($delim eq ']') { + $inbracket = 0; + } + elsif ($inbracket || $delim ne $outer) { + $delim = '\\' . $delim; + } + $addr .= $prefix; + $addr .= $delim; + if ($delim eq $outer && !$inbracket) { + last DELIM; + } + } + $addr =~ s/\t/\\t/g; + &simplify($addr); + $addr; +} + +sub q { + local($string) = @_; + local($*) = 1; + $string =~ s/^:\t?//g; + $string; +} + +sub simplify { + $_[0] =~ s/_a-za-z0-9/\\w/ig; + $_[0] =~ s/a-z_a-z0-9/\\w/ig; + $_[0] =~ s/a-za-z_0-9/\\w/ig; + $_[0] =~ s/a-za-z0-9_/\\w/ig; + $_[0] =~ s/_0-9a-za-z/\\w/ig; + $_[0] =~ s/0-9_a-za-z/\\w/ig; + $_[0] =~ s/0-9a-z_a-z/\\w/ig; + $_[0] =~ s/0-9a-za-z_/\\w/ig; + $_[0] =~ s/\[\\w\]/\\w/g; + $_[0] =~ s/\[^\\w\]/\\W/g; + $_[0] =~ s/\[0-9\]/\\d/g; + $_[0] =~ s/\[^0-9\]/\\D/g; + $_[0] =~ s/\\d\\d\*/\\d+/g; + $_[0] =~ s/\\D\\D\*/\\D+/g; + $_[0] =~ s/\\w\\w\*/\\w+/g; + $_[0] =~ s/\\t\\t\*/\\t+/g; + $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g; + $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g; +} + +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; diff --git a/x2p/s2p.SH b/x2p/s2p.SH deleted file mode 100755 index a4d5a39dfc..0000000000 --- a/x2p/s2p.SH +++ /dev/null @@ -1,779 +0,0 @@ -case $CONFIG in -'') - if test -f config.sh; then TOP=.; - elif test -f ../config.sh; then TOP=..; - elif test -f ../../config.sh; then TOP=../..; - elif test -f ../../../config.sh; then TOP=../../..; - elif test -f ../../../../config.sh; then TOP=../../../..; - else - echo "Can't find config.sh."; exit 1 - fi - . $TOP/config.sh - ;; -esac -: This forces SH files to create target in same directory as SH file. -: This is so that make depend always knows where to find SH derivatives. -case "$0" in -*/*) cd `expr X$0 : 'X\(.*\)/'` ;; -esac - -echo "Extracting x2p/s2p (with variable substitutions)" -: This section of the file will have variable substitutions done on it. -: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. -: Protect any dollar signs and backticks that you do not want interpreted -: by putting a backslash in front. You may delete these comments. -rm -f s2p -$spitshell >s2p <>s2p <<'!NO!SUBS!' - -# $RCSfile: s2p.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:23 $ -# -# $Log: s2p.SH,v $ - -$indent = 4; -$shiftwidth = 4; -$l = '{'; $r = '}'; - -while ($ARGV[0] =~ /^-/) { - $_ = shift; - last if /^--/; - if (/^-D/) { - $debug++; - open(BODY,'>-'); - next; - } - if (/^-n/) { - $assumen++; - next; - } - if (/^-p/) { - $assumep++; - next; - } - die "I don't recognize this switch: $_\n"; -} - -unless ($debug) { - open(BODY,">/tmp/sperl$$") || - &Die("Can't open temp file: $!\n"); -} - -if (!$assumen && !$assumep) { - print BODY &q(<<'EOT'); -: while ($ARGV[0] =~ /^-/) { -: $_ = shift; -: last if /^--/; -: if (/^-n/) { -: $nflag++; -: next; -: } -: die "I don't recognize this switch: $_\\n"; -: } -: -EOT -} - -print BODY &q(<<'EOT'); -: #ifdef PRINTIT -: #ifdef ASSUMEP -: $printit++; -: #else -: $printit++ unless $nflag; -: #endif -: #endif -: <><> -: $\ = "\n"; # automatically add newline on print -: <><> -: #ifdef TOPLABEL -: LINE: -: while (chop($_ = <>)) { -: #else -: LINE: -: while (<>) { -: chop; -: #endif -EOT - -LINE: -while (<>) { - - # Wipe out surrounding whitespace. - - s/[ \t]*(.*)\n$/$1/; - - # Perhaps it's a label/comment. - - if (/^:/) { - s/^:[ \t]*//; - $label = &make_label($_); - if ($. == 1) { - $toplabel = $label; - if (/^(top|(re)?start|redo|begin(ning)|again|input)$/i) { - $_ = <>; - redo LINE; # Never referenced, so delete it if not a comment. - } - } - $_ = "$label:"; - if ($lastlinewaslabel++) { - $indent += 4; - print BODY &tab, ";\n"; - $indent -= 4; - } - if ($indent >= 2) { - $indent -= 2; - $indmod = 2; - } - next; - } else { - $lastlinewaslabel = ''; - } - - # Look for one or two address clauses - - $addr1 = ''; - $addr2 = ''; - if (s/^([0-9]+)//) { - $addr1 = "$1"; - $addr1 = "\$. == $addr1" unless /^,/; - } - elsif (s/^\$//) { - $addr1 = 'eof()'; - } - elsif (s|^/||) { - $addr1 = &fetchpat('/'); - } - if (s/^,//) { - if (s/^([0-9]+)//) { - $addr2 = "$1"; - } elsif (s/^\$//) { - $addr2 = "eof()"; - } elsif (s|^/||) { - $addr2 = &fetchpat('/'); - } else { - &Die("Invalid second address at line $.\n"); - } - if ($addr2 =~ /^\d+$/) { - $addr1 .= "..$addr2"; - } - else { - $addr1 .= "...$addr2"; - } - } - - # Now we check for metacommands {, }, and ! and worry - # about indentation. - - s/^[ \t]+//; - # a { to keep vi happy - if ($_ eq '}') { - $indent -= 4; - next; - } - if (s/^!//) { - $if = 'unless'; - $else = "$r else $l\n"; - } else { - $if = 'if'; - $else = ''; - } - if (s/^{//) { # a } to keep vi happy - $indmod = 4; - $redo = $_; - $_ = ''; - $rmaybe = ''; - } else { - $rmaybe = "\n$r"; - if ($addr2 || $addr1) { - $space = ' ' x $shiftwidth; - } else { - $space = ''; - } - $_ = &transmogrify(); - } - - # See if we can optimize to modifier form. - - if ($addr1) { - if ($_ !~ /[\n{}]/ && $rmaybe && !$change && - $_ !~ / if / && $_ !~ / unless /) { - s/;$/ $if $addr1;/; - $_ = substr($_,$shiftwidth,1000); - } else { - $_ = "$if ($addr1) $l\n$change$_$rmaybe"; - } - $change = ''; - next LINE; - } -} continue { - @lines = split(/\n/,$_); - for (@lines) { - unless (s/^ *<<--//) { - print BODY &tab; - } - print BODY $_, "\n"; - } - $indent += $indmod; - $indmod = 0; - if ($redo) { - $_ = $redo; - $redo = ''; - redo LINE; - } -} -if ($lastlinewaslabel++) { - $indent += 4; - print BODY &tab, ";\n"; - $indent -= 4; -} - -if ($appendseen || $tseen || !$assumen) { - $printit++ if $dseen || (!$assumen && !$assumep); - print BODY &q(<<'EOT'); -: #ifdef SAWNEXT -: } -: continue { -: #endif -: #ifdef PRINTIT -: #ifdef DSEEN -: #ifdef ASSUMEP -: print if $printit++; -: #else -: if ($printit) -: { print; } -: else -: { $printit++ unless $nflag; } -: #endif -: #else -: print if $printit; -: #endif -: #else -: print; -: #endif -: #ifdef TSEEN -: $tflag = 0; -: #endif -: #ifdef APPENDSEEN -: if ($atext) { chop $atext; print $atext; $atext = ''; } -: #endif -EOT - -print BODY &q(<<'EOT'); -: } -EOT -} - -close BODY; - -unless ($debug) { - open(HEAD,">/tmp/sperl2$$.c") - || &Die("Can't open temp file 2: $!\n"); - print HEAD "#define PRINTIT\n" if $printit; - print HEAD "#define APPENDSEEN\n" if $appendseen; - print HEAD "#define TSEEN\n" if $tseen; - print HEAD "#define DSEEN\n" if $dseen; - print HEAD "#define ASSUMEN\n" if $assumen; - print HEAD "#define ASSUMEP\n" if $assumep; - print HEAD "#define TOPLABEL\n" if $toplabel; - print HEAD "#define SAWNEXT\n" if $sawnext; - if ($opens) {print HEAD "$opens\n";} - open(BODY,"/tmp/sperl$$") - || &Die("Can't reopen temp file: $!\n"); - while () { - print HEAD $_; - } - close HEAD; - - print &q(<<"EOT"); -: #!$bin/perl -: eval 'exec $bin/perl -S \$0 \${1+"\$@"}' -: if \$running_under_some_shell; -: -EOT - open(BODY,"cc -E /tmp/sperl2$$.c |") || - &Die("Can't reopen temp file: $!\n"); - while () { - /^# [0-9]/ && next; - /^[ \t]*$/ && next; - s/^<><>//; - print; - } -} - -&Cleanup; -exit; - -sub Cleanup { - chdir "/tmp"; - unlink "sperl$$", "sperl2$$", "sperl2$$.c"; -} -sub Die { - &Cleanup; - die $_[0]; -} -sub tab { - "\t" x ($indent / 8) . ' ' x ($indent % 8); -} -sub make_filehandle { - local($_) = $_[0]; - local($fname) = $_; - if (!$seen{$fname}) { - $_ = "FH_" . $_ if /^\d/; - s/[^a-zA-Z0-9]/_/g; - s/^_*//; - $_ = "\U$_"; - if ($fhseen{$_}) { - for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {} - $_ .= $tmp; - } - $fhseen{$_} = 1; - $opens .= &q(<<"EOT"); -: open($_, '>$fname') || die "Can't create $fname: \$!"; -EOT - $seen{$fname} = $_; - } - $seen{$fname}; -} - -sub make_label { - local($label) = @_; - $label =~ s/[^a-zA-Z0-9]/_/g; - if ($label =~ /^[0-9_]/) { $label = 'L' . $label; } - $label = substr($label,0,8); - - # Could be a reserved word, so capitalize it. - substr($label,0,1) =~ y/a-z/A-Z/ - if $label =~ /^[a-z]/; - - $label; -} - -sub transmogrify { - { # case - if (/^d/) { - $dseen++; - chop($_ = &q(<<'EOT')); -: <<--#ifdef PRINTIT -: $printit = 0; -: <<--#endif -: next LINE; -EOT - $sawnext++; - next; - } - - if (/^n/) { - chop($_ = &q(<<'EOT')); -: <<--#ifdef PRINTIT -: <<--#ifdef DSEEN -: <<--#ifdef ASSUMEP -: print if $printit++; -: <<--#else -: if ($printit) -: { print; } -: else -: { $printit++ unless $nflag; } -: <<--#endif -: <<--#else -: print if $printit; -: <<--#endif -: <<--#else -: print; -: <<--#endif -: <<--#ifdef APPENDSEEN -: if ($atext) {chop $atext; print $atext; $atext = '';} -: <<--#endif -: $_ = <>; -: chop; -: <<--#ifdef TSEEN -: $tflag = 0; -: <<--#endif -EOT - next; - } - - if (/^a/) { - $appendseen++; - $command = $space . "\$atext .= <<'End_Of_Text';\n<<--"; - $lastline = 0; - while (<>) { - s/^[ \t]*//; - s/^[\\]//; - unless (s|\\$||) { $lastline = 1;} - s/^([ \t]*\n)/<><>$1/; - $command .= $_; - $command .= '<<--'; - last if $lastline; - } - $_ = $command . "End_Of_Text"; - last; - } - - if (/^[ic]/) { - if (/^c/) { $change = 1; } - $addr1 = 1 if $addr1 eq ''; - $addr1 = '$iter = (' . $addr1 . ')'; - $command = $space . - " if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--"; - $lastline = 0; - while (<>) { - s/^[ \t]*//; - s/^[\\]//; - unless (s/\\$//) { $lastline = 1;} - s/'/\\'/g; - s/^([ \t]*\n)/<><>$1/; - $command .= $_; - $command .= '<<--'; - last if $lastline; - } - $_ = $command . "End_Of_Text"; - if ($change) { - $dseen++; - $change = "$_\n"; - chop($_ = &q(<<"EOT")); -: <<--#ifdef PRINTIT -: $space\$printit = 0; -: <<--#endif -: ${space}next LINE; -EOT - $sawnext++; - } - last; - } - - if (/^s/) { - $delim = substr($_,1,1); - $len = length($_); - $repl = $end = 0; - $inbracket = 0; - for ($i = 2; $i < $len; $i++) { - $c = substr($_,$i,1); - if ($c eq $delim) { - if ($inbracket) { - substr($_, $i, 0) = '\\'; - $i++; - $len++; - } - else { - if ($repl) { - $end = $i; - last; - } else { - $repl = $i; - } - } - } - elsif ($c eq '\\') { - $i++; - if ($i >= $len) { - $_ .= 'n'; - $_ .= <>; - $len = length($_); - $_ = substr($_,0,--$len); - } - elsif (substr($_,$i,1) =~ /^[n]$/) { - ; - } - elsif (!$repl && - substr($_,$i,1) =~ /^[(){}\w]$/) { - $i--; - $len--; - substr($_, $i, 1) = ''; - } - elsif (!$repl && - substr($_,$i,1) =~ /^[<>]$/) { - substr($_,$i,1) = 'b'; - } - elsif ($repl && substr($_,$i,1) =~ /^\d$/) { - substr($_,$i-1,1) = '$'; - } - } - elsif ($c eq '&' && $repl) { - substr($_, $i, 0) = '$'; - $i++; - $len++; - } - elsif ($c eq '$' && $repl) { - substr($_, $i, 0) = '\\'; - $i++; - $len++; - } - elsif ($c eq '[' && !$repl) { - $i++ if substr($_,$i,1) eq '^'; - $i++ if substr($_,$i,1) eq ']'; - $inbracket = 1; - } - elsif ($c eq ']') { - $inbracket = 0; - } - elsif ($c eq "\t") { - substr($_, $i, 1) = '\\t'; - $i++; - $len++; - } - elsif (!$repl && index("()+",$c) >= 0) { - substr($_, $i, 0) = '\\'; - $i++; - $len++; - } - } - &Die("Malformed substitution at line $.\n") - unless $end; - $pat = substr($_, 0, $repl + 1); - $repl = substr($_, $repl+1, $end-$repl-1); - $end = substr($_, $end + 1, 1000); - &simplify($pat); - $dol = '$'; - $subst = "$pat$repl$delim"; - $cmd = ''; - while ($end) { - if ($end =~ s/^g//) { - $subst .= 'g'; - next; - } - if ($end =~ s/^p//) { - $cmd .= ' && (print)'; - next; - } - if ($end =~ s/^w[ \t]*//) { - $fh = &make_filehandle($end); - $cmd .= " && (print $fh \$_)"; - $end = ''; - next; - } - &Die("Unrecognized substitution command". - "($end) at line $.\n"); - } - chop ($_ = &q(<<"EOT")); -: <<--#ifdef TSEEN -: $subst && \$tflag++$cmd; -: <<--#else -: $subst$cmd; -: <<--#endif -EOT - next; - } - - if (/^p/) { - $_ = 'print;'; - next; - } - - if (/^w/) { - s/^w[ \t]*//; - $fh = &make_filehandle($_); - $_ = "print $fh \$_;"; - next; - } - - if (/^r/) { - $appendseen++; - s/^r[ \t]*//; - $file = $_; - $_ = "\$atext .= `cat $file 2>/dev/null`;"; - next; - } - - if (/^P/) { - $_ = 'print $1 if /^(.*)/;'; - next; - } - - if (/^D/) { - chop($_ = &q(<<'EOT')); -: s/^.*\n?//; -: redo LINE if $_; -: next LINE; -EOT - $sawnext++; - next; - } - - if (/^N/) { - chop($_ = &q(<<'EOT')); -: $_ .= "\n"; -: $len1 = length; -: $_ .= <>; -: chop if $len1 < length; -: <<--#ifdef TSEEN -: $tflag = 0; -: <<--#endif -EOT - next; - } - - if (/^h/) { - $_ = '$hold = $_;'; - next; - } - - if (/^H/) { - $_ = '$hold .= "\n"; $hold .= $_;'; - next; - } - - if (/^g/) { - $_ = '$_ = $hold;'; - next; - } - - if (/^G/) { - $_ = '$_ .= "\n"; $_ .= $hold;'; - next; - } - - if (/^x/) { - $_ = '($_, $hold) = ($hold, $_);'; - next; - } - - if (/^b$/) { - $_ = 'next LINE;'; - $sawnext++; - next; - } - - if (/^b/) { - s/^b[ \t]*//; - $lab = &make_label($_); - if ($lab eq $toplabel) { - $_ = 'redo LINE;'; - } else { - $_ = "goto $lab;"; - } - next; - } - - if (/^t$/) { - $_ = 'next LINE if $tflag;'; - $sawnext++; - $tseen++; - next; - } - - if (/^t/) { - s/^t[ \t]*//; - $lab = &make_label($_); - $_ = q/if ($tflag) {$tflag = 0; /; - if ($lab eq $toplabel) { - $_ .= 'redo LINE;}'; - } else { - $_ .= "goto $lab;}"; - } - $tseen++; - next; - } - - if (/^y/) { - s/abcdefghijklmnopqrstuvwxyz/a-z/g; - s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g; - s/abcdef/a-f/g; - s/ABCDEF/A-F/g; - s/0123456789/0-9/g; - s/01234567/0-7/g; - $_ .= ';'; - } - - if (/^=/) { - $_ = 'print $.;'; - next; - } - - if (/^q/) { - chop($_ = &q(<<'EOT')); -: close(ARGV); -: @ARGV = (); -: next LINE; -EOT - $sawnext++; - next; - } - } continue { - if ($space) { - s/^/$space/; - s/(\n)(.)/$1$space$2/g; - } - last; - } - $_; -} - -sub fetchpat { - local($outer) = @_; - local($addr) = $outer; - local($inbracket); - local($prefix,$delim,$ch); - - # Process pattern one potential delimiter at a time. - - DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) { - $prefix = $1; - $delim = $2; - if ($delim eq '\\') { - s/(.)//; - $ch = $1; - $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/; - $ch = 'b' if $ch =~ /^[<>]$/; - $delim .= $ch; - } - elsif ($delim eq '[') { - $inbracket = 1; - s/^\^// && ($delim .= '^'); - s/^]// && ($delim .= ']'); - } - elsif ($delim eq ']') { - $inbracket = 0; - } - elsif ($inbracket || $delim ne $outer) { - $delim = '\\' . $delim; - } - $addr .= $prefix; - $addr .= $delim; - if ($delim eq $outer && !$inbracket) { - last DELIM; - } - } - $addr =~ s/\t/\\t/g; - &simplify($addr); - $addr; -} - -sub q { - local($string) = @_; - local($*) = 1; - $string =~ s/^:\t?//g; - $string; -} - -sub simplify { - $_[0] =~ s/_a-za-z0-9/\\w/ig; - $_[0] =~ s/a-z_a-z0-9/\\w/ig; - $_[0] =~ s/a-za-z_0-9/\\w/ig; - $_[0] =~ s/a-za-z0-9_/\\w/ig; - $_[0] =~ s/_0-9a-za-z/\\w/ig; - $_[0] =~ s/0-9_a-za-z/\\w/ig; - $_[0] =~ s/0-9a-z_a-z/\\w/ig; - $_[0] =~ s/0-9a-za-z_/\\w/ig; - $_[0] =~ s/\[\\w\]/\\w/g; - $_[0] =~ s/\[^\\w\]/\\W/g; - $_[0] =~ s/\[0-9\]/\\d/g; - $_[0] =~ s/\[^0-9\]/\\D/g; - $_[0] =~ s/\\d\\d\*/\\d+/g; - $_[0] =~ s/\\D\\D\*/\\D+/g; - $_[0] =~ s/\\w\\w\*/\\w+/g; - $_[0] =~ s/\\t\\t\*/\\t+/g; - $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g; - $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g; -} - -!NO!SUBS! -chmod 755 s2p -$eunicefix s2p -- cgit v1.2.1