-------------
+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 <mcook@cognex.com>
+ #Newsgroups: comp.lang.perl
+ #Subject: bug: print -$1
+ #Date: 01 Feb 1995 15:31:25 GMT
+ #Message-ID: <MCOOK.95Feb1103125@erawan.cognex.com>
+
+ $_ = "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) = <blurch*>;
+
+ than
+
+ $file = <blurch*>;
+
+ 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 <Tim.Bunce@ig.co.uk>
+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 <Tim.Bunce@ig.co.uk>
+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
-------------
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.
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
# $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$$ <<EOF
ARGGGHHHH!!!!!
Revision=''
Source=''
State=''
+ar=''
+archobjs=''
+exe_ext=''
+firstmakefile=''
+lib_ext=''
+obj_ext=''
+path_sep=''
afs=''
alignbytes=''
archlib=''
i_gdbm=''
i_grp=''
i_limits=''
+i_locale=''
i_malloc=''
i_math=''
i_memory=''
groupcat=''
hostcat=''
passcat=''
+d_oldarchlib=''
+oldarchlib=''
+oldarchlibexp=''
orderlib=''
ranlib=''
package=''
spackage=''
patchlevel=''
perladmin=''
+perlpath=''
prefix=''
prefixexp=''
installprivlib=''
scriptdirexp=''
selecttype=''
sig_name=''
-sig_max=''
sig_num=''
-d_sitelib=''
-installsitelib=''
-sitelib=''
-sitelibexp=''
+installsitearch=''
+sitearch=''
+sitearchexp=''
sizetype=''
so=''
sharpbang=''
shsharp=''
spitshell=''
ssizetype=''
+startperl=''
startsh=''
stdchar=''
sysman=''
EOF
: process the command line options
-set X `for arg in "$@"; do echo $arg; done | awk -f options.awk`
+set X `for arg in "$@"; do echo "X$arg"; done |
+ sed -e s/X// | awk -f options.awk`
eval "set $*"
shift
rm -f options.awk
for thisthing in \$dir/\$thing; do
: just loop through to pick last item
done
- if test -f \$thisthing; then
+ if test -f \$thisthing -a -r \$thisthing; then
echo \$thisthing
exit 0
elif test -f \$dir/\$thing.exe; then
echo $file is in $xxx.
;;
*)
- echo "I don't know where $file is. I hope it's in everyone's PATH."
+ echo "I don't know where '$file' is, and my life depends on it."
+ echo "Go find a public domain implementation or fix your PATH setting!"
+ exit 1
;;
esac
done
$test -d /usr/apollo/bin && osname=apollo
$test -f /etc/saf/_sactab && osname=svr4
$test -d /usr/include/minix && osname=minix
- $test -d /MachTen && osname=machten && \
- osvers=`/usr/etc/version | $awk '{print $2}' | \
- $sed -e 's/[A-Za-z]$//'`
+ if $test -d /MachTen; then
+ osname=machten
+ if $test -x /sbin/version; then
+ osvers=`/sbin/version | $awk '{print $2}' |
+ $sed -e 's/[A-Za-z]$//'`
+ elif $test -x /usr/etc/version; then
+ osvers=`/usr/etc/version | $awk '{print $2}' |
+ $sed -e 's/[A-Za-z]$//'`
+ else
+ osvers="$2.$3"
+ fi
+ fi
if $test -f $uname; then
set X $myuname
shift
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 <<EOM
-
-Some systems have different model sizes. On most systems they are called
-small, medium, large, and huge. On the PDP11 they are called unsplit and
-split. If your system doesn't support different memory models, say "none".
-If you wish to force everything to one memory model, say "none" here and
-put the appropriate flags later when it asks you for other cc and ld flags.
-Venix systems may wish to put "none" and let the compiler figure things out.
-(In the following question multiple model names should be space separated.)
-
-EOM
-rp="Which memory models are supported?"
-. ./myread
-models="$ans"
-case "$models" in
-none)
- small=''
- medium=''
- large=''
- huge=''
- unsplit=''
- split=''
+: set up shell script to do ~ expansion
+cat >filexp <<EOSS
+$startsh
+: expand filename
+case "\$1" in
+ ~/*|~)
+ echo \$1 | $sed "s|~|\${HOME-\$LOGDIR}|"
;;
-*split)
- case "$split" in
- '') if $contains '\-i' $sysman/ld.1 >/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 '}' </etc/passwd\`
+ if $test ! -d "\$dir"; then
+ me=\`basename \$0\`
+ echo "\$me: can't locate home directory for: \$name" >&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 <<EOM
-#include <stdio.h>
-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 <<EOSS
-$startsh
-: expand filename
-case "\$1" in
- ~/*|~)
- echo \$1 | $sed "s|~|\${HOME-\$LOGDIR}|"
- ;;
- ~*)
- 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 '}' </etc/passwd\`
- if $test ! -d "\$dir"; then
- me=\`basename \$0\`
- echo "\$me: can't locate home directory for: \$name" >&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
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 <<EOM
-: see how we invoke the C preprocessor
-echo " "
-echo "Now, how can we feed standard input to your C preprocessor..." >&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.c >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.c >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.c >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.c >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.c >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.c >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.c >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.c >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.c >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.c >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.c >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 <<EOM
-
-By default, $package will be installed in $dflt/bin, manual
-pages under $dflt/man, etc..., i.e. with $dflt as prefix for
-all installation directories. Typically set to /usr/local, but you
-may choose /usr if you wish to install $package among your system
-binaries. If you wish to have binaries under /bin but manual pages
-under /usr/local/man, that's ok: you will be prompted separately
-for each of the installation directories, the prefix being only used
-to set the defaults.
+By default, $package will be installed in $dflt/bin, manual
+pages under $dflt/man, etc..., i.e. with $dflt as prefix for
+all installation directories. Typically set to /usr/local, but you
+may choose /usr if you wish to install $package among your system
+binaries. If you wish to have binaries under /bin but manual pages
+under /usr/local/man, that's ok: you will be prompted separately
+for each of the installation directories, the prefix being only used
+to set the defaults.
EOM
fn=d~
esac;;
esac'
-: 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 "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 <<EOM
+
+There are some auxiliary files for $package that need to be put into a
+private library directory that is accessible by everyone.
+
+EOM
+fn=d~+
+rp='Pathname where the private library files will reside?'
. ./getfile
-if $test "X$ansexp" != "X$binexp"; then
- installbin=''
+if $test "X$privlibexp" != "X$ansexp"; then
+ installprivlib=''
fi
-bin="$ans"
-binexp="$ansexp"
+privlib="$ans"
+privlibexp="$ansexp"
if $afs; then
$cat <<EOM
Since you are running AFS, I need to distinguish the directory in which
-executables reside from the directory in which they are installed (and from
+private files reside from the directory in which they are installed (and from
which they are presumably copied to the former directory by occult means).
EOM
- case "$installbin" in
- '') dflt=`echo $binexp | sed 's#^/afs/#/afs/.#'`;;
- *) dflt="$installbin";;
+ case "$installprivlib" in
+ '') dflt=`echo $privlibexp | sed 's#^/afs/#/afs/.#'`;;
+ *) dflt="$installprivlib";;
esac
fn=de~
- rp='Where will public executables be installed?'
+ rp='Where will private files be installed?'
. ./getfile
- installbin="$ans"
+ installprivlib="$ans"
else
- installbin="$binexp"
+ installprivlib="$privlibexp"
+fi
+
+: 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.)"
: set the prefixup variable, to restore leading tilda escape
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 <<EOM
-
-Some installations have a separate directory just for executable scripts so
-that they can mount it across multiple architectures but keep the scripts in
-one spot. You might, for example, have a subdirectory of /usr/share for this.
-Or you might just lump your scripts in with all your other executables.
-
+cat <<EOM
+
+$spackage contains architecture-dependent library files. If you are
+sharing libraries in a heterogeneous environment, you might store
+these files in a separate location. Otherwise, you can just include
+them with the rest of the public library files.
+
EOM
-fn=d~
-rp='Where do you keep publicly executable scripts?'
+fn=d+~
+rp='Where do you want to put the public architecture-dependent libraries?'
. ./getfile
-if $test "X$ansexp" != "X$scriptdirexp"; then
- installscript=''
-fi
-scriptdir="$ans"
-scriptdirexp="$ansexp"
+archlib="$ans"
+archlibexp="$ansexp"
+
if $afs; then
$cat <<EOM
Since you are running AFS, I need to distinguish the directory in which
-scripts reside from the directory in which they are installed (and from
+private files reside from the directory in which they are installed (and from
which they are presumably copied to the former directory by occult means).
EOM
- case "$installscript" in
- '') dflt=`echo $scriptdirexp | sed 's#^/afs/#/afs/.#'`;;
- *) dflt="$installscript";;
+ case "$installarchlib" in
+ '') dflt=`echo $archlibexp | sed 's#^/afs/#/afs/.#'`;;
+ *) dflt="$installarchlib";;
esac
fn=de~
- rp='Where will public scripts be installed?'
+ rp='Where will architecture-dependent library files be installed?'
. ./getfile
- installscript="$ans"
+ installarchlib="$ans"
else
- installscript="$scriptdirexp"
+ installarchlib="$archlibexp"
+fi
+if $test X"$archlib" = X"$privlib"; then
+ d_archlib="$undef"
+else
+ d_archlib="$define"
fi
-: determine where private executables go
-set dflt privlib lib/$package
+: determine where site specific architecture-dependent libraries go.
+
+set dflt sitearch lib/site_perl/$archname
eval $prefixit
$cat <<EOM
-There are some auxiliary files for $package that need to be put into a
-private library directory that is accessible by everyone.
+The installation process will also create a directory for
+architecture-dependent site-specific extensions and modules.
EOM
-fn=d~+
-rp='Pathname where the private library files will reside?'
+fn=nd~+
+rp='Pathname for the site-specific architecture-dependent library files?'
. ./getfile
-if $test "X$privlibexp" != "X$ansexp"; then
- installprivlib=''
+if $test "X$sitearchexp" != "X$ansexp"; then
+ installsitearch=''
fi
-privlib="$ans"
-privlibexp="$ansexp"
+sitearch="$ans"
+sitearchexp="$ansexp"
if $afs; then
$cat <<EOM
which they are presumably copied to the former directory by occult means).
EOM
- case "$installprivlib" in
- '') dflt=`echo $privlibexp | sed 's#^/afs/#/afs/.#'`;;
- *) dflt="$installprivlib";;
+ case "$installsitearch" in
+ '') dflt=`echo $sitearchexp | sed 's#^/afs/#/afs/.#'`;;
+ *) dflt="$installsitearch";;
esac
fn=de~
rp='Where will private files be installed?'
. ./getfile
- installprivlib="$ans"
+ installsitearch="$ans"
else
- installprivlib="$privlibexp"
+ installsitearch="$sitearchexp"
fi
-: determine the architecture name
+: set up the script used to warn in case of inconsistency
+cat <<'EOSC' >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 <<EOM
-$spackage contains architecture-dependent library files. If you are
-sharing libraries in a heterogeneous environment, you might store
-these files in a separate location. Otherwise, you can just include
-them with the rest of the public library files.
+In 5.001, Perl stored architecutre-dependent library files in a library
+with a name such as $privlib/$archname,
+and this directory contained files from the standard extensions and
+files from any additional extensions you might have added. Starting
+with version 5.002, all the architecture-dependent standard extensions
+will go into $archlib,
+while locally-added extensions will go into
+$sitearch.
+
+If you wish Perl to continue to search the old architecture-dependent
+library for your local extensions, give the path to that directory.
+If you do not wish to use your old architecture-dependent library
+files, answer 'none'.
EOM
-fn=d~
-rp='Where do you want to put the public architecture-dependent libraries?'
+fn=dn~
+rp='Directory for your old 5.001 architecture-dependent libraries?'
. ./getfile
-archlib="$ans"
-archlibexp="$ansexp"
+oldarchlib="$ans"
+oldarchlibexp="$ansexp"
+case "$oldarchlib" in
+''|' ') val="$undef" ;;
+*) val="$define" ;;
+esac
+set d_oldarchlib
+eval $setvar
+: determine where public executables go
+echo " "
+set dflt bin bin
+eval $prefixit
+fn=d~
+rp='Pathname where the public executables will reside?'
+. ./getfile
+if $test "X$ansexp" != "X$binexp"; then
+ installbin=''
+fi
+bin="$ans"
+binexp="$ansexp"
if $afs; then
$cat <<EOM
Since you are running AFS, I need to distinguish the directory in which
-private files reside from the directory in which they are installed (and from
+executables reside from the directory in which they are installed (and from
which they are presumably copied to the former directory by occult means).
EOM
- case "$installarchlib" in
- '') dflt=`echo $archlibexp | sed 's#^/afs/#/afs/.#'`;;
- *) dflt="$installarchlib";;
+ case "$installbin" in
+ '') dflt=`echo $binexp | sed 's#^/afs/#/afs/.#'`;;
+ *) dflt="$installbin";;
esac
fn=de~
- rp='Where will architecture-dependent library files be installed?'
+ rp='Where will public executables be installed?'
. ./getfile
- installarchlib="$ans"
-else
- installarchlib="$archlibexp"
-fi
-if $test X"$archlib" = X"$privlib"; then
- d_archlib="$undef"
+ installbin="$ans"
else
- d_archlib="$define"
+ installbin="$binexp"
fi
-: determine whether the user wants to include a site-specific library
-: in addition to privlib.
-$cat <<EOM
-
-Some sites may wish to specify a local directory for $package
-to search by default in addition to $privlib.
-If you don't want to use such an additional directory, answer 'none'.
-
-EOM
-case "$sitelib" in
-'') dflt=none ;;
-*) dflt="$sitelib" ;;
+: determine where manual pages are on this system
+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`
+ ;;
esac
-fn=d~+n
-rp='Local directory for additional library files?'
-. ./getfile
-if $test "X$sitelibexp" != "X$ansexp"; then
- installsitelib=''
-fi
-sitelib="$ans"
-sitelibexp="$ansexp"
-if $afs; then
- case "$sitelib" in
- '') installsitelib="$sitelibexp"
- ;;
- *) $cat <<EOM
-
-Since you are running AFS, I need to distinguish the directory in which
-private files reside from the directory in which they are installed (and from
-which they are presumably copied to the former directory by occult means).
-
-EOM
- case "$installsitelib" in
- '') dflt=`echo $sitelibexp | sed 's#^/afs/#/afs/.#'`;;
- *) dflt="$installsitelib";;
- esac
- fn=de~
- rp='Where will additional local files be installed?'
- . ./getfile
- installsitelib="$ans"
- ;;
- esac
+if $test -d "$sysman"; then
+ echo "System manual is in $sysman." >&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
;;
esac
echo " "
-fn=dn~
+fn=dn+~
rp="Where do the main $spackage manual pages (source) go?"
. ./getfile
if test "X$man1direxp" != "X$ansexp"; then
;;
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$$"
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
;;
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 <<EOM
+
+Some installations have a separate directory just for executable scripts so
+that they can mount it across multiple architectures but keep the scripts in
+one spot. You might, for example, have a subdirectory of /usr/share for this.
+Or you might just lump your scripts in with all your other executables.
+
+EOM
+fn=d~
+rp='Where do you keep publicly executable scripts?'
+. ./getfile
+if $test "X$ansexp" != "X$scriptdirexp"; then
+ installscript=''
fi
-: you do not want to know about this
-set $myhostname
-myhostname=$1
+scriptdir="$ans"
+scriptdirexp="$ansexp"
+if $afs; then
+ $cat <<EOM
-: verify guess
-if $test "$myhostname" ; then
- dflt=y
- rp='Your host name appears to be "'$myhostname'".'" Right?"
- . ./myread
- case "$ans" in
- y*) ;;
- *) myhostname='';;
+Since you are running AFS, I need to distinguish the directory in which
+scripts reside from the directory in which they are installed (and from
+which they are presumably copied to the former directory by occult means).
+
+EOM
+ case "$installscript" in
+ '') dflt=`echo $scriptdirexp | sed 's#^/afs/#/afs/.#'`;;
+ *) dflt="$installscript";;
esac
+ fn=de~
+ rp='Where will public scripts be installed?'
+ . ./getfile
+ installscript="$ans"
+else
+ installscript="$scriptdirexp"
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]'`
- ;;
-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
-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 <<EOM
+: figure out how to guarantee perl startup
+case "$startperl" in
+'')
+ case "$sharpbang" in
+ *!)
+ $cat <<EOH
-I need to get your e-mail address in Internet format if possible, i.e.
-something like user@host.domain. Please answer accurately since I have
-no easy means to double check it. The default value provided below
-is most probably close to the reality but may not be valid from outside
-your organization...
+I can use the #! construct to start perl on your system. This will
+make startup of perl scripts faster, but may cause problems if you
+want to share those scripts and perl is not in a standard place
+($perlpath) on all your platforms. The alternative is to force
+a shell by starting the script with a single ':' character.
-EOM
-cont=x
-while test "$cont"; do
- case "$cf_email" in
- '') dflt="$cf_by@$myhostname$mydomain";;
- *) dflt="$cf_email";;
- esac
- rp='What is your e-mail address?'
- . ./myread
- cf_email="$ans"
- case "$cf_email" in
- *@*.*) cont='' ;;
- *)
- rp='Address does not look like an Internet one. Use it anyway?'
- case "$fastread" in
- yes) dflt=y ;;
- *) dflt=n ;;
- esac
+EOH
+ dflt=y
+ rp='Shall I use #! to start up perl?'
. ./myread
case "$ans" in
- y*) cont='' ;;
- *) echo " " ;;
+ y*|Y*) startperl="#!$perlpath";;
+ *) startperl=": # use perl";;
esac
;;
+ *) startperl=": # use perl"
+ ;;
esac
-done
-
-$cat <<EOM
-
-If you or somebody else will be maintaining perl at your site, please
-fill in the correct e-mail address here so that they may be contacted
-if necessary. Currently, the "perlbug" program included with perl
-will send mail to this address in addition to perlbug@perl.com. You may
-enter "none" for no administrator.
+ ;;
+esac
+echo "I'll use $startperl to start perl scripts."
-EOM
-case "$perladmin" in
-'') dflt="$cf_email";;
-*) dflt="$perladmin";;
-esac
-rp='Perl administrator e-mail address'
-. ./myread
-perladmin="$ans"
-
-
-: determine optimize, if desired, or use for debug flag also
-case "$optimize" in
-' ') dflt='none';;
-'') dflt='-O';;
-*) dflt="$optimize";;
+: 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";;
esac
-$cat <<EOH
-
-Some C compilers have problems with their optimizers, by default, $package
-compiles with the -O flag to use the optimizer. Alternately, you might want
-to use the symbolic debugger, which uses the -g flag (on traditional Unix
-systems). Either flag can be specified here. To use neither flag, specify
-the word "none".
+$cat <<EOM
+
+Some systems have different model sizes. On most systems they are called
+small, medium, large, and huge. On the PDP11 they are called unsplit and
+split. If your system doesn't support different memory models, say "none".
+If you wish to force everything to one memory model, say "none" here and
+put the appropriate flags later when it asks you for other cc and ld flags.
+Venix systems may wish to put "none" and let the compiler figure things out.
+(In the following question multiple model names should be space separated.)
-EOH
-rp="What optimizer/debugger flag should be used?"
+EOM
+rp="Which memory models are supported?"
. ./myread
-optimize="$ans"
-case "$optimize" in
-'none') optimize=" ";;
-esac
+models="$ans"
-dflt=''
-case "$ccflags" in
-'')
- case "$gccversion" in
- 1*) dflt='-fpcc-struct-return' ;;
+case "$models" in
+none)
+ small=''
+ medium=''
+ large=''
+ huge=''
+ unsplit=''
+ split=''
+ ;;
+*split)
+ case "$split" in
+ '') if $contains '\-i' $sysman/ld.1 >/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 <<EOH
-
-Your C compiler may want other flags. For this question you should include
--I/whatever and -DWHATEVER flags and any other flags used by the C compiler,
-but you should NOT include libraries or ld flags like -lwhatever. If you
-want $package to honor its debug switch, you should include -DDEBUGGING here.
-Your C compiler might also need additional flags, such as -D_POSIX_SOURCE,
--DHIDEMYMALLOC or -DCRIPPLED_CC.
-
-To use no flags, specify the word "none".
-
-EOH
-set X $dflt
-shift
-dflt=${1+"$@"}
-rp="Any additional cc flags?"
-. ./myread
-case "$ans" in
-none) ccflags='';;
-*) ccflags="$ans";;
-esac
-
-: the following weeds options from ccflags that are of no interest to cpp
-cppflags="$ccflags"
-case "$gccversion" in
-1*) cppflags="$cppflags -D__GNUC__"
-esac
-case "$mips_type" in
-'');;
-*BSD*) cppflags="$cppflags -DSYSTYPE_BSD43";;
-esac
-case "$cppflags" in
-'');;
+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 "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 <cpp.c \
- >cpp1.out 2>/dev/null && \
- $cpprun -DLFRULB=bar $ftry $cpplast <cpp.c \
- >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 <<EOH
-
-Your C linker may need flags. For this question you should
-include -L/whatever and any other flags used by the C linker, but you
-should NOT include libraries like -lwhatever.
-
-Make sure you include the appropriate -L/path flags if your C linker
-does not normally search all of the directories you specified above,
-namely
- $libpth
-To use no flags, specify the word "none".
-
-EOH
-
-rp="Any additional ld flags (NOT including libraries)?"
-. ./myread
-case "$ans" in
-none) ldflags='';;
-*) ldflags="$ans";;
-esac
-rmlist="$rmlist pdp11"
+fi
+chmod +x bsd usg v7 osf1 eunice xenix venix
+$eunicefix bsd usg v7 osf1 eunice xenix venix
+$rm -f foo
-: coherency check
+: see if we need a special compiler
echo " "
-echo "Checking your choice of C compiler and flags for coherency..." >&4
-set X $cc $optimize $ccflags $ldflags try.c -o try
-shift
-$cat >try.msg <<EOM
-I've tried to compile and run a simple program with:
-
- $*
- ./try
-
-and I got the following output:
+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
-$cat > try.c <<'EOF'
-#include <stdio.h>
-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 <<EOM
+#include <stdio.h>
+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 <<EOM
-
-On some systems, shared libraries may be available. Answer 'none' if
-you want to suppress searching of shared libraries for the remaining
-of this configuration.
-
-EOM
-rp='What is the file extension used for shared libraries?'
-. ./myread
-so="$ans"
-
-: Looking for optional libraries
+: What should the include directory be ?
echo " "
-echo "Checking for optional libraries..." >&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 <<EOM
-
-Some versions of Unix support shared libraries, which make executables smaller
-but make load time slightly longer.
-
-On some systems, mostly newer Unix System V's, the shared library is included
-by putting the option "-lc_s" as the last thing on the cc command line when
-linking. Other systems use shared libraries by default. There may be other
-libraries needed to compile $package on your machine as well. If your system
-needs the "-lc_s" option, include it here. Include any other special libraries
-here as well. Say "none" for none.
-EOM
-
+ $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 " "
-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 <<EOM
-
-I can use 'nm' to extract the symbols from your C libraries. This is a time
-consuming task which may generate huge output on the disk (up to 3 megabytes)
-but that should make the symbols extraction faster. The alternative is to skip
-the 'nm' extraction part and to compile a small test program instead to
-determine whether each symbol is present. If you have a fast C compiler and/or
-if your 'nm' output cannot be parsed, this may be the best solution.
-
-EOM
-rp='Shall I use nm to extract C symbols from the libraries?'
-. ./myread
-case "$ans" in
-n|N) usenm=false;;
-*) usenm=true;;
-esac
-
-runnm=$usenm
-case "$reuseval" in
-true) runnm=false;;
-esac
-
-: nm options which may be necessary
-case "$nm_opt" in
-'') if $test -f /mach_boot; then
- nm_opt=''
- elif $test -d /usr/ccs/lib; then
- nm_opt='-p'
- elif $test -f /dgux; then
- nm_opt='-p'
- else
- nm_opt=''
- fi;;
-esac
-case "$runnm" in
-true)
-: get list of predefined functions in a handy place
+: see how we invoke the C preprocessor
echo " "
-case "$libc" in
-'') libc=unknown
- case "$libs" in
- *-lc_s*) libc=`./loc libc_s.a $libc $libpth`
- esac
- ;;
-esac
-libnames='';
-case "$libs" in
-'') ;;
-*) for thislib in $libs; do
- case "$thislib" in
- -lc|-lc_s)
- : Handle C library specially below.
- ;;
- -l*)
- thislib=`echo $thislib | $sed -e 's/^-l//'`
- if try=`./loc lib$thislib.$so.'*' X $libpth`; $test -f "$try"; then
- :
- 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
- :
+echo "Now, how can we feed standard input to your C preprocessor..." >&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.c >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.c >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.c >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.c >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.c >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.c >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.c >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.c >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.c >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.c >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.c >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 <<EOH
+
+Some C compilers have problems with their optimizers, by default, $package
+compiles with the -O flag to use the optimizer. Alternately, you might want
+to use the symbolic debugger, which uses the -g flag (on traditional Unix
+systems). Either flag can be specified here. To use neither flag, specify
+the word "none".
+
+EOH
+rp="What optimizer/debugger flag should be used?"
+. ./myread
+optimize="$ans"
+case "$optimize" in
+'none') optimize=" ";;
+esac
+
+dflt=''
+case "$ccflags" in
+'')
+ case "$gccversion" in
+ 1*) dflt='-fpcc-struct-return' ;;
+ esac
+ case "$optimize" in
+ *-g*) dflt="$dflt -DDEBUGGING";;
+ 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
+ ;;
+ 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 <<EOH
+
+Your C compiler may want other flags. For this question you should include
+-I/whatever and -DWHATEVER flags and any other flags used by the C compiler,
+but you should NOT include libraries or ld flags like -lwhatever. If you
+want $package to honor its debug switch, you should include -DDEBUGGING here.
+Your C compiler might also need additional flags, such as -D_POSIX_SOURCE,
+-DHIDEMYMALLOC or -DCRIPPLED_CC.
+
+To use no flags, specify the word "none".
+
+EOH
+set X $dflt
+shift
+dflt=${1+"$@"}
+rp="Any additional cc flags?"
+. ./myread
+case "$ans" in
+none) ccflags='';;
+*) ccflags="$ans";;
+esac
+
+: the following weeds options from ccflags that are of no interest to cpp
+cppflags="$ccflags"
+case "$gccversion" in
+1*) cppflags="$cppflags -D__GNUC__"
+esac
+case "$mips_type" in
+'');;
+*BSD*) cppflags="$cppflags -DSYSTYPE_BSD43";;
+esac
+case "$cppflags" in
+'');;
+*)
+ 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 <cpp.c \
+ >cpp1.out 2>/dev/null && \
+ $cpprun -DLFRULB=bar $ftry $cpplast <cpp.c \
+ >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 <<EOH
+
+Your C linker may need flags. For this question you should
+include -L/whatever and any other flags used by the C linker, but you
+should NOT include libraries like -lwhatever.
+
+Make sure you include the appropriate -L/path flags if your C linker
+does not normally search all of the directories you specified above,
+namely
+ $libpth
+To use no flags, specify the word "none".
+
+EOH
+
+rp="Any additional ld flags (NOT including libraries)?"
+. ./myread
+case "$ans" in
+none) ldflags='';;
+*) ldflags="$ans";;
+esac
+rmlist="$rmlist pdp11"
+
+: coherency check
+echo " "
+echo "Checking your choice of C compiler and flags for coherency..." >&4
+set X $cc $optimize $ccflags $ldflags try.c -o try
+shift
+$cat >try.msg <<EOM
+I've tried to compile and run a simple program with:
+
+ $*
+ ./try
+
+and I got the following output:
+
+EOM
+$cat > try.c <<'EOF'
+#include <stdio.h>
+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 <<EOM
+
+On some systems, shared libraries may be available. Answer 'none' if
+you want to suppress searching of shared libraries for the remaining
+of this configuration.
+
+EOM
+rp='What is the file extension used for shared libraries?'
+. ./myread
+so="$ans"
+
+: Looking for optional libraries
+echo " "
+echo "Checking for optional libraries..." >&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 <<EOM
+
+Some versions of Unix support shared libraries, which make executables smaller
+but make load time slightly longer.
+
+On some systems, mostly newer Unix System V's, the shared library is included
+by putting the option "-lc_s" as the last thing on the cc command line when
+linking. Other systems use shared libraries by default. There may be other
+libraries needed to compile $package on your machine as well. If your system
+needs the "-lc_s" option, include it here. Include any other special libraries
+here as well. Say "none" for none.
+EOM
+
+echo " "
+rp="Any additional libraries?"
+. ./myread
+case "$ans" in
+none) libs=' ';;
+*) libs="$ans";;
+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 "$usenm" in
+ true) dflt=y;;
+ *) dflt=n;;
+ esac
+ ;;
+esac
+$cat <<EOM
+
+I can use 'nm' to extract the symbols from your C libraries. This is a time
+consuming task which may generate huge output on the disk (up to 3 megabytes)
+but that should make the symbols extraction faster. The alternative is to skip
+the 'nm' extraction part and to compile a small test program instead to
+determine whether each symbol is present. If you have a fast C compiler and/or
+if your 'nm' output cannot be parsed, this may be the best solution.
+
+EOM
+rp='Shall I use nm to extract C symbols from the libraries?'
+. ./myread
+case "$ans" in
+n|N) usenm=false;;
+*) usenm=true;;
+esac
+
+runnm=$usenm
+case "$reuseval" in
+true) runnm=false;;
+esac
+
+: nm options which may be necessary
+case "$nm_opt" in
+'') if $test -f /mach_boot; then
+ nm_opt=''
+ elif $test -d /usr/ccs/lib; then
+ nm_opt='-p'
+ elif $test -f /dgux; then
+ nm_opt='-p'
+ else
+ nm_opt=''
+ fi;;
+esac
+
+case "$runnm" in
+true)
+: get list of predefined functions in a handy place
+echo " "
+case "$libc" in
+'') libc=unknown
+ case "$libs" in
+ *-lc_s*) libc=`./loc libc_s.a $libc $libpth`
+ esac
+ ;;
+esac
+libnames='';
+case "$libs" in
+'') ;;
+*) for thislib in $libs; do
+ case "$thislib" in
+ -lc|-lc_s)
+ : Handle C library specially below.
+ ;;
+ -l*)
+ thislib=`echo $thislib | $sed -e 's/^-l//'`
+ if try=`./loc lib$thislib.$so.'*' X $libpth`; $test -f "$try"; then
+ :
+ 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
+ try=''
+ 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
$test -r $1 || set /usr/shlib/libc.$so
$test -r $1 || \
set `echo blurfl; echo /usr/lib/libc.$so.[0-9]* | \
#include <errno.h>
#include <sys/types.h>
#include <signal.h>
+#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];
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);
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 <<EOM
-#$i_dirent I_DIRENT /**/
-#$i_sysdir I_SYS_DIR /**/
-#$i_sysndir I_SYS_NDIR /**/
-
-#if defined(I_DIRENT)
-#include <dirent.h>
-#if defined(NeXT) && defined(I_SYS_DIR) /* NeXT needs dirent + sys/dir.h */
-#include <sys/dir.h>
-#endif
-#else
-#ifdef I_SYS_NDIR
-#include <sys/ndir.h>
-#else
-#ifdef I_SYS_DIR
-#ifdef hp9000s500
-#include <ndir.h> /* may be wrong in the future */
-#else
-#include <sys/dir.h>
-#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 <stdio.h>
-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.c >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 <<EOM
-Hmm, I don't seem to be able to catenate tokens with your cpp. You're going
-to have to edit the values of CAT[2-5] in config.h...
+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
- cpp_stuff="/* Help! How do we handle cpp_stuff? */*/"
+ 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
-$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 <<EOCP
-#$d_const HASCONST
-#ifndef HASCONST
-#define const
-#endif
-#include <sys/types.h>
-#include <db.h>
-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 <<EOCP
-#$d_const HASCONST
-#ifndef HASCONST
-#define const
+ echo "Checking whether closedir() returns a status..." >&4
+ cat > closedir.c <<EOM
+#$i_dirent I_DIRENT /**/
+#$i_sysdir I_SYS_DIR /**/
+#$i_sysndir I_SYS_NDIR /**/
+
+#if defined(I_DIRENT)
+#include <dirent.h>
+#if defined(NeXT) && defined(I_SYS_DIR) /* NeXT needs dirent + sys/dir.h */
+#include <sys/dir.h>
#endif
-#include <sys/types.h>
-#include <db.h>
-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 <sys/ndir.h>
+#else
+#ifdef I_SYS_DIR
+#ifdef hp9000s500
+#include <ndir.h> /* may be wrong in the future */
+#else
+#include <sys/dir.h>
+#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 <<EOM
- Support flag bits are:
- 1: basic void declarations.
- 2: arrays of pointers to functions returning void.
- 4: operations between pointers to and addresses of void functions.
- 8: generic void pointers.
-EOM
+set d_void_closedir
+eval $setvar
+$rm -f closedir*
+: check for volatile keyword
echo " "
-case "$voidflags" in
-'')
- $cat >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 <dbm.h>"
- 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 <ndbm.h>"
- ;;
- 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 <gdbm.h>"
+: 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 <stdio.h>
+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 <<EOM
-A number of extensions are supplied with $package. You may choose to
-compile these extensions for dynamic loading (the default), compile
-them into the $package executable (static loading), or not include
-them at all. Answer "none" to include no extensions.
-
+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.c >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 <<EOM
+Hmm, I don't seem to be able to catenate tokens with your cpp. You're going
+to have to edit the values of CAT[2-5] in config.h...
EOM
- case "$dynamic_ext" in
- '') dflt="$avail_ext" ;;
- *) dflt="$dynamic_ext" ;;
- esac
- case "$dflt" in
- '') dflt=none;;
- esac
- rp="What extensions do you wish to load dynamically?"
- . ./myread
- case "$ans" in
- none) dynamic_ext=' ' ;;
- *) dynamic_ext="$ans" ;;
- esac
+ cpp_stuff="/* Help! How do we handle cpp_stuff? */*/"
+fi
+$rm -f cpp_stuff.*
- case "$static_ext" in
- '')
- : Exclude those already listed in dynamic linking
- dflt=''
- for xxx in $avail_ext; do
- case " $dynamic_ext " in
- *" $xxx "*) ;;
- *) dflt="$dflt $xxx" ;;
- esac
- done
- set X $dflt
- shift
- dflt="$*"
- ;;
- *) dflt="$static_ext"
- ;;
- esac
+: see if this is a db.h system
+set db.h i_db
+eval $inhdr
+
+case "$i_db" in
+define)
+ : Check the return type needed for hash
+ echo " "
+ echo "Checking return type needed for hash for Berkeley DB ..." >&4
+ $cat >try.c <<EOCP
+#$d_const HASCONST
+#ifndef HASCONST
+#define const
+#endif
+#include <sys/types.h>
+#include <db.h>
+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 <<EOCP
+#$d_const HASCONST
+#ifndef HASCONST
+#define const
+#endif
+#include <sys/types.h>
+#include <db.h>
+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 <<EOM
-A number of extensions are supplied with $package. Answer "none"
-to include no extensions.
+*) db_prefixtype='int'
+ ;;
+esac
+: check for void type
+echo " "
+echo "Checking to see how well your C compiler groks the void type..." >&4
+echo " "
+$cat >&4 <<EOM
+ Support flag bits are:
+ 1: basic void declarations.
+ 2: arrays of pointers to functions returning void.
+ 4: operations between pointers to and addresses of void functions.
+ 8: generic void pointers.
EOM
- case "$static_ext" in
- '') dflt="$avail_ext" ;;
- *) dflt="$static_ext" ;;
- esac
+echo " "
+case "$voidflags" in
+'')
+ $cat >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
. ./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
: 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 <signal.h>' |
$cppstdin $cppminus $cppflags 2>/dev/null |
$grep '^[ ]*#.*include' |
'') 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.
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 <signal.h>\n";
- printf "main() {\n";
-}
+$cat > signal.c <<'EOP'
+#include <sys/types.h>
+#include <signal.h>
+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";
END {
printf "}\n";
}
-' >signal.c
-$cat >signal.cmd <<EOS
+' >>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 <<EOS
$startsh
$test -s signal.lst && exit 0
if $cc $ccflags signal.c -o signal $ldflags >/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
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:"
}
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
*) 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 <dbm.h>"
+ 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=''
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
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 <ndbm.h>"
+ ;;
+ esac
+ ;;
+esac
+val="$t_ndbm"
+set i_ndbm
+eval $setvar
+
: see if net/errno.h is available
val=''
set net/errno.h val
;;
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 <gdbm.h>"
+ ;;
+ 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 <<EOM
+A number of extensions are supplied with $package. You may choose to
+compile these extensions for dynamic loading (the default), compile
+them into the $package executable (static loading), or not include
+them at all. Answer "none" to include no extensions.
+
+EOM
+ case "$dynamic_ext" in
+ '') dflt="$avail_ext" ;;
+ *) dflt="$dynamic_ext" ;;
+ esac
+ case "$dflt" in
+ '') dflt=none;;
+ esac
+ rp="What extensions do you wish to load dynamically?"
+ . ./myread
+ case "$ans" in
+ none) dynamic_ext=' ' ;;
+ *) dynamic_ext="$ans" ;;
+ esac
+
+ case "$static_ext" in
+ '')
+ : Exclude those already listed in dynamic linking
+ dflt=''
+ for xxx in $avail_ext; do
+ case " $dynamic_ext " in
+ *" $xxx "*) ;;
+ *) dflt="$dflt $xxx" ;;
+ esac
+ done
+ set X $dflt
+ shift
+ dflt="$*"
+ ;;
+ *) dflt="$static_ext"
+ ;;
+ 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
+ ;;
+*)
+ $cat <<EOM
+A number of extensions are supplied with $package. Answer "none"
+to include no extensions.
+
+EOM
+ case "$static_ext" in
+ '') dflt="$avail_ext" ;;
+ *) dflt="$static_ext" ;;
+ esac
+
+ case "$dflt" in
+ '') dflt=none;;
+ esac
+ rp="What extensions do you wish to include?"
+ . ./myread
+ case "$ans" in
+ none) static_ext=' ' ;;
+ *) static_ext="$ans" ;;
+ esac
+ ;;
+esac
+
+set X $dynamic_ext $static_ext
+shift
+extensions="$*"
+
+$cat <<EOM
+
+I need to get your e-mail address in Internet format if possible, i.e.
+something like user@host.domain. Please answer accurately since I have
+no easy means to double check it. The default value provided below
+is most probably close to the reality but may not be valid from outside
+your organization...
+
+EOM
+cont=x
+while test "$cont"; do
+ case "$cf_email" in
+ '') dflt="$cf_by@$myhostname$mydomain";;
+ *) dflt="$cf_email";;
+ esac
+ rp='What is your e-mail address?'
+ . ./myread
+ cf_email="$ans"
+ case "$cf_email" in
+ *@*.*) cont='' ;;
+ *)
+ rp='Address does not look like an Internet one. Use it anyway?'
+ case "$fastread" in
+ yes) dflt=y ;;
+ *) dflt=n ;;
+ esac
+ . ./myread
+ case "$ans" in
+ y*) cont='' ;;
+ *) echo " " ;;
+ esac
+ ;;
+ esac
+done
+
+$cat <<EOM
+
+If you or somebody else will be maintaining perl at your site, please
+fill in the correct e-mail address here so that they may be contacted
+if necessary. Currently, the "perlbug" program included with perl
+will send mail to this address in addition to perlbug@perl.com. You may
+enter "none" for no administrator.
+
+EOM
+case "$perladmin" in
+'') dflt="$cf_email";;
+*) dflt="$perladmin";;
+esac
+rp='Perl administrator e-mail address'
+. ./myread
+perladmin="$ans"
+
: Remove build directory name from cppstdin so it can be used from
: either the present location or the final installed location.
echo " "
afs='$afs'
alignbytes='$alignbytes'
aphostname='$aphostname'
+ar='$ar'
archlib='$archlib'
archlibexp='$archlibexp'
archname='$archname'
+archobjs='$archobjs'
awk='$awk'
baserev='$baserev'
bash='$bash'
d_msgsnd='$d_msgsnd'
d_mymalloc='$d_mymalloc'
d_nice='$d_nice'
+d_oldarchlib='$d_oldarchlib'
d_oldsock='$d_oldsock'
d_open3='$d_open3'
d_pathconf='$d_pathconf'
d_shmdt='$d_shmdt'
d_shmget='$d_shmget'
d_shrplib='$d_shrplib'
-d_sitelib='$d_sitelib'
d_socket='$d_socket'
d_sockpair='$d_sockpair'
d_statblks='$d_statblks'
egrep='$egrep'
emacs='$emacs'
eunicefix='$eunicefix'
+exe_ext='$exe_ext'
expr='$expr'
extensions='$extensions'
find='$find'
+firstmakefile='$firstmakefile'
flex='$flex'
fpostype='$fpostype'
freetype='$freetype'
i_gdbm='$i_gdbm'
i_grp='$i_grp'
i_limits='$i_limits'
+i_locale='$i_locale'
i_malloc='$i_malloc'
i_math='$i_math'
i_memory='$i_memory'
installman3dir='$installman3dir'
installprivlib='$installprivlib'
installscript='$installscript'
-installsitelib='$installsitelib'
+installsitearch='$installsitearch'
intsize='$intsize'
known_extensions='$known_extensions'
ksh='$ksh'
lddlflags='$lddlflags'
ldflags='$ldflags'
less='$less'
+lib_ext='$lib_ext'
libc='$libc'
libpth='$libpth'
libs='$libs'
nm_opt='$nm_opt'
nroff='$nroff'
o_nonblock='$o_nonblock'
+obj_ext='$obj_ext'
+oldarchlib='$oldarchlib'
+oldarchlibexp='$oldarchlibexp'
optimize='$optimize'
orderlib='$orderlib'
osname='$osname'
package='$package'
passcat='$passcat'
patchlevel='$patchlevel'
+path_sep='$path_sep'
perl='$perl'
perladmin='$perladmin'
+perlpath='$perlpath'
pg='$pg'
phostname='$phostname'
plibpth='$plibpth'
shmattype='$shmattype'
shrpdir='$shrpdir'
shsharp='$shsharp'
-sig_max='$sig_max'
sig_name='$sig_name'
sig_num='$sig_num'
signal_t='$signal_t'
-sitelib='$sitelib'
-sitelibexp='$sitelibexp'
+sitearch='$sitearch'
+sitearchexp='$sitearchexp'
sizetype='$sizetype'
sleep='$sleep'
smail='$smail'
spitshell='$spitshell'
split='$split'
ssizetype='$ssizetype'
+startperl='$startperl'
startsh='$startsh'
static_ext='$static_ext'
stdchar='$stdchar'
+++ /dev/null
-#!/usr/local/bin/perl5
-# perl5 -x notes 2> expected > actual ; diff expected actual
-open(EVAL, "| perl5 -x") || die "Can't pipe to perl5\n";
-while (<DATA>) {
- 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 <sanders@bsdi.com>
-#
-# 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 <absinthe@viva.chem.washington.edu>
-# Tom Christiansen <tchrist@wraeththu.cs.colorado.edu>
-# Dean Roehrich <roehrich@ferrari.cray.com>
-# Larry Wall <lwall@netlabs.com>
-# Lionel Cons <Lionel.Cons@cern.ch>
-#
-
-# 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 <float>;
- # 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__
*
*/
+/*
+ * 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)
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.
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<Configure -O>.
+
If you are willing to accept all the defaults, and you want terse
output, you can run
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
=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<not> included with perl. See the library documentation for
+how to obtain the libraries.
I<Note:> If your database header (.h) files are not in a
directory normally searched by your C compiler, then you will need to
=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<man less> would end up calling up Perl's less.pm module man
+page, rather than the B<less> 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
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:
F<Makefile> and F<makefile> is the dependencies at the bottom of
F<makefile>. If you have to make any changes, you should edit
F<makefile>, not F<Makefile> since the Unix B<make> command reads
-F<makefile>.
+F<makefile> first.
Configure will offer to do this step for you, so it isn't listed
explicitly above.
If you want to see exactly what will happen without installing
anything, you can run
-
+
./perl installperl -n
./perl installman -n
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.
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</usr/local/lib/perl5/sun4-sunos/5.002>) so that
+they are still accessible. I<Note:> perl5.000 and perl5.001 did not
+put their architecture-dependent libraries in a version-specific
+directory. They are simply in F</usr/local/lib/perl5/$archname>. If
+you will not be using 5.000 or 5.001, you may safely remove those
+files.
+
+The standard library files in F</usr/local/lib/perl5>
+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</usr/local/lib/perl/archname/5.002>. 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.
*
*/
+/*
+ * 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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
## 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.
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
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:
.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.
# 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.
*)
$spitshell >>Makefile <<'!NO!SUBS!'
rm -f $(perllib)
- ar rcu $(perllib) perl.o $(obj)
+ $(AR) rcu $(perllib) perl.o $(obj)
@$(ranlib) $(perllib)
!NO!SUBS!
;;
# 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; \
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
# 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
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
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!
-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
- 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
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
- 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
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.
Optimizations
constant function cache
switch structures
- foreach(@array)
+ eval qw() at compile time
foreach (1..1000000)
foreach(reverse...)
Set KEEP on constant split
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
-#define ST(off) stack_base[ax + off]
+#define ST(off) stack_base[ax + (off)]
#ifdef CAN_PROTOTYPE
#define XS(name) void name(CV* cv)
/* 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)
}
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()?) */
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;
#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*)
#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 */
-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 <<!GROK!THIS!
-#!$binexp/perl
-#
+#!/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 dollars and backticks do not need the extra backslash.
-$spitshell >>c2ph <<'!NO!SUBS!'
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
+#
#
# c2ph (aka pstruct)
# Tom Christiansen, <tchrist@convex.com>
sub buildscrunchlist {
$scrunch_code = "sub quick_scrunch {\n";
for (values %intrinsics) {
- $scrunch_code .= "\ts/($_\{2,})/'$_' . length(\$1)/ge;\n";
+ $scrunch_code .= "\ts/(${_}{2,})/'$_' . length(\$1)/ge;\n";
}
$scrunch_code .= "}\n";
print "$scrunch_code" if $debug;
}
}
}
+!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 ':';
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
* 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_
*/
#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
#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
* 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:
* 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
* 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
* 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
* within your programs. The mere use of the "const" keyword will
* trigger the necessary tests.
*/
-/*#define HASCONST /**/
+#define HASCONST /**/
#ifndef HASCONST
#define const
#endif
* 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
* 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:
* 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
* 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
* 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
* 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
* 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
* 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
*/
#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
* 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
* available to change the real, effective and saved gid of the current
* process.
*/
-#define HAS_SETREGID /**/
+/*#define HAS_SETREGID /**/
/*#define HAS_SETRESGID /**/
/* HAS_SETREUID:
* available to change the real, effective and saved uid of the current
* process.
*/
-#define HAS_SETREUID /**/
+/*#define HAS_SETREUID /**/
/*#define HAS_SETRESUID /**/
/* HAS_SETRGID:
* 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
* 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)
* 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
* This symbol, if defined, indicates that this C compiler knows about
* the volatile declaration.
*/
-/*#define HASVOLATILE /**/
+#define HASVOLATILE /**/
#ifndef HASVOLATILE
#define volatile
#endif
* 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.
* This symbol, if defined, indicates that <dlfcn.h> exists and should
* be included.
*/
-/*#define I_DLFCN /**/
+#define I_DLFCN /**/
/* I_FCNTL:
* This manifest constant tells the C program to include <fcntl.h>.
* This symbol, if defined, indicates that <net/errno.h> 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
* This symbol, if defined, indicates to the C program that it should
* include <sys/dir.h>.
*/
-#define I_SYS_DIR /**/
+/*#define I_SYS_DIR /**/
/* I_SYS_FILE:
* This symbol, if defined, indicates to the C program that it should
* This symbol, if defined, indicates to the C program that it should
* include <sys/select.h> in order to get definition of struct timeval.
*/
-/*#define I_SYS_SELECT /**/
+#define I_SYS_SELECT /**/
/* I_SYS_TIMES:
* This symbol, if defined, indicates to the C program that it should
* This symbol, if defined, indicates to the C program that it should
* include <varargs.h>.
*/
-/*#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
*/
/*#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
*/
#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
*
* int main _((int argc, char *argv[]));
*/
-/*#define CAN_PROTOTYPE /**/
+#define CAN_PROTOTYPE /**/
#ifdef CAN_PROTOTYPE
#define _(args) args
#else
* 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
*/
#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
* 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.
*/
#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.
*/
#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.
*/
/*#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 <dbm.h> exists and should
+ * be included.
+ */
+/* I_RPCSVC_DBM:
+ * This symbol, if defined, indicates that <rpcsvc/dbm.h> exists and
+ * should be included.
+ */
+/*#define I_DBM /**/
+#define I_RPCSVC_DBM /**/
+
+/* I_LOCALE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <locale.h>.
+ */
+#define I_LOCALE /**/
/* I_SYS_STAT:
* This symbol, if defined, indicates to the C program that it should
*/
#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.
/* 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:
*/
#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
* 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
*/
#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.
/* 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
#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.
*/
#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...
#$i_dbm I_DBM /**/
#$i_rpcsvcdbm I_RPCSVC_DBM /**/
+/* I_LOCALE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <locale.h>.
+ */
+#$i_locale I_LOCALE /**/
+
/* I_SYS_STAT:
* This symbol, if defined, indicates to the C program that it should
* include <sys/stat.h>.
*/
#$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
#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 @_ */ \
}
#define POPFORMAT(cx) \
- defoutgv = cx->blk_sub.dfoutgv;
+ setdefout(cx->blk_sub.dfoutgv); \
+ SvREFCNT_dec(cx->blk_sub.dfoutgv);
/* eval context */
struct block_eval {
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 {
I32 sbu_maxiters;
I32 sbu_safebase;
I32 sbu_once;
+ I32 sbu_oldsave;
char * sbu_orig;
SV * sbu_dstr;
SV * sbu_targ;
#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
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, \
#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 */
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
do_close(gv,FALSE);
continue;
}
- defoutgv = argvoutgv;
+ setdefout(argvoutgv);
lastfd = fileno(IoIFP(GvIOp(argvoutgv)));
(void)Fstat(lastfd,&statbuf);
#ifdef HAS_FCHMOD
}
if (inplace) {
(void)do_close(argvoutgv,FALSE);
- defoutgv = gv_fetchpv("STDOUT",TRUE,SVt_PVIO);
+ setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
}
return Nullfp;
}
}
/* 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) {
(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 &&
sv_catpvn(sv, rsave + len, rightlen - len);
else if (leftlen > len)
sv_catpvn(sv, lsave + len, leftlen - len);
+ else
+ *SvEND(sv) = '\0';
break;
}
}
+++ /dev/null
-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: <KHERA.93Oct21140851@thneed.cs.duke.edu>
-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.")
-\f
-;; 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))
-\f
-;; 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)))
-\f
-(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))))))
-
-\f
-(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))
-\f
-(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
-
-
--- /dev/null
+;;; 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.")
+\f
+
+;;; 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))
+
+
+\f
+;; 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))))
+\f
+;; 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))
+\f
+;; 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))))
+\f
+;; 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
+ "[#\"'`]\\|\\<q\\(\\|[wqx]\\)\\>"
+ 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
+ "[#\"'`]\\|\\<q\\(\\|[wqx]\\)\\>"
+ 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)))
+\f
+(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))))))
+
+
+\f
+(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]"
+ '("\\<sub[ \t]+\\([^ \t{]+\\)[ \t]*[{\n]" 1
+ font-lock-function-name-face)
+ '("\\<\\(package\\|require\\|use\\)[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t;]" ; require A if B;
+ 2 font-lock-function-name-face)
+ (if (featurep 'font-lock-extra)
+ '("\\([]}\\\\%@>*&]\\|\\$[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))
+ '("\\<for\\(each\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*("
+ 2 font-lock-variable-name-face)))
+ (if (and (fboundp 'turn-on-font-lock) ; Check for newer font-lock
+ (not (cperl-xemacs-p))) ; not yet as of XEmacs 19.12
+ (setq t-font-lock-keywords
+ (append
+ t-font-lock-keywords
+ '(("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)"
+ 1
+ (if (= (- (match-end 2) (match-beginning 2)) 1)
+ (if (eq (char-after (match-beginning 3)) ?{)
+ font-lock-other-emphasized-face
+ font-lock-emphasized-face) ; arrays and hashes
+ font-lock-variable-name-face) ; Just to put something
+ t)
+ ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1
+ (if (eq (char-after (match-beginning 2)) ?%)
+ font-lock-other-emphasized-face
+ font-lock-emphasized-face)
+ t) ; arrays and hashes
+ ;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2")
+ ;;; Too much noise from \s* @s[ and friends
+ ;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)"
+ ;;(3 font-lock-function-name-face t t)
+ ;;(4
+ ;; (if (cperl-slash-is-regexp)
+ ;; font-lock-function-name-face 'default) nil t))
+ ))))
+ (defconst perl-font-lock-keywords t-font-lock-keywords
+ "Additional expressions to highlight in Perl mode."))
+ (if (fboundp 'ps-print-buffer) (cperl-ps-print-init))
+ (if (featurep 'font-lock-extra)
+ (font-lock-require-faces
+ (list
+ ;; Color-light Color-dark Gray-light Gray-dark Mono
+ (list 'font-lock-comment-face
+ ["Firebrick" "OrangeRed" "DimGray" "Gray80"]
+ nil
+ [nil nil t t t]
+ [nil nil t t t]
+ nil)
+ (list 'font-lock-string-face
+ ["RosyBrown" "LightSalmon" "Gray50" "LightGray"]
+ nil
+ nil
+ [nil nil t t t]
+ nil)
+ (list 'font-lock-keyword-face
+ ["Purple" "LightSteelBlue" "DimGray" "Gray90"]
+ nil
+ [nil nil t t t]
+ nil
+ nil)
+ (list 'font-lock-function-name-face
+ (vector
+ "Blue" "LightSkyBlue" "Gray50" "LightGray"
+ (cdr (assq 'background-color ; if mono
+ (frame-parameters))))
+ (vector
+ nil nil nil nil
+ (cdr (assq 'foreground-color ; if mono
+ (frame-parameters))))
+ [nil nil t t t]
+ nil
+ nil)
+ (list 'font-lock-variable-name-face
+ ["DarkGoldenrod" "LightGoldenrod" "DimGray" "Gray90"]
+ nil
+ [nil nil t t t]
+ [nil nil t t t]
+ nil)
+ (list 'font-lock-type-face
+ ["DarkOliveGreen" "PaleGreen" "DimGray" "Gray80"]
+ nil
+ [nil nil t t t]
+ nil
+ [nil nil t t t]
+ )
+ (list 'font-lock-reference-face
+ ["CadetBlue" "Aquamarine" "Gray50" "LightGray"]
+ nil
+ [nil nil t t t]
+ nil
+ [nil nil t t t]
+ )
+ (list 'font-lock-other-type-face
+ ["chartreuse3" ("orchid1" "orange")
+ nil "Gray80"]
+ [nil nil "gray90"]
+ [nil nil nil t t]
+ [nil nil t t]
+ [nil nil t t t]
+ )
+ (list 'font-lock-emphasized-face
+ ["blue" "yellow" nil "Gray80"]
+ ["lightyellow2" ("navy" "os2blue" "darkgreen")
+ "gray90"]
+ t
+ nil
+ nil)
+ (list 'font-lock-other-emphasized-face
+ ["red" "red" nil "Gray80"]
+ ["lightyellow2" ("navy" "os2blue" "darkgreen")
+ "gray90"]
+ t
+ t
+ nil)))
+ (defvar cperl-guessed-background nil
+ "Display characteristics as guessed by cperl.")
+ (or (fboundp 'x-color-defined-p)
+ (defalias 'x-color-defined-p
+ (cond ((fboundp 'color-defined-p) 'color-defined-p)
+ ;; XEmacs >= 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))))
+++ /dev/null
-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: <MEISSNER.93Oct17171021@pasta.osf.org>
-References: <BSHAW.93Oct17143524@bobasun.spdc.ti.com>
-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.93Oct17143524@bobasun.spdc.ti.com> 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: <CA7uq9.30J@murdoch.acc.Virginia.EDU>
-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.
-
-
+++ /dev/null
-;; 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 <pattern> 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.")
-\f
-(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))
-\f
-;; 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)))
-\f
-(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"))
-\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"))))
-\f
-(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! ;;;;;;;;;
+++ /dev/null
-;; 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")
-\f
-(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)))))
-\f
-;; 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)))
-\f
-(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)))
+++ /dev/null
-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(<linenum>); 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(IN, "<&STDIN"); # so we don't dingle stdin
-open(OUT,">/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.
-<CR> 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($.);
- <IN>;
-}
-
-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;
+++ /dev/null
-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-<foo>* buffers, each of which keep growing. "perldb-next-error"
- correctly handles the constantly growing *perldb-<foo>* 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-<bar>*
- buffer at the top (even if it was previously parsed), and will completely
- lose the marker of the last reported error in *perldb-<foo>*.
-
- 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)))))
- \f
- ;; 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)))))
- \f
- ;; 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-<foo>* 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)))
-+ \f
-+ (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)
-
-
#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
#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
#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
#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
#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
#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)
#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
# 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;
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 ;
Added prototype support for multiple btree compare callbacks.
-=head 1.0
+=head2 1.0
B<DB_File> has been in use for over a year. To reflect that, the
version number has been incremented to 1.0.
Using the I<push> 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
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"
/* #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) \
sv = ST(4) ;
RETVAL = ParseOpenInfo(name, flags, mode, sv, "new") ;
+ if (RETVAL->dbp == NULL)
+ RETVAL = NULL ;
}
OUTPUT:
RETVAL
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);
{
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);
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);
DBT value ;
int i ;
int One ;
+ DB * Db = db->dbp ;
CurrentDB = db ;
RETVAL = -1 ;
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;
}
{
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);
}
{
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);
}
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)
{
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;
}
NAME => 'DB_File',
LIBS => ["-L/usr/local/lib -ldb"],
#INC => '-I/usr/local/include',
- VERSION => 1.0,
+ VERSION => 1.01,
);
+++ /dev/null
-# 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<tmon.out>. The supplied I<dprofpp> 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<perl>, L<dprofpp>, 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;
+++ /dev/null
-#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);
+++ /dev/null
-use ExtUtils::MakeMaker;
-WriteMakefile(
- 'NAME' => 'Devel::DProf',
- 'VERSION' => 'Apr5,1995',
- 'clean' => {'FILES' => "tmon.out"},
- 'EXE_FILES' => ['dprofpp'],
-
-);
+++ /dev/null
-Please consult the pod in DProf.pm.
-
-Dean Roehrich
+++ /dev/null
-#!/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<dprofpp> command interprets a profile file produced by the Devel::DProf
-profiler. By default dprofpp will read the file I<tmon.out> 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<cnt> 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<die> from within an eval for exception handling
-(catch/throw) or for setjmp/longjmp may not generate a readable profile.
-
-Applications which call I<exit> from within a subroutine will leave an
-incomplete profile.
-
-=head1 FILES
-
- dprofpp - profile processor
- tmon.out - raw profile
-
-=head1 SEE ALSO
-
-L<perl>, L<Devel::DProf>, 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
-.
-
+++ /dev/null
-#!./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();
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.
# 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";
# 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);
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;
}
--- /dev/null
+/* 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 <os2.h>
+
+#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.
#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;
break;
+# 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<GDBM_File> 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<prep.ai.mit.edu>, 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<finger fsf@prep.ai.mit.edu>.
+
+=head1 BUGS
+
+The available functions and the gdbm/perl interface need to be documented.
+
+=head1 SEE ALSO
+
+L<perl(1)>, L<DB_File(3)>.
+
+=cut
+
package GDBM_File;
require Carp;
#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;
# -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"];
# 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'];
# -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'];
# 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'];
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";
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};
}
############################
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 {
sub DESTROY {
close($_[0]);
- ungensym($_[0]);
}
sub eof {
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 {
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;
#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;
}
if (strEQ(name, "SEEK_CUR"))
#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
#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':
if (strEQ(name, "X_OK"))
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. */
# which perform the corresponding actions in the subdirectory.
WriteMakefile(
- 'MYEXTLIB' => 'sdbm/libsdbm.a',
+ 'MYEXTLIB' => 'sdbm/libsdbm$(LIB_EXT)',
);
'
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)
* 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) {
/*
use ExtUtils::MakeMaker;
-WriteMakefile();
+WriteMakefile(VERSION => 1.3);
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
Unlike the old mechanism of requiring a translated F<socket.ph>
file, this uses the B<h2xs> 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:
=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
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
@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
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/.*:://;
# include <sys/types.h>
# endif
#include <sys/socket.h>
+#include <sys/un.h>
# ifdef I_NETINET_IN
# include <netinet/in.h>
# endif
}
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:
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 );
{
STRLEN sockaddrlen;
struct sockaddr_in addr;
- short family;
short port;
struct in_addr ip_address;
char * sin = SvPV(sin_sv,sockaddrlen);
"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)));
}
bufptr
bxor_amg
check
-coeff
compiling
compl_amg
compcv
gv_stashsv
he_delayfree
he_free
+he_root
hoistmust
hv_clear
hv_delete
scan_word
scope
screaminstr
+setdefout
setenv_getix
skipspace
stack_grow
sv_2mortal
sv_2nv
sv_2pv
+sv_add_arena
sv_backoff
sv_bless
sv_catpv
warn
watch
whichsig
-whichsigname
xiv_arenaroot
xiv_root
xnv_root
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;
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
* 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
-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 <<!GROK!THIS!
-#!$binexp/perl
+#!/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 = '$archlibexp';
+\$perlincl = $Config{archlibexp};
+
!GROK!THIS!
-: In the following dollars and backticks do not need the extra backslash.
-$spitshell >>h2ph <<'!NO!SUBS!'
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
chdir '/usr/include' || die "Can't cd /usr/include";
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
+
+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 ':';
-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 <<!GROK!THIS!
-#!$binexp/perl
+#!/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!
-$spitshell >>h2xs <<'!NO!SUBS!'
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
=head1 NAME
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 ){
print PL ");\n";
-system '/bin/ls > MANIFEST';
+system '/bin/ls > MANIFEST' or system 'ls > MANIFEST';
!NO!SUBS!
-chmod 755 h2xs
-$eunicefix h2xs
+
+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 ':';
# Changes for dynamic linking by Wayne Scott <wscott@ichips.intel.com>
#
# 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.
;;
esac
ccflags="$ccflags -DSTANDARD_C"
-lddlflags='-shared -expect_unresolved "*" -s'
+lddlflags='-shared -expect_unresolved "*" -s -hidden'
# 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
+
# 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"
;;
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)
# 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
-
--- /dev/null
+# 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="$*"
# 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
--- /dev/null
+# 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'
# 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/'`
'') 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 <<EOF
Note that there is a bug in some versions of NFS on the DECStation that
static void hsplit _((HV *hv));
static void hfreeentries _((HV *hv));
+static HE* more_he();
+
+static HE*
+new_he()
+{
+ HE* he;
+ if (he_root) {
+ he = he_root;
+ he_root = (HE*)he->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;
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;
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;
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;
}
return;
SvREFCNT_dec(hent->hent_val);
Safefree(hent->hent_key);
- Safefree(hent);
+ del_he(hent);
}
void
return;
sv_2mortal(hent->hent_val); /* free between statements */
Safefree(hent->hent_key);
- Safefree(hent);
+ del_he(hent);
}
void
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;
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);
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)) {
}
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;
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'};
#!./perl
BEGIN { @INC=('./lib', '../lib') }
use File::Find;
+use Config;
$mainperldir = "/usr/bin";
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.
@pods = (<pod/*.pod>);
-# Read in the config file.
-
-open(CONFIG, "config.sh") || die "You haven't run Configure yet!\n";
-while (<CONFIG>) {
- 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;
&makedir($installprivlib);
&makedir($installarchlib);
+&makedir($installsitelib) if ($installsitelib);
+&makedir($installsitearch) if ($installsitearch);
+
if (chdir "lib") {
$do_installarchlib = ! &samepath($installarchlib, '.');
$do_installprivlib = ! &samepath($installprivlib, '.');
e_tmpname
endav
envgv
+errgv
eval_root
eval_start
fdpid
+++ /dev/null
-$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;
eval {require $name};
}
elsif ($AUTOLOAD =~ /::DESTROY$/) {
- eval "sub $AUTOLOAD {}";
+ # eval "sub $AUTOLOAD {}";
+ *$AUTOLOAD = sub {};
}
if ($@){
$@ =~ s/ at .*\n//;
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) = (/(.*])(.*)/);
# 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)){
$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){
# For now both of these produce warnings.
open(OUT,">/dev/null") || open(OUT,">nla0:"); # avoid 'not opened' warning
- my(@subnames);
+ my(@subnames, %proto);
while (<IN>) {
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";
}
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);
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
=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";
=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<perlsub/Overriding builtin functions>.)
+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<all> 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<perlsub/Overriding builtin functions>.) 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
#
sub getcwd
{
- if($Config{'osname'} eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} }
-
my($dotdots, $cwd, @pst, @cst, $dir, @tst);
unless (@cst = stat('.'))
# 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);
}
-# 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);
}
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 '..';
}
$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('',<DATA>) || 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";
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;
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'};
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;
$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
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
}
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}};
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;
@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;
# 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 = (
%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";
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
check_manifest();
}
- check_hints();
-
$self = {} unless (defined $self);
+ check_hints();
+
my(%initial_att) = %$self; # record initial attributes
if (defined $self->{CONFIGURE}) {
$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!^/!;
unless ($self->{NORECURS}) {
foreach $dir (@{$self->{DIR}}){
chdir $dir;
+ package main;
local *FH;
open FH, "Makefile.PL";
eval join "", <FH>;
(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'
$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;
return unless -f "hints/$hint.pl"; # really there
# execute the hintsfile:
+ local *HINTS;
open HINTS, "hints/$hint.pl";
@goodhints = <HINTS>;
close HINTS;
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 ]) {
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 = <STDIN>);
- $ans || $def;
+ my $ans;
+ if ($ISA_TTY) {
+ local $|=1;
+ print "$mess $dispdef";
+ chop($ans = <STDIN>);
+ }
+ return $ans if defined $ans;
+ return $def;
}
sub attrib_help {
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;
}
($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
# 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/<archname>
+ # INST_LIB PERL_SRC/lib ./blib
+ # INST_ARCHLIB PERL_SRC/lib ./blib/<archname>
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") {
# 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 {
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} ){
$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}";
}
}
$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};
$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;
}
}
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};
# 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";
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;
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){
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}
";
# 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
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
';
}
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)
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
$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)";
}
push(@tmdeps, "typemap") if -f "typemap";
my(@tmargs) = map("-typemap $_", @tmdeps);
+ if( exists $self->{XSOPT} ){
+ unshift( @tmargs, $self->{XSOPT} );
+ }
"
XSUBPPDIR = $xsdir
XSUBPP = \$(XSUBPPDIR)/xsubpp
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, "
}
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)\"";
}
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;
}
}
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
';
}
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);
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);
$(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");
}
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 <<END;
+
+Warning: I could not locate your pod2man program. Please make sure,
+ your pod2man program is in your PATH before you execute 'make'
+
+END
+ $pod2man_exe = "-S pod2man";
+ }
my(@m);
- push @m,
+ push @m,
+qq[POD2MAN_EXE = $pod2man_exe\n],
q[POD2MAN = $(PERL) -we '%m=@ARGV;for (keys %m){' \\
-e 'next if -e $$m{$$_} && -M $$m{$$_} < -M "].$self->{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 :";
# 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, "
qq{
subdirs ::
- \@ -cd $subdir && \$(MAKE) all \$(PASTHRU)
+ \@-cd $subdir && \$(MAKE) all \$(PASTHRU)
};
}
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";
};
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";' \\
-e 'mkmanifest();'
# 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, '
# 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
";
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;
}
$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.
# 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:
# 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 || []}) );
$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, $_;
}
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}
";
}
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
}
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 $@
};
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;
# 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;
}
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;
}
$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;
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<hints/> directory. The hints files are expected to be named
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
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
INST_MAN3DIR. All these default to ./blib or something below blib if
you are I<not> building below the perl source directory. If you I<are>
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<install> 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
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
=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"
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
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
{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
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<MANIFEST.SKIP> file (See ExtUtils::Manifest::skipcheck() for
+details)
+
=item make distclean
does a realclean first and then the distcheck. Note that this is not
=item make disttest
Makes a distdir first, and runs a C<perl Makefile.PL>, a make, and
-a make install in that directory.
+a make test in that directory.
=item make tardist
C<ExtUtils::Manifest::fullcheck;>
+C<ExtUtils::Manifest::skipcheck;>
+
+C<ExtUtild::Manifest::manifind();>
+
C<ExtUtils::Manifest::maniread($file);>
C<ExtUtils::Manifest::manicopy($read,$target,$how);>
Fullcheck() does both a manicheck() and a filecheck().
+Skipcheck() lists all the files that are skipped due to your
+C<MANIFEST.SKIP> file.
+
+Manifind() retruns a hash reference. The keys of the hash are the
+files found below the current directory.
+
Maniread($file) reads a named C<MANIFEST> file (defaults to
C<MANIFEST> in the current directory) and returns a HASH reference
with files being the keys and comments being the values of the HASH.
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<ln> instead
-of C<cp>, which is the default).
+specify a different methods of "copying". Valid values are C<cp>,
+which actually copies the files, C<ln> which creates hard links, and
+C<best> 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
$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;
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;
chmod( $mode | ( $mode & 0100 ? 0111 : 0 ), $_ );
}
+sub best {
+ my ($srcFile, $dstFile) = @_;
+ if (-l $srcFile) {
+ cp($srcFile, $dstFile);
+ } else {
+ ln($srcFile, $dstFile);
+ }
+}
+
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";
sub Q {
my($text) = @_;
- $text =~ tr/#//d;
+ $text =~ s/^#//gm;
$text =~ s/\[\[/{/g;
$text =~ s/\]\]/}/g;
$text;
# 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"
}
# print initialization routine
-print qq/extern "C"\n/ if $cplusplus;
print Q<<"EOF";
+##ifdef __cplusplus
+#extern "C"
+##endif
#XS(boot_$Module_cname)
#[[
# dXSARGS;
@ISA = qw(Exporter);
@EXPORT = qw(find finddepth $name $dir);
+$dont_use_nlink = 1 if $Config{osname} =~ m:^os/?2$:i ;
+
# Usage:
# use File::Find;
#
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.
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: $!";
+ }
}
}
package IPC::Open3;
-require 5.000;
+require 5.001;
require Exporter;
use Carp;
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.
# &open3: Marc Horowitz <marc@mit.edu>
# derived mostly from &open2 by tom christiansen, <tchrist@convex.com>
+# fixed for 5.001 by Ulrich Kunitz <kunitz@mai-koeln.com>
#
# $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $
#
# 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.
$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: $!";
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));
package Shell;
+use Config;
+
sub import {
my $self = shift;
my ($callpack, $callfile, $callline) = caller;
$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 = <READ>;
+ close READ;
+ waitpid \$pid, 0;
+ \@ret;
+ }
+ else {
+ local(\$/) = undef;
+ my \$ret = <READ>;
+ close READ;
+ waitpid \$pid, 0;
+ \$ret;
+ }
}
else {
open(SUBPROC, "-|")
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);
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)) {
} 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";
}
# 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 <muir@idiom.com>
-# Version: 4/19/95
#
+# Version: 9/21/95
+#
package Text::Tabs;
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;
--- /dev/null
+
+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 <muir@idiom.com>
+# 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;
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 {
--- /dev/null
+#!/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<diagnostics> 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<perldiag>. 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<does> enable perl's B<-w> flag.) Your whole
+compilation will then be subject(ed :-) to the enhanced diagnostics.
+These still go out B<STDERR>.
+
+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<no diagnostics> 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<perldiag> introduction before
+any other diagnostics. The $diagnostics::PRETTY can generate nicer escape
+sequences for pgers.
+
+=head2 The I<splain> Program
+
+While apparently a whole nuther program, I<splain> is actually nothing
+more than a link to the (executable) F<diagnostics.pm> module, as well as
+a link to the F<diagnostics.pod> documentation. The B<-v> flag is like
+the C<use diagnostics -verbose> directive.
+The B<-p> flag is like the
+$diagnostics::PRETTY variable. Since you're post-processing with
+I<splain>, there's no sense in being able to enable() or disable() processing.
+
+Output from I<splain> is directed to B<STDOUT>, 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 <CR> here: ";
+ my $a, $b = scalar <STDIN>;
+ 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<stdout> 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<use> 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<perldiag.pod> file when available at
+runtime. Otherwise, they may be embedded in the file itself when the
+splain package is built. See the F<Makefile> 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<before> 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<splain>, you should expect a bit of whimsy.
+
+=head1 AUTHOR
+
+Tom Christiansen F<E<lt>tchrist@mox.perl.comE<gt>>, 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 (<POD_DIAG>) {
+ 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 <DATA>\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 = <<EOFUNC;
+sub transmo {
+ local \$^W = 0; # recursive warnings we do NOT need!
+ study;
+EOFUNC
+
+### sub finish_compilation { # 5.001e panic: top_level for embedded version
+ print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
+ ### local
+ $RS = '';
+ local $_;
+ while (<POD_DIAG>) {
+ #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
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;
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";
+ }
}
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.
}
}
+1;
__END__
=head1 NAME
use lib LIST;
-is the same as saying
+is I<almost> 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
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
--- /dev/null
+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<overload.pm> - 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<Number> (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<add> will be called to execute C<$a+$b> if $a
+is a reference to an object blessed into the package C<Number>, or if $a is
+not an object from a package with defined mathemagic addition, but $b is a
+reference to a C<Number>. It can also be called in other situations, like
+C<$a+=7>, or C<$a++>. See L<MAGIC AUTOGENERATION>. (Mathemagical
+methods refer to methods triggered by an overloaded mathematical
+operator.)
+
+=head2 Calling Conventions for Binary Operations
+
+The functions specified in the C<use overload ...> directive are called
+with three (in one particular case with four, see L<Last Resort>)
+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<undef>
+
+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<undef>. 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<use overload>:
+
+=over 5
+
+=item * I<Arithmetic operations>
+
+ "+", "+=", "-", "-=", "*", "*=", "/", "/=", "%", "%=",
+ "**", "**=", "<<", "<<=", ">>", ">>=", "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<abs>.
+
+=item * I<Comparison operations>
+
+ "<", "<=", ">", ">=", "==", "!=", "<=>",
+ "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 C<sort>ing
+arrays, C<cmp> is used to compare values subject to C<use overload>.
+
+=item * I<Bit operations>
+
+ "&", "^", "|", "neg", "!", "~",
+
+"C<neg>" stands for unary minus. If the method for C<neg> is not
+specified, it can be autogenerated using the method for subtraction.
+
+=item * I<Increment and decrement>
+
+ "++", "--",
+
+If undefined, addition and subtraction methods can be
+used instead. These operations are called both in prefix and
+postfix form.
+
+=item * I<Transcendental functions>
+
+ "atan2", "cos", "sin", "exp", "abs", "log", "sqrt",
+
+If C<abs> is unavailable, it can be autogenerated using methods
+for "<" or "<=>" combined with either unary minus or subtraction.
+
+=item * I<Boolean, string and numeric conversion>
+
+ "bool", "\"\"", "0+",
+
+If one or two of these operations are unavailable, the remaining ones can
+be used instead. C<bool> is used in the flow control operators
+(like C<while>) 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<Special>
+
+ "nomethod", "fallback", "=",
+
+see L<SPECIAL SYMBOLS FOR C<use overload>>.
+
+=back
+
+See L<"Fallback"> for an explanation of when a missing method can be autogenerated.
+
+=head1 SPECIAL SYMBOLS FOR C<use overload>
+
+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<gt> "nomethodMethod"> was specified in the
+C<use overload> 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<use overload> 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<undef>
+
+Perl tries to use a
+substituted method (see L<MAGIC AUTOGENERATION>). 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<undef> value, but no exception is raised. Instead,
+it silently reverts to what it would have done were there no C<use overload>
+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<use
+overload>. 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<Example>
+
+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<Assignment forms of arithmetic operations>
+
+C<$a+=$b> can use the method for C<"+"> if the method for C<"+=">
+is not defined.
+
+=item I<Conversion operations>
+
+String, numeric, and boolean conversion are calculated in terms of one
+another if not all of them are defined.
+
+=item I<Increment and decrement>
+
+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<abs($a)>
+
+can be expressed in terms of C<$aE<lt>0> and C<-$a> (or C<0-$a>).
+
+=item I<Unary minus>
+
+can be expressed in terms of subtraction.
+
+=item I<Concatenation>
+
+can be expressed in terms of string conversion.
+
+=item I<Comparison operations>
+
+can be expressed in terms of its "spaceship" counterpart: either
+C<E<lt>=E<gt>> or C<cmp>:
+
+ <, >, <=, >=, ==, != in terms of <=>
+ lt, gt, le, ge, eq, ne in terms of cmp
+
+=item I<Copy operator>
+
+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<cmp>' should return a blessed reference, the autogenerated `C<lt>'
+function will produce only a standard logical value based on the
+numerical value of the result of `C<cmp>'. In particular, a working
+numeric conversion is needed in this case (possibly expressed in terms of
+other conversions).
+
+Similarly, C<.=> and C<x=> 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<use> 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<overload.pm> provides the following public functions:
+
+=over 5
+
+=item overload::StrVal(arg)
+
+Gives string value of C<arg> as in absence of stringify overloading.
+
+=item overload::Overloaded(arg)
+
+Returns true if C<arg> is subject to overloading of some operations.
+
+=item overload::Method(obj,op)
+
+Returns C<undef> or a reference to the method that implements C<op>.
+
+=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<use overload>, C<no overload>, and @ISA only during
+C<bless>ing; so if they are changed dynamically, you'll need an
+additional fake C<bless>ing 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<use overload> 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<use overload> 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 <F<ilya@math.mps.ohio-state.edu>>.
+
+=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
+
#
# $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") {
$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
$| = 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 ",
--- /dev/null
+#!/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<diagnostics> 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<perldiag>. 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<does> enable perl's B<-w> flag.) Your whole
+compilation will then be subject(ed :-) to the enhanced diagnostics.
+These still go out B<STDERR>.
+
+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<no diagnostics> 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<perldiag> introduction before
+any other diagnostics. The $diagnostics::PRETTY can generate nicer escape
+sequences for pgers.
+
+=head2 The I<splain> Program
+
+While apparently a whole nuther program, I<splain> is actually nothing
+more than a link to the (executable) F<diagnostics.pm> module, as well as
+a link to the F<diagnostics.pod> documentation. The B<-v> flag is like
+the C<use diagnostics -verbose> directive.
+The B<-p> flag is like the
+$diagnostics::PRETTY variable. Since you're post-processing with
+I<splain>, there's no sense in being able to enable() or disable() processing.
+
+Output from I<splain> is directed to B<STDOUT>, 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 <CR> here: ";
+ my $a, $b = scalar <STDIN>;
+ 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<stdout> 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<use> 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<perldiag.pod> file when available at
+runtime. Otherwise, they may be embedded in the file itself when the
+splain package is built. See the F<Makefile> 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<before> 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<splain>, you should expect a bit of whimsy.
+
+=head1 AUTHOR
+
+Tom Christiansen F<E<lt>tchrist@mox.perl.comE<gt>>, 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 (<POD_DIAG>) {
+ 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 <DATA>\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 = <<EOFUNC;
+sub transmo {
+ local \$^W = 0; # recursive warnings we do NOT need!
+ study;
+EOFUNC
+
+### sub finish_compilation { # 5.001e panic: top_level for embedded version
+ print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
+ ### local
+ $RS = '';
+ local $_;
+ while (<POD_DIAG>) {
+ #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
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;
else
croak("No such hook: %s", s);
i = 0;
+ if (*svp) {
+ SvREFCNT_dec(*svp);
+ *svp = 0;
+ }
}
else {
i = whichsig(s); /* ...no, a brick */
#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);
#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);
#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);
#endif
#endif
egid = (I32)getegid();
- tainting |= (euid != uid || egid != gid);
+ tainting |= (uid && (euid != uid || egid != gid));
break;
case ':':
chopset = SvPV_force(sv,na);
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;
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);
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
}
print "\t}\n";
}
- print $tail;
+ print $tail2;
}
sub canon{
* "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)
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 );
/* 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 */
}
#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;
}
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;
}
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--) {
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) &&
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:
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:
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:
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;
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;
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];
}
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 {
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) ));
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 */
{
LOOP *loop;
int padoff = 0;
+ I32 iterflags = 0;
copline = forline;
if (sv) {
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);
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);
}
}
CV *
-newSUB(floor,op,block)
+newSUB(floor,op,proto,block)
I32 floor;
OP *op;
+OP *proto;
OP *block;
{
register CV *cv;
}
}
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 {
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);
s++;
else
s = name;
- if (strEQ(s, "BEGIN")) {
+ if (strEQ(s, "BEGIN") && !error_count) {
line_t oldline = compiling.cop_line;
ENTER;
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);
register CV *cv;
char *name;
GV *gv;
- AV* av;
I32 ix;
if (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 *
*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:
*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:
}
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) {
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;
}
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);
OP *op;
{
cPMOP->op_pmflags |= PMf_RUNTIME;
+ cPMOP->op_pmpermflags |= PMf_RUNTIME;
return op;
}
scalar(kid);
if (kid->op_sibling)
- return too_many_arguments(op);
+ return too_many_arguments(op,op_name[op->op_type]);
return 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;
}
* 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
REGEXP * op_pmregexp; /* compiled expression */
SV * op_pmshort; /* for a fast bypass of execute() */
U16 op_pmflags;
+ U16 op_pmpermflags;
char op_pmslen;
};
0x00000000, /* and */
0x00000000, /* or */
0x00001106, /* xor */
- 0x00000000, /* cond_expr */
+ 0x00000040, /* cond_expr */
0x00000004, /* andassign */
0x00000004, /* orassign */
0x00000040, /* method */
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
--- /dev/null
+# 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}' <dummy.map | sort | uniq > 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!
--- /dev/null
+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
--- /dev/null
+# 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 <doughera@lafcol.lafayette.edu>
+
+========================================================
+
+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.
--- /dev/null
+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 <<!GROK!THIS!
++
++ Makefile: $osname/Makefile.SH
++
++ !GROK!THIS!
++ else
++ echo "Could not find $osname/Makefile.SH! Skipping target \$(perllib) in Makefile!"
++ fi
++ ;;
+ *)
+ $spitshell >>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/tty
+
+ minitest: miniperl
+ - cd t && chmod +x TEST */*.t
+! - cd t && (rm -f perl; $(LNS) ../miniperl perl) \
+ && ./perl TEST base/*.t comp/*.t cmd/*.t io/*.t op/*.t </dev/tty
+
+ clist: $(c)
+--- 428,444 ----
+
+ # When done, touch perlmain.c so that it doesn't get remade each time.
+ depend: makedepend
+! sh ./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$(exe_ext); $(LNS) ../perl$(exe_ext) perl$(exe_ext)) && ./perl TEST </dev/tty
+
+ minitest: miniperl
+ - cd t && chmod +x TEST */*.t
+! - cd t && (rm -f perl$(exe_ext); $(LNS) ../miniperl$(exe_ext) perl$(exe_ext)) \
+ && ./perl TEST base/*.t comp/*.t cmd/*.t io/*.t op/*.t </dev/tty
+
+ clist: $(c)
+***************
+*** 415,421 ****
+ case `pwd` in
+ *SH)
+ $rm -f ../Makefile
+! ln Makefile ../Makefile
+ ;;
+ esac
+! rm -f makefile
+--- 458,464 ----
+ case `pwd` in
+ *SH)
+ $rm -f ../Makefile
+! $ln Makefile ../Makefile
+ ;;
+ esac
+! rm -f $firstmakefile
--- /dev/null
+*** Configure.orig Thu Oct 19 07:48:18 1995
+--- Configure Wed Nov 01 20:14:32 1995
+***************
+*** 561,566 ****
+--- 561,575 ----
+ defvoidused=''
+ voidflags=''
+ CONFIG=''
++ archobjs=''
++ firstmakefile='makefile'
++ obj_ext='.o'
++ obj_ext_regexp='\.o'
++ lib_ext='.a'
++ exe_ext=
++ ar='ar'
++ plibext=
++ path_sep=$p_
+
+ define='define'
+ undef='undef'
+***************
+*** 1363,1369 ****
+ say=offhand
+ for file in $trylist; do
+ xxx=`./loc $file $file $pth`
+! eval $file=$xxx
+ eval _$file=$xxx
+ case "$xxx" in
+ /*)
+--- 1370,1378 ----
+ say=offhand
+ for file in $trylist; do
+ xxx=`./loc $file $file $pth`
+! if test "X$file" != "X$xxx" ; then
+! eval $file=$xxx
+! fi
+ eval _$file=$xxx
+ case "$xxx" in
+ /*)
+***************
+*** 2156,2162 ****
+ 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." ;;
+--- 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 "<sys/file.h> 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 "<sys/file.h> 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 "<fcntl.h> 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 "<fcntl.h> 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
--- /dev/null
+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 (<CONFIG>) {
+! 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) {
+! $_ = <CONFIG>;
+! 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 {
--- /dev/null
+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|^[^;]*/||' | \
--- /dev/null
+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 <<!GROK!THIS!
+***************
+*** 33,39 ****
+--- 36,51 ----
+ mallocobj = $mallocobj
+ shellflags = $shellflags
+
++ firstmakefile = $firstmakefile
++
+ libs = $libs
++ O = $obj_ext
++ O_REGEXP = $obj_ext_regexp
++ A = $lib_ext
++ AR = $ar
++
++ .SUFFIXES: .c \$(O)
++
+ !GROK!THIS!
+
+ cat >>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");
--- /dev/null
+#define INCL_DOS
+#define INCL_NOPM
+#include <os2.h>
+
+/*
+ * Various Unix compatibility functions for OS/2
+ */
+
+#include <stdio.h>
+#include <errno.h>
+#include <limits.h>
+#include <process.h>
+
+#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
--- /dev/null
+#include <signal.h>
+
+/* 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 <stdlib.h> /* before the following definitions */
+#include <unistd.h> /* 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
-#define PATCHLEVEL 1
+#define PATCHLEVEL 2
/* 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.
#endif
*/
-char rcsid[] = "perl.c\nPatch level: ###\n";
+dEXT char rcsid[] = "perl.c\nPatch level: ###\n";
#ifdef IAMSUID
#ifndef DOSUID
return;
destruct_level = perl_destruct_level;
+#ifdef DEBUGGING
+ {
+ char *s;
+ if (s = getenv("PERL_DESTRUCT_LEVEL"))
+ destruct_level = atoi(s);
+ }
+#endif
+
LEAVE;
FREETMPS;
}
if (sv_count != 0)
warn("Scalars leaked: %d\n", sv_count);
+ sv_free_arenas();
DEBUG_P(debprofdump());
}
case 'c':
case 'd':
case 'D':
+ case 'h':
case 'i':
case 'l':
case 'n':
if (create && !GvCV(gv))
return newSUB(start_subparse(),
newSVOP(OP_CONST, 0, newSVpv(name,0)),
+ Nullop,
Nullop);
if (gv)
return GvCV(gv);
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:
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) {
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
}
}
+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 *
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
#endif
/*SUPPRESS 530*/
return s;
+ case 'h':
+ usage(origargv[0]);
+ exit(0);
case 'i':
if (inplace)
Safefree(inplace);
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
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
uid |= gid << 16;
euid |= egid << 16;
#endif
- tainting |= (euid != uid || egid != gid);
+ tainting |= (uid && (euid != uid || egid != gid));
}
static void
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);
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');
incpush(getenv("PERLLIB"));
}
-#ifdef SITELIB_EXP
- incpush(SITELIB_EXP);
+#ifdef APPLLIB_EXP
+ incpush(APPLLIB_EXP);
#endif
+
#ifdef ARCHLIB_EXP
incpush(ARCHLIB_EXP);
#endif
#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
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);
* 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
#endif
#include <stdio.h>
-#ifdef USE_NEXT_CTYPE
+#ifdef USE_NEXT_CTYPE
#include <appkit/NXCType.h>
#else
#include <ctype.h>
#endif
+#ifdef I_LOCALE
+#include <locale.h>
+#endif
+
#ifdef METHOD /* Defined by OSF/1 v3.0 by ctype.h */
#undef METHOD
#endif
# include <stdlib.h>
#endif /* STANDARD_C */
+/* Maybe this comes after <stdlib.h> 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)
# endif
# endif
# endif
-#endif
+#endif
#ifdef FPUTS_BOTCH
/* work around botch in SunOS 4.0.1 and 4.0.2 */
#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"
#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
#define SCAN_REPL 2
#ifdef DEBUGGING
-# ifndef register
+# ifndef register
# define register
# endif
# define PAD_SV(po) pad_sv(po)
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 */
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;
/* 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 */
--- /dev/null
+#!/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 <kjahds@kjahds.com>
+# -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 <doughera@lafcol.lafayette.edu>
+# -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<perldoc> [B<-h>] [B<-v>] PageName|ModuleName|ProgramName
+
+=head1 DESCRIPTION
+
+I<perldoc> 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<PageName|ModuleName|ProgramName>
+
+The item you want to look up. Nested modules (such as C<File::Basename>)
+are specified either as C<File::Basename> or C<File/Basename>. You may also
+give a descriptive name of a page, such as C<perlfunc>. 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<PERLDOC> environment variable will be used before the
+command line arguments. C<perldoc> also searches directories
+specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
+defined) and C<PATH> environment variables.
+(The latter is so that embedded pods for executables, such as
+C<perldoc> itself, are available.)
+
+=head1 AUTHOR
+
+Kenneth Albanowski <kjahds@kjahds.com>
+
+Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>
+
+=head1 SEE ALSO
+
+=head1 DIAGNOSTICS
+
+=cut
+
+if(@ARGV<1) {
+ die <<EOF;
+Usage: $0 [-h] [-v] PageName|ModuleName|ProgramName
+
+We suggest you use "perldoc perldoc" to get aquainted
+with the system.
+EOF
+}
+
+use Getopt::Std;
+
+sub usage{
+ warn "@_\n" if @_;
+ die <<EOF;
+perldoc [-h] [-v] PageName|ModuleName|ProgramName...
+ -h Display this help message.
+ -v Verbosely describe what's going on.
+PageName|ModuleName...
+ is the name of a piece of documentation that you want to look at. You
+ may either give a descriptive name of the page (as in the case of
+ `perlfunc') the name of a module, either like `Term::Info',
+ `Term/Info', the partial name of a module, like `info', or
+ `makemaker', or the name of a program, like `perldoc'.
+
+Any switches in the PERLDOC environment variable will be used before the
+command line arguments.
+
+EOF
+}
+
+use Text::ParseWords;
+
+
+unshift(@ARGV,shellwords($ENV{"PERLDOC"}));
+
+getopts("hv") || usage;
+
+usage if $opt_h;
+
+$index = $opt_i;
+@pages = @ARGV;
+
+sub containspod {
+ my($file) = @_;
+ local($_);
+ open(TEST,"<$file");
+ while(<TEST>) {
+ 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 <IN>;
+ close(IN);
+ close(OUT);
+ }
+}
+
+if( $opt_f ) {
+ open(TMP,"<$tmp");
+ print while <TMP>;
+ 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 ':';
+++ /dev/null
-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 <<!GROK!THIS!
-#!$binexp/perl
-!GROK!THIS!
-
-$spitshell >>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 <doughera@lafcol.lafayette.edu>
-# -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<perldoc> [B<-h>] PageName|ModuleName
-
-=head1 DESCRIPTION
-
-I<perldoc> 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<PageName|ModuleName>
-
-The item you want to look up. Nested modules (such as C<File::Basename>)
-are specified either as C<File::Basename> or C<File/Basename>. You
-may also give a descriptive name of a page, such as C<perlfunc>.
-
-=back
-
-=head1 ENVIRONMENT
-
-Any switches in the C<PERLDOC> environment variable will be used before the
-command line arguments. C<perldoc> also searches directories
-specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
-defined) and C<PATH> environment variables.
-(The latter is so that embedded pods for executables, such as
-C<perldoc> itself, are available.)
-
-=head1 AUTHOR
-
-Kenneth Albanowski <kjahds@kjahds.com>
-
-Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>
-
-=head1 SEE ALSO
-
-=head1 DIAGNOSTICS
-
-=cut
-
-if(@ARGV<1) {
- die <<EOF;
-Usage: $0 [-h] PageName|ModuleName
-
-We suggest you use "perldoc perldoc" to get aquainted
-with the system.
-EOF
-}
-
-use Getopt::Std;
-
-sub usage{
- warn "@_\n" if @_;
- die <<EOF;
-perlman [-h] PageName|ModuleName...
- -h Display this help message.
-PageName|ModuleName...
- is the name of a piece of documentation that you want to look at. You
- may either give a descriptive name of the page (as in the case of
- `perlfunc') or the name of a module, either like `Term::Info',
- `Term/Info'.
-
-Any switches in the PERLDOC environment variable will be used before the
-command line arguments.
-
-EOF
-}
-
-use Text::ParseWords;
-
-unshift(@ARGV,shellwords($ENV{"PERLDOC"}));
-
-getopts("h") || usage;
-
-usage if $opt_h;
-
-$index = $opt_i;
-@pages = @ARGV;
-
-sub containspod {
- my($file) = @_;
- local($_);
- open(TEST,"<$file");
- while(<TEST>) {
- 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 <IN>;
- close(IN);
-}
-close(OUT);
-!NO!SUBS!
-chmod 755 perldoc
-$eunicefix perldoc
#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,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 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,
-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,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,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",
"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 ';'",
"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 : HASHBRACK expr ';' '}'",
"term : HASHBRACK ';' '}'",
-"term : ANONSUB startsub block",
+"term : ANONSUB startsub proto block",
"term : scalar",
"term : star",
"term : scalar '[' expr ']'",
"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 ')'",
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
switch (yyn)
{
case 1:
-#line 83 "perly.y"
+#line 84 "perly.y"
{
#if defined(YYDEBUG) && defined(DEBUGGING)
yydebug = (debug & 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));
}
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)),
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,
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;
-*** 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");
}
- #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;
- 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
{
yyn = *yys;
***************
-*** 1367,1372 ****
---- 1345,1358 ----
+*** 1371,1376 ****
+--- 1346,1359 ----
yyerrflag = 0;
yychar = (-1);
yyvsp = yyvs;
*yyssp = yystate = 0;
***************
-*** 1382,1388 ****
+*** 1386,1392 ****
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
yychar, yys);
}
#endif
---- 1368,1374 ----
+--- 1369,1375 ----
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
}
#endif
***************
-*** 1392,1403 ****
+*** 1396,1407 ****
{
#if YYDEBUG
if (yydebug)
}
*++yyssp = yystate = yytable[yyn];
*++yyvsp = yylval;
---- 1378,1403 ----
+--- 1379,1404 ----
{
#if YYDEBUG
if (yydebug)
*++yyssp = yystate = yytable[yyn];
*++yyvsp = yylval;
***************
-*** 1433,1444 ****
+*** 1437,1448 ****
{
#if YYDEBUG
if (yydebug)
}
*++yyssp = yystate = yytable[yyn];
*++yyvsp = yylval;
---- 1433,1459 ----
+--- 1434,1460 ----
{
#if YYDEBUG
if (yydebug)
*++yyssp = yystate = yytable[yyn];
*++yyvsp = yylval;
***************
-*** 1448,1455 ****
+*** 1452,1459 ****
{
#if YYDEBUG
if (yydebug)
#endif
if (yyssp <= yyss) goto yyabort;
--yyssp;
---- 1463,1471 ----
+--- 1464,1472 ----
{
#if YYDEBUG
if (yydebug)
if (yyssp <= yyss) goto yyabort;
--yyssp;
***************
-*** 1466,1473 ****
+*** 1470,1477 ****
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
}
#endif
yychar = (-1);
---- 1482,1490 ----
+--- 1483,1491 ----
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
#endif
yychar = (-1);
***************
-*** 1476,1482 ****
+*** 1480,1486 ****
yyreduce:
#if YYDEBUG
if (yydebug)
yystate, yyn, yyrule[yyn]);
#endif
yym = yylen[yyn];
---- 1493,1499 ----
+--- 1494,1500 ----
yyreduce:
#if YYDEBUG
if (yydebug)
#endif
yym = yylen[yyn];
***************
-*** 2163,2170 ****
+*** 2189,2196 ****
{
#if YYDEBUG
if (yydebug)
#endif
yystate = YYFINAL;
*++yyssp = YYFINAL;
---- 2180,2188 ----
+--- 2203,2211 ----
{
#if YYDEBUG
if (yydebug)
yystate = YYFINAL;
*++yyssp = YYFINAL;
***************
-*** 2178,2184 ****
+*** 2204,2210 ****
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
YYFINAL, yychar, yys);
}
#endif
---- 2196,2202 ----
+--- 2219,2225 ----
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
}
#endif
***************
-*** 2193,2212 ****
+*** 2219,2238 ****
yystate = yydgoto[yym];
#if YYDEBUG
if (yydebug)
yyaccept:
! return (0);
}
---- 2211,2245 ----
+--- 2234,2268 ----
yystate = yydgoto[yym];
#if YYDEBUG
if (yydebug)
#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;
%token <ival> '{' ')'
%token <opval> WORD METHOD FUNCMETH THING PMFUNC PRIVATEREF
+%token <opval> FUNC0SUB UNIOPSUB LSTOPSUB
%token <pval> LABEL
%token <ival> FORMAT SUB ANONSUB PACKAGE USE
%token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE FOR
%type <opval> block lineseq line loop cond nexpr else argexpr
%type <opval> expr term scalar ary hsh arylen star amper sideff
%type <opval> listexpr listexprcom indirob
-%type <opval> texpr listop method
+%type <opval> texpr listop method proto
%type <pval> label
%type <opval> cont
| 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
{ 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(); }
;
{ $$ = 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
{ $$ = 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 '('
{ $$ = 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; }
{ $$ = 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 ')'
-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 \
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 \
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 \
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 \
perlsub.tex \
perlsyn.tex \
perltrap.tex \
- perlvar.tex
-
+ perlvar.tex \
+ perlxs.tex \
+ perlxstut.tex
man: pod2man $(MAN)
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
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
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
(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</usr/local/lib/perl5/man/man3> 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</usr/local/man/> 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</usr/local/man/man1> and F</usr/local/man/man3>,
+you would only need to add F</usr/local/man> 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<perldoc> 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
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
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
=head1 AUTHOR
-Larry Wall <F<lwall@netlabs.com.>, with the help of oodles of other folks.
+Larry Wall E<lt><F<lwall@netlabs.com>E<gt>, with the help of oodles of other folks.
=head1 FILES
=head1 SEE ALSO
a2p awk to perl translator
+
s2p sed to perl translator
=head1 DIAGNOSTICS
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()
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<http://perl.com/perl/bugs/>.
+
Perl actually stands for Pathologically Eclectic Rubbish Lister, but
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.
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)
=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<SUPER> 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" }
package Foo;
@ISA = qw( Bar Baz );
- @Foo::Inherit::ISA = @ISA; # Access to overridden methods.
sub new {
my $type = shift;
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;
=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
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<awk>:
+
+ 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<csh>. (Actually, it's not
the length of the array, it's the subscript of the last element, since
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
Numeric literals are specified in any of the customary floating point or
integer formats:
-
12345
12345.67
.23E-10
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
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
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";
The price is $Price.
EOF
- print << x 10; # Legal but discouraged. Use <<"".
- Merry Christmas!
-
print <<`EOC`; # execute commands
echo hi there
echo lo there
(@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<NOT> interpolate, see L<perlref>.
The null list is represented by (). Interpolating it in a list
# 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];
($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().
# same as map assignment above
%map = ('red',0x00f,'blue',0x0f0,'green',0xf00);
-It is often more readable to use the C<=E<gt>> operator between key/value pairs
-(the C<=E<gt>> 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<gt>> operator between key/value
+pairs. The C<=E<gt>> 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
+ );
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
(W) You tried to do a bind on a closed socket. Did you forget to check
the return value of your socket() call? See L<perlfunc/bind>.
+=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()
you should only be calling it out of an AUTOLOAD routine anyway. See
L<perlfunc/goto>.
+=item Can't localize a reference
+
+(F) You said something like C<local $$ref>, 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
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}.
(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.
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.
=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<lt>=E<gt> or C<cmp>, or by not using them correctly.
+it by not using C<E<lt>=E<gt>> or C<cmp>, or by not using them correctly.
See L<perlfunc/sort>.
=item Sort subroutine didn't return single value
(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
(F) The sort comparison routine specified is declared but doesn't seem to
have been defined yet. See L<perlfunc/sort>.
+=item Undefined top format "%s" called
+
+(F) The format indicated doesn't seem to exist. Perhaps it's really in
+another package? See L<perlform>.
+
=item unexec of %s into %s failed!
(F) The unexec() routine failed for some reason. See your local FSF
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
throws away the left argument, which is not what you want. See
L<perlref> 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
--- /dev/null
+=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<awk> 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<print @LoL>? 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<references> 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<use> 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<gt>[3]>, C<$h-E<gt>{fred}>, or even C<$ob-E<gt>method()-E<gt>[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<very same place>, and they will therefore all hold
+whatever was last in @list! It's similar to the problem demonstrated in
+the following C program:
+
+ #include <pwd.h>
+ 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<rp> and C<dp> 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<copy>
+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<copy> 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<would> 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<per se>. This means that the my() variable is
+remade afresh each time through the loop. So even though it I<looks> 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<i'th>
+element of C<a>. 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<i'th> 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<use strict>
+
+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<at compile time>,
+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 E<lt>F<ilya@math.ohio-state.edu>E<gt>
+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<x> 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<x> command which is nearly the same.
+
+=head1 SEE ALSO
+
+perlref(1), perldata(1)
+
+=head1 AUTHOR
+
+Tom Christiansen E<lt>F<tchrist@perl.com>E<gt>
+
+Last update:
+Sat Oct 7 22:41:09 MDT 1995
+
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<perlfunc/my> for other issues.
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<next unless -f $file && -T $file>.
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
Accepts an incoming socket connect, just as the accept(2) system call
does. Returns the packed address if it succeeded, FALSE otherwise.
-See example in L<perlipc>.
+See example in L<perlipc/"Sockets: Client/Server Communication">.
=item alarm SECONDS
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</select()> below.
+or else see L</select()> below. It is not advised to intermix alarm()
+and sleep() calls.
=item atan2 Y,X
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<perlipc>.
+packed address of the appropriate type for the socket. See the examples in
+L<perlipc/"Sockets: Client/Server Communication">.
=item binmode FILEHANDLE
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<perlobj> 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<perlobj> for more about the
+blessing (and blessings) of objects.
=item caller EXPR
$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
=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;
@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.
=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
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<perlipc>.
+packed address of the appropriate type for the socket. See the examples in
+L<perlipc/"Sockets: Client/Server Communication">.
=item cos EXPR
=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:
[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<NOT> 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
}
dbmclose(%HIST);
+See also L<DB_File> for many other interesting possibilities.
+
=item defined EXPR
Returns a boolean value saying whether the lvalue EXPR has a real value
=item die LIST
Outside of an eval(), prints the value of LIST to C<STDERR> 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<($? E<gt>E<gt> 8)> (backtick `command` status). If C<($? E<gt>E<gt> 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:
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
=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
=item eof FILEHANDLE
+=item eof ()
+
=item eof
Returns 1 if the next read on FILEHANDLE will return end of file, or if
An C<eof> 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<eof()> is reasonable to use inside a while (<>) loop to detect the end
of only the last file. Use C<eof(ARGV)> or eof without the parentheses to
test I<EACH> file in a while (<>) loop. Examples:
}
Practical hint: you almost never need to use C<eof> 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<eof>
=item eval EXPR
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.
=item flock FILEHANDLE,OPERATION
-Calls flock(2) on FILEHANDLE. See L<flock(2)> 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<flock(2)> 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;
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<undef> 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.
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);
exec "what you really wanna do";
die "no exec";
# ... or ...
- some_perl_code_here;
+ ## (some_perl_code_here)
exit 0;
}
exit 0;
=item formline PICTURE, LIST
-This is an internal function used by formats, though you may call it
+This is an internal function used by C<format>s, though you may call it
too. It formats (see L<perlform>) 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<perlform> for other examples.
=item getc FILEHANDLE
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 >/dev/tty 2>&1";
+ }
+ else {
+ system "stty", '-icanon',
+ system "stty", 'eol', "\001";
+ }
+
+ $key = getc(STDIN);
+
+ if ($BSD_STYLE) {
+ system "stty -cbreak </dev/tty >/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</etc/utmp>, 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.
=item getpriority WHICH,WHO
-Returns the current priority for a process, a process group, or a
-user. (See L<getpriority(2)>.) Will produce a fatal error if used on a
+Returns the current priority for a process, a process group, or a user.
+(See L<getpriority(2)>.) Will raise a fatal exception if used on a
machine that doesn't implement getpriority(2).
=item getpwnam NAME
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
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) =
=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</use> and L<perlmod>.
+for the package used. See also L</use>, L<perlmod>, and L<Exporter>.
=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
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<ioctl.ph> doesn't
exist or doesn't have the correct definitions you'll have to roll your
-own, based on your C header files such as <sys/ioctl.h>. (There is a
-Perl script called B<h2ph> 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 F<E<lt>sys/ioctl.hE<gt>>.
+(There is a Perl script called B<h2ph> 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: $!";
}
print $key, '=', $ENV{$key}, "\n";
}
+To sort an array by value, you'll need to use a C<sort{}>
+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<SIGNAL> is negative, it kills process groups instead of processes.
-(On System V, a negative I<PROCESS> 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<SIGNAL> is negative, it kills
+process groups instead of processes. (On System V, a negative I<PROCESS>
+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<perlipc/"Signals"> man page for details.
=item last LABEL
omitted, the command refers to the innermost enclosing loop. The
C<continue> block, if any, is not executed:
- line: while (<STDIN>) {
- last line if /^$/; # exit when done with header
+ LINE: while (<STDIN>) {
+ 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
=item listen SOCKET,QUEUESIZE
Does the same thing that the listen system call does. Returns TRUE if
-it succeeded, FALSE otherwise. See example in L<perlipc>.
+it succeeded, FALSE otherwise. See example in L<perlipc/"Sockets: Client/Server Communication">.
=item local EXPR
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
=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
=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<eval>, or C<do/require/use>'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
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
The C<next> command is like the C<continue> statement in C; it starts
the next iteration of the loop:
- line: while (<STDIN>) {
- next line if /^#/; # discard comments
+ LINE: while (<STDIN>) {
+ next LINE if /^#/; # discard comments
...
}
=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/;
=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<perlipc/"Using open() for IPC">
+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<open2>,
+L<open3>, and L<perlipc/"Bidirectional Communication"> 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";
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
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")
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]';
open(FOO, "cat -n '$file'|");
open(FOO, "-|") || exec 'cat', '-n', $file;
+See L<perlipc/"Safe Pipe Opens"> 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
stdio buffering, so you may need to set $| to flush your WRITEHANDLE
after each command, depending on the application.
+See L<open2>, L<open3>, and L<perlipc/"Bidirectional Communication">
+for examples of such things.
+
=item pop ARRAY
Pops and returns the last value of the array, shortening the array by
=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<m//g> search left off for the variable
in question. May be modified to change that offset.
=item print FILEHANDLE LIST
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
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<perlipc/"UDP: Message Passing"> for examples.
=item redo LABEL
# a simpleminded Pascal comment stripper
# (warning: assumes no { or } in strings)
- line: while (<STDIN>) {
+ LINE: while (<STDIN>) {
while (s|({.*}.*){.*}|$1 |) {}
s|{.*}| |;
if (s|{.*| |) {
while (<STDIN>) {
if (/}/) { # end of comment?
s|^|$front{|;
- redo line;
+ redo LINE;
}
}
}
=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
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
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
$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 = '';
}
$bits;
}
- $rin = &fhbits('STDIN TTY SOCK');
+ $rin = fhbits('STDIN TTY SOCK');
The usual idiom is:
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);
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<perlipc/"UDP: Message Passing"> for examples.
=item setpgrp PID,PGRP
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<perlipc>.
+the proper definitions imported. See the example in L<perlipc/"Sockets: Client/Server Communication">.
=item socketpair SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL
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
(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</PATTERN/> may be replaced with an expression to specify
patterns that vary at runtime. (To do runtime compilation only once,
use C</$variable/o>.)
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
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
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<DB_File>
+or the F<Config> module for interesting tie() implementations.
+
=item time
Returns the number of non-leap seconds since 00:00:00 UTC, January 1,
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
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);
=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
=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<kill -l> 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<except for> 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<eval{}> 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<eval{}> 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<t/lib/posix.t> 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 (<STATUS>) {
+ 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<f1>, the process F<cmd1>, standard input (F<tmpfile>
+in this case), the F<f2> file, the F<cmd2> command, and finally the F<f3>
+file. 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<writing> 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<to> minus, you can
+write to the filehandle you opened and your kid will find it in his
+STDIN. If you open a pipe I<from> 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 (<STDIN>) {
+ 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 (<KID>) {
+ # 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<modules> file mentioned below in the L<SEE ALSO> 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 = <Reader>;
+
+The problem with this is that Unix buffering is going to really
+ruin your day. Even though your C<Writer> 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<cat> 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<Comm.pl> 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<Comm> library also has expect()
+and interact() functions. Find the library (and hopefully its
+successor F<IPC::Chat>) at your nearest CPAN archive as detailed
+in the L<SEE ALSO> section below.
- select(S); $| = 1; select(stdout);
+=head1 Sockets: Client/Server Communication
- if ($child = fork) {
- while (<>) {
- print S;
- }
- sleep 3;
- do dokill();
- }
- else {
- while (<S>) {
- 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<Socket> 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 = <SOCK>) {
+ 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 (<NS>) {
- 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<perlsec>)
+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 = <SOCK>) {
+ 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 "$!";
Put this code in a separate file to be run in more that one process
Call this file F<give>:
- #'give' the semaphore
+ # 'give' the semaphore
# run this in the original process and you will see
# that the second process continues
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<use strict> and
+C<require "sys/ipc.ph">. Better yet, perhaps someone should create an
+C<IPC::SysV> module the way we have the C<Socket> 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<use strict> and some of the my() statements for 5.000, and for both
+you'll have to load in version 1.2 of the F<Socket.pm> module, which
+was/is/shall-be included in I<perl5.001o>.
+
+Most of these routines quietly but politely return C<undef> 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<Socket> 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<perlfunc>, you should also check out
+the F<modules> file at your nearest CPAN site. (See L<perlmod> or best
+yet, the F<Perl FAQ> for a description of what CPAN is and where to get it.)
+Section 5 of the F<modules> 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.
--- /dev/null
+=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<not> 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<use strict>, 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<also> 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<undef> 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<couldn't> 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<two-dimensional slice>, 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<strict refs>, 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 <tchrist@perl.com>
+
+Last udpate: Sat Oct 7 19:35:26 MDT 1995
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:
the name of the subroutine is qualified so that its name is inserted
into package C<main>.
-Assignment to a symbol table entry performs an aliasing operation,
+Assignment to a typeglob performs an aliasing operation,
i.e.,
*dick = *richard;
=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<perlobj>.
+by listing the other package name in its @ISA array.
+
+For more on this, see L<perlobj>.
=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
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<Exporter> and the I<Perl Modules File> for details on
+mechanics and style issues in module creation.
+
+Perl modules are included into your program by saying
use Module;
=over 12
+=item C<diagnostics>
+
+Pragma to produce enhanced diagnostics
+
=item C<integer>
-Perl pragma to compute arithmetic in integer instead of double
+Pragma to compute arithmetic in integer instead of double
=item C<less>
-Perl pragma to request less of something from the compiler
+Pragma to request less of something from the compiler
=item C<sigtrap>
-Perl pragma to enable stack backtrace on unexpected signals
+Pragma to enable stack backtrace on unexpected signals
=item C<strict>
-Perl pragma to restrict unsafe constructs
+Pragma to restrict unsafe constructs
=item C<subs>
-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<Abbrev>
-
-create an abbreviation table from a list
-
-=item C<AnyDBM_File>
-
-provide framework for multiple DBMs
-
-=item C<AutoLoader>
-
-load functions only on demand
-
-=item C<AutoSplit>
-
-split a package for autoloading
-
-=item C<Basename>
-
-parse file name and path from a specification
-
-=item C<Benchmark>
-
-benchmark running times of code
-
-=item C<Carp>
-
-warn or die of errors (from perspective of caller)
+Exporter module. See their own documentation for details.
-=item C<CheckTree>
+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<Collate>
+They should all have their own documentation installed and accessible via
+your system man(1) command. If that fails, try the I<perldoc> program.
-compare 8-bit scalar data according to the current locale
-
-=item C<Config>
-
-access Perl configuration option
+=head2 Extension Modules
-=item C<Cwd>
+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<DynaLoader>
+=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<English>
+=over
-use nice English (or B<awk>) names for ugly punctuation variables
+=item *
+Language Extensions and Documentation Tools
-=item C<Env>
+=item *
+Development Support
-Perl module that imports environment variables
+=item *
+Operating System Interfaces
-=item C<Exporter>
+=item *
+Networking, Device Control (modems) and InterProcess Communication
-module to control namespace manipulations
+=item *
+Data Types and Data Type Utilities
-=item C<Fcntl>
+=item *
+Database Interfaces
-load the C Fcntl.h defines
+=item *
+User Interfaces
-=item C<FileHandle>
+=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<Find>
+=item *
+String Processing, Language Text Processing, Parsing and Searching
-traverse a file tree
+=item *
+Option, Argument, Parameter and Configuration File Processing
-=item C<Finddepth>
+=item *
+Internationalization and Locale
-traverse a directory structure depth-first
+=item *
+Authentication, Security and Encryption
-=item C<Getopt>
+=item *
+World Wide Web, HTML, HTTP, CGI, MIME
-basic and extended getopt(3) processing
+=item *
+Server and Daemon Utilities
-=item C<MakeMaker>
+=item *
+Archiving and Compression
-generate a Makefile for Perl extension
+=item *
+Images, Pixmap and Bitmap Manipulation, Drawing and Graphing
-=item C<Open2>
+=item *
+Mail and Usenet News
-open a process for both reading and writing
+=item *
+Control Flow Utilities (callbacks and exceptions etc)
-=item C<Open3>
+=item *
+File Handle and Input/Output Stream Utilities
-open a process for reading, writing, and error handling
+=item *
+Miscellaneous Modules
-=item C<POSIX>
+=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<Ping>
+=over
-check a host for upness
+=item *
+ftp://ftp.sterling.com/programming/languages/perl/
-=item C<Socket>
+=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<Curses>
+=item *
+ftp://ftp.ci.uminho.pt/pub/lang/perl/
-Written by William Setzer <F<William_Setzer@ncsu.edu>>, 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<DBI>
+=item *
+ftp://ftp.pasteur.fr/pub/computing/unix/perl/CPAN/
-This is the portable database interface written by
-<F<Tim.Bunce@ig.co.uk>>. This supersedes the many perl4 ports for
-database extensions. The official archive for DBperl extensions is
-F<ftp.demon.co.uk:/pub/perl/db>. 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<DB_File>
+=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<DB_File> for
-where.
+=item *
+ftp://ftp.tekotago.ac.nz/pub/perl/CPAN/
-=item C<Sx>
+=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
-<F<dbg@sgi.com>>, then and rewritten for Sx by FrE<eacute>dE<eacute>ric
-Chauveau <F<fmc@pasteur.fr>>. 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<Tk>
+=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 <F<mbeattie@sable.ox.ac.uk>>.
-If you are unable to locate it using archie(1L) or a similar
-tool, you may try retrieving it from F</private/Tk-october.tar.gz>
-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/.
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.
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)
C</o> constitutes a promise that you won't change the variables in the pattern.
If you change them, Perl won't even notice.
-If the PATTERN evaluates to 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
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</o> 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<perlre> for further explanation on these.
Options are:
# 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
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<E<lt>$fooE<gt>> 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<E<lt>${foo}E<gt>>. (Alternately, you can
-call the internal function directly as C<glob($foo)>, 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<E<lt>$fooE<gt>>
+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<E<lt>${foo}E<gt>>.
+These days, it's consdired cleaner to call the internal function directly
+as C<glob($foo)>, which is probably the right way to have done it in the
+first place.) Example:
while (<*.c>) {
chmod 0644, $_;
implementation of using a shell, the glob() routine may get "Arg list too
long" errors (unless you've installed tcsh(1L) as F</bin/csh>).
+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) = <blurch*>;
+
+than
+
+ $file = <blurch*>;
+
+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
=item text
=over N
=back
+ =cut
=item *
TeX, and other markup languages, as used for online documentation.
Both B<pod2html> and B<pod2man> 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
modifiers may also be embedded within the regular expression itself using
the new C<(?...)> construct. See below.
-The C</x> 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</x> 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<perlop>.
=head2 Regular Expressions
digit'th substring. (Outside of the pattern, always use "$" instead of
"\" in front of the digit. The scope of $<digit> (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 ?.
+(Don't
+convert references into strings though, or you'll break their referenceness.)
+
=head1 NAME
perlref - Perl references and nested data structures
implicit loop with either the B<-n> or B<-p> switch. It's just not the
mandatory default like it is in B<sed> and B<awk>.)
+=head2 Declarations
+
Perl is, for the most part, a free-form language. (The only
exception to this is format declarations, for obvious reasons.) Comments
are indicated by the "#" 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<or> instead of C<||> there.
-Subroutines declarations can also be imported by a C<use> statement.
+Subroutines declarations can also be loaded up with the C<require> statement
+or both loaded and imported into your namespace with a C<use> statement.
+See L<perlmod> 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
block takes up more than one line, since you may eventually add another line.)
Note that there are some operators like C<eval {}> and C<do {}> 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<SINGLE> modifier,
just before the terminating semicolon (or block ending). The possible
can write loops like:
do {
- $_ = <STDIN>;
+ $line = <STDIN>;
...
- } until $_ eq ".\n";
+ } until $line eq ".\n";
See L<perlfunc/do>. Note also that the loop control
statements described later will I<NOT> 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
The C<while> 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<next>, C<last>, and C<redo> (see below). If there is a C<continue>
-BLOCK, it is always executed just before the conditional is about to be
-evaluated again, just like the third part of a C<for> loop in C.
-Thus it can be used to increment a loop variable, even when the loop
-has been continued via the C<next> statement (which is similar to the C
-C<continue> statement).
+optional, and if present, consists of an identifier followed by a colon.
+The LABEL identifies the loop for the loop control statements C<next>,
+C<last>, and C<redo>. 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<continue> BLOCK, it is always executed just before the
+conditional is about to be evaluated again, just like the third part of a
+C<for> loop in C. Thus it can be used to increment a loop variable, even
+when the loop has been continued via the C<next> statement (which is
+similar to the C C<continue> statement).
+
+=head2 Loop Control
+
+The C<next> command is like the C<continue> statement in C; it starts
+the next iteration of the loop:
+
+ LINE: while (<STDIN>) {
+ next LINE if /^#/; # discard comments
+ ...
+ }
+
+The C<last> command is like the C<break> statement in C (as used in
+loops); it immediately exits the loop in question. The
+C<continue> block, if any, is not executed:
+
+ LINE: while (<STDIN>) {
+ last LINE if /^$/; # exit when done with header
+ ...
+ }
+
+The C<redo> command restarts the loop block without evaluating the
+conditional again. The C<continue> block, if any, is I<not> 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</etc/termcap>.
+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 = <ARGV>) {
+ chomp($line);
+ if ($line =~ s/\\$//) {
+ $line .= <ARGV>;
+ 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 (<STDIN>) {
+ while (s|({.*}.*){.*}|$1 |) {}
+ s|{.*}| |;
+ if (s|{.*| |) {
+ $front = $_;
+ while (<STDIN>) {
+ if (/}/) { # end of comment?
+ s|^|$front{|;
+ redo LINE;
+ }
+ }
+ }
+ print;
+ }
+
+Note that if there were a C<continue> block on the above code, it would get
+executed even on discarded lines.
If the word C<while> is replaced by the word C<until>, the sense of the
test is reversed, but the conditional is still tested before the first
In either the C<if> or the C<while> 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<for> loop works exactly like the corresponding C<while> loop:
+Perl's C-style C<for> loop works exactly like the corresponding C<while> loop:
for ($i = 1; $i < 10; $i++) {
...
$i++;
}
-The foreach loop iterates over a normal list value and sets the
+The C<foreach> 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<my>, it uses
-that variable instead of the global one, but it's still localized to
-the loop.) The C<foreach> keyword is actually a synonym for the C<for>
-keyword, so you can use C<foreach> for readability or C<for> 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<my>, 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<foreach> keyword is actually a synonym for the C<for> keyword, so
+you can use C<foreach> for readability or C<for> 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<foreach>
+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<foreach> statement more
+rapidly than it would the equivalent C<for> 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<continue> block
-is optional. This construct is particularly nice for doing case
+is optional.
+
+The BLOCK construct is particularly nice for doing case
structures.
SWITCH: {
else
{ $nothing = 1 }
+
+A common idiom for a switch statement is to use C<foreach>'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<goto> statement.
+A loop's LABEL is not actually a valid target for a C<goto>;
+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<goto>, 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<next>, C<last>, or C<redo> insetad
+resorting to a C<goto>. For certain applications, the catch and throw pair of
+C<eval{}> and die() for exception processing can also be a prudent approach.
=item *
-C<ARGV> must be capitalized.
+C<ARGV> must be capitalized. C<$ARGV[0]> is C's C<argv[1]>, and C<argv[0]>
+ends up in C<$0>.
=item *
=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<open FOO || die> 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.
=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 "C<E<lt>E<gt>>" 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
+"C<E<lt>E<gt>>" 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
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<xsubpp>.)
-
- 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.
}
}
+=head2 The REQUIRE: Keyword
+
+The REQUIRE: keyword is used to indicate the minimum version of the
+B<xsubpp> compiler needed to compile the XS module. An XS module which
+contains the following statement will only compile with B<xsubpp> version
+1.922 or greater:
+
+ REQUIRE: 1.922
+
=head2 The CLEANUP: Keyword
This keyword can be used when an XSUB requires special cleanup procedures
--- /dev/null
+=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<perlguts> and
+L<perlxs>.
+
+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 <extension>.pm and <extension>.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<use extension;>. 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 <stdlib.h>
+ #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<constant> 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<constant> 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 <libtest4.h>
+
+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
+F<E<lt>okamoto@hpcc123.corp.hp.comE<gt>>
--- /dev/null
+#!/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 = '<A HREF="file://localhost/usr/local/htmldir/'; # file url
+# $type = '<A HREF="http://www.bozo.com/perl/manual/html/' # server
+#
+################################################################################
+
+$type = '<A HREF="';
+$dir = "."; # location of pods
+
+# look in these pods for things not found within the current pod
+# be careful tho, namespace collisions cause stupid links
+
+@inclusions = qw[
+ perlfunc perlvar perlrun perlop
+];
+################################################################################
+# END CONFIGURE
+################################################################################
+
+$A = {}; # The beginning of all things
+
+unless (@Pods) {
+ opendir(DIR,$dir) or die "Can't opendir $dir: $ERRNO";
+ @Pods = grep(/\.pod$/,readdir(DIR));
+ closedir(DIR) or die "Can't closedir $dir: $ERRNO";
+}
+@Pods or die "aak, expected pods";
+
+# loop twice through the pods, first to learn the links, then to produce html
+for $count (0,1) {
+ print STTDER "Scanning pods...\n" unless $count;
+ foreach $podfh ( @Pods ) {
+ ($pod = $podfh) =~ s/\.pod$//;
+ Debug("files", "opening 2 $podfh" );
+ print "Creating $pod.html from $podfh\n" if $count;
+ $RS = "\n="; # grok pods by item (Nonstandard but effecient)
+ open($podfh,"<".$podfh) || die "can't open $podfh: $ERRNO";
+ @all = <$podfh>;
+ 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 '<!-- $Id$ -->',"\n",'<HTML><HEAD>',"\n";
+ print HTML "<CENTER>" unless $NO_NS;
+ print HTML "<TITLE>$pod</TITLE>\n</HEAD>\n<BODY>";
+ print HTML "</CENTER>" 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</BODY>\n</HTML>\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{<DL COMPACT>} : qq{<$$list_type>};
+ $$depth++;
+ }
+ elsif ($which eq "back") {
+ print HTML qq{\n</$$list_type>\n};
+ $$depth--;
+ }
+}
+
+sub do_hdr{ # headers
+ my($num,$title,$rest,$depth) = @_;
+ print HTML qq{<p><hr>\n} if $num == 1;
+ process_thing(\$title,"NAME");
+ print HTML qq{\n<H$num> };
+ print HTML $title;
+ print HTML qq{</H$num>\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<DT><STRONG>\n};
+ print HTML $title;
+ print HTML qq{\n</STRONG>\n};
+ print HTML qq{<DD>\n};
+ }
+ else {
+ print HTML qq{\n<LI>};
+ 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{<UL>};
+ foreach $line (@lines) {
+ ($line =~ /^\s+(\w*)\t(.*)/) && (($key,$rem) = ($1,$2));
+ print HTML defined($Podnames{$key})
+ ? "<LI>$type$key.html\">$key<\/A>\t$rem</LI>\n"
+ : "<LI>$line</LI>\n";
+ }
+ print HTML qq{</UL>\n};
+ }
+ elsif ($lines[0] =~ /^\s/) { # preformatted code
+ if ($paras[$p] =~/>>|<</) {
+ print HTML qq{\n<PRE>\n};
+ $inpre=1;
+ }
+ else { # Still cant beat XMP. Yes, I know
+ print HTML qq{\n<XMP>\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</XMP>\n};
+ print HTML qq{<PRE>\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</PRE>\n}) : (qq{\n</XMP>\n});
+ }
+ else { # other text
+ @lines = split(/\n/,$paras[$p]);
+ foreach $line (@lines) {
+ process_thing(\$line,"HTML");
+ print HTML qq{$line\n};
+ }
+ }
+ print HTML qq{<p>};
+ }
+}
+
+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<A NAME=\"".$value."\">\n$bigkey</A>\n"
+ }
+ else {
+ return "\n$type$pod2.html\#".$value."\">$bigkey<\/A>\n";
+ }
+ }
+ }
+ if ($char =~ /[IF]/) {
+ return "<EM>$bigkey</EM>";
+ } elsif ($char =~ /C/) {
+ return "<CODE>$bigkey</CODE>";
+ } else {
+ return "<STRONG>$bigkey</STRONG>";
+ }
+}
+
+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{<A HREF="$1">$1</A>})@ge;
+ s,([a-z0-9_.-]+\@([a-z0-9_-]+\.)+([a-z0-9_-]+)),noremap(qq{<A HREF="MAILTO:$1">$1</A>}),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 <EM>$page</EM> manpage<\/A>\n";
+ } else {
+ (warn "Bizarre entry $page/$item") if $Debug;
+ return "the <EM>$_[0]</EM> manpage\n";
+ }
+ }
+
+ if ($item =~ s/"(.*)"/$1/ || ($item =~ /[^\w\/\-]/ && $item !~ /^\$.$/)) {
+ $text = "<EM>$item</EM>";
+ $ref = "Headers";
+ } else {
+ $text = "<EM>$item</EM>";
+ $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<A NAME=\"".$value."\">\n$text</A>\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<A NAME=\"".$value."\">\n$text</A>\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<A NAME=\"".$value."\">\n$var</A>\n"
+ : "\n$type$pod2.html\#".$value."\">$var<\/A>\n";
+ }
+ }
+ Debug( "vars", "bummer, $var not a var");
+ return "<STRONG>$var</STRONG>";
+}
+
+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/<</noremap("<<")/eg;
+ s/([^ESIBLCF])</$1\<\;/g;
+ s/E<([^\/][^<>]*)>/\&$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 ':';
+++ /dev/null
-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 <<!GROK!THIS!
-#!$binexp/perl
-eval 'exec perl -S \$0 \${1+"\$@"}'
- if \$running_under_some_shell;
-!GROK!THIS!
-
-$spitshell >>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='<A HREF="';
-$debug = 0;
-
-unless(@Pods){
- opendir(DIR,$dir) or die "Can't opendir $dir: $ERRNO";
- @Pods = grep(/\.pod$/,readdir(DIR));
- closedir(DIR) or die "Can't closedir $dir: $ERRNO";
-}
-@Pods or die "expected pods";
-
-# loop twice through the pods, first to learn the links, then to produce html
-for $count (0,1){
- (print "Scanning pods...\n") unless $count;
- foreach $podfh ( @Pods ) {
- ($pod = $podfh) =~ s/\.pod$//;
- Debug("files", "opening 2 $podfh" );
- (print "Creating $pod.html from $podfh\n") if $count;
- $RS = "\n=";
- open($podfh,"<".$podfh) || die "can't open $podfh: $ERRNO";
- @all=<$podfh>;
- 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";
- <!-- \$RCSfile\$\$Revision\$\$Date\$ -->
- <!-- \$Log\$ -->
- <HTML>
-HTML__EOQ
- <TITLE>\U$pod\E</TITLE>
-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</HTML>\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</$$list_type>\n};
- $$depth--;
- }
-}
-
-sub do_hdr{
- my($num,$title,$rest,$depth)=@_;
- ($num == 1) and print HTML qq{<p><hr>\n};
- process_thing(\$title,"NAME");
- print HTML qq{\n<H$num> };
- print HTML $title;
- print HTML qq{</H$num>\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<DT><STRONG>\n};
- print HTML $title;
- print HTML qq{\n</STRONG></DT>\n};
- print HTML qq{<DD>\n};
- }
- else{
- print HTML qq{\n<LI>};
- ($list_type ne "OL") && (print HTML $title,"\n");
- }
- do_rest($rest);
- print HTML ($list_type eq "DL" )? qq{</DD>} : qq{</LI>};
-}
-
-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{<UL>};
- foreach $line (@lines){
- ($line =~ /^\s+(\w*)\t(.*)/) && (($key,$rem) = ($1,$2));
- print HTML defined($Podnames{$key}) ?
- "<LI>$type$key.html\">$key<\/A>\t$rem</LI>\n" :
- "<LI>$line</LI>\n";
- }
- print HTML qq{</UL>\n};
- }
- elsif($lines[0] =~ /^\s/){ # preformatted code
- if($paras[$p] =~/>>|<</){
- print HTML qq{\n<PRE>\n};
- $inpre=1;
- }
- else{
- print HTML qq{\n<XMP>\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</XMP>\n};
- print HTML qq{<PRE>\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</PRE>\n}) : (qq{\n</XMP>\n});
- }
- else{ # other text
- @lines=split(/\n/,$paras[$p]);
- foreach $line (@lines){
- process_thing(\$line,"HTML");
- print HTML qq{$line\n};
- }
- }
- print HTML qq{<p>};
- }
-}
-
-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<A NAME=\"".$value."\">\n$bigkey</A>\n"
- }
- else{
- return "\n$type$pod2.html\#".$value."\">$bigkey<\/A>\n";
- }
- }
- }
- if ($char =~ /[IF]/) {
- return "<EM>$bigkey</EM>";
- } elsif($char =~ /C/) {
- return "<CODE>$bigkey</CODE>";
- } else {
- return "<STRONG>$bigkey</STRONG>";
- }
-}
-
-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 <EM>$page</EM> manpage<\/A>\n";
- } else {
- (warn "Bizarre entry $page/$item") if $Debug;
- return "the <EM>$_[0]</EM> manpage\n";
- }
- }
-
- if ($item =~ s/"(.*)"/$1/ || ($item =~ /[^\w\/\-]/ && $item !~ /^\$.$/)) {
- $text = "<EM>$item</EM>";
- $ref = "Headers";
- } else {
- $text = "<EM>$item</EM>";
- $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<A NAME=\"".$value."\">\n$text</A>\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<A NAME=\"".$value."\">\n$text</A>\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<A NAME=\"".$value."\">\n$var</A>\n"
- : "\n$type$pod2.html\#".$value."\">$var<\/A>\n";
- }
- }
- Debug( "vars", "bummer, $var not a var");
- return "<STRONG>$var</STRONG>";
-}
-
-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/<</noremap("<<")/eg;
- $$thing=~s/(?:[^ESIBLCF])</noremap("<")/eg;
- $$thing=~s/E<([^\/][^<>]*)>/\&$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
-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 <<!GROK!THIS!
-#!$binexp/perl
-eval 'exec perl -S \$0 \${1+"\$@"}'
- if \$running_under_some_shell;
+#!/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!
-$spitshell >>pod2latex <<'!NO!SUBS!'
+# 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.
);
}
!NO!SUBS!
-chmod 755 pod2latex
-$eunicefix pod2latex
+
+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 ':';
-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 <<!GROK!THIS!
-#!$binexp/perl
-eval 'exec perl -S \$0 \${1+"\$@"}'
- if \$running_under_some_shell;
+#!/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!
-$spitshell >>pod2man <<'!NO!SUBS!'
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
$/ = "";
$cutting = 1;
);
}
!NO!SUBS!
-chmod 755 pod2man
-$eunicefix pod2man
+
+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 ':';
GP *ogp = GvGP(sv);
SSCHECK(3);
- SSPUSHPTR(sv);
+ SSPUSHPTR(SvREFCNT_inc(sv));
SSPUSHPTR(ogp);
SSPUSHINT(SAVEt_GP);
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());
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;
}
sv = POPs;
if (!sv || !SvROK(sv))
- RETPUSHUNDEF;
+ RETPUSHNO;
sv = SvRV(sv);
pv = sv_reftype(sv,TRUE);
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;
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);
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);
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);
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 == '_') {
sv_setnv(TARG, -SvNV(sv));
SETTARG;
}
+ else
+ SETn(-SvNV(sv));
}
RETURN;
}
dTOPss;
register I32 anum;
- if (SvNIOK(sv)) {
+ if (SvNIOKp(sv)) {
IV iv = ~SvIV(sv);
if (iv < 0)
SETn( (double) ~U_L(SvNV(sv)) );
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;
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;
}
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
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;
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));
(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);
}
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);
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));
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;
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();
}
}
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);
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)))
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;
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;
}
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);
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;
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;
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);
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)
(*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
)
{
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);
lex_end();
LEAVE;
- sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),"");
+ sv_setpv(GvSV(errgv),"");
RETURNOP(retop);
}
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;
}
curpm = newpm; /* Don't pop $1 et al till now */
LEAVE;
- sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),"");
+ sv_setpv(GvSV(errgv),"");
RETURN;
}
Safefree(fops);
SvCOMPILED_on(sv);
}
-
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;
{
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;
}
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);
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);
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:
(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;
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);
(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;
gid = (int)getgid();
egid = (int)getegid();
}
- tainting |= (euid != uid || egid != gid);
+ tainting |= (uid && (euid != uid || egid != gid));
}
delaymagic = 0;
if (GIMME == G_ARRAY) {
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;
}
}
I32 gimme = GIMME;
STRLEN len;
I32 minmatch = 0;
+ I32 oldsave = savestack_ix;
if (op->op_flags & OPf_STACKED)
TARG = POPs;
++rx->endp[0];
goto play_it_again;
}
+ LEAVE_SCOPE(oldsave);
RETURN;
}
else {
else
mg->mg_len = -1;
}
+ LEAVE_SCOPE(oldsave);
RETPUSHYES;
}
tmps = rx->startp[0] = tmps + (s - t);
rx->endp[0] = tmps + SvCUR(pm->op_pmshort);
}
+ LEAVE_SCOPE(oldsave);
RETPUSHYES;
nope:
mg->mg_len = -1;
}
}
+ LEAVE_SCOPE(oldsave);
if (gimme == G_ARRAY)
RETURN;
RETPUSHNO;
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);
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;
}
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;
(void)SvPOK_only(TARG);
SvSETMAGIC(TARG);
PUSHs(&sv_yes);
+ LEAVE_SCOPE(oldsave);
RETURN;
}
/*SUPPRESS 560*/
(void)SvPOK_only(TARG);
SvSETMAGIC(TARG);
PUSHs(&sv_yes);
+ LEAVE_SCOPE(oldsave);
RETURN;
}
else if (clen) {
(void)SvPOK_only(TARG);
SvSETMAGIC(TARG);
PUSHs(&sv_yes);
+ LEAVE_SCOPE(oldsave);
RETURN;
}
else {
(void)SvPOK_only(TARG);
SvSETMAGIC(TARG);
PUSHs(&sv_yes);
+ LEAVE_SCOPE(oldsave);
RETURN;
}
/* NOTREACHED */
(void)SvPOK_only(TARG);
SvSETMAGIC(TARG);
PUSHs(sv_2mortal(newSViv((I32)iters)));
+ LEAVE_SCOPE(oldsave);
RETURN;
}
PUSHs(&sv_no);
+ LEAVE_SCOPE(oldsave);
RETURN;
}
}
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));
(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;
}
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... */
DIE("Undefined subroutine called");
}
+ gimme = GIMME;
if ((op->op_private & OPpDEREF_DB) && !CvXSUB(cv)) {
sv = GvSV(DBsub);
save_item(sv);
DIE("No DBsub routine");
}
- gimme = GIMME;
-
if (CvXSUB(cv)) {
if (CvOLDSTYLE(cv)) {
I32 (*fp3)_((int,int,int));
}
}
}
- statusvalue = my_pclose(fp);
+ statusvalue = FIXSTATUS(my_pclose(fp));
}
else {
statusvalue = -1;
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");
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");
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)) {
if (!rgv || !wgv)
goto badexit;
+ if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
+ DIE(no_usym, "filehandle");
rstio = GvIOn(rgv);
wstio = GvIOn(wgv);
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");
}
#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
+#ifdef __linux__
+ growsize = sizeof(fd_set);
+#else
growsize = maxlen; /* little endians can use vecs directly */
+#endif
#else
#ifdef NFDBITS
#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;
}
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);
}
if (IoLINES_LEFT(io) < FmLINES(formtarget) &&
formtarget != toptarget)
{
+ GV *fgv;
+ CV *cv;
if (!IoTOP_GV(io)) {
GV *topgv;
char tmpbuf[256];
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:
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
{
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;
}
/* 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 */
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;
#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;
}
else {
value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), na));
}
+ statusvalue = FIXSTATUS(value);
do_execfree();
SP = ORIGMARK;
PUSHi(value);
(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)));
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));
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));
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));
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));
#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));
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));
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));
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));
}
/* Check for proper termination. */
- if (paren && *nextchar() != ')') {
+ if (paren && (regparse >= regxend || *nextchar() != ')')) {
FAIL("unmatched () in regexp");
} else if (!paren && regparse < regxend) {
if (*regparse == ')') {
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;
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++;
{
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;
}
regparse++;
continue;
}
- break;
}
+ return retval;
}
- return retval;
}
/*
CURCUR cc;
cc.cur = 0;
+ cc.oldcc = 0;
regcc = &cc;
#ifdef DEBUGGING
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
/* regtill = regbol; */
break;
}
- return 0;
+ sayNO;
case MBOL:
if (locinput == regbol
? regprev == '\n'
{
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;
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:
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;
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:
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;
n = regmatch(PREVOPER(next)); /* start on the WHILEM */
regcpblow(cp);
regcc = cc.oldcc;
- return n;
+ saySAME(n);
}
/* NOT REACHED */
case WHILEM: {
*/
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. */
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. */
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. */
cc->cur = n;
cc->lastloc = locinput;
if (regmatch(cc->scan))
- return TRUE;
+ sayYES;
regcppop(); /* Restore some previous $<digit>s? */
reginput = locinput;
}
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: {
do {
reginput = locinput;
if (regmatch(NEXTOPER(scan)))
- return 1;
+ sayYES;
for (n = *reglastparen; n > lastparen; n--)
regendp[n] = 0;
*reglastparen = n;
scan = regnext(scan);
#endif
} while (scan != NULL && OP(scan) == BRANCH);
- return 0;
+ sayNO;
/* NOTREACHED */
}
}
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)) {
reginput = locinput + ln;
}
else
- return 0;
+ sayNO;
}
}
else {
/* 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]);
*/
FAIL("corrupted regexp pointers");
/*NOTREACHED*/
+ sayNO;
+
+yes:
+#ifdef DEBUGGING
+ regindent--;
+#endif
+ return 1;
+
+no:
+#ifdef DEBUGGING
+ regindent--;
+#endif
return 0;
}
* know. Run now! Hope is in speed!" --Gandalf
*/
-char **watchaddr = 0;
-char *watchok;
+dEXT char **watchaddr = 0;
+dEXT char *watchok;
#ifndef DEBUGGING
GP *ogp = GvGP(gv);
SSCHECK(3);
- SSPUSHPTR(gv);
+ SSPUSHPTR(SvREFCNT_inc(gv));
SSPUSHPTR(ogp);
SSPUSHINT(SAVEt_GP);
gv = (GV*)SSPOPPTR;
gp_free(gv);
GvGP(gv) = (GP*)ptr;
+ SvREFCNT_dec(gv);
break;
case SAVEt_FREESV:
ptr = SSPOPPTR;
#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() \
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;
}
#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
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");
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 "),
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));)
}
}
+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()
{
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);
}
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);
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));
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:
GvSV(dstr) = sref;
break;
}
+ if (dref != sref)
+ GvFLAGS(dstr) |= GVf_IMPORTED; /* crude */
if (dref)
SvREFCNT_dec(dref);
if (intro)
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';
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 */
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;
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);
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)
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;
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;
*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);
}
}
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;
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
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));
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]/,
+++ /dev/null
-#!./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";
-}
-
}
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
$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
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;
test (ref $a eq "Oscalar"); # 31
-$Oscalar::OVERLOAD{'++'} = sub {${$_[0]}+=2;$_[0]};
+eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ];
$b=$a;
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";
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;
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";
# 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}
}
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";
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);
lex_state = LEX_INTERPEND;
}
}
- TOKEN(']');
+ TERM(']');
case '{':
leftbracket:
s++;
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++;
}
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);
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;
}
/* 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)
}
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 '`':
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? */
/* 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;
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);
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);
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();
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;
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;
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;
lex_repl = repl;
}
+ pm->op_pmpermflags = pm->op_pmflags;
lex_op = (OP*)pm;
yylval.ival = OP_SUBST;
return 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)
s++, term = '\'';
else
term = '"';
+ if (!isALNUM(*s))
+ deprecate("bare << to mean <<\"\"");
while (isALNUM(*s))
*d++ = *s++;
} /* assuming tokenbuf won't clobber */
else
croak("Unterminated <> operator");
- if (*d == '$') d++;
+ if (*d == '$' && d[1]) d++;
while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
d++;
if (d - tokenbuf != len) {
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");
}
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;
}
}
#endif /* HAS_MEMCMP */
-#ifdef I_VARARGS
+#if defined(I_STDARG) || defined(I_VARARGS)
#ifndef HAS_VPRINTF
#ifdef USE_CHAR_VSPRINTF
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
return fdopen(p[this], mode);
}
#else
-#ifdef atarist
+#if defined(atarist) || defined(OS2)
FILE *popen();
FILE *
my_popen(cmd,mode)
}
#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;
signal(SIGQUIT, qstat);
return(pid < 0 ? pid : status);
}
-#endif /* !VMS */
+#endif /* !DOSISH */
+
+#if !defined(DOSISH) || defined(OS2)
I32
wait4pid(pid,statusp,flags)
int pid;
return;
}
-#ifdef atarist
+#if defined(atarist) || defined(OS2)
int pclose();
I32
my_pclose(ptr)
#> 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
# 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
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
SOCKCLIS =
SOCKHLIS =
SOCKOBJ =
+SOCKPM =
# C preprocessor manifest "DEBUGGING" ==> perl -D, not the VMS debugger
CFLAGS = /Define=(DEBUGGING$(SOCKDEF)$(XTRADEF))$(XTRACCFLAGS)$(DBGCCFLAGS)
# 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. ####
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)
@ 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.
[.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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
- 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
- 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;*
- 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
- 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;*
* 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
*/
* 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 */
* 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 /**/
* 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
* 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
/* 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 /**/
# 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
.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 <<<<<
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)
SOCKCLIS = ,$(SOCKC)
SOCKHLIS = ,$(SOCKH)
SOCKOBJ = ,sockadapt$(O)
+SOCKPM = [.lib]Socket.pm
.else
SOCKDEF =
SOCKLIB =
SOCKCLIS =
SOCKHLIS =
SOCKOBJ =
+SOCKPM =
.endif
# C preprocessor manifest "DEBUGGING" ==> perl -D, not the VMS debugger
# 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. ####
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)
@ 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.
[.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
$(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)
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
- 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
- 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;*
- 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
- 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;*
# 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;
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 (<PM>) {
+ 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;
$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.
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
$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
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}})),'
';
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'}),"
$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) ;"
};
}
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 = )
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);
";
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);
# 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);
}
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;
$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);
}
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);
}
');
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 ---
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;
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, "
# 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);
}
$(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}};
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) = @_;
# 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/;
'','',''
}
-# --- 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) = @_;
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__
# (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) {
}
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;
$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) = @_;
if ($1 eq 'main' || $1 eq 'perl_init_ext') {
print "\tskipped\n" if $debug > 1;
}
- else { $funcs{$1}++ }
+ else { $fcns{$1}++ }
}
}
print "opcode.h>> $_" if $debug > 2;
if (/^OP \*\s/) { &scan_func($_); }
if (/^EXT/) { &scan_var($_); }
+ if (/^\s+OP_/) { &scan_enum($_); }
+ last LINE unless $_ = <CPP>;
+ }
+ while (/^typedef enum/ .. /^\}/) {
+ print "global enum>> $_" if $debug > 2;
+ &scan_enum($_);
last LINE unless $_ = <CPP>;
}
while (/^#.*proto\.h/i .. /^#.*perl\.h/i) {
while (<DATA>) {
next if /^#/;
s/\s+#.*\n//;
+ next if /^\s*$/;
($key,$array) = split('=',$_);
print "Adding $key to \%$array list\n" if $debug > 1;
${$array}{$key}++;
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
$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;
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";
+++ /dev/null
-/* 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. */
You may need to make this change to scripts written for a
Unix system which expect that after a call to C<unlink>,
no files with the names passed to C<unlink> 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<use Config> and C<$Config{'d_unlink_all_versions'}> is
+C<define>, then C<unlink> will delete all versions of a
+file on the first call.)
C<unlink> will delete a file if at all possible, even if it
requires changing file protection (though it won't try to
--- /dev/null
+#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;
+}
--- /dev/null
+#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
/* 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
* 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");
+}
*
* 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
* This version is set up for perl5 with socketshr 0.9D TCP/IP support.
*/
-#include <socketshr.h>
+/* 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 */
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;
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 <socket.h>
+#include <in.h>
+#include <inet.h>
+#include <netdb.h>
+/* However, we don't have these two in the system headers. */
+void setnetent();
+void endnetent();
+
+#endif
+
+#include <socketshr.h>
+/* 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 *);
$
$! 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.;*
$$END-OF-TEST$$
$ wrapup:
$ If F$Search("Echo.Exe").nes."" Then Delete/Log/NoConfirm Echo.Exe;*
-$ Set Default &olddef
+$ Set Default [-]
$ Exit
*
* 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 <acedef.h>
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};
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;
}
}
}
- 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;
}
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. */
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) {
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);
}
/*}}}*/
+
+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++) {
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");
}
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;
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);
}
}
bool
vms_do_aexec(SV *really,SV **mark,SV **sp)
{
-
if (sp > mark) {
if (vfork_called) { /* this follows a vfork - act Unixish */
vfork_called--;
}
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;
}
{ /* 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;
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() */
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)) {
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() */
(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;
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},
--- /dev/null
+# 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 (<C>) {
+ if (/^dEXT/) { # we've already got a fixed copy
+ print COUT $_,<C>;
+ 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 (<H>) {
+ $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;
#include <rmsdef.h> /* at which errno and vaxc$errno are */
#include <ssdef.h> /* 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
# 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__
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=''
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
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
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 \
# 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();
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
-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 <<!GROK!THIS!
-#!$binexp/perl
+#!/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 <tml+@pitt.edu>
# 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);
}
}
print <<"END";
-#!$bin/perl
+$startperl
-eval 'exec $bin/perl -S \$0 \${1+"\$@"}'
+eval 'exec perl -S \$0 \${1+"\$@"}'
if \$running_under_some_shell;
END
"'$string'";
}
!NO!SUBS!
-chmod 755 find2perl
-$eunicefix find2perl
+
+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 ':';
-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 <<!GROK!THIS!
-#!$binexp/perl
-
-eval 'exec perl -S \$0 \${1+"\$@"}'
- if \$running_under_some_shell;
-
-\$bin = '$bin';
+#!/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 dollars and backticks do not need the extra backslash.
-$spitshell >>s2p <<'!NO!SUBS!'
+# 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 $
#
close HEAD;
print &q(<<"EOT");
-: #!$bin/perl
-: eval 'exec $bin/perl -S \$0 \${1+"\$@"}'
+: $startperl
+: eval 'exec perl -S \$0 \${1+"\$@"}'
: if \$running_under_some_shell;
:
EOT
}
!NO!SUBS!
-chmod 755 s2p
-$eunicefix s2p
+
+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 ':';
projects / p5sagit/p5-mst-13.2.git / commitdiff