diff options
| author | Perl 5 Porters <perl5-porters@africa.nicoh.com> | 1996-11-19 14:16:00 +1200 |
|---|---|---|
| committer | Chip Salzenberg <chip@atlantic.net> | 1996-11-19 14:16:00 +1200 |
| commit | 55497cffdd24c959994f9a8ddd56db8ce85e1c5b (patch) | |
| tree | 444dfb8adc0e5b96d56e0532791122c366f50a3e | |
| parent | c822f08a5087943f7d9e2c36ce42ea035f03ab97 (diff) | |
| download | perl-55497cffdd24c959994f9a8ddd56db8ce85e1c5b.tar.gz | |
[inseparable changes from patch from perl5.003_07 to perl5.003_08]
CORE LANGUAGE CHANGES
Subject: Bitwise op sign rationalization
From: Chip Salzenberg <chip@atlantic.net>
Files: op.c opcode.pl pod/perlop.pod pod/perltoc.pod pp.c pp.h pp_hot.c proto.h sv.c t/op/bop.t
Make bitwise ops result in unsigned values, unless C<use
integer> is in effect. Includes initial support for UVs.
Subject: Defined scoping for C<my> in control structures
From: Chip Salzenberg <chip@atlantic.net>
Files: op.c perly.c perly.c.diff perly.h perly.y proto.h toke.c
Finally defines semantics of "my" in control expressions,
like the condition of "if" and "while". In all cases, scope
of a "my" var extends to the end of the entire control
structure. Also adds new construct "for my", which
automatically declares the control variable "my" and limits
its scope to the loop.
Subject: Fix ++/-- after int conversion (e.g. 'printf "%d"')
From: Chip Salzenberg <chip@atlantic.net>
Files: pp.c pp_hot.c sv.c
This patch makes Perl correctly ignore SvIVX() if either
NOK or POK is true, since SvIVX() may be a truncated or
overflowed version of the real value.
Subject: Make code match Camel II re: functions that use $_
From: Paul Marquess <pmarquess@bfsec.bt.co.uk>
Files: opcode.pl
Subject: Provide scalar context on left side of "->"
From: Chip Salzenberg <chip@atlantic.net>
Files: perly.c perly.y
Subject: Quote bearword package/handle FOO in "funcname FOO => 'bar'"
From: Chip Salzenberg <chip@atlantic.net>
Files: toke.c
OTHER CORE CHANGES
Subject: Warn on overflow of octal and hex integers
From: Chip Salzenberg <chip@atlantic.net>
Files: proto.h toke.c util.c
Subject: If -w active, warn for commas and hashes ('#') in qw()
From: Chip Salzenberg <chip@atlantic.net>
Files: toke.c
Subject: Fixes for pack('w')
From: Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de>
Files: pp.c t/op/pack.t
Subject: More complete output from sv_dump()
From: Gurusamy Sarathy <gsar@engin.umich.edu>
Files: sv.c
Subject: Major '..' and debugger patches
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
Files: lib/perl5db.pl op.c pp_ctl.c scope.c scope.h
Subject: Fix for formline()
From: Gurusamy Sarathy <gsar@engin.umich.edu>
Files: global.sym mg.c perl.h pod/perldiag.pod pp_ctl.c proto.h sv.c t/op/write.t
Subject: Fix stack botch in untie and binmode
From: Gurusamy Sarathy <gsar@engin.umich.edu>
Files: pp_sys.c
Subject: Complete EMBED, including symbols from interp.sym
From: Chip Salzenberg <chip@atlantic.net>
Files: MANIFEST embed.pl ext/DynaLoader/dlutils.c ext/SDBM_File/sdbm/sdbm.h global.sym handy.h malloc.c perl.h pp_sys.c proto.h regexec.c toke.c util.c x2p/Makefile.SH x2p/a2p.h x2p/handy.h x2p/util.h
New define EMBEDMYMALLOC makes embedding total by
avoiding "Mymalloc" etc.
Subject: Support old embedding for people who want it
From: Chip Salzenberg <chip@atlantic.net>
Files: MANIFEST Makefile.SH old_embed.pl old_global.sym
PORTABILITY
Subject: Miscellaneous VMS fixes
From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
Files: lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_VMS.pm lib/Math/Complex.pm lib/Time/Local.pm lib/timelocal.pl perl.h perl_exp.SH proto.h t/TEST t/io/read.t t/lib/findbin.t t/lib/getopt.t util.c utils/h2xs.PL vms/Makefile vms/config.vms vms/descrip.mms vms/ext/Stdio/Stdio.pm vms/ext/Stdio/Stdio.xs vms/perlvms.pod vms/test.com vms/vms.c
Subject: DJGPP patches (MS-DOS)
From: "Douglas E. Wegscheid" <wegscd@whirlpool.com>
Files: doio.c dosish.h ext/SDBM_File/sdbm/sdbm.c handy.h lib/AutoSplit.pm lib/Cwd.pm lib/File/Find.pm malloc.c perl.c perl.h pp_sys.c proto.h sv.c util.c
Subject: Patch to make Perl work under AmigaOS
From: "Norbert Pueschel" <pueschel@imsdd.meb.uni-bonn.de>
Files: MANIFEST hints/amigaos.sh installman lib/File/Basename.pm lib/File/Find.pm pod/pod2man.PL pp_sys.c util.c
141 files changed, 7247 insertions, 2977 deletions
@@ -8,6 +8,157 @@ or in the .../src/5/0/unsupported directory for sub-version releases.) ---------------- +Version 5.003_08 +---------------- + +This patch was a compendium of various fixes and enhancements from +many people. Here are some of the more significant changes. + + + CORE LANGUAGE CHANGES + + Title: "Make C<no FOO> fail if C<unimport FOO> fails" + From: Tim Bunce <Tim.Bunce@ig.co.uk> + Files: gv.c + + Title: "Bitwise op sign rationalization" + (Make bitwise ops result in unsigned values, unless C<use + integer> is in effect. Includes initial support for UVs.) + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c opcode.pl pod/perlop.pod pod/perltoc.pod pp.c pp.h + pp_hot.c proto.h sv.c t/op/bop.t + + Title: "Defined scoping for C<my> in control structures" + (Finally defines semantics of "my" in control expressions, + like the condition of "if" and "while". In all cases, scope + of a "my" var extends to the end of the entire control + structure. Also adds new construct "for my", which + automatically declares the control variable "my" and limits + its scope to the loop.) + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c perly.c perly.c.diff perly.h perly.y proto.h toke.c + + Title: "Fix ++/-- after int conversion (e.g. 'printf "%d"')" + (This patch makes Perl correctly ignore SvIVX() if either + NOK or POK is true, since SvIVX() may be a truncated or + overflowed version of the real value.) + From: Chip Salzenberg <chip@atlantic.net> + Files: pp.c pp_hot.c sv.c + + Title: "Make code match Camel II re: functions that use $_" + From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Files: opcode.pl + + Title: "Provide scalar context on left side of "->"" + From: Chip Salzenberg <chip@atlantic.net> + Files: perly.c perly.y + + Title: "Quote bearword package/handle FOO in "funcname FOO => 'bar'"" + From: Chip Salzenberg <chip@atlantic.net> + Files: toke.c + + + OTHER CORE CHANGES + + Title: "Warn on overflow of octal and hex integers" + From: Chip Salzenberg <chip@atlantic.net> + Files: proto.h toke.c util.c + + Title: "If -w active, warn for commas and hashes ('#') in qw()" + From: Chip Salzenberg <chip@atlantic.net> + Files: toke.c + + Title: "Fixes for pack('w')" + From: Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de> + Files: pp.c t/op/pack.t + + Title: "More complete output from sv_dump()" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Files: sv.c + + Title: "Major '..' and debugger patches" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Files: lib/perl5db.pl op.c pp_ctl.c scope.c scope.h + + Title: "Fix for formline()" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Files: global.sym mg.c perl.h pod/perldiag.pod pp_ctl.c proto.h sv.c + t/op/write.t + + Title: "Fix stack botch in untie and binmode" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Files: pp_sys.c + + Title: "Complete EMBED, including symbols from interp.sym" + (New define EMBEDMYMALLOC makes embedding total by + avoiding "Mymalloc" etc.) + From: Chip Salzenberg <chip@atlantic.net> + Files: MANIFEST embed.pl ext/DynaLoader/dlutils.c + ext/SDBM_File/sdbm/sdbm.h global.sym handy.h malloc.c + perl.h pp_sys.c proto.h regexec.c toke.c util.c + x2p/Makefile.SH x2p/a2p.h x2p/handy.h x2p/util.h + + Title: "Support old embedding for people who want it" + From: Chip Salzenberg <chip@atlantic.net> + Files: MANIFEST Makefile.SH old_embed.pl old_global.sym + + + PORTABILITY + + Title: "Miscellaneous VMS fixes" + From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU> + Files: lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_VMS.pm + lib/Math/Complex.pm lib/Time/Local.pm lib/timelocal.pl + perl.h perl_exp.SH proto.h t/TEST t/io/read.t + t/lib/findbin.t t/lib/getopt.t util.c utils/h2xs.PL + vms/Makefile vms/config.vms vms/descrip.mms + vms/ext/Stdio/Stdio.pm vms/ext/Stdio/Stdio.xs + vms/perlvms.pod vms/test.com vms/vms.c + + Title: "DJGPP patches (MS-DOS)" + From: "Douglas E. Wegscheid" <wegscd@whirlpool.com> + Files: doio.c dosish.h ext/SDBM_File/sdbm/sdbm.c handy.h + lib/AutoSplit.pm lib/Cwd.pm lib/File/Find.pm malloc.c perl.c + perl.h pp_sys.c proto.h sv.c util.c + + Title: "Plan 9 update" + From: Luther Huffman <lutherh@infinet.com> + Files: plan9/buildinfo plan9/config.plan9 plan9/exclude + plan9/genconfig.pl plan9/mkfile plan9/setup.rc + + Title: "Patch to make Perl work under AmigaOS" + From: "Norbert Pueschel" <pueschel@imsdd.meb.uni-bonn.de> + Files: MANIFEST hints/amigaos.sh installman lib/File/Basename.pm + lib/File/Find.pm pod/pod2man.PL pp_sys.c util.c + + LIBRARY AND EXTENSIONS + + Title: "DB_File 1.05" + From: Paul Marquess (pmarquess@bfsec.bt.co.uk) + Files: ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs t/lib/db-hash.t + + Title: "Getopts::Std patch for hash support" + From: Stephen Zander <stephen.zander@interlock.mckesson.com> + Files: lib/Getopt/Std.pm + + Title: "Kludge for bareword handles" + (Add 'require IO::Handle' at beginning of FileHandle.pm) + From: Chip Salzenberg <chip@atlantic.net> + Files: ext/FileHandle/FileHandle.pm + + Title: "Re: strtod / strtol patch for POSIX module" + From: hammen@gothamcity.jsc.nasa.gov (David Hammen) + Files: Configure config_h.SH ext/POSIX/POSIX.pm ext/POSIX/POSIX.pod + ext/POSIX/POSIX.xs t/lib/posix.t + + BUNDLED UTILITIES + + Title: "Fix a2p translation of '{print "a" "b" "c"}'" + From: Chip Salzenberg <chip@atlantic.net> + Files: x2p/a2p.c x2p/a2p.y + + +---------------- Version 5.003_07 ---------------- @@ -202,6 +202,7 @@ hints/README.NeXT Notes about NeXT hints. hints/README.hints Notes about hints. hints/aix.sh Hints for named architecture hints/altos486.sh Hints for named architecture +hints/amigaos.sh Hints for named architecture hints/apollo.sh Hints for named architecture hints/aux.sh Hints for named architecture hints/bsdos.sh Hints for named architecture @@ -386,6 +387,8 @@ miniperlmain.c Basic perl w/o dynamic loading or extensions mv-if-diff Script to mv a file if it changed myconfig Prints summary of the current configuration nostdio.h Cause compile error on stdio calls +old_embed.pl Produces embed.h using old_global.sym +old_global.sym Old list of symbols to hide when embedded op.c Opcode syntax tree code op.h Opcode syntax tree header opcode.h Automatically generated opcode header @@ -708,7 +711,6 @@ 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.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.PL Sed to perl translator diff --git a/Makefile.SH b/Makefile.SH index e3ee81493d..9052a4dfed 100755 --- a/Makefile.SH +++ b/Makefile.SH @@ -342,9 +342,10 @@ run_byacc: FORCE @ echo 'Expect' 130 shift/reduce and 1 reduce/reduce conflict $(BYACC) -d perly.y sh $(shellflags) ./perly.fixer y.tab.c perly.c - sed -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' perly.c >perly.tmp && mv perly.tmp perly.c - mv y.tab.h perly.h - echo 'extern YYSTYPE yylval;' >>perly.h + sed -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' \ + -e 's/y\.tab/perly/g' perly.c >perly.tmp && mv perly.tmp perly.c + echo 'extern YYSTYPE yylval;' >>y.tab.h + cmp -s y.tab.h perly.h && rm -f y.tab.h || mv y.tab.h 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 diff --git a/README.os2 b/README.os2 index f5bf87db06..bbadbf64b0 100644 --- a/README.os2 +++ b/README.os2 @@ -144,9 +144,12 @@ Cf. L<Prerequisites>. =item B<EMX> -B<EMX> runtime is required. Note that it is possible to make F<perl_.exe> -to run under DOS without any external support by binding F<emx.exe> to -it, see L<emxbind>. +B<EMX> runtime is required (may be substituted by B<RSX>). Note that +it is possible to make F<perl_.exe> to run under DOS without any +external support by binding F<emx.exe> to it, see L<emxbind>. Note +that under DOS for best results one should use B<RSX> runtime, which +has much more functions working (like C<fork>, C<popen> and so on). In +fact B<RSX> is required if there is no C<VCPI> present. Only the latest runtime is supported, currently C<0.9c>. @@ -161,7 +164,13 @@ The runtime component should have the name F<emxrt.zip>. To run Perl on C<DPMS> platforms one needs B<RSX> runtime. This is needed under DOS-inside-OS/2, Win0.31, Win0.95 and WinNT (see -L<"Other OSes">). +L<"Other OSes">). I do not know whether B<RSX> would work with C<VCPI> +only, as B<EMX> would. + +Having B<RSX> and the latest F<sh.exe> one gets a fully functional +B<*nix>-ish environment under DOS, say, C<fork>, C<``> and +pipe-C<open> work. In fact, MakeMaker works (for static build), so one +can have Perl development environment under DOS. One can get B<RSX> from, say @@ -170,6 +179,10 @@ One can get B<RSX> from, say Contact the author on C<rainer@mathematik.uni-bielefeld.de>. +The latest F<sh.exe> with DOS hooks is available at + + ftp://ftp.math.ohio-state.edu/pub/users/ilya/os2/sh_dos.exe + =item B<HPFS> Perl does not care about file systems, but to install the whole perl @@ -254,9 +267,22 @@ meta-characters. =head2 I cannot run extenal programs +=over 4 + +=item + Did you run your programs with C<-w> switch? See L<Starting OS/2 programs under Perl>. +=item + +Do you try to run I<internal> shell commands, like C<`copy a b`> +(internal for F<cmd.exe>), or C<`glob a*b`> (internal for ksh)? You +need to specify your shell explicitely, like C<`cmd /c copy a b`>, +since Perl cannot deduce which commands are internal to your shell. + +=back + =head2 I cannot embed perl into my program, or use F<perl.dll> from my program. @@ -273,6 +299,16 @@ I had reports it does not work. Somebody would need to fix it. =back +=head2 C<``> and pipe-C<open> do not work under DOS. + +This may a variant of just L<"I cannot run extenal programs">, or a +deeper problem. Basically: you I<need> B<RSX> (see L<"Prerequisites">) +for these commands to work, and you need a port of F<sh.exe> which +understands command arguments. One of such ports is listed in +L<"Prerequisites"> under B<RSX>. + +I do not know whether C<DPMI> is required. + =head1 INSTALLATION =head2 Automatic binary installation @@ -674,7 +710,7 @@ Now run make test -Some tests (4..6) should fail. Some perl invocations should end in a +Some tests (5..7) should fail. Some perl invocations should end in a segfault (system error C<SYS3175>). To get finer error reports, cd t @@ -692,7 +728,8 @@ The report you get may look like Note that using `make test' target two more tests may fail: C<op/exec:1> because of (mis)feature of C<pdksh>, and C<lib/posix:15>, which checks -that the buffers are not flushed on C<_exit>. +that the buffers are not flushed on C<_exit> (this is a bug in the test +which assumes that tty output is buffered). The reasons for failed tests are: @@ -961,8 +998,22 @@ eventually). =item -Since <lockf> is present in B<EMX>, but is not functional, the same is -true for perl. +Since <flock> is present in B<EMX>, but is not functional, the same is +true for perl. Here is the list of things which may be "broken" on +EMX (from EMX docs): + + - The functions recvmsg(), sendmsg(), and socketpair() are not + implemented. + - sock_init() is not required and not implemented. + - flock() is not yet implemented (dummy function). + - kill: + Special treatment of PID=0, PID=1 and PID=-1 is not implemented. + - waitpid: + WUNTRACED + Not implemented. + waitpid() is not implemented for negative values of PID. + +Note that C<kill -9> does not work with the current version of EMX. =item @@ -974,6 +1025,36 @@ the current C<pdksh>. =back +=head2 Modifications + +Perl modifies some standard C library calls in the following ways: + +=over 9 + +=item C<popen> + +C<my_popen> always uses F<sh.exe>, cf. L<"PERL_SH_DIR">. + +=item C<tmpnam> + +is created using C<TMP> or C<TEMP> environment variable, via +C<tempnam>. + +=item C<tmpfile> + +If the current directory is not writable, it is created using modified +C<tmpnam>, so there may be a race condition. + +=item C<ctermid> + +a dummy implementation. + +=item C<stat> + +C<os2_stat> special-cases F</dev/tty> and F</dev/con>. + +=back + =head1 Perl flavors Because of ideosyncrasies of OS/2 one cannot have all the eggs in the @@ -786,6 +786,24 @@ #define HAS_SYS_ERRLIST /**/ #define Strerror(e) strerror(e) +/* HAS_STRTOD: + * This symbol, if defined, indicates that the strtod routine is + * available to translate strings to doubles. + */ +#define HAS_STRTOD /**/ + +/* HAS_STRTOL: + * This symbol, if defined, indicates that the strtol routine is + * available to translate strings to integers. + */ +#define HAS_STRTOL /**/ + +/* HAS_STRTOUL: + * This symbol, if defined, indicates that the strtoul routine is + * available to translate strings to integers. + */ +#define HAS_STRTOUL /**/ + /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to transform strings. @@ -21,12 +21,18 @@ # (exit $?0) || exec sh $0 $argv:q -if test $0 -ef `echo $0 | sed -e s/configure/Configure/`; then - echo "You're configure and Configure scripts seem to be identical." + +case "$0" in +*configure) + if cmp $0 `echo $0 | sed -e s/configure/Configure/` >/dev/null; then + echo "Your configure and Configure scripts seem to be identical." echo "This can happen on filesystems that aren't fully case sensitive." echo "You'll have to explicitely extract Configure and run that." exit 1 -fi + fi + ;; +esac + opts='' verbose='' create='-e' @@ -418,7 +418,7 @@ register GV *gv; (void)unlink(SvPVX(sv)); (void)rename(oldname,SvPVX(sv)); do_open(gv,SvPVX(sv),SvCUR(sv),FALSE,0,0,Nullfp); -#endif /* MSDOS */ +#endif /* DOSISH */ #else (void)UNLINK(SvPVX(sv)); if (link(oldname,SvPVX(sv)) < 0) { @@ -1057,7 +1057,7 @@ char *cmd; return FALSE; } -#endif +#endif /* OS2 */ I32 apply(type,mark,sp) @@ -1108,6 +1108,8 @@ register SV **sp; #ifdef HAS_KILL case OP_KILL: TAINT_PROPER("kill"); + if (mark == sp) + break; s = SvPVx(*++mark, na); tot = sp - mark; if (isUPPER(*s)) { @@ -1258,7 +1260,7 @@ register struct stat *statbufp; */ return (bit & statbufp->st_mode) ? TRUE : FALSE; -#else /* ! MSDOS */ +#else /* ! DOSISH */ if ((effective ? euid : uid) == 0) { /* root is special */ if (bit == S_IXUSR) { if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode)) @@ -1279,7 +1281,7 @@ register struct stat *statbufp; else if (statbufp->st_mode & bit >> 6) return TRUE; /* ok as "other" */ return FALSE; -#endif /* ! MSDOS */ +#endif /* ! DOSISH */ } #endif /* ! VMS */ @@ -1,11 +1,39 @@ #define ABORT() abort(); -#define BIT_BUCKET "\dev\nul" +#define SH_PATH "/bin/sh" + +#ifdef DJGPP +#define BIT_BUCKET "nul" +#define OP_BINARY O_BINARY +void Perl_DJGPP_init(); +#define PERL_SYS_INIT(argcp, argvp) STMT_START { \ + Perl_DJGPP_init(); } STMT_END +#else #define PERL_SYS_INIT(c,v) +#define BIT_BUCKET "\dev\nul" +#endif + #define PERL_SYS_TERM() #define dXSUB_SYS int dummy #define TMPPATH "plXXXXXX" +/* + * 5.003_07 and earlier keyed on #ifdef MSDOS for determining if we were + * running on DOS, *and* if we had to cope with 16 bit memory addressing + * constraints, *and* we need to have memory allocated as unsigned long. + * + * with the advent of *real* compilers for DOS, they are not locked together. + * MSDOS means "I am running on MSDOS". HAS_64K_LIMIT means "I have + * 16 bit memory addressing constraints". + * + * if you need the last, try #DEFINE MEM_SIZE unsigned long. + */ +#ifdef MSDOS + #ifndef DJGPP + #define HAS_64K_LIMIT + #endif +#endif + /* USEMYBINMODE * This symbol, if defined, indicates that the program should * use the routine my_binmode(FILE *fp, char iotype) to insure diff --git a/emacs/cperl-mode.el b/emacs/cperl-mode.el index c78a148e45..ba4a863be5 100644 --- a/emacs/cperl-mode.el +++ b/emacs/cperl-mode.el @@ -10,7 +10,7 @@ ;; This file is not (yet) part of GNU Emacs. It may be distributed ;; either under the same terms as GNU Emacs, or under the same terms -;; as Perl. You should have recieved a copy of Perl Artistic license +;; as Perl. You should have received a copy of Perl Artistic license ;; along with the Perl distribution. ;; GNU Emacs is free software; you can redistribute it and/or modify @@ -24,13 +24,15 @@ ;; 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. +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, 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.25 1996/09/06 09:51:41 ilya Exp ilya $ +;; $Id: cperl-mode.el,v 1.29 1996/11/18 23:10:26 ilya Exp ilya $ ;;; To use this mode put the following into your .emacs file: @@ -53,7 +55,7 @@ ;;; 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 +;;; either 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 @@ -63,12 +65,12 @@ ;;; 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 +;;; If you have a 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. +;;; into your .emacs file. ;;;; This mode supports font-lock, imenu and mode-compile. In the ;;;; hairy version font-lock is on, but you should activate imenu @@ -289,7 +291,7 @@ ;;; Electric-; should work better. ;;; Minor bugs with POD marking. -;;;; After 1.25 +;;;; After 1.25 (probably not...) ;;; `cperl-info-page' introduced. ;;; To make `uncomment-region' working, `comment-region' would ;;; not insert extra space. @@ -302,10 +304,30 @@ ;;; are not treated. ;;; POD/friends scan merged in one pass. ;;; Syntax class is not used for analyzing the code, only char-syntax -;;; may be cecked against _ or'ed with w. +;;; may be checked against _ or'ed with w. ;;; Syntax class of `:' changed to be _. ;;; `cperl-find-bad-style' added. +;;;; After 1.25 +;;; When search for here-documents, we ignore commented << in simplest cases. +;;; `cperl-get-help' added, available on C-h v and from menu. +;;; Auto-help added. Default with `cperl-hairy', switchable on/off +;;; with startup variable `cperl-lazy-help-time' and from +;;; menu. Requires `run-with-idle-timer'. +;;; Highlighting of @abc{@efg} was wrong - interchanged two regexps. + +;;;; After 1.27 +;;; Indentation: At toplevel after a label - fixed. +;;; 1.27 was put to archives in binary mode ===> DOSish :-( + +;;;; After 1.28 +;;; Thanks to Martin Buchholz <mrb@Eng.Sun.COM>: misprints in +;;; comments and docstrings corrected, XEmacs support cleaned up. +;;; The closing parenths would enclose the region into matching +;;; parens under the same conditions as the opening ones. +;;; Minor updates to `cperl-short-docs'. +;;; Will not consider <<= as start of here-doc. + (defvar cperl-extra-newline-before-brace nil "*Non-nil means that if, elsif, while, until, else, for, foreach and do constructs look like: @@ -409,6 +431,9 @@ Can be overwritten by `cperl-hairy' if nil.") The opposite behaviour is always available if prefixed with C-c. Can be overwritten by `cperl-hairy' if nil.") +(defvar cperl-lazy-help-time nil + "*Not-nil (and non-null) means to show lazy help after given idle time.") + (defvar cperl-pod-face 'font-lock-comment-face "*The result of evaluation of this expression is used for pod highlighting.") @@ -431,7 +456,7 @@ You can always make lookup from menu or using \\[cperl-find-pods-heres].") May require patched `imenu' and `imenu-go'.") (defvar cperl-info-page "perl" - "Name of the info page containging perl docs. + "Name of the info page containing perl docs. Older version of this page was called `perl5', newer `perl'.") @@ -469,6 +494,8 @@ CPerl/Tools/Tags menu beforehand. Run CPerl/Tools/Insert-spaces-if-needed to fix your lazy typing. +Switch auto-help on/off with CPerl/Tools/Auto-help. + Before reporting (non-)problems look in the problem section on what I know about them.") @@ -479,26 +506,26 @@ It may be corrected on the level of C code, please look in the `non-problems' section if you want to volunteer. CPerl mode tries to corrects some Emacs misunderstandings, however, -for effeciency reasons the degree of correction is different for +for efficiency reasons the degree of correction is different for different operations. The partially corrected problems are: POD sections, here-documents, regexps. The operations are: highlighting, indentation, electric keywords, electric braces. This may be confusing, since the regexp s#//#/#\; may be highlighted -as a comment, but it will recognized as a regexp by the indentation +as a comment, but it will be recognized as a regexp by the indentation code. Or the opposite case, when a pod section is highlighted, but breaks the indentation of the following code. The main trick (to make $ a \"backslash\") makes constructions like -${aaa} look like unbalanced braces. The only trick I can think out is +${aaa} look like unbalanced braces. The only trick I can think of is to insert it as $ {aaa} (legal in perl5, not in perl4). Similar problems arise in regexps, when /(\\s|$)/ should be rewritten -as /($|\\s)/. Note that such a transpositinon is not always possible +as /($|\\s)/. Note that such a transposition is not always possible :-(. " ) (defvar cperl-non-problems 'please-ignore-this-line -"As you know from `problems' section, Perl syntax too hard for CPerl. +"As you know from `problems' section, Perl syntax is too hard for CPerl. Most the time, if you write your own code, you may find an equivalent \(and almost as readable) expression. @@ -530,7 +557,7 @@ b) Supply the code to me (IZ). Pods are treated _very_ rudimentally. Here-documents are not treated at all (except highlighting and inhibiting indentation). (This may change some time. RMS approved making syntax lookup recognize text -attributes, but volonteers are needed to change Emacs C code.) +attributes, but volunteers are needed to change Emacs C code.) To speed up coloring the following compromises exist: a) sub in $mypackage::sub may be highlighted. @@ -546,8 +573,13 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove ;;; Portability stuff: -(defsubst cperl-xemacs-p () - (string-match "XEmacs\\|Lucid" emacs-version)) +(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) +(defmacro cperl-define-key (fsf-key definition &optional xemacs-key) + `(define-key cperl-mode-map + ,(if xemacs-key + `(if cperl-xemacs-p ,xemacs-key ,fsf-key) + fsf-key) + ,definition)) (defvar del-back-ch (car (append (where-is-internal 'delete-backward-char) (where-is-internal 'backward-delete-char-untabify))) @@ -556,7 +588,7 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove (and (vectorp del-back-ch) (= (length del-back-ch) 1) (setq del-back-ch (aref del-back-ch 0))) -(if (cperl-xemacs-p) +(if cperl-xemacs-p (progn ;; "Active regions" are on: use region only if active ;; "Active regions" are off: use region unconditionally @@ -568,10 +600,10 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove (defun cperl-mark-active () mark-active)) (defsubst cperl-enable-font-lock () - (or (cperl-xemacs-p) window-system)) + (or cperl-xemacs-p window-system)) (if (boundp 'unread-command-events) - (if (cperl-xemacs-p) + (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 @@ -628,39 +660,37 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove (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 "\C-c\C-a" 'cperl-toggle-auto-newline) - (define-key cperl-mode-map "\C-c\C-k" 'cperl-toggle-abbrev) - (define-key cperl-mode-map "\C-c\C-e" 'cperl-toggle-electric) - (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" 'cperl-electric-backspace) - (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) + (cperl-define-key "{" 'cperl-electric-lbrace) + (cperl-define-key "[" 'cperl-electric-paren) + (cperl-define-key "(" 'cperl-electric-paren) + (cperl-define-key "<" 'cperl-electric-paren) + (cperl-define-key "}" 'cperl-electric-brace) + (cperl-define-key "]" 'cperl-electric-rparen) + (cperl-define-key ")" 'cperl-electric-rparen) + (cperl-define-key ";" 'cperl-electric-semi) + (cperl-define-key ":" 'cperl-electric-terminator) + (cperl-define-key "\C-j" 'newline-and-indent) + (cperl-define-key "\C-c\C-j" 'cperl-linefeed) + (cperl-define-key "\C-c\C-a" 'cperl-toggle-auto-newline) + (cperl-define-key "\C-c\C-k" 'cperl-toggle-abbrev) + (cperl-define-key "\C-c\C-e" 'cperl-toggle-electric) + (cperl-define-key "\e\C-q" 'cperl-indent-exp) ; Usually not bound + ;;(cperl-define-key "\M-q" 'cperl-fill-paragraph) + ;;(cperl-define-key "\e;" 'cperl-indent-for-comment) + (cperl-define-key "\177" 'cperl-electric-backspace) + (cperl-define-key "\t" 'cperl-indent-command) + ;; don't clobber the backspace binding: + (cperl-define-key "\C-hf" 'cperl-info-on-command [(control h) f]) + (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command + [(control c) (control h) f]) + (cperl-define-key "\C-hv" 'cperl-get-help [(control h) v]) + (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)) + (cperl-define-key "\M-q" 'cperl-fill-paragraph) + (cperl-define-key "\e;" 'cperl-indent-for-comment) + (cperl-define-key "\e\C-\\" 'cperl-indent-region)) (substitute-key-definition 'indent-sexp 'cperl-indent-exp cperl-mode-map global-map) @@ -728,7 +758,11 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove ["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]) + ["Help on function at point" cperl-info-on-current-command t] + ["Help on symbol at point" cperl-get-help t] + ["Auto-help on" cperl-lazy-install (fboundp 'run-with-idle-timer)] + ["Auto-help off" cperl-lazy-unstall + (fboundp 'run-with-idle-timer)]) ("Toggle..." ["Auto newline" cperl-toggle-auto-newline t] ["Electric parens" cperl-toggle-electric t] @@ -830,13 +864,13 @@ between the braces. If CPerl decides that you want to insert 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 +\\[cperl-linefeed] is a convenience 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 +appropriately indented blank line. If you need a usual `newline-and-indent' behaviour, it is on \\[newline-and-indent], see documentation on `cperl-electric-linefeed'. @@ -862,6 +896,15 @@ 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'). +Even if you have no info-format documentation, short one-liner-style +help is available on \\[cperl-get-help]. + +It is possible to show this help automatically after some idle +time. This is regulated by variable `cperl-lazy-help-time'. Default +with `cperl-hairy' is 5 secs idle time if the value of this variable +is nil. It is also possible to switch this on/off from the +menu. Requires `run-with-idle-timer'. + Variables `cperl-pod-here-scan', `cperl-pod-here-fontify', `cperl-pod-face', `cperl-pod-head-face' control processing of pod and here-docs sections. In a future version results of scan may be used @@ -926,15 +969,10 @@ with no args." (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)))) + ;; don't clobber the backspace binding: + (cperl-define-key "\C-hf" 'cperl-info-on-current-command [(control h) f]) + (cperl-define-key "\C-c\C-hf" 'cperl-info-on-command + [(control c) (control h) f]))) (setq major-mode 'perl-mode) (setq mode-name "CPerl") (if (not cperl-mode-abbrev-table) @@ -1009,6 +1047,8 @@ with no args." (and (boundp 'msb-menu-cond) (not cperl-msb-fixed) (cperl-msb-fix)) + (if (featurep 'easymenu) + (easy-menu-add cperl-menu)) ; A NOP under FSF Emacs. (run-hooks 'cperl-mode-hook) ;; After hooks since fontification will break this (if cperl-pod-here-scan (cperl-find-pods-heres))) @@ -1089,7 +1129,7 @@ with no args." ;;; (setq prevc (current-column))))))) (defun cperl-indent-for-comment () - "Substite for `indent-for-comment' in CPerl." + "Substitute for `indent-for-comment' in CPerl." (interactive) (let (cperl-wrong-comment) (indent-for-comment) @@ -1111,6 +1151,8 @@ See `comment-region'." (let ((comment-start "#")) (comment-region b e (- arg)))) +(defvar cperl-brace-recursing nil) + (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 @@ -1118,55 +1160,74 @@ place (even in empty line), but not after. If after \")\" and the inserted char is \"{\", insert extra newline before only if `cperl-extra-newline-before-brace'." (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))) - (and (eq last-command-char ?\{) ; Do not insert newline - ;; if after ")" and `cperl-extra-newline-before-brace' - ;; is nil, do not insert extra newline. - (not cperl-extra-newline-before-brace) - (save-excursion - (skip-chars-backward " \t") - (eq (preceding-char) ?\)))) - (if cperl-auto-newline - (progn (cperl-indent-line) (newline) t) nil))) + (let (insertpos + (other-end (if (and cperl-electric-parens-mark + (cperl-mark-active) + (< (mark) (point))) + (mark) + nil))) + (if (and other-end + (not cperl-brace-recursing) + (cperl-val 'cperl-electric-parens) + (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))) + ;; Need to insert a matching pair (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))))) + (setq insertpos (point-marker)) + (goto-char other-end) + (setq last-command-char ?\{) + (cperl-electric-lbrace arg insertpos)) + (forward-char 1)) + (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))) + (and (eq last-command-char ?\{) ; Do not insert newline + ;; if after ")" and `cperl-extra-newline-before-brace' + ;; is nil, do not insert extra newline. + (not cperl-extra-newline-before-brace) + (save-excursion + (skip-chars-backward " \t") + (eq (preceding-char) ?\)))) + (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) +(defun cperl-electric-lbrace (arg &optional end) "Insert character, correct line's indentation, correct quoting by space." (interactive "P") (let (pos after + (cperl-brace-recursing t) (cperl-auto-newline cperl-auto-newline) - (other-end (if (and cperl-electric-parens-mark - (cperl-mark-active) - (> (mark) (point))) - (save-excursion - (goto-char (mark)) - (point-marker)) - nil))) + (other-end (or end + (if (and cperl-electric-parens-mark + (cperl-mark-active) + (> (mark) (point))) + (save-excursion + (goto-char (mark)) + (point-marker)) + nil)))) (and (cperl-val 'cperl-electric-lbrace-space) (eq (preceding-char) ?$) (save-excursion @@ -1215,10 +1276,39 @@ char is \"{\", insert extra newline before only if (insert last-command-char) ))) +(defun cperl-electric-rparen (arg) + "Insert a matching pair of parentheses if marking is active. +If not, or if we are not at the end of marking range, would self-insert." + (interactive "P") + (let ((beg (save-excursion (beginning-of-line) (point))) + (other-end (if (and cperl-electric-parens-mark + (cperl-mark-active) + (< (mark) (point))) + (mark) + nil)) + p) + (if (and other-end + (cperl-val 'cperl-electric-parens) + (memq last-command-char '( ?\) ?\] ?\} ?\> )) + (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)) + ;;(not (save-excursion (search-backward "#" beg t))) + ) + (progn + (insert last-command-char) + (setq p (point)) + (if other-end (goto-char other-end)) + (insert (cdr (assoc last-command-char '((?\} . ?\{) + (?\] . ?\[) + (?\) . ?\() + (?\> . ?\<))))) + (goto-char (1+ p))) + (call-interactively 'self-insert-command) + ))) + (defun cperl-electric-keyword () "Insert a construction appropriate after a keyword." (let ((beg (save-excursion (beginning-of-line) (point))) - (dollar (eq (preceding-char) ?$))) + (dollar (eq last-command-char ?$))) (and (save-excursion (backward-sexp 1) (cperl-after-expr-p nil "{};:")) @@ -1659,7 +1749,12 @@ Returns nil if line starts inside a string, t if in a comment." ;; Now add a little if this is a continuation line. (if (or (bobp) (memq (preceding-char) (append " ;}" nil)) ; Was ?\) - (memq char-after (append ")]}" nil))) + (memq char-after (append ")]}" nil)) + (and (eq (preceding-char) ?\:) ; label + (progn + (forward-sexp -1) + (skip-chars-backward " \t") + (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:")))) 0 cperl-continued-statement-offset)))) ((/= (char-after containing-sexp) ?{) @@ -1721,7 +1816,7 @@ Returns nil if line starts inside a string, t if in a comment." (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 + ;; not believe when the indentation of the label is too ;; small. (save-excursion (forward-char 1) @@ -1744,7 +1839,7 @@ Returns nil if line starts inside a string, t if in a comment." (if (> (current-indentation) cperl-min-label-indent) (- (current-indentation) cperl-label-offset) - ;; Do not belive: `max' is involved + ;; Do not believe: `max' is involved (+ old-indent cperl-indent-level)) (current-column))))) ;; If no previous statement, @@ -1894,7 +1989,7 @@ POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'." (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 + ;; not believe when the indentation of the label is too ;; small. (save-excursion (forward-char 1) @@ -1920,7 +2015,7 @@ POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'." (if (> (current-indentation) cperl-min-label-indent) (list (list 'label-in-block (point))) - ;; Do not belive: `max' is involved + ;; Do not believe: `max' is involved (list (list 'label-in-block-min-indent (point)))) ;; Before statement @@ -2042,7 +2137,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', "\\(\\`\n?\\|\n\n\\)=" "\\|" ;; One extra () before this: - "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\3\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)\\)" + "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\3\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)[^=]\\)" ; [^=] to avoid <<=. "\\|" ;; 1+5 extra () before this: "^[ \t]*format[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"))) @@ -2105,74 +2200,82 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (match-beginning 1) (match-end 1) 'face head-face)))) (goto-char e))) - ;; 1 () ahead - ;; "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\3\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)\\)" - ((match-beginning 2) ; 1 + 1 - (if (match-beginning 5) ;4 + 1 - (setq b1 (match-beginning 5) ; 4 + 1 - e1 (match-end 5)) ; 4 + 1 - (setq b1 (match-beginning 4) ; 3 + 1 - e1 (match-end 4))) ; 3 + 1 - (setq tag (buffer-substring b1 e1) - qtag (regexp-quote tag)) - (cond (cperl-pod-here-fontify - (put-text-property b1 e1 'face font-lock-reference-face) - (cperl-put-do-not-fontify b1 e1))) - (forward-line) - (setq b (point)) - (cond ((re-search-forward (concat "^" qtag "$") max 'toend) - (if cperl-pod-here-fontify - (progn - (put-text-property (match-beginning 0) (match-end 0) - 'face font-lock-reference-face) - (cperl-put-do-not-fontify b (match-end 0)) - ;;(put-text-property (max (point-min) (1- b)) - ;; (min (point-max) - ;; (1+ (match-end 0))) - ;; cperl-do-not-fontify t) - (put-text-property b (match-beginning 0) - 'face here-face))) - (put-text-property b (match-beginning 0) - 'syntax-type 'here-doc) - (cperl-put-do-not-fontify b (match-beginning 0))) - (t (message "End of here-document `%s' not found." tag)))) - (t - ;; 1+5=6 extra () before this: - ;; "^[ \t]*format[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"))) - (setq b (point) - name (if (match-beginning 7) ; 6 + 1 - (buffer-substring (match-beginning 7) ; 6 + 1 - (match-end 7)) ; 6 + 1 - "")) - (setq argument nil) - (if cperl-pod-here-fontify - (while (and (eq (forward-line) 0) - (not (looking-at "^[.;]$"))) - (cond - ((looking-at "^#")) ; Skip comments - ((and argument ; Skip argument multi-lines - (looking-at "^[ \t]*{")) - (forward-sexp 1) - (setq argument nil)) - (argument ; Skip argument lines - (setq argument nil)) - (t ; Format line - (setq b1 (point)) - (setq argument (looking-at "^[^\n]*[@^]")) - (end-of-line) - (put-text-property b1 (point) - 'face font-lock-string-face) - (cperl-put-do-not-fontify b1 (point))))) - (re-search-forward (concat "^[.;]$") max 'toend)) - (beginning-of-line) - (if (looking-at "^[.;]$") - (progn - (put-text-property (point) (+ (point) 2) - 'face font-lock-string-face) - (cperl-put-do-not-fontify (point) (+ (point) 2))) - (message "End of format `%s' not found." name)) - (forward-line) - (put-text-property b (point) 'syntax-type 'format) + ;; Here document + ;; 1 () ahead + ;; "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\3\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)\\)" + ((match-beginning 2) ; 1 + 1 + ;; Abort in comment (_extremely_ simplified): + (setq b (point)) + (if (save-excursion + (beginning-of-line) + (search-forward "#" b t)) + nil + (if (match-beginning 5) ;4 + 1 + (setq b1 (match-beginning 5) ; 4 + 1 + e1 (match-end 5)) ; 4 + 1 + (setq b1 (match-beginning 4) ; 3 + 1 + e1 (match-end 4))) ; 3 + 1 + (setq tag (buffer-substring b1 e1) + qtag (regexp-quote tag)) + (cond (cperl-pod-here-fontify + (put-text-property b1 e1 'face font-lock-reference-face) + (cperl-put-do-not-fontify b1 e1))) + (forward-line) + (setq b (point)) + (cond ((re-search-forward (concat "^" qtag "$") max 'toend) + (if cperl-pod-here-fontify + (progn + (put-text-property (match-beginning 0) (match-end 0) + 'face font-lock-reference-face) + (cperl-put-do-not-fontify b (match-end 0)) + ;;(put-text-property (max (point-min) (1- b)) + ;; (min (point-max) + ;; (1+ (match-end 0))) + ;; cperl-do-not-fontify t) + (put-text-property b (match-beginning 0) + 'face here-face))) + (put-text-property b (match-beginning 0) + 'syntax-type 'here-doc) + (cperl-put-do-not-fontify b (match-beginning 0))) + (t (message "End of here-document `%s' not found." tag))))) + ;; format + (t + ;; 1+5=6 extra () before this: + ;; "^[ \t]*format[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"))) + (setq b (point) + name (if (match-beginning 7) ; 6 + 1 + (buffer-substring (match-beginning 7) ; 6 + 1 + (match-end 7)) ; 6 + 1 + "")) + (setq argument nil) + (if cperl-pod-here-fontify + (while (and (eq (forward-line) 0) + (not (looking-at "^[.;]$"))) + (cond + ((looking-at "^#")) ; Skip comments + ((and argument ; Skip argument multi-lines + (looking-at "^[ \t]*{")) + (forward-sexp 1) + (setq argument nil)) + (argument ; Skip argument lines + (setq argument nil)) + (t ; Format line + (setq b1 (point)) + (setq argument (looking-at "^[^\n]*[@^]")) + (end-of-line) + (put-text-property b1 (point) + 'face font-lock-string-face) + (cperl-put-do-not-fontify b1 (point))))) + (re-search-forward (concat "^[.;]$") max 'toend)) + (beginning-of-line) + (if (looking-at "^[.;]$") + (progn + (put-text-property (point) (+ (point) 2) + 'face font-lock-string-face) + (cperl-put-do-not-fontify (point) (+ (point) 2))) + (message "End of format `%s' not found." name)) + (forward-line) + (put-text-property b (point) 'syntax-type 'format) ;;; (cond ((re-search-forward (concat "^[.;]$") max 'toend) ;;; (if cperl-pod-here-fontify ;;; (progn @@ -2183,7 +2286,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;;; 'syntax-type 'format) ;;; (cperl-put-do-not-fontify b (match-beginning 0))) ;;; (t (message "End of format `%s' not found." name))) - ))) + ))) ;;; (while (re-search-forward "\\(\\`\n?\\|\n\n\\)=" max t) ;;; (if (looking-at "\n*cut\\>") ;;; (progn @@ -2734,36 +2837,43 @@ indentation and initial hashes. Behaves usually outside of comment." "\\|") ; Flow control "\\)\\>") 2) ; was "\\)[ \n\t;():,\|&]" ; In what follows we use `type' style - ; for overwritable buildins + ; for overwritable builtins (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" + ;; "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\\|" @@ -2797,18 +2907,20 @@ indentation and initial hashes. Behaves usually outside of comment." "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??? + ;; for nonoverwritable builtins + ;; Somehow 's', 'm' are not auto-generated??? (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" "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\\|" @@ -2825,7 +2937,7 @@ indentation and initial hashes. Behaves usually outside of comment." ;; "#include" "#define" "#undef") ;; "\\|") '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0 - font-lock-function-name-face) ; Not very good, triggers at "[a-z]" + font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]" '("\\<sub[ \t]+\\([^ \t{;]+\\)[ \t]*[{\n]" 1 font-lock-function-name-face) '("\\<\\(package\\|require\\|use\\|import\\|no\\|bootstrap\\)[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t;]" ; require A if B; @@ -2871,8 +2983,14 @@ indentation and initial hashes. Behaves usually outside of comment." (setq t-font-lock-keywords-1 (and (fboundp 'turn-on-font-lock) ; Check for newer font-lock - (not (cperl-xemacs-p)) ; not yet as of XEmacs 19.12 - '(("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" + (not cperl-xemacs-p) ; not yet as of XEmacs 19.12 + '( + ("\\(\\([@%]\\|\$#\\)[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 + ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" 1 (if (= (- (match-end 2) (match-beginning 2)) 1) (if (eq (char-after (match-beginning 3)) ?{) @@ -2880,11 +2998,6 @@ indentation and initial hashes. Behaves usually outside of comment." 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_]\\)\\|\\(/\\)\\)" @@ -2996,7 +3109,7 @@ indentation and initial hashes. Behaves usually outside of comment." 'font-lock-other-type-face "Face to use for data types from another group.") ) - (if (not (cperl-xemacs-p)) nil + (if (not cperl-xemacs-p) nil (or (boundp 'font-lock-comment-face) (defconst font-lock-comment-face 'font-lock-comment-face @@ -3183,7 +3296,7 @@ Available styles are GNU, K&R, BSD and Whitesmith." (mode-compile))) (defun cperl-info-buffer () - ;; Returns buffer with documentation. Creats if missing + ;; Returns buffer with documentation. Creates if missing (let ((info (get-buffer "*info-perl*"))) (if info info (save-window-excursion @@ -3283,7 +3396,7 @@ Available styles are GNU, K&R, BSD and Whitesmith." (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 +All first occurrences 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. @@ -3324,7 +3437,7 @@ Will not move the position at the start to the left." (setq tcol (current-column) seen t) (if (> tcol col) (setq col tcol))) (or seen - (error "The construction to line up occured only once")) + (error "The construction to line up occurred only once")) (goto-char beg) (setq col (+ col minshift)) (if (/= (% col step) 0) (setq step (* step (1+ (/ col step))))) @@ -3596,7 +3709,7 @@ in subdirectories too." ;; Name known (setcdr cons1 (cons (cons fileind (vector file info)) (cdr cons1))) - ;; First occurence of the name, start alist + ;; First occurrence of the name, start alist (setq cons1 (cons name (list (cons fileind (vector file info))))) (if pack (setcar (cdr cperl-hierarchy) @@ -3852,3 +3965,564 @@ Currently it is tuned to C and Perl syntax." found-bad found))) (not not-found))) + +;;; Getting help +(defvar cperl-have-help-regexp + ;;(concat "\\(" + (mapconcat + 'identity + '("[$@%*&][0-9a-zA-Z_:]+" ; Usual variable + "[$@]\\^[a-zA-Z]" ; Special variable + "[$@][^ \n\t]" ; Special variable + "-[a-zA-Z]" ; File test + "\\\\[a-zA-Z0]" ; Special chars + "[-!&*+,-./<=>?\\\\^|~]+" ; Operator + "[a-zA-Z_0-9:]+" ; symbol or number + "x=" + "#!" + ) + ;;"\\)\\|\\(" + "\\|" + ) + ;;"\\)" + ;;) + "Matches places in the buffer we can find help for.") + +(defvar cperl-message-on-help-error t) + +(defun cperl-get-help () + "Get one-line docs on the symbol at the point. +The data for these docs is a little bit obsolete and may be in fact longer +than a line. Your contribution to update/shorten it is appreciated." + (interactive) + (save-excursion + ;; Get to the something meaningful + (or (eobp) (eolp) (forward-char 1)) + (re-search-backward "[-a-zA-Z0-9_:!&*+,-./<=>?\\\\^|~$%@]" + (save-excursion (beginning-of-line) (point)) + 'to-beg) + ;; (cond + ;; ((or (eobp) (looking-at "[][ \t\n{}();,]")) ; Not at a symbol + ;; (skip-chars-backward " \n\t\r({[]});,") + ;; (or (bobp) (backward-char 1)))) + ;; Try to backtrace + (cond + ((looking-at "[a-zA-Z0-9_:]") ; symbol + (skip-chars-backward "[a-zA-Z0-9_:]") + (cond + ((and (eq (preceding-char) ?^) ; $^I + (eq (char-after (- (point) 2)) ?\$)) + (forward-char -2)) + ((memq (preceding-char) (append "*$@%&\\" nil)) ; *glob + (forward-char -1))) + (if (and (eq (preceding-char) ?\<) + (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <FH> + (forward-char -1))) + ((and (looking-at "=") (eq (preceding-char) ?x)) ; x= + (forward-char -1)) + ((and (looking-at "\\^") (eq (preceding-char) ?\$)) ; $^I + (forward-char -1)) + ((looking-at "[-!&*+,-./<=>?\\\\^|~]") + (skip-chars-backward "[-!&*+,-./<=>?\\\\^|~]") + (cond + ((and (eq (preceding-char) ?\$) + (not (eq (char-after (- (point) 2)) ?\$))) ; $- + (forward-char -1)) + ((and (eq (following-char) ?\>) + (string-match "[a-zA-Z0-9_]" (char-to-string (preceding-char))) + (save-excursion + (forward-sexp -1) + (and (eq (preceding-char) ?\<) + (looking-at "\\$?[a-zA-Z0-9_:]+>")))) ; <FH> + (search-backward "<")))) + ((and (eq (following-char) ?\$) + (eq (preceding-char) ?\<) + (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <$fh> + (forward-char -1))) + ;;(or (eobp) (forward-char 1)) + (if (looking-at cperl-have-help-regexp) + (cperl-describe-perl-symbol + (buffer-substring (match-beginning 0) (match-end 0))) + (if cperl-message-on-help-error + (message "Nothing found for %s..." + (buffer-substring (point) (+ 5 (point)))))))) + +;;; Stolen from perl-descr.el by Johan Vromans: + +(defvar cperl-doc-buffer " *perl-doc*" + "Where the documentation can be found.") + +(defun cperl-describe-perl-symbol (val) + "Display the documentation of symbol at point, a Perl operator." + ;; We suppose that the current position is at the start of the symbol + ;; when we convert $_[5] to @_ + (let (;;(fn (perl-symbol-at-point)) + (enable-recursive-minibuffers t) + ;;val + args-file regexp) + ;; (interactive + ;; (let ((fn (perl-symbol-at-point)) + ;; (enable-recursive-minibuffers t) + ;; val args-file regexp) + ;; (setq val (read-from-minibuffer + ;; (if fn + ;; (format "Symbol (default %s): " fn) + ;; "Symbol: "))) + ;; (if (string= val "") + ;; (setq val fn)) + (cond + ((string-match "^[&*][a-zA-Z_]" val) + (setq val (concat (substring val 0 1) "NAME"))) + ((looking-at "[$@][a-zA-Z_:0-9]+\\([[{]\\)") + (if (= ?\[ (char-after (match-beginning 1))) + (setq val (concat "@" (substring val 1))) + (setq val (concat "%" (substring val 1))))) + ((and (string= val "x") (looking-at "x=")) + (setq val "x=")) + ((string-match "^\\$[\C-a-\C-z]" val) + (setq val (concat "$^" (char-to-string (+ ?A -1 (aref val 1)))))) + ((and (string= "<" val) (looking-at "<\\$?[a-zA-Z0-9_:]+>")) + (setq val "<NAME>"))) +;;; (if (string-match "^[&*][a-zA-Z_]" val) +;;; (setq val (concat (substring val 0 1) "NAME")) +;;; (if (looking-at "[$@][a-zA-Z_:0-9]+\\([[{]\\)") +;;; (if (= ?\[ (char-after (match-beginning 1))) +;;; (setq val (concat "@" (substring val 1))) +;;; (setq val (concat "%" (substring val 1)))) +;;; (if (and (string= val "x") (looking-at "x=")) +;;; (setq val "x=") +;;; (if (looking-at "[$@][a-zA-Z_:0-9]") +;;; )))) + (setq regexp (concat "^" "\\([^a-zA-Z0-9_:]+[ \t]\\)?" + (regexp-quote val) + "\\([ \t([/]\\|$\\)")) + + ;; get the buffer with the documentation text + (cperl-switch-to-doc-buffer) + + ;; lookup in the doc + (goto-char (point-min)) + (let ((case-fold-search nil)) + (list + (if (re-search-forward regexp (point-max) t) + (save-excursion + (beginning-of-line 1) + (let ((lnstart (point))) + (end-of-line) + (message "%s" (buffer-substring lnstart (point))))) + (if cperl-message-on-help-error + (message "No definition for %s" val))))))) + +(defvar cperl-short-docs "Ignore my value" + "# based on '@(#)@ perl-descr.el 1.9 - describe-perl-symbol' [Perl 5] +! Logical negation. +!= Numeric inequality. +!~ Search pattern, substitution, or translation (negated). +$! In numeric context: errno. In a string context: error string. +$\" The separator which joins elements of arrays interpolated in strings. +$# The output format for printed numbers. Initial value is %.20g. +$$ The process number of the perl running this script. Altered (in the child process) by fork(). +$% The current page number of the currently selected output channel. + + The following variables are always local to the current block: + +$1 Match of the 1st set of parentheses in the last match (auto-local). +$2 Match of the 2nd set of parentheses in the last match (auto-local). +$3 Match of the 3rd set of parentheses in the last match (auto-local). +$4 Match of the 4th set of parentheses in the last match (auto-local). +$5 Match of the 5th set of parentheses in the last match (auto-local). +$6 Match of the 6th set of parentheses in the last match (auto-local). +$7 Match of the 7th set of parentheses in the last match (auto-local). +$8 Match of the 8th set of parentheses in the last match (auto-local). +$9 Match of the 9th set of parentheses in the last match (auto-local). +$& The string matched by the last pattern match (auto-local). +$' The string after what was matched by the last match (auto-local). +$` The string before what was matched by the last match (auto-local). + +$( The real gid of this process. +$) The effective gid of this process. +$* Deprecated: Set to 1 to do multiline matching within a string. +$+ The last bracket matched by the last search pattern. +$, The output field separator for the print operator. +$- The number of lines left on the page. +$. The current input line number of the last filehandle that was read. +$/ The input record separator, newline by default. +$0 The name of the file containing the perl script being executed. May be set +$: The set of characters after which a string may be broken to fill continuation fields (starting with ^) in a format. +$; The subscript separator for multi-dimensional array emulation. Default is \"\\034\". +$< The real uid of this process. +$= The page length of the current output channel. Default is 60 lines. +$> The effective uid of this process. +$? The status returned by the last ``, pipe close or `system'. +$@ The perl error message from the last eval or do @var{EXPR} command. +$ARGV The name of the current file used with <> . +$[ Deprecated: The index of the first element/char in an array/string. +$\\ The output record separator for the print operator. +$] The perl version string as displayed with perl -v. +$^ The name of the current top-of-page format. +$^A The current value of the write() accumulator for format() lines. +$^D The value of the perl debug (-D) flags. +$^E Information about the last system error other than that provided by $!. +$^F The highest system file descriptor, ordinarily 2. +$^H The current set of syntax checks enabled by `use strict'. +$^I The value of the in-place edit extension (perl -i option). +$^L What formats output to perform a formfeed. Default is \f. +$^O The operating system name under which this copy of Perl was built. +$^P Internal debugging flag. +$^T The time the script was started. Used by -A/-M/-C file tests. +$^W True if warnings are requested (perl -w flag). +$^X The name under which perl was invoked (argv[0] in C-speech). +$_ The default input and pattern-searching space. +$| Flag for auto-flush after write/print on the currently selected output channel. Default is 0. +$~ The name of the current report format. +% Modulo division. +%= Modulo division assignment. +%ENV Contains the current environment. +%INC List of files that have been require-d or do-ne. +%SIG Used to set signal handlers for various signals. +& Bitwise and. +&& Logical and. +&&= Logical and assignment. +&= Bitwise and assignment. +* Multiplication. +** Exponentiation. +*NAME Refers to all objects represented by NAME. *NAM1 = *NAM2 makes NAM1 a reference to NAM2. +&NAME(arg0, ...) Subroutine call. Arguments go to @_. ++ Addition. +++ Auto-increment (magical on strings). ++= Addition assignment. +, Comma operator. +- Subtraction. +-- Auto-decrement. +-= Subtraction assignment. +-A Access time in days since script started. +-B File is a non-text (binary) file. +-C Inode change time in days since script started. +-M Age in days since script started. +-O File is owned by real uid. +-R File is readable by real uid. +-S File is a socket . +-T File is a text file. +-W File is writable by real uid. +-X File is executable by real uid. +-b File is a block special file. +-c File is a character special file. +-d File is a directory. +-e File exists . +-f File is a plain file. +-g File has setgid bit set. +-k File has sticky bit set. +-l File is a symbolic link. +-o File is owned by effective uid. +-p File is a named pipe (FIFO). +-r File is readable by effective uid. +-s File has non-zero size. +-t Tests if filehandle (STDIN by default) is opened to a tty. +-u File has setuid bit set. +-w File is writable by effective uid. +-x File is executable by effective uid. +-z File has zero size. +. Concatenate strings. +.. Alternation, also range operator. +.= Concatenate assignment strings +/ Division. /PATTERN/ioxsmg Pattern match +/= Division assignment. +/PATTERN/ioxsmg Pattern match. +< Numeric less than. <pattern> Glob. See <NAME>, <> as well. +<NAME> Reads line from filehandle NAME. NAME must be bareword/dollar-bareword. +<pattern> Glob. (Unless pattern is bareword/dollar-bareword - see <NAME>) +<> Reads line from union of files in @ARGV (= command line) and STDIN. +<< Bitwise shift left. << start of HERE-DOCUMENT. +<= Numeric less than or equal to. +<=> Numeric compare. += Assignment. +== Numeric equality. +=~ Search pattern, substitution, or translation +> Numeric greater than. +>= Numeric greater than or equal to. +>> Bitwise shift right. +>>= Bitwise shift right assignment. +? : Alternation (if-then-else) operator. ?PAT? Backwards pattern match. +?PATTERN? Backwards pattern match. +@ARGV Command line arguments (not including the command name - see $0). +@INC List of places to look for perl scripts during do/include/use. +@_ Parameter array for subroutines. Also used by split unless in array context. +\\ Creates a reference to whatever follows, like \$var. +\\0 Octal char, e.g. \\033. +\\E Case modification terminator. See \\Q, \\L, and \\U. +\\L Lowercase until \\E . +\\U Upcase until \\E . +\\Q Quote metacharacters until \\E . +\\a Alarm character (octal 007). +\\b Backspace character (octal 010). +\\c Control character, e.g. \\c[ . +\\e Escape character (octal 033). +\\f Formfeed character (octal 014). +\\l Lowercase of next character. See also \\L and \\u, +\\n Newline character (octal 012). +\\r Return character (octal 015). +\\t Tab character (octal 011). +\\u Upcase of next character. See also \\U and \\l, +\\x Hex character, e.g. \\x1b. +^ Bitwise exclusive or. +__END__ End of program source. +__DATA__ End of program source. +__FILE__ Current (source) filename. +__LINE__ Current line in current source. +ARGV Default multi-file input filehandle. <ARGV> is a synonym for <>. +ARGVOUT Output filehandle with -i flag. +BEGIN { block } Immediately executed (during compilation) piece of code. +END { block } Pseudo-subroutine executed after the script finishes. +DATA Input filehandle for what follows after __END__ or __DATA__. +accept(NEWSOCKET,GENERICSOCKET) +alarm(SECONDS) +atan2(X,Y) +bind(SOCKET,NAME) +binmode(FILEHANDLE) +caller[(LEVEL)] +chdir(EXPR) +chmod(LIST) +chop[(LIST|VAR)] +chown(LIST) +chroot(FILENAME) +close(FILEHANDLE) +closedir(DIRHANDLE) +cmp String compare. +connect(SOCKET,NAME) +continue of { block } continue { block }. Is executed after `next' or at end. +cos(EXPR) +crypt(PLAINTEXT,SALT) +dbmclose(ASSOC_ARRAY) +dbmopen(ASSOC,DBNAME,MODE) +defined(EXPR) +delete($ASSOC{KEY}) +die(LIST) +do { ... }|SUBR while|until EXPR executes at least once +do(EXPR|SUBR([LIST])) +dump LABEL +each(ASSOC_ARRAY) +endgrent +endhostent +endnetent +endprotoent +endpwent +endservent +eof[([FILEHANDLE])] +eq String equality. +eval(EXPR) or eval { BLOCK } +exec(LIST) +exit(EXPR) +exp(EXPR) +fcntl(FILEHANDLE,FUNCTION,SCALAR) +fileno(FILEHANDLE) +flock(FILEHANDLE,OPERATION) +for (EXPR;EXPR;EXPR) { ... } +foreach [VAR] (@ARRAY) { ... } +fork +ge String greater than or equal. +getc[(FILEHANDLE)] +getgrent +getgrgid(GID) +getgrnam(NAME) +gethostbyaddr(ADDR,ADDRTYPE) +gethostbyname(NAME) +gethostent +getlogin +getnetbyaddr(ADDR,ADDRTYPE) +getnetbyname(NAME) +getnetent +getpeername(SOCKET) +getpgrp(PID) +getppid +getpriority(WHICH,WHO) +getprotobyname(NAME) +getprotobynumber(NUMBER) +getprotoent +getpwent +getpwnam(NAME) +getpwuid(UID) +getservbyname(NAME,PROTO) +getservbyport(PORT,PROTO) +getservent +getsockname(SOCKET) +getsockopt(SOCKET,LEVEL,OPTNAME) +gmtime(EXPR) +goto LABEL +grep(EXPR,LIST) +gt String greater than. +hex(EXPR) +if (EXPR) { ... } [ elsif (EXPR) { ... } ... ] [ else { ... } ] or EXPR if EXPR +index(STR,SUBSTR[,OFFSET]) +int(EXPR) +ioctl(FILEHANDLE,FUNCTION,SCALAR) +join(EXPR,LIST) +keys(ASSOC_ARRAY) +kill(LIST) +last [LABEL] +le String less than or equal. +length(EXPR) +link(OLDFILE,NEWFILE) +listen(SOCKET,QUEUESIZE) +local(LIST) +localtime(EXPR) +log(EXPR) +lstat(EXPR|FILEHANDLE|VAR) +lt String less than. +m/PATTERN/iogsmx +mkdir(FILENAME,MODE) +msgctl(ID,CMD,ARG) +msgget(KEY,FLAGS) +msgrcv(ID,VAR,SIZE,TYPE.FLAGS) +msgsnd(ID,MSG,FLAGS) +my VAR or my (VAR1,...) Introduces a lexical variable ($VAR, @ARR, or %HASH). +ne String inequality. +next [LABEL] +oct(EXPR) +open(FILEHANDLE[,EXPR]) +opendir(DIRHANDLE,EXPR) +ord(EXPR) +pack(TEMPLATE,LIST) +package Introduces package context. +pipe(READHANDLE,WRITEHANDLE) +pop(ARRAY) +print [FILEHANDLE] [(LIST)] +printf [FILEHANDLE] (FORMAT,LIST) +push(ARRAY,LIST) +q/STRING/ Synonym for 'STRING' +qq/STRING/ Synonym for \"STRING\" +qx/STRING/ Synonym for `STRING` +rand[(EXPR)] +read(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) +readdir(DIRHANDLE) +readlink(EXPR) +recv(SOCKET,SCALAR,LEN,FLAGS) +redo [LABEL] +rename(OLDNAME,NEWNAME) +require [FILENAME | PERL_VERSION] +reset[(EXPR)] +return(LIST) +reverse(LIST) +rewinddir(DIRHANDLE) +rindex(STR,SUBSTR[,OFFSET]) +rmdir(FILENAME) +s/PATTERN/REPLACEMENT/gieoxsm +scalar(EXPR) +seek(FILEHANDLE,POSITION,WHENCE) +seekdir(DIRHANDLE,POS) +select(FILEHANDLE | RBITS,WBITS,EBITS,TIMEOUT) +semctl(ID,SEMNUM,CMD,ARG) +semget(KEY,NSEMS,SIZE,FLAGS) +semop(KEY,...) +send(SOCKET,MSG,FLAGS[,TO]) +setgrent +sethostent(STAYOPEN) +setnetent(STAYOPEN) +setpgrp(PID,PGRP) +setpriority(WHICH,WHO,PRIORITY) +setprotoent(STAYOPEN) +setpwent +setservent(STAYOPEN) +setsockopt(SOCKET,LEVEL,OPTNAME,OPTVAL) +shift[(ARRAY)] +shmctl(ID,CMD,ARG) +shmget(KEY,SIZE,FLAGS) +shmread(ID,VAR,POS,SIZE) +shmwrite(ID,STRING,POS,SIZE) +shutdown(SOCKET,HOW) +sin(EXPR) +sleep[(EXPR)] +socket(SOCKET,DOMAIN,TYPE,PROTOCOL) +socketpair(SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL) +sort [SUBROUTINE] (LIST) +splice(ARRAY,OFFSET[,LENGTH[,LIST]]) +split[(/PATTERN/[,EXPR[,LIMIT]])] +sprintf(FORMAT,LIST) +sqrt(EXPR) +srand(EXPR) +stat(EXPR|FILEHANDLE|VAR) +study[(SCALAR)] +sub [NAME [(format)]] { BODY } or sub [NAME [(format)]]; +substr(EXPR,OFFSET[,LEN]) +symlink(OLDFILE,NEWFILE) +syscall(LIST) +sysread(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) +system(LIST) +syswrite(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) +tell[(FILEHANDLE)] +telldir(DIRHANDLE) +time +times +tr/SEARCHLIST/REPLACEMENTLIST/cds +truncate(FILE|EXPR,LENGTH) +umask[(EXPR)] +undef[(EXPR)] +unless (EXPR) { ... } [ else { ... } ] or EXPR unless EXPR +unlink(LIST) +unpack(TEMPLATE,EXPR) +unshift(ARRAY,LIST) +until (EXPR) { ... } or EXPR until EXPR +utime(LIST) +values(ASSOC_ARRAY) +vec(EXPR,OFFSET,BITS) +wait +waitpid(PID,FLAGS) +wantarray +warn(LIST) +while (EXPR) { ... } or EXPR while EXPR +write[(EXPR|FILEHANDLE)] +x Repeat string or array. +x= Repetition assignment. +y/SEARCHLIST/REPLACEMENTLIST/ +| Bitwise or. +|| Logical or. +~ Unary bitwise complement. +#! OS interpreter indicator. If contains `perl', used for options, and -x. +") + +(defun cperl-switch-to-doc-buffer () + "Go to the perl documentation buffer and insert the documentation." + (interactive) + (let ((buf (get-buffer-create cperl-doc-buffer))) + (if (interactive-p) + (switch-to-buffer-other-window buf) + (set-buffer buf)) + (if (= (buffer-size) 0) + (progn + (insert (documentation-property 'cperl-short-docs + 'variable-documentation)) + (setq buffer-read-only t))))) + +(if (fboundp 'run-with-idle-timer) + (progn + (defvar cperl-help-shown nil + "Non-nil means that the help was already shown now.") + + (defvar cperl-help-timer nil + "Non-nil means that the help was already shown now.") + + (defun cperl-lazy-install () + (interactive) + (make-variable-buffer-local 'cperl-help-shown) + (if (cperl-val cperl-lazy-help-time) + (progn + (add-hook 'post-command-hook 'cperl-lazy-hook) + (setq cperl-help-timer + (run-with-idle-timer + (cperl-val cperl-lazy-help-time 1000000 5) + t + 'cperl-get-help-defer))))) + + (defun cperl-lazy-unstall () + (interactive) + (remove-hook 'post-command-hook 'cperl-lazy-hook) + (cancel-timer cperl-help-timer)) + + (defun cperl-lazy-hook () + (setq cperl-help-shown nil)) + + (defun cperl-get-help-defer () + (if (not (eq major-mode 'perl-mode)) nil + (let ((cperl-message-on-help-error nil)) + (cperl-get-help) + (setq cperl-help-shown t)))) + (cperl-lazy-install))) @@ -19,9 +19,10 @@ /* globals we need to hide from the world */ #define AMG_names Perl_AMG_names +#define Error Perl_Error +#define He Perl_He #define No Perl_No #define Sv Perl_Sv -#define He Perl_He #define Xpv Perl_Xpv #define Yes Perl_Yes #define abs_amg Perl_abs_amg @@ -32,6 +33,7 @@ #define an Perl_an #define atan2_amg Perl_atan2_amg #define band_amg Perl_band_amg +#define block_type Perl_block_type #define bool__amg Perl_bool__amg #define bor_amg Perl_bor_amg #define buf Perl_buf @@ -39,9 +41,9 @@ #define bufptr Perl_bufptr #define bxor_amg Perl_bxor_amg #define check Perl_check +#define compcv Perl_compcv #define compiling Perl_compiling #define compl_amg Perl_compl_amg -#define compcv Perl_compcv #define comppad Perl_comppad #define comppad_name Perl_comppad_name #define comppad_name_fill Perl_comppad_name_fill @@ -53,8 +55,6 @@ #define cryptseen Perl_cryptseen #define cshlen Perl_cshlen #define cshname Perl_cshname -#define curcop Perl_curcop -#define curcopdb Perl_curcopdb #define curinterp Perl_curinterp #define curpad Perl_curpad #define cv_const_sv Perl_cv_const_sv @@ -67,7 +67,6 @@ #define do_undump Perl_do_undump #define ds Perl_ds #define egid Perl_egid -#define envgv Perl_envgv #define eq_amg Perl_eq_amg #define error_count Perl_error_count #define euid Perl_euid @@ -93,23 +92,24 @@ #define last_lop Perl_last_lop #define last_lop_op Perl_last_lop_op #define last_uni Perl_last_uni +#define lc_collate_active Perl_lc_collate_active #define le_amg Perl_le_amg -#define lex_state Perl_lex_state -#define lex_defer Perl_lex_defer -#define lex_expect Perl_lex_expect #define lex_brackets Perl_lex_brackets -#define lex_formbrack Perl_lex_formbrack -#define lex_fakebrack Perl_lex_fakebrack +#define lex_brackstack Perl_lex_brackstack #define lex_casemods Perl_lex_casemods +#define lex_casestack Perl_lex_casestack +#define lex_defer Perl_lex_defer #define lex_dojoin Perl_lex_dojoin -#define lex_starts Perl_lex_starts -#define lex_stuff Perl_lex_stuff -#define lex_repl Perl_lex_repl -#define lex_op Perl_lex_op +#define lex_expect Perl_lex_expect +#define lex_fakebrack Perl_lex_fakebrack +#define lex_formbrack Perl_lex_formbrack #define lex_inpat Perl_lex_inpat #define lex_inwhat Perl_lex_inwhat -#define lex_brackstack Perl_lex_brackstack -#define lex_casestack Perl_lex_casestack +#define lex_op Perl_lex_op +#define lex_repl Perl_lex_repl +#define lex_starts Perl_lex_starts +#define lex_state Perl_lex_state +#define lex_stuff Perl_lex_stuff #define linestr Perl_linestr #define log_amg Perl_log_amg #define lshift_amg Perl_lshift_amg @@ -118,8 +118,8 @@ #define markstack Perl_markstack #define markstack_max Perl_markstack_max #define markstack_ptr Perl_markstack_ptr -#define maxo Perl_maxo #define max_intro_pending Perl_max_intro_pending +#define maxo Perl_maxo #define min_intro_pending Perl_min_intro_pending #define mod_amg Perl_mod_amg #define mod_ass_amg Perl_mod_ass_amg @@ -131,22 +131,27 @@ #define multi_start Perl_multi_start #define na Perl_na #define ncmp_amg Perl_ncmp_amg -#define nextval Perl_nextval -#define nexttype Perl_nexttype -#define nexttoke Perl_nexttoke #define ne_amg Perl_ne_amg #define neg_amg Perl_neg_amg +#define nexttoke Perl_nexttoke +#define nexttype Perl_nexttype #define nexttype Perl_nexttype #define nextval Perl_nextval +#define nextval Perl_nextval +#define nice_chunk Perl_nice_chunk +#define nice_chunk_size Perl_nice_chunk_size #define no_aelem Perl_no_aelem #define no_dir_func Perl_no_dir_func #define no_func Perl_no_func #define no_helem Perl_no_helem #define no_mem Perl_no_mem #define no_modify Perl_no_modify +#define no_myglob Perl_no_myglob #define no_security Perl_no_security #define no_sock_func Perl_no_sock_func +#define no_symref Perl_no_symref #define no_usym Perl_no_usym +#define no_wrongref Perl_no_wrongref #define nointrp Perl_nointrp #define nomem Perl_nomem #define nomemok Perl_nomemok @@ -163,15 +168,17 @@ #define origalen Perl_origalen #define origenviron Perl_origenviron #define osname Perl_osname +#define pad_reset_pending Perl_pad_reset_pending #define padix Perl_padix +#define padix_floor Perl_padix_floor #define patleave Perl_patleave #define pow_amg Perl_pow_amg #define pow_ass_amg Perl_pow_ass_amg #define ppaddr Perl_ppaddr #define profiledata Perl_profiledata #define provide_ref Perl_provide_ref -#define psig_ptr Perl_psig_ptr #define psig_name Perl_psig_name +#define psig_ptr Perl_psig_ptr #define qrt_amg Perl_qrt_amg #define rcsid Perl_rcsid #define reall_srchlen Perl_reall_srchlen @@ -181,6 +188,7 @@ #define regdummy Perl_regdummy #define regendp Perl_regendp #define regeol Perl_regeol +#define regflags Perl_regflags #define regfold Perl_regfold #define reginput Perl_reginput #define regkind Perl_regkind @@ -208,6 +216,7 @@ #define rsfp_filters Perl_rsfp_filters #define rshift_amg Perl_rshift_amg #define rshift_ass_amg Perl_rshift_ass_amg +#define save_iv Perl_save_iv #define save_pptr Perl_save_pptr #define savestack Perl_savestack #define savestack_ix Perl_savestack_ix @@ -223,7 +232,6 @@ #define sgt_amg Perl_sgt_amg #define sig_name Perl_sig_name #define sig_num Perl_sig_num -#define siggv Perl_siggv #define sighandler Perl_sighandler #define simple Perl_simple #define sin_amg Perl_sin_amg @@ -243,7 +251,6 @@ #define sv_no Perl_sv_no #define sv_undef Perl_sv_undef #define sv_yes Perl_sv_yes -#define tainting Perl_tainting #define thisexpr Perl_thisexpr #define timesbuf Perl_timesbuf #define tokenbuf Perl_tokenbuf @@ -257,6 +264,7 @@ #define vtbl_dbline Perl_vtbl_dbline #define vtbl_env Perl_vtbl_env #define vtbl_envelem Perl_vtbl_envelem +#define vtbl_fm Perl_vtbl_fm #define vtbl_glob Perl_vtbl_glob #define vtbl_isa Perl_vtbl_isa #define vtbl_isaelem Perl_vtbl_isaelem @@ -275,6 +283,7 @@ #define warn_nl Perl_warn_nl #define warn_nosemi Perl_warn_nosemi #define warn_reserved Perl_warn_reserved +#define warn_uninit Perl_warn_uninit #define watchaddr Perl_watchaddr #define watchok Perl_watchok #define yychar Perl_yychar @@ -316,12 +325,14 @@ #define bind_match Perl_bind_match #define block_end Perl_block_end #define block_start Perl_block_start +#define boot_core_UNIVERSAL Perl_boot_core_UNIVERSAL #define calllist Perl_calllist #define cando Perl_cando #define cast_ulong Perl_cast_ulong #define check_uni Perl_check_uni #define checkcomma Perl_checkcomma #define ck_aelem Perl_ck_aelem +#define ck_bitop Perl_ck_bitop #define ck_concat Perl_ck_concat #define ck_delete Perl_ck_delete #define ck_eof Perl_ck_eof @@ -498,6 +509,7 @@ #define magic_setbm Perl_magic_setbm #define magic_setdbline Perl_magic_setdbline #define magic_setenv Perl_magic_setenv +#define magic_setfm Perl_magic_setfm #define magic_setglob Perl_magic_setglob #define magic_setisa Perl_magic_setisa #define magic_setmglob Perl_magic_setmglob @@ -512,6 +524,7 @@ #define magic_wipepack Perl_magic_wipepack #define magicname Perl_magicname #define markstack_grow Perl_markstack_grow +#define mem_collxfrm Perl_mem_collxfrm #define mess Perl_mess #define mg_clear Perl_mg_clear #define mg_copy Perl_mg_copy @@ -968,7 +981,16 @@ #define repeatcpy Perl_repeatcpy #define rninstr Perl_rninstr #define runops Perl_runops +#define safecalloc Perl_safecalloc +#define safemalloc Perl_safemalloc +#define safefree Perl_safefree +#define saferealloc Perl_saferealloc +#define safexcalloc Perl_safexcalloc +#define safexmalloc Perl_safexmalloc +#define safexfree Perl_safexfree +#define safexrealloc Perl_safexrealloc #define same_dirent Perl_same_dirent +#define save_I16 Perl_save_I16 #define save_I32 Perl_save_I32 #define save_aptr Perl_save_aptr #define save_ary Perl_save_ary @@ -1041,6 +1063,7 @@ #define sv_clear Perl_sv_clear #define sv_cmp Perl_sv_cmp #define sv_dec Perl_sv_dec +#define sv_derived_from Perl_sv_derived_from #define sv_dump Perl_sv_dump #define sv_eq Perl_sv_eq #define sv_free Perl_sv_free @@ -1073,6 +1096,7 @@ #define sv_setref_pv Perl_sv_setref_pv #define sv_setref_pvn Perl_sv_setref_pvn #define sv_setsv Perl_sv_setsv +#define sv_setuv Perl_sv_setuv #define sv_unmagic Perl_sv_unmagic #define sv_unref Perl_sv_unref #define sv_upgrade Perl_sv_upgrade @@ -1095,6 +1119,7 @@ #define xpv_root Perl_xpv_root #define xrv_root Perl_xrv_root #define yyerror Perl_yyerror +#define yydestruct Perl_yydestruct #define yylex Perl_yylex #define yyparse Perl_yyparse #define yywarn Perl_yywarn @@ -1105,14 +1130,6 @@ #ifdef MULTIPLICITY -/* Undefine symbols that were defined by EMBED. Somewhat ugly */ - -#undef curcop -#undef curcopdb -#undef envgv -#undef siggv -#undef tainting - #define Argv (curinterp->IArgv) #define Cmd (curinterp->ICmd) #define DBgv (curinterp->IDBgv) @@ -1417,4 +1434,155 @@ #define Iunsafe unsafe #define Iwarnhook warnhook +#define Argv Perl_Argv +#define Cmd Perl_Cmd +#define DBgv Perl_DBgv +#define DBline Perl_DBline +#define DBsignal Perl_DBsignal +#define DBsingle Perl_DBsingle +#define DBsub Perl_DBsub +#define DBtrace Perl_DBtrace +#define allgvs Perl_allgvs +#define ampergv Perl_ampergv +#define argvgv Perl_argvgv +#define argvoutgv Perl_argvoutgv +#define basetime Perl_basetime +#define beginav Perl_beginav +#define bodytarget Perl_bodytarget +#define cddir Perl_cddir +#define chopset Perl_chopset +#define copline Perl_copline +#define curblock Perl_curblock +#define curcop Perl_curcop +#define curcopdb Perl_curcopdb +#define curcsv Perl_curcsv +#define curpm Perl_curpm +#define curstack Perl_curstack +#define curstash Perl_curstash +#define curstname Perl_curstname +#define cxstack Perl_cxstack +#define cxstack_ix Perl_cxstack_ix +#define cxstack_max Perl_cxstack_max +#define dbargs Perl_dbargs +#define debdelim Perl_debdelim +#define debname Perl_debname +#define debstash Perl_debstash +#define defgv Perl_defgv +#define defoutgv Perl_defoutgv +#define defstash Perl_defstash +#define delaymagic Perl_delaymagic +#define diehook Perl_diehook +#define dirty Perl_dirty +#define dlevel Perl_dlevel +#define dlmax Perl_dlmax +#define doextract Perl_doextract +#define doswitches Perl_doswitches +#define dowarn Perl_dowarn +#define dumplvl Perl_dumplvl +#define e_fp Perl_e_fp +#define e_tmpname Perl_e_tmpname +#define endav Perl_endav +#define envgv Perl_envgv +#define errgv Perl_errgv +#define eval_root Perl_eval_root +#define eval_start Perl_eval_start +#define fdpid Perl_fdpid +#define filemode Perl_filemode +#define firstgv Perl_firstgv +#define forkprocess Perl_forkprocess +#define formfeed Perl_formfeed +#define formtarget Perl_formtarget +#define gensym Perl_gensym +#define in_eval Perl_in_eval +#define incgv Perl_incgv +#define inplace Perl_inplace +#define last_in_gv Perl_last_in_gv +#define lastfd Perl_lastfd +#define lastretstr Perl_lastretstr +#define lastscream Perl_lastscream +#define lastsize Perl_lastsize +#define lastspbase Perl_lastspbase +#define laststatval Perl_laststatval +#define laststype Perl_laststype +#define leftgv Perl_leftgv +#define lineary Perl_lineary +#define localizing Perl_localizing +#define localpatches Perl_localpatches +#define main_cv Perl_main_cv +#define main_root Perl_main_root +#define main_start Perl_main_start +#define mainstack Perl_mainstack +#define maxscream Perl_maxscream +#define maxsysfd Perl_maxsysfd +#define minus_F Perl_minus_F +#define minus_a Perl_minus_a +#define minus_c Perl_minus_c +#define minus_l Perl_minus_l +#define minus_n Perl_minus_n +#define minus_p Perl_minus_p +#define multiline Perl_multiline +#define mystack_base Perl_mystack_base +#define mystack_mark Perl_mystack_mark +#define mystack_max Perl_mystack_max +#define mystack_sp Perl_mystack_sp +#define mystrk Perl_mystrk +#define nrs Perl_nrs +#define ofmt Perl_ofmt +#define ofs Perl_ofs +#define ofslen Perl_ofslen +#define oldlastpm Perl_oldlastpm +#define oldname Perl_oldname +#define op_mask Perl_op_mask +#define origargc Perl_origargc +#define origargv Perl_origargv +#define origfilename Perl_origfilename +#define ors Perl_ors +#define orslen Perl_orslen +#define parsehook Perl_parsehook +#define patchlevel Perl_patchlevel +#define perldb Perl_perldb +#define perl_destruct_level Perl_perl_destruct_level +#define pidstatus Perl_pidstatus +#define preambled Perl_preambled +#define preambleav Perl_preambleav +#define preprocess Perl_preprocess +#define restartop Perl_restartop +#define rightgv Perl_rightgv +#define rs Perl_rs +#define runlevel Perl_runlevel +#define sawampersand Perl_sawampersand +#define sawi Perl_sawi +#define sawstudy Perl_sawstudy +#define sawvec Perl_sawvec +#define screamfirst Perl_screamfirst +#define screamnext Perl_screamnext +#define secondgv Perl_secondgv +#define siggv Perl_siggv +#define signalstack Perl_signalstack +#define sortcop Perl_sortcop +#define sortstack Perl_sortstack +#define sortstash Perl_sortstash +#define splitstr Perl_splitstr +#define statcache Perl_statcache +#define statgv Perl_statgv +#define statname Perl_statname +#define statusvalue Perl_statusvalue +#define stdingv Perl_stdingv +#define strchop Perl_strchop +#define strtab Perl_strtab +#define sv_count Perl_sv_count +#define sv_objcount Perl_sv_objcount +#define sv_root Perl_sv_root +#define sv_arenaroot Perl_sv_arenaroot +#define tainted Perl_tainted +#define tainting Perl_tainting +#define tmps_floor Perl_tmps_floor +#define tmps_ix Perl_tmps_ix +#define tmps_max Perl_tmps_max +#define tmps_stack Perl_tmps_stack +#define top_env Perl_top_env +#define toptarget Perl_toptarget +#define unsafe Perl_unsafe +#define warnhook Perl_warnhook + #endif /* MULTIPLICITY */ @@ -46,43 +46,41 @@ print EM <<'END'; #ifdef MULTIPLICITY -/* Undefine symbols that were defined by EMBED. Somewhat ugly */ - END - open(INT, "<interp.sym") || die "Can't open interp.sym: $!\n"; while (<INT>) { s/[ \t]*#.*//; # Delete comments. next unless /\S/; - s/^\s*(\S*).*$/#undef $1/; - print EM $_ if (exists $global{$1}); + s/^\s*(\S+).*$/#define $1\t\t(curinterp->I$1)/; + s/(................\t)\t/$1/; + print EM $_; } close(INT) || warn "Can't close interp.sym: $!\n"; -print EM "\n"; +print EM <<'END'; + +#else /* not multiple, so translate interpreter symbols the other way... */ + +END open(INT, "<interp.sym") || die "Can't open interp.sym: $!\n"; while (<INT>) { s/[ \t]*#.*//; # Delete comments. next unless /\S/; - s/^\s*(\S+).*$/#define $1\t\t(curinterp->I$1)/; + s/^\s*(\S+).*$/#define I$1\t\t$1/; s/(................\t)\t/$1/; print EM $_; } close(INT) || warn "Can't close interp.sym: $!\n"; -print EM <<'END'; - -#else /* not multiple, so translate interpreter symbols the other way... */ - -END +print EM "\n"; open(INT, "<interp.sym") || die "Can't open interp.sym: $!\n"; while (<INT>) { s/[ \t]*#.*//; # Delete comments. next unless /\S/; - s/^\s*(\S+).*$/#define I$1\t\t$1/; + s/^\s*(\S+).*$/#define $1\t\tPerl_$1/; s/(................\t)\t/$1/; print EM $_; } diff --git a/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c index 599dd37ea5..e13427a353 100644 --- a/ext/DynaLoader/dlutils.c +++ b/ext/DynaLoader/dlutils.c @@ -84,7 +84,7 @@ SaveError(pat, va_alist) /* prepend underscore to s. write into buf. return buf. */ -char * +static char * dl_add_underscore(s, buf) char *s; char *buf; diff --git a/ext/IO/lib/IO/File.pm b/ext/IO/lib/IO/File.pm index ef9d510f91..9b3025f36d 100644 --- a/ext/IO/lib/IO/File.pm +++ b/ext/IO/lib/IO/File.pm @@ -43,7 +43,7 @@ IO::File - supply object methods for filehandles =head1 DESCRIPTION -C<IO::File> is inherits from C<IO::Handle> ans C<IO::Seekable>. It extends +C<IO::File> inherits from C<IO::Handle> and C<IO::Seekable>. It extends these classes with methods that are specific to file handles. =head1 CONSTRUCTOR diff --git a/ext/IO/lib/IO/Handle.pm b/ext/IO/lib/IO/Handle.pm index e4abdd2ecb..4b0b93cc6f 100644 --- a/ext/IO/lib/IO/Handle.pm +++ b/ext/IO/lib/IO/Handle.pm @@ -169,7 +169,7 @@ module keeps a C<timeout> variable in 'io_socket_timeout'. L<perlfunc>, L<perlop/"I/O Operators">, -L<POSIX/"FileHandle"> +L<FileHandle> =head1 BUGS diff --git a/ext/SDBM_File/sdbm/sdbm.c b/ext/SDBM_File/sdbm/sdbm.c index d4836be671..a62334c45e 100644 --- a/ext/SDBM_File/sdbm/sdbm.c +++ b/ext/SDBM_File/sdbm/sdbm.c @@ -135,7 +135,7 @@ int mode; * open the files in sequence, and stat the dirfile. * If we fail anywhere, undo everything, return NULL. */ -# ifdef OS2 +#if defined(OS2) || defined(MSDOS) flags |= O_BINARY; # endif if ((db->pagf = open(pagname, flags, mode)) > -1) { diff --git a/ext/SDBM_File/sdbm/sdbm.h b/ext/SDBM_File/sdbm/sdbm.h index 8fcdda0f9f..c05f0d0fa8 100644 --- a/ext/SDBM_File/sdbm/sdbm.h +++ b/ext/SDBM_File/sdbm/sdbm.h @@ -108,19 +108,6 @@ extern long sdbm_hash proto((char *, int)); # endif #endif -#ifdef MYMALLOC -# ifdef HIDEMYMALLOC -# define malloc Mymalloc -# define realloc Myremalloc -# define free Myfree -# define calloc Mycalloc -# endif -# define safemalloc malloc -# define saferealloc realloc -# define safefree free -# define safecalloc calloc -#endif - #if defined(__STDC__) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus) # define STANDARD_C 1 #endif @@ -163,6 +150,31 @@ extern long sdbm_hash proto((char *, int)); #define MEM_SIZE Size_t +/* This comes after <stdlib.h> so we don't try to change the standard + * library prototypes; we'll use our own instead. */ + +#if defined(MYMALLOC) && (defined(HIDEMYMALLOC) || defined(EMBEDMYMALLOC)) + +# ifdef HIDEMYMALLOC +# define malloc Mymalloc +# define calloc Mycalloc +# define realloc Myremalloc +# define free Myfree +# endif +# ifdef EMBEDMYMALLOC +# define malloc Perl_malloc +# define calloc Perl_calloc +# define realloc Perl_realloc +# define free Perl_free +# endif + + Malloc_t malloc _((MEM_SIZE nbytes)); + Malloc_t calloc _((MEM_SIZE elements, MEM_SIZE size)); + Malloc_t realloc _((Malloc_t where, MEM_SIZE nbytes)); + Free_t free _((Malloc_t where)); + +#endif /* MYMALLOC && (HIDEMYMALLOC || EMBEDMYMALLOC) */ + #ifdef I_STRING #include <string.h> #else diff --git a/global.sym b/global.sym index 62f7064576..c2d8992568 100644 --- a/global.sym +++ b/global.sym @@ -3,9 +3,10 @@ # Variables AMG_names +Error +He No Sv -He Xpv Yes abs_amg @@ -16,6 +17,7 @@ amagic_generation an atan2_amg band_amg +block_type bool__amg bor_amg buf @@ -23,9 +25,9 @@ bufend bufptr bxor_amg check +compcv compiling compl_amg -compcv comppad comppad_name comppad_name_fill @@ -37,8 +39,6 @@ cos_amg cryptseen cshlen cshname -curcop -curcopdb curinterp curpad cv_const_sv @@ -51,7 +51,6 @@ div_ass_amg do_undump ds egid -envgv eq_amg error_count euid @@ -79,22 +78,22 @@ last_lop_op last_uni lc_collate_active le_amg -lex_state -lex_defer -lex_expect lex_brackets -lex_formbrack -lex_fakebrack +lex_brackstack lex_casemods +lex_casestack +lex_defer lex_dojoin -lex_starts -lex_stuff -lex_repl -lex_op +lex_expect +lex_fakebrack +lex_formbrack lex_inpat lex_inwhat -lex_brackstack -lex_casestack +lex_op +lex_repl +lex_starts +lex_state +lex_stuff linestr log_amg lshift_amg @@ -103,8 +102,8 @@ lt_amg markstack markstack_max markstack_ptr -maxo max_intro_pending +maxo min_intro_pending mod_amg mod_ass_amg @@ -116,22 +115,27 @@ multi_open multi_start na ncmp_amg -nextval -nexttype -nexttoke ne_amg neg_amg +nexttoke nexttype +nexttype +nextval nextval +nice_chunk +nice_chunk_size no_aelem no_dir_func no_func no_helem no_mem no_modify +no_myglob no_security no_sock_func +no_symref no_usym +no_wrongref nointrp nomem nomemok @@ -148,15 +152,17 @@ opargs origalen origenviron osname +pad_reset_pending padix +padix_floor patleave pow_amg pow_ass_amg ppaddr profiledata provide_ref -psig_ptr psig_name +psig_ptr qrt_amg rcsid reall_srchlen @@ -166,6 +172,7 @@ regcode regdummy regendp regeol +regflags regfold reginput regkind @@ -193,6 +200,7 @@ rsfp rsfp_filters rshift_amg rshift_ass_amg +save_iv save_pptr savestack savestack_ix @@ -208,7 +216,6 @@ sge_amg sgt_amg sig_name sig_num -siggv sighandler simple sin_amg @@ -228,7 +235,6 @@ subtr_ass_amg sv_no sv_undef sv_yes -tainting thisexpr timesbuf tokenbuf @@ -242,6 +248,7 @@ vtbl_bm vtbl_dbline vtbl_env vtbl_envelem +vtbl_fm vtbl_glob vtbl_isa vtbl_isaelem @@ -260,6 +267,7 @@ vtbl_vec warn_nl warn_nosemi warn_reserved +warn_uninit watchaddr watchok yychar @@ -304,12 +312,14 @@ av_unshift bind_match block_end block_start +boot_core_UNIVERSAL calllist cando cast_ulong check_uni checkcomma ck_aelem +ck_bitop ck_concat ck_delete ck_eof @@ -486,6 +496,7 @@ magic_setarylen magic_setbm magic_setdbline magic_setenv +magic_setfm magic_setglob magic_setisa magic_setmglob @@ -957,7 +968,16 @@ regprop repeatcpy rninstr runops +safecalloc +safemalloc +safefree +saferealloc +safexcalloc +safexmalloc +safexfree +safexrealloc same_dirent +save_I16 save_I32 save_aptr save_ary @@ -1030,6 +1050,7 @@ sv_clean_objs sv_clear sv_cmp sv_dec +sv_derived_from sv_dump sv_eq sv_free @@ -1062,6 +1083,7 @@ sv_setref_nv sv_setref_pv sv_setref_pvn sv_setsv +sv_setuv sv_unmagic sv_unref sv_upgrade @@ -1084,6 +1106,7 @@ xnv_root xpv_root xrv_root yyerror +yydestruct yylex yyparse yywarn @@ -181,43 +181,21 @@ typedef U16 line_t; Renew macros. --Andy Dougherty August 1996 */ + #ifndef lint #ifndef LEAKTEST -#ifndef safemalloc -# ifdef __cplusplus - extern "C" { -# endif -Malloc_t safemalloc _((MEM_SIZE)); -Malloc_t saferealloc _((Malloc_t, MEM_SIZE)); -Free_t safefree _((Malloc_t)); -Malloc_t safecalloc _((MEM_SIZE, MEM_SIZE)); -# ifdef __cplusplus - } -# endif -#endif -#ifndef MSDOS #define New(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t)))) #define Newc(x,v,n,t,c) (v = (c*)safemalloc((MEM_SIZE)((n) * sizeof(t)))) #define Newz(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t)))), \ memzero((char*)(v), (n) * sizeof(t)) #define Renew(v,n,t) (v = (t*)saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))) #define Renewc(v,n,t,c) (v = (c*)saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))) -#else -#define New(x,v,n,t) (v = (t*)safemalloc(((unsigned long)(n) * sizeof(t)))) -#define Newc(x,v,n,t,c) (v = (c*)safemalloc(((unsigned long)(n) * sizeof(t)))) -#define Newz(x,v,n,t) (v = (t*)safemalloc(((unsigned long)(n) * sizeof(t)))), \ - memzero((char*)(v), (n) * sizeof(t)) -#define Renew(v,n,t) (v = (t*)saferealloc((Malloc_t)(v),((unsigned long)(n)*sizeof(t)))) -#define Renewc(v,n,t,c) (v = (c*)saferealloc((Malloc_t)(v),((unsigned long)(n)*sizeof(t)))) -#endif /* MSDOS */ #define Safefree(d) safefree((Malloc_t)(d)) #define NEWSV(x,len) newSV(len) + #else /* LEAKTEST */ -Malloc_t safexmalloc(); -Malloc_t safexrealloc(); -Free_t safexfree(); -Malloc_t safexcalloc(); + #define New(x,v,n,t) (v = (t*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))) #define Newc(x,v,n,t,c) (v = (c*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))) #define Newz(x,v,n,t) (v = (t*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))), \ @@ -229,11 +207,15 @@ Malloc_t safexcalloc(); #define MAXXCOUNT 1200 long xcount[MAXXCOUNT]; long lastxcount[MAXXCOUNT]; + #endif /* LEAKTEST */ + #define Move(s,d,n,t) (void)memmove((char*)(d),(char*)(s), (n) * sizeof(t)) #define Copy(s,d,n,t) (void)memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) #define Zero(d,n,t) (void)memzero((char*)(d), (n) * sizeof(t)) + #else /* lint */ + #define New(x,v,n,s) (v = Null(s *)) #define Newc(x,v,n,s,c) (v = Null(s *)) #define Newz(x,v,n,s) (v = Null(s *)) @@ -242,6 +224,7 @@ long lastxcount[MAXXCOUNT]; #define Copy(s,d,n,t) #define Zero(d,n,t) #define Safefree(d) d = d + #endif /* lint */ #ifdef USE_STRUCT_COPY diff --git a/hints/amigaos.sh b/hints/amigaos.sh new file mode 100644 index 0000000000..8328c8a3d3 --- /dev/null +++ b/hints/amigaos.sh @@ -0,0 +1,43 @@ +# hints/amigaos.sh +# +# talk to pueschel@imsdd.meb.uni-bonn.de if you want to change this file. +# +# misc stuff +archname='m68k-amigaos' +cc='gcc' +firstmakefile='GNUmakefile' +ccflags='-DAMIGAOS -mstackextend' +optimize='-O2 -fomit-frame-pointer' + +cppminus=' ' +cpprun='cpp' +cppstdin='cpp' + +usenm='y' +usemymalloc='n' +usevfork='true' +useperlio='true' +d_eofnblk='define' +d_fork='undef' +d_vfork='define' +groupstype='int' + +# libs + +libpth="/local/lib $prefix/lib" +glibpth="$libpth" +xlibpth="$libpth" + +libswanted='dld m c gdbm' +so=' ' + +# dynamic loading + +dlext='o' +cccdlflags='none' +ccdlflags='none' +lddlflags='-oformat a.out-amiga -r' + +# Avoid telldir prototype conflict in pp_sys.c (AmigaOS uses const DIR *) +# Configure should test for this. Volunteers? +pp_sys_cflags='ccflags="$ccflags -DHAS_TELLDIR_PROTOTYPE"' diff --git a/hints/freebsd.sh b/hints/freebsd.sh index 1e92053cf5..e8bee396a3 100644 --- a/hints/freebsd.sh +++ b/hints/freebsd.sh @@ -14,6 +14,10 @@ # Ollivier Robert <Ollivier.Robert@keltia.frmug.fr.net> # Date: Fri, 12 May 1995 14:30:38 +0200 (MET DST) # +# Additional 2.2 defines from +# Mark Murray <mark@grondar.za> +# Date: Wed, 6 Nov 1996 09:44:58 +0200 (MET) +# # The two flags "-fpic -DPIC" are used to indicate a # will-be-shared object. Configure will guess the -fpic, (and the # -DPIC is not used by perl proper) but the full define is included to @@ -43,16 +47,38 @@ case "$osvers" in d_setruid='undef' ;; # -# Trying to cover 2.0.5, 2.1-current and future 2.1 +# Trying to cover 2.0.5, 2.1-current and future 2.1/2.2 # It does not covert all 2.1-current versions as the output of uname # changed a few times. # +# Even though seteuid/setegid are available, they've been turned off +# because perl isn't coded with saved set[ug]id variables in mind. +# In addition, a small patch is requried to suidperl to avoid a security +# problem with FreeBSD. +# 2.0.5*|2.0-built*|2.1*) usevfork='true' + d_dosuid='define' + d_setregid='define' + d_setreuid='define' + d_setegid='undef' + d_seteuid='undef' + ;; +# +# 2.2 and above have phkmalloc(3). +2.2*) + usevfork='true' + usemymalloc='n' + d_dosuid='define' + d_setregid='define' + d_setreuid='define' + d_setegid='undef' + d_seteuid='undef' ;; # -# Guesses at what will be needed after 2.1 +# Guesses at what will be needed after 2.2 *) usevfork='true' + usemymalloc='n' ;; esac diff --git a/hints/machten.sh b/hints/machten.sh index 321a80a297..f6f75d6616 100644 --- a/hints/machten.sh +++ b/hints/machten.sh @@ -13,8 +13,9 @@ # Martijn Koster <m.koster@webcrawler.com> # Richard Yeh <rcyeh@cco.caltech.edu> # -# File::Find's use of link count disabled by Dominic Dunlop 950528 -# Perl's use of sigsetjmp etc. disabled by Dominic Dunlop 950521 +# Do not use perl's malloc; SysV IPC OK -- Neil Cutcliffe, Tenon 961030 +# File::Find's use of link count disabled by Dominic Dunlop 960528 +# Perl's use of sigsetjmp etc. disabled by Dominic Dunlop 960521 # # Comments, questions, and improvements welcome! # @@ -22,11 +23,20 @@ # know how to use it yet. # # Updated by Dominic Dunlop <domo@tcp.ip.lu> -# Tue May 28 11:20:08 WET DST 1996 +# Wed Nov 13 11:47:09 WET 1996 + + +# Power MachTen is a real memory system and its standard malloc +# has been optimized for this. Using this malloc instead of Perl's +# malloc may result in significant memory savings. +usemymalloc='false' # Configure doesn't know how to parse the nm output. usenm=undef +# Install in /usr/local by default +prefix='/usr/local' + # At least on PowerMac, doubles must be aligned on 8 byte boundaries. # I don't know if this is true for all MachTen systems, or how to # determine this automatically. @@ -60,16 +70,3 @@ Hmm...You had some extra variables I don't know about...I'll try to keep 'em. Read the File::Find documentation for more information. EOM - -# Date: Wed, 18 Sep 1996 11:29:40 +0200 -# From: Dominic Dunlop <domo@tcp.ip.lu> -# Subject: Re: Perl 5.003 from ftp.tenon.com requires MT 4.0.3 - -# MachTen 4.0.2 and earlier do not implement System V interprocess -# communication (message queues, semaphores and shered memory); 4.0.3 has a -# half-baked implementation which provides the corresponding library -# functions but does not implement the system calls or provide the header -# files (or documentation). The perl installation process correctly divines -# that System V IPC is not usable in either case. Do not attempt to persuade -# it otherwise, or the resulting perl will crash (rather than producing an -# error message) if you attempt to use the functions. diff --git a/installman b/installman index d57cdb14e9..c5663dd562 100755 --- a/installman +++ b/installman @@ -126,7 +126,7 @@ sub runpod2man { # Convert name from File/Basename.pm to File::Basename.3 format, # if necessary. $manpage =~ s#\.p(m|od)$##; - if ($^O eq 'os2') { + if ($^O eq 'os2' || $^O eq 'amigaos') { $manpage =~ s#/#.#g; } else { $manpage =~ s#/#::#g; diff --git a/installperl b/installperl index 8f8f7e79ef..a9082df737 100755 --- a/installperl +++ b/installperl @@ -167,27 +167,30 @@ foreach $file (@corefiles) { $mainperl_is_instperl = 0; 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") { + local($usrbinperl) = "$mainperldir/perl$exe_ext"; + local($instperl) = "$installbin/perl$exe_ext"; + local($expinstperl) = "$binexp/perl$exe_ext"; + + # First make sure $usrbinperl is not already the same as the perl we + # just installed. + if (-x $usrbinperl) { # 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") || + &samepath($usrbinperl, $instperl) || (($binexp ne $installbin) && - (-l "$mainperldir/perl$exe_ext") && - ((readlink "$mainperldir/perl$exe_ext") eq "$binexp/perl$exe_ext")); + (-l $usrbinperl) && + ((readlink $usrbinperl) eq $expinstperl)); } if ((! $mainperl_is_instperl) && - (&yn("Many scripts expect perl to be installed as " . - "$mainperldir/perl.\n" . - "Do you wish to have $mainperldir/perl be the same as\n" . - "$binexp/perl? [y] "))) + (&yn("Many scripts expect perl to be installed as $usrbinperl.\n" . + "Do you wish to have $usrbinperl be the same as\n" . + "$expinstperl? [y] "))) { - unlink("$mainperldir/perl$exe_ext"); - CORE::link("$installbin/perl$exe_ext", "$mainperldir/perl$exe_ext") || - symlink("$binexp/perl$exe_ext", "$mainperldir/perl$exe_ext") || - cmd("cp $installbin/perl$exe_ext $mainperldir$exe_ext"); + unlink($usrbinperl); + eval { CORE::link $instperl, $usrbinperl } || + eval { symlink $expinstperl, $usrbinperl } || + cmd("cp $instperl $usrbinperl"); $mainperl_is_instperl = 1; } } diff --git a/lib/AutoLoader.pm b/lib/AutoLoader.pm index 7d781d13c0..fa9a322449 100644 --- a/lib/AutoLoader.pm +++ b/lib/AutoLoader.pm @@ -95,10 +95,6 @@ subroutine may have a shorter name that the routine itself. This can lead to conflicting file names. The I<AutoSplit> package warns of these potential conflicts when used to split a module. -Calling foo($1) for the autoloaded function foo() might not work as -expected, because the AUTOLOAD function of B<AutoLoader> clobbers the -regexp variables. Invoking it as foo("$1") avoids this problem. - =cut AUTOLOAD { diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm index b582f78d69..d9bd17a7f7 100644 --- a/lib/AutoSplit.pm +++ b/lib/AutoSplit.pm @@ -195,6 +195,7 @@ sub autosplit_file{ die "Package $package does not match filename $filename" unless ($filename =~ m/$modpname.pm$/ or + ($^O eq "msdos") or $Is_VMS && $filename =~ m/$modpname.pm/i); if ($check_mod_time){ diff --git a/lib/Carp.pm b/lib/Carp.pm index 5de8f83d14..1a1b79ea3f 100644 --- a/lib/Carp.pm +++ b/lib/Carp.pm @@ -29,6 +29,8 @@ not where carp() was called. $CarpLevel = 0; # How many extra package levels to skip on carp. $MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all. +$MaxArgLen = 64; # How much of each argument to print. 0 = all. +$MaxArgNums = 8; # How many arguments to print. 0 = all. require Exporter; @ISA = Exporter; @@ -38,8 +40,10 @@ sub longmess { my $error = shift; my $mess = ""; my $i = 1 + $CarpLevel; - my ($pack,$file,$line,$sub,$eval,$require); - while (($pack,$file,$line,$sub,undef,undef,$eval,$require) = caller($i++)) { + my ($pack,$file,$line,$sub,$hargs,$eval,$require); + my (@a); + while (do { { package DB; @a = caller($i++) } } ) { + ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a; if ($error =~ m/\n$/) { $mess .= $error; } else { @@ -56,6 +60,21 @@ sub longmess { } elsif ($sub eq '(eval)') { $sub = 'eval {...}'; } + if ($hargs) { + @a = @DB::args; # must get local copy of args + if ($MaxArgNums and @a > $MaxArgNums) { + $#a = $MaxArgNums; + $a[$#a] = "..."; + } + for (@a) { + s/'/\\'/g; + substr($_,$MaxArgLen) = '...' if $MaxArgLen and $MaxArgLen < length; + 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; + } + $sub .= '(' . join(', ', @a) . ')'; + } $mess .= "\t$sub " if $error eq "called"; $mess .= "$error at $file line $line\n"; } diff --git a/lib/Cwd.pm b/lib/Cwd.pm index 83b472cf6a..d7a4875574 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -38,7 +38,7 @@ the trailing line terminator). It is recommended that cwd (or another 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 +L<perlsub/Overriding Builtin Functions>.) Note that it will only be kept up to date if all packages which use chdir import it from Cwd. =cut @@ -108,7 +108,7 @@ sub getcwd } unless (@tst = lstat("$dotdots/$dir")) { - warn "lstat($dotdots/$dir): $!"; + # warn "lstat($dotdots/$dir): $!"; # Just because you can't lstat this directory # doesn't mean you'll never find the right one. # closedir(PARENT); @@ -172,7 +172,7 @@ sub fastcwd { my $chdir_init = 0; sub chdir_init { - if ($ENV{'PWD'} and $^O ne 'os2') { + if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'msdos') { my($dd,$di) = stat('.'); my($pd,$pi) = stat($ENV{'PWD'}); if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { @@ -237,6 +237,13 @@ sub _os2_cwd { return $ENV{'PWD'}; } +sub _msdos_cwd { + $ENV{'PWD'} = `command /c cd`; + chop $ENV{'PWD'}; + $ENV{'PWD'} =~ s:\\:/:g ; + return $ENV{'PWD'}; +} + my($oldw) = $^W; $^W = 0; # assignments trigger 'subroutine redefined' warning if ($^O eq 'VMS') { @@ -259,7 +266,13 @@ elsif ($^O eq 'os2') { *getcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; *fastgetcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; *fastcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; - } +} +elsif ($^O eq 'msdos') { + *cwd = \&_msdos_cwd; + *getcwd = \&_msdos_cwd; + *fastgetcwd = \&_msdos_cwd; + *fastcwd = \&_msdos_cwd; +} $^W = $oldw; # package main; eval join('',<DATA>) || die $@; # quick test diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index dc8b94334e..eac7c13ad5 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/lib/ExtUtils/Liblist.pm @@ -8,9 +8,12 @@ use Config; use Cwd 'cwd'; use File::Basename; -my $Config_libext = $Config{lib_ext} || ".a"; - sub ext { + if ($^O eq 'VMS') { return &_vms_ext; } + else { return &_unix_os2_ext; } +} + +sub _unix_os2_ext { my($self,$potential_libs, $Verbose) = @_; if ($^O =~ 'os2' and $Config{libs}) { # Dynamic libraries are not transitive, so we may need including @@ -24,6 +27,8 @@ sub ext { my($so) = $Config{'so'}; my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + # compute $extralibs, $bsloadlibs and $ldloadlibs from # $potential_libs @@ -174,6 +179,136 @@ sub ext { ("@extralibs", "@bsloadlibs", "@ldloadlibs",join(":",@ld_run_path)); } + +sub _vms_ext { + my($self, $potential_libs,$verbose) = @_; + return ('', '', '', '') unless $potential_libs; + + my(@dirs,@libs,$dir,$lib,%sh,%olb,%obj); + my $cwd = cwd(); + my($so,$lib_ext,$obj_ext) = @Config{'so','lib_ext','obj_ext'}; + # List of common Unix library names and there VMS equivalents + # (VMS equivalent of '' indicates that the library is automatially + # searched by the linker, and should be skipped here.) + my %libmap = ( 'm' => '', 'f77' => '', 'F77' => '', 'V77' => '', 'c' => '', + 'malloc' => '', 'crypt' => '', 'resolv' => '', 'c_s' => '', + 'socket' => '', 'X11' => 'DECW$XLIBSHR', + 'Xt' => 'DECW$XTSHR', 'Xm' => 'DECW$XMLIBSHR', + 'Xmu' => 'DECW$XMULIBSHR'); + if ($Config{'vms_cc_type'} ne 'decc') { $libmap{'curses'} = 'VAXCCURSE'; } + + print STDOUT "Potential libraries are '$potential_libs'\n" if $verbose; + + # First, sort out directories and library names in the input + foreach $lib (split ' ',$potential_libs) { + push(@dirs,$1), next if $lib =~ /^-L(.*)/; + push(@dirs,$lib), next if $lib =~ /[:>\]]$/; + push(@dirs,$lib), next if -d $lib; + push(@libs,$1), next if $lib =~ /^-l(.*)/; + push(@libs,$lib); + } + push(@dirs,split(' ',$Config{'libpth'})); + + # Now make sure we've got VMS-syntax absolute directory specs + # (We don't, however, check whether someone's hidden a relative + # path in a logical name.) + foreach $dir (@dirs) { + unless (-d $dir) { + print STDOUT "Skipping nonexistent Directory $dir\n" if $verbose > 1; + $dir = ''; + next; + } + print STDOUT "Resolving directory $dir\n" if $verbose; + if ($self->file_name_is_absolute($dir)) { $dir = $self->fixpath($dir,1); } + else { $dir = $self->catdir($cwd,$dir); } + } + @dirs = grep { length($_) } @dirs; + unshift(@dirs,''); # Check each $lib without additions first + + LIB: foreach $lib (@libs) { + if (exists $libmap{$lib}) { + next unless length $libmap{$lib}; + $lib = $libmap{$lib}; + } + + my(@variants,$variant,$name,$test,$cand); + my($ctype) = ''; + + # If we don't have a file type, consider it a possibly abbreviated name and + # check for common variants. We try these first to grab libraries before + # a like-named executable image (e.g. -lperl resolves to perlshr.exe + # before perl.exe). + if ($lib !~ /\.[^:>\]]*$/) { + push(@variants,"${lib}shr","${lib}rtl","${lib}lib"); + push(@variants,"lib$lib") if $lib !~ /[:>\]]/; + } + push(@variants,$lib); + print STDOUT "Looking for $lib\n" if $verbose; + foreach $variant (@variants) { + foreach $dir (@dirs) { + my($type); + + $name = "$dir$variant"; + print "\tChecking $name\n" if $verbose > 2; + if (-f ($test = VMS::Filespec::rmsexpand($name))) { + # It's got its own suffix, so we'll have to figure out the type + if ($test =~ /(?:$so|exe)$/i) { $type = 'sh'; } + elsif ($test =~ /(?:$lib_ext|olb)$/i) { $type = 'olb'; } + elsif ($test =~ /(?:$obj_ext|obj)$/i) { + print STDOUT "Warning (will try anyway): Plain object file $test found in library list\n"; + $type = 'obj'; + } + else { + print STDOUT "Warning (will try anyway): Unknown library type for $test; assuming shared\n"; + $type = 'sh'; + } + } + elsif (-f ($test = VMS::Filespec::rmsexpand($name,$so)) or + -f ($test = VMS::Filespec::rmsexpand($name,'.exe'))) { + $type = 'sh'; + $name = $test unless $test =~ /exe;?\d*$/i; + } + elsif (not length($ctype) and # If we've got a lib already, don't bother + ( -f ($test = VMS::Filespec::rmsexpand($name,$lib_ext)) or + -f ($test = VMS::Filespec::rmsexpand($name,'.olb')))) { + $type = 'olb'; + $name = $test unless $test =~ /olb;?\d*$/i; + } + elsif (not length($ctype) and # If we've got a lib already, don't bother + ( -f ($test = VMS::Filespec::rmsexpand($name,$obj_ext)) or + -f ($test = VMS::Filespec::rmsexpand($name,'.obj')))) { + print STDOUT "Warning (will try anyway): Plain object file $test found in library list\n"; + $type = 'obj'; + $name = $test unless $test =~ /obj;?\d*$/i; + } + if (defined $type) { + $ctype = $type; $cand = $name; + last if $ctype eq 'sh'; + } + } + if ($ctype) { + eval '$' . $ctype . "{'$cand'}++"; + die "Error recording library: $@" if $@; + print STDOUT "\tFound as $name (really $test), type $type\n" if $verbose > 1; + next LIB; + } + } + print STDOUT "Warning (will try anyway): No library found for $lib\n"; + } + + @libs = sort keys %obj; + # This has to precede any other CRTLs, so just make it first + if ($olb{VAXCCURSE}) { + push(@libs,"$olb{VAXCCURSE}/Library"); + delete $olb{VAXCCURSE}; + } + push(@libs, map { "$_/Library" } sort keys %olb); + push(@libs, map { "$_/Share" } sort keys %sh); + $lib = join(' ',@libs); + print "Result: $lib\n" if $verbose; + wantarray ? ($lib, '', $lib, '') : $lib; +} + 1; __END__ @@ -247,11 +382,55 @@ object file. This list is used to create a .bs (bootstrap) file. This module deals with a lot of system dependencies and has quite a few architecture specific B<if>s in the code. +=head2 VMS implementation + +The version of ext() which is executed under VMS differs from the +Unix-OS/2 version in several respects: + +=over 2 + +=item * + +Input library and path specifications are accepted with or without the +C<-l> and C<-L> prefices used by Unix linkers. If neither prefix is +present, a token is considered a directory to search if it is in fact +a directory, and a library to search for otherwise. Authors who wish +their extensions to be portable to Unix or OS/2 should use the Unix +prefixes, since the Unix-OS/2 version of ext() requires them. + +=item * + +Wherever possible, shareable images are preferred to object libraries, +and object libraries to plain object files. In accordance with VMS +naming conventions, ext() looks for files named I<lib>shr and I<lib>rtl; +it also looks for I<lib>lib and libI<lib> to accomodate Unix conventions +used in some ported software. + +=item * + +For each library that is found, an appropriate directive for a linker options +file is generated. The return values are space-separated strings of +these directives, rather than elements used on the linker command line. + +=item * + +LDLOADLIBS and EXTRALIBS are always identical under VMS, and BSLOADLIBS +and LD_RIN_PATH are always empty. + +=back + +In addition, an attempt is made to recognize several common Unix library +names, and filter them out or convert them to their VMS equivalents, as +appropriate. + +In general, the VMS version of ext() should properly handle input from +extensions originally designed for a Unix or VMS environment. If you +encounter problems, or discover cases where the search could be improved, +please let us know. + =head1 SEE ALSO L<ExtUtils::MakeMaker> =cut - - diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index ca2bf652ee..5d97956405 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -1701,7 +1701,7 @@ sub init_others { # --- Initialize Other Attributes }; # These get overridden for VMS and maybe some other systems - $self->{NOOP} ||= "sh -c true"; + $self->{NOOP} ||= '$(SHELL) -c true'; $self->{FIRST_MAKEFILE} ||= "Makefile"; $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE}; $self->{MAKE_APERL_FILE} ||= "Makefile.aperl"; @@ -1923,6 +1923,10 @@ sub macro { Called by staticmake. Defines how to write the Makefile to produce a static new perl. +By default the Makefile produced includes all the static extensions in +the perl library. (Purified versions of library files, e.g., +DynaLoader_pure_p1_c0_032.a are automatically ignored to avoid link errors.) + =cut sub makeaperl { @@ -1987,6 +1991,8 @@ $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) File::Find::find(sub { return unless m/\Q$self->{LIB_EXT}\E$/; return if m/^libperl/; + # Skip purified versions of libraries (e.g., DynaLoader_pure_p1_c0_032.a) + return if m/_pure_\w+_\w+_\w+\.\w+$/ and -f "$File::Find::dir/.pure"; if( exists $self->{INCLUDE_EXT} ){ my $found = 0; @@ -2107,7 +2113,7 @@ $tmp/perlmain\$(OBJ_EXT): $tmp/perlmain.c $tmp/perlmain.c: $makefilename}, q{ }.$self->{NOECHO}.q{echo Writing $@ }.$self->{NOECHO}.q{$(PERL) $(MAP_PERLINC) -e 'use ExtUtils::Miniperl; \\ - writemain(grep s#.*/auto/##, qw|$(MAP_STATIC)|)' > $@.tmp && mv $@.tmp $@ + writemain(grep s#.*/auto/##, qw|$(MAP_STATIC)|)' > $@t && mv $@t $@ }; @@ -2451,7 +2457,7 @@ $(OBJECT) : $(PERL_HDRS) =item pm_to_blib Defines target that copies all files in the hash PM to their -destination and autosplits them. See L<ExtUtils::Install/pm_to_blib> +destination and autosplits them. See L<ExtUtils::Install/DESCRIPTION> =cut diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index d05ddac6b8..1a63f215da 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -6,7 +6,7 @@ # Author: Charles Bailey bailey@genetics.upenn.edu package ExtUtils::MM_VMS; -$ExtUtils::MM_VMS::Revision=$ExtUtils::MM_VMS::Revision = '5.38 (02-Oct-1996)'; +$ExtUtils::MM_VMS::Revision=$ExtUtils::MM_VMS::Revision = '5.38 (22-Oct-1996)'; unshift @MM::ISA, 'ExtUtils::MM_VMS'; use Config; @@ -194,6 +194,7 @@ sub updir { package ExtUtils::MM_VMS; +sub ExtUtils::MM_VMS::ext; sub ExtUtils::MM_VMS::guess_name; sub ExtUtils::MM_VMS::find_perl; sub ExtUtils::MM_VMS::path; @@ -204,7 +205,6 @@ sub ExtUtils::MM_VMS::file_name_is_absolute; sub ExtUtils::MM_VMS::replace_manpage_separator; sub ExtUtils::MM_VMS::init_others; sub ExtUtils::MM_VMS::constants; -sub ExtUtils::MM_VMS::const_loadlibs; sub ExtUtils::MM_VMS::cflags; sub ExtUtils::MM_VMS::const_cccmd; sub ExtUtils::MM_VMS::pm_to_blib; @@ -268,6 +268,16 @@ sub AUTOLOAD { #__DATA__ + +# This isn't really an override. It's just here because ExtUtils::MM_VMS +# appears in @MM::ISA before ExtUtils::Liblist, so if there isn't an ext() +# in MM_VMS, then AUTOLOAD is called, and bad things happen. So, we just +# mimic inheritance here and hand off to ExtUtils::Liblist. +sub ext { + ExtUtils::Liblist::ext(@_); +} + + =head2 SelfLoaded methods Those methods which override default MM_Unix methods are marked @@ -289,12 +299,24 @@ package name. sub guess_name { my($self) = @_; - my($defname,$defpm); + my($defname,$defpm,@pm,%xs,$pm); local *PM; $defname = basename(fileify($ENV{'DEFAULT'})); $defname =~ s![\d\-_]*\.dir.*$!!; # Clip off .dir;1 suffix, and package version $defpm = $defname; + # Fallback in case for some reason a user has copied the files for an + # extension into a working directory whose name doesn't reflect the + # extension's name. We'll use the name of a unique .pm file, or the + # first .pm file with a matching .xs file. + if (not -e "${defpm}.pm") { + @pm = map { s/.pm$//; $_ } glob('*.pm'); + if (@pm == 1) { ($defpm = $pm[0]) =~ s/.pm$//; } + elsif (@pm) { + %xs = map { s/.xs$//; ($_,1) } glob('*.xs'); + if (%xs) { foreach $pm (@pm) { $defpm = $pm, last if exists $xs{$pm}; } } + } + } if (open(PM,"${defpm}.pm")){ while (<PM>) { if (/^\s*package\s+([^;]+)/i) { @@ -700,57 +722,6 @@ PM_TO_BLIB = ',join(', ',@{$self->{PM_TO_BLIB}}),' join('',@m); } -=item const_loadlibs (override) - -Basically a stub which passes through library specfications provided -by the caller. Will be updated or removed when VMS support is added -to ExtUtils::Liblist. - -=cut - -sub const_loadlibs { - my($self) = @_; - my (@m); - push @m, " -# $self->{NAME} might depend on some other libraries. -# (These comments may need revising:) -# -# Dependent libraries can be linked in one of three ways: -# -# 1. (For static extensions) by the ld command when the perl binary -# is linked with the extension library. See EXTRALIBS below. -# -# 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. -# -# 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. -# -# 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($self->fixpath($_) . ' ',$self->{'EXTRALIBS'})," -BSLOADLIBS = ",map($self->fixpath($_) . ' ',$self->{'BSLOADLIBS'})," -LDLOADLIBS = ",map($self->fixpath($_) . ' ',$self->{'LDLOADLIBS'}),"\n"; - - join('',@m); -} - =item cflags (override) Bypass shell script and produce qualifiers for CC directly (but warn @@ -1271,7 +1242,21 @@ $(BASEEXT).opt : Makefile.PL $(PERL) -e "print ""$(INST_STATIC)/Include=$(BASEEXT)\n$(INST_STATIC)/Library\n"";" >>$(MMS$TARGET) '); + if (length $self->{LDLOADLIBS}) { + my($lib); my($line) = ''; + foreach $lib (split ' ', $self->{LDLOADLIBS}) { + $lib =~ s%\$%\\\$%g; # Escape '$' in VMS filespecs + if (length($line) + length($lib) > 160) { + push @m, "\t\$(PERL) -e \"print qq[$line]\" >>\$(MMS\$TARGET)\n"; + $line = $lib . '\n'; + } + else { $line .= $lib . '\n'; } + } + push @m, "\t\$(PERL) -e \"print qq[$line]\" >>\$(MMS\$TARGET)\n" if $line; + } + join('',@m); + } =item dynamic_lib (override) @@ -1414,8 +1399,7 @@ sub manifypods { } else { $pod2man_exe = $self->catfile($Config{scriptdirexp},'pod2man'); } - if ($pod2man_exe = $self->perl_script($pod2man_exe)) { $found_pod2man = 1; } - else { + if (not ($pod2man_exe = $self->perl_script($pod2man_exe))) { # No pod2man but some MAN3PODS to be installed print <<END; @@ -2255,18 +2239,6 @@ map_clean : join '', @m; } -=item ext (specific) - -Stub routine standing in for C<ExtUtils::LibList::ext> until VMS -support is added to that package. - -=cut - -sub ext { - my($self) = @_; - '','',''; -} - # --- Output postprocessing section --- =item nicetext (override) diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap index 14d1222e63..c65b1cf35d 100644 --- a/lib/ExtUtils/typemap +++ b/lib/ExtUtils/typemap @@ -127,7 +127,7 @@ T_REF_IV_PTR else croak(\"$var is not of type ${ntype}\") T_PTROBJ - if (sv_isa($arg, \"${ntype}\")) { + if (sv_derived_from($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = ($type) tmp; } diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index eaf5bd4342..6823955113 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -76,7 +76,7 @@ perl(1), perlxs(1), perlxstut(1), perlxs(1) =cut # Global Constants -$XSUBPP_version = "1.938"; +$XSUBPP_version = "1.939"; require 5.002; use vars '$cplusplus'; @@ -741,7 +741,9 @@ while (fetch_para()) { $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++; } - death ("Code is not inside a function") + death ("Code is not inside a function" + ." (maybe last function was ended by a blank line " + ." followed by a a statement on column one?)") if $line[0] =~ /^\s/; # initialize info arrays diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm index 2602f0d530..ad44c5df32 100644 --- a/lib/File/Basename.pm +++ b/lib/File/Basename.pm @@ -2,8 +2,6 @@ package File::Basename; =head1 NAME -Basename - parse file specifications - fileparse - split a pathname into pieces basename - extract just the filename from a path @@ -35,10 +33,10 @@ pieces using the syntax of different operating systems. You select the syntax via the routine fileparse_set_fstype(). If the argument passed to it contains one of the substrings -"VMS", "MSDOS", or "MacOS", the file specification syntax of that -operating system is used in future calls to fileparse(), -basename(), and dirname(). If it contains none of these -substrings, UNIX syntax is used. This pattern matching is +"VMS", "MSDOS", "MacOS" or "AmigaOS", the file specification +syntax of that operating system is used in future calls to +fileparse(), basename(), and dirname(). If it contains none of +these substrings, UNIX syntax is used. This pattern matching is case-insensitive. If you've selected VMS syntax, and the file specification you pass to one of these routines contains a "/", they assume you are using UNIX emulation and apply the UNIX syntax @@ -156,6 +154,9 @@ sub fileparse { elsif ($fstype =~ /^MacOS/i) { ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/); } + elsif ($fstype =~ /^AmigaOS/i) { + ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/); + } elsif ($fstype !~ /^VMS/i) { # default to Unix ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#); $dirpath = './' unless $dirpath; @@ -206,6 +207,11 @@ sub dirname { $dirname =~ s:[^\\]+$:: unless length($basename); $dirname = '.' unless length($dirname); } + elsif ($fstype =~ /AmigaOS/i) { + if ( $dirname =~ /:$/) { return $dirname } + chop $dirname; + $dirname =~ s#[^:/]+$## unless length($basename); + } else { if ( $dirname =~ m:^/+$:) { return '/'; } chop $dirname; diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm index 5cea310265..2e555590f7 100644 --- a/lib/File/Copy.pm +++ b/lib/File/Copy.pm @@ -7,6 +7,7 @@ package File::Copy; require Exporter; use Carp; +use UNIVERSAL qw(isa); @ISA=qw(Exporter); @EXPORT=qw(copy); @@ -24,10 +25,11 @@ sub copy { croak("Usage: copy( file1, file2 [, buffersize]) ") unless(@_ == 2 || @_ == 3); - if (($^O eq 'VMS' or $^O eq 'os2') && ref(\$_[1]) ne 'GLOB' && - !(defined ref $_[1] and (ref($_[1]) eq 'GLOB' || - ref($_[1]) eq 'FileHandle' || ref($_[1]) eq 'VMS::Stdio'))) - { return File::Copy::syscopy($_[0],$_[1]) } + if (defined &File::Copy::syscopy && + \&File::Copy::syscopy != \&File::Copy::copy && + ref(\$_[1]) ne 'GLOB' && + !(defined ref $_[1] and isa($_[1], 'GLOB'))) + { return File::Copy::syscopy($_[0],$_[1]) } my $from = shift; my $to = shift; @@ -158,10 +160,10 @@ C<copy> routine. For VMS systems, this calls the C<rmscopy> routine (see below). For OS/2 systems, this calls the C<syscopy> XSUB directly. -=head2 Special behavior under VMS +=head2 Special behavior if C<syscopy> is defined (VMS and OS/2) If the second argument to C<copy> is not a file handle for an -already opened file, then C<copy> will perform an RMS copy of +already opened file, then C<copy> will perform an "system copy" of the input file to a new output file, in order to preserve file attributes, indexed file structure, I<etc.> The buffer size parameter is ignored. If the second argument to C<copy> is a @@ -169,10 +171,12 @@ Perl handle to an opened file, then data is copied using Perl operators, and no effort is made to preserve file attributes or record structure. -The RMS copy routine may also be called directly under VMS -as C<File::Copy::rmscopy> (or C<File::Copy::syscopy>, which +The system copy routine may also be called directly under VMS and OS/2 +as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which is just an alias for this routine). +=over + =item rmscopy($from,$to[,$date_flag]) The first and second arguments may be strings, typeglobs, or @@ -207,6 +211,8 @@ it defaults to 0. Like C<copy>, C<rmscopy> returns 1 on success. If an error occurs, it sets C<$!>, deletes the output file, and returns 0. +=back + =head1 RETURN Returns 1 on success, 0 on failure. $! will be set if an error was diff --git a/lib/File/Find.pm b/lib/File/Find.pm index b0312be10e..c5ce68ca1a 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -259,7 +259,8 @@ if ($^O =~ m:^mswin32:i) { $dont_use_nlink = 1; } -$dont_use_nlink = 1 if $^O eq 'os2'; +$dont_use_nlink = 1 + if $^O eq 'os2' || $^O eq 'msdos' || $^O eq 'amigaos'; 1; diff --git a/lib/FindBin.pm b/lib/FindBin.pm index 45d9e33341..bbd72a2aa2 100644 --- a/lib/FindBin.pm +++ b/lib/FindBin.pm @@ -96,7 +96,7 @@ $VERSION = $VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/); # $realpath; #} -sub abs_path +sub my_abs_path { my $start = shift || '.'; my($dotdots, $cwd, @pst, @cst, $dir, @tst); @@ -154,6 +154,8 @@ BEGIN { *Dir = \$Bin; *RealDir = \$RealBin; + if (defined &Cwd::sys_abspath) { *abs_path = \&Cwd::sys_abspath} + else { *abs_path = \&my_abs_path} if($0 eq '-e' || $0 eq '-') { diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index 11d10f8d03..d684577f8d 100644 --- a/lib/Getopt/Long.pm +++ b/lib/Getopt/Long.pm @@ -80,7 +80,7 @@ linkage specified in the HASH. The command line options are taken from array @ARGV. Upon completion of GetOptions, @ARGV will contain the rest (i.e. the non-options) of the command line. - + Each option specifier designates the name of the option, optionally followed by an argument specifier. Values for argument specifiers are: diff --git a/lib/Math/BigInt.pm b/lib/Math/BigInt.pm index a4d8b6bd18..f76f2611f0 100644 --- a/lib/Math/BigInt.pm +++ b/lib/Math/BigInt.pm @@ -171,11 +171,11 @@ sub add { #(int_num_array, int_num_array) return int_num_array $car = 0; for $x (@x) { last unless @y || $car; - $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5); + $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5) ? 1 : 0; } for $y (@y) { last unless $car; - $y -= 1e5 if $car = (($y += $car) >= 1e5); + $y -= 1e5 if $car = (($y += $car) >= 1e5) ? 1 : 0; } (@x, @y, $car); } diff --git a/lib/Math/Complex.pm b/lib/Math/Complex.pm index 5ec4a5661e..aec0776c6c 100644 --- a/lib/Math/Complex.pm +++ b/lib/Math/Complex.pm @@ -699,6 +699,11 @@ sub stringify_cartesian { my ($x, $y) = @{$z->cartesian}; my ($re, $im); + $x = int($x + ($x < 0 ? -1 : 1) * 1e-14) + if int(abs($x)) != int(abs($x) + 1e-14); + $y = int($y + ($y < 0 ? -1 : 1) * 1e-14) + if int(abs($y)) != int(abs($y) + 1e-14); + $re = "$x" if abs($x) >= 1e-14; if ($y == 1) { $im = 'i' } elsif ($y == -1) { $im = '-i' } @@ -734,7 +739,13 @@ sub stringify_polar { if (abs($nt) <= 1e-14) { $theta = 0 } elsif (abs(pi-$nt) <= 1e-14) { $theta = 'pi' } - return "\[$r,$theta\]" if defined $theta; + if (defined $theta) { + $r = int($r + ($r < 0 ? -1 : 1) * 1e-14) + if int(abs($r)) != int(abs($r) + 1e-14); + $theta = int($theta + ($theta < 0 ? -1 : 1) * 1e-14) + if int(abs($theta)) != int(abs($theta) + 1e-14); + return "\[$r,$theta\]"; + } # # Okay, number is not a real. Try to identify pi/n and friends... @@ -753,6 +764,11 @@ sub stringify_polar { $theta = $nt unless defined $theta; + $r = int($r + ($r < 0 ? -1 : 1) * 1e-14) + if int(abs($r)) != int(abs($r) + 1e-14); + $theta = int($theta + ($theta < 0 ? -1 : 1) * 1e-14) + if int(abs($theta)) != int(abs($theta) + 1e-14); + return "\[$r,$theta\]"; } diff --git a/lib/Pod/Text.pm b/lib/Pod/Text.pm index 4faed4904e..9998c48e24 100644 --- a/lib/Pod/Text.pm +++ b/lib/Pod/Text.pm @@ -1,6 +1,6 @@ package Pod::Text; -# Version 1.01 +# Version 1.02 =head1 NAME @@ -116,14 +116,14 @@ sub prepare_for_output { $maxnest = 10; while ($maxnest-- && /[A-Z]</) { unless ($FANCY) { - s/C<(.*?)>/`$1'/g; + s/C<(.*?)>/`$1'/sg; } else { - s/C<(.*?)>/noremap("E<lchevron>${1}E<rchevron>")/ge; + s/C<(.*?)>/noremap("E<lchevron>${1}E<rchevron>")/sge; } # s/[IF]<(.*?)>/italic($1)/ge; - s/I<(.*?)>/*$1*/g; + s/I<(.*?)>/*$1*/sg; # s/[CB]<(.*?)>/bold($1)/ge; - s/X<.*?>//g; + s/X<.*?>//sg; # LREF: a manpage(3f) s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))?>:the $1$2 manpage:g; # LREF: an =item on another manpage @@ -167,9 +167,9 @@ sub prepare_for_output { ? "the section on \"$2\" in the $1 manpage" : "the section on \"$2\"" } - }gex; + }sgex; - s/[A-Z]<(.*?)>/$1/g; + s/[A-Z]<(.*?)>/$1/sg; } clear_noremap(1); } diff --git a/lib/Sys/Syslog.pm b/lib/Sys/Syslog.pm index 9df3161a63..c5241703da 100644 --- a/lib/Sys/Syslog.pm +++ b/lib/Sys/Syslog.pm @@ -7,6 +7,7 @@ use Carp; @EXPORT = qw(openlog closelog setlogmask syslog); use Socket; +use Sys::Hostname; # adapted from syslog.pl # @@ -85,7 +86,7 @@ L<syslog(3)> =head1 AUTHOR -Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<lwall@sems.com>E<gt> +Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<larry@wall.org>E<gt> =cut @@ -190,7 +191,7 @@ sub syslog { sub xlate { local($name) = @_; - $name =~ y/a-z/A-Z/; + $name = uc $name; $name = "LOG_$name" unless $name =~ /^LOG_/; $name = "Sys::Syslog::$name"; eval(&$name) || -1; diff --git a/lib/Term/Cap.pm b/lib/Term/Cap.pm index d4d91c6827..5a73ecfc52 100644 --- a/lib/Term/Cap.pm +++ b/lib/Term/Cap.pm @@ -195,11 +195,8 @@ sub Tgetent { ## public -- static method last; } } - if (defined $entry) { - $entry .= $_; - } else { - $entry = $_; - } + defined $entry or $entry = ''; + $entry .= $_; }; while ($state != 0) { diff --git a/lib/Term/Complete.pm b/lib/Term/Complete.pm index 884f83fa90..bdab2ad81d 100644 --- a/lib/Term/Complete.pm +++ b/lib/Term/Complete.pm @@ -71,6 +71,8 @@ CONFIG: { } sub Complete { + my($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r); + $prompt = shift; if (ref $_[0] || $_[0] =~ /^\*/) { @cmp_lst = sort @{$_[0]}; diff --git a/lib/Text/ParseWords.pm b/lib/Text/ParseWords.pm index 33b683525d..f86c8c2991 100644 --- a/lib/Text/ParseWords.pm +++ b/lib/Text/ParseWords.pm @@ -115,7 +115,7 @@ sub quotewords { last; } else { - while ($_ && !(/^$delim/ || /^['"\\]/)) { + while ($_ ne '' && !(/^$delim/ || /^['"\\]/)) { $snippet .= substr($_, 0, 1); substr($_, 0, 1) = ''; } diff --git a/lib/Text/Soundex.pm b/lib/Text/Soundex.pm index a334404667..ddc758c94e 100644 --- a/lib/Text/Soundex.pm +++ b/lib/Text/Soundex.pm @@ -48,7 +48,7 @@ sub soundex foreach (@s) { - tr/a-z/A-Z/; + $_ = uc $_; tr/A-Z//cd; if ($_ eq '') diff --git a/lib/Time/Local.pm b/lib/Time/Local.pm index 1fab298e0a..2bdf23cb1b 100644 --- a/lib/Time/Local.pm +++ b/lib/Time/Local.pm @@ -40,12 +40,12 @@ after the 1st of January, 2038 on most machines. =cut BEGIN { - @epoch = localtime(0); - $SEC = 1; $MIN = 60 * $SEC; $HR = 60 * $MIN; $DAY = 24 * $HR; + $epoch = (localtime(2*$DAY))[5]; # Allow for bugs near localtime == 0. + $YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0; my $t = time; @@ -71,13 +71,13 @@ BEGIN { sub timegm { $ym = pack(C2, @_[5,4]); $cheat = $cheat{$ym} || &cheat; - return -1 if $cheat<0; + return -1 if $cheat<0 and $^O ne 'VMS'; $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAY; } sub timelocal { $time = &timegm + $tzsec; - return -1 if $cheat<0; + return -1 if $cheat<0 and $^O ne 'VMS'; @test = localtime($time); $time -= $HR if $test[2] != $_[2]; $time; @@ -100,7 +100,7 @@ sub cheat { if $_[0] > 59 || $_[0] < 0; $guess = $^T; @g = gmtime($guess); - $year += $YearFix if $year < $epoch[5]; + $year += $YearFix if $year < $epoch; $lastguess = ""; while ($diff = $year - $g[5]) { $guess += $diff * (363 * $DAY); diff --git a/lib/abbrev.pl b/lib/abbrev.pl index c233d4af7e..62975e66f3 100644 --- a/lib/abbrev.pl +++ b/lib/abbrev.pl @@ -17,7 +17,7 @@ sub main'abbrev { $len = 1; foreach $cmp (@cmp) { next if $cmp eq $name; - while (substr($cmp,0,$len) eq $abbrev) { + while (@extra && substr($cmp,0,$len) eq $abbrev) { $abbrev .= shift(@extra); ++$len; } diff --git a/lib/bigint.pl b/lib/bigint.pl index a274736e44..bfd2efa88c 100644 --- a/lib/bigint.pl +++ b/lib/bigint.pl @@ -168,11 +168,11 @@ sub add { #(int_num_array, int_num_array) return int_num_array $car = 0; for $x (@x) { last unless @y || $car; - $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5); + $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5) ? 1 : 0; } for $y (@y) { last unless $car; - $y -= 1e5 if $car = (($y += $car) >= 1e5); + $y -= 1e5 if $car = (($y += $car) >= 1e5) ? 1 : 0; } (@x, @y, $car); } diff --git a/lib/complete.pl b/lib/complete.pl index 1e08f9145a..335245269c 100644 --- a/lib/complete.pl +++ b/lib/complete.pl @@ -35,7 +35,7 @@ CONFIG: { sub Complete { package Complete; - local($[,$return) = 0; + local($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r); if ($_[1] =~ /^StB\0/) { ($prompt, *_) = @_; } diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm index a8af08f8c2..02fae7aa9f 100755 --- a/lib/diagnostics.pm +++ b/lib/diagnostics.pm @@ -415,10 +415,27 @@ sub warn_trap { sub death_trap { my $exception = $_[0]; - splainthis($exception); + + # See if we are coming from anywhere within an eval. If so we don't + # want to explain the exception because it's going to get caught. + my $in_eval = 0; + my $i = 0; + while (1) { + my $caller = (caller($i++))[3] or last; + if ($caller eq '(eval)') { + $in_eval = 1; + last; + } + } + + splainthis($exception) unless $in_eval; if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; } &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap; - $SIG{__DIE__} = $SIG{__WARN__} = ''; + + # We don't want to unset these if we're coming from an eval because + # then we've turned off diagnostics. (Actually what does this next + # line do? -PSeibel) + $SIG{__DIE__} = $SIG{__WARN__} = '' unless $in_eval; local($Carp::CarpLevel) = 1; confess "Uncaught exception from user code:\n\t$exception"; # up we go; where we stop, nobody knows, but i think we die now diff --git a/lib/getcwd.pl b/lib/getcwd.pl index d8860181c1..9dd694500c 100644 --- a/lib/getcwd.pl +++ b/lib/getcwd.pl @@ -44,9 +44,9 @@ sub getcwd } unless (@tst = lstat("$dotdots/$dir")) { - warn "lstat($dotdots/$dir): $!"; - closedir(getcwd'PARENT); #'); - return ''; + # warn "lstat($dotdots/$dir): $!"; + # closedir(getcwd'PARENT); #'); + # return ''; } } while ($dir eq '.' || $dir eq '..' || $tst[$[] != $pst[$[] || diff --git a/lib/getopts.pl b/lib/getopts.pl index a0818d1e3a..852aae89b1 100644 --- a/lib/getopts.pl +++ b/lib/getopts.pl @@ -8,23 +8,22 @@ sub Getopts { local($argumentative) = @_; local(@args,$_,$first,$rest); local($errs) = 0; - local($[) = 0; @args = split( / */, $argumentative ); while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { ($first,$rest) = ($1,$2); $pos = index($argumentative,$first); - if($pos >= $[) { - if($args[$pos+1] eq ':') { + if($pos >= 0) { + if($pos < $#args && $args[$pos+1] eq ':') { shift(@ARGV); if($rest eq '') { ++$errs unless @ARGV; $rest = shift(@ARGV); } - eval "\$opt_$first = \$rest;"; + ${"opt_$first"} = $rest; } else { - eval "\$opt_$first = 1"; + ${"opt_$first"} = 1; if($rest eq '') { shift(@ARGV); } diff --git a/lib/look.pl b/lib/look.pl index 4c14e64727..e8dc8aacb6 100644 --- a/lib/look.pl +++ b/lib/look.pl @@ -10,7 +10,7 @@ sub look { $blksize,$blocks) = stat(FH); $blksize = 8192 unless $blksize; $key =~ s/[^\w\s]//g if $dict; - $key =~ y/A-Z/a-z/ if $fold; + $key = lc $key if $fold; $max = int($size / $blksize); while ($max - $min > 1) { $mid = int(($max + $min) / 2); @@ -19,7 +19,7 @@ sub look { $_ = <FH>; chop; s/[^\w\s]//g if $dict; - y/A-Z/a-z/ if $fold; + $_ = lc $_ if $fold; if ($_ lt $key) { $min = $mid; } @@ -33,7 +33,7 @@ sub look { while (<FH>) { chop; s/[^\w\s]//g if $dict; - y/A-Z/a-z/ if $fold; + $_ = lc $_ if $fold; last if $_ ge $key; $min = tell(FH); } diff --git a/lib/perl5db.pl b/lib/perl5db.pl index a57475ce06..3f3a4c2762 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -2,7 +2,7 @@ package DB; # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 0.95; +$VERSION = 0.96; $header = "perl5db.pl patch level $VERSION"; # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) @@ -23,6 +23,27 @@ $header = "perl5db.pl patch level $VERSION"; # $DB::sub being the called subroutine. It also inserts a BEGIN # {require 'perl5db.pl'} before the first line. # +# After each `require'd file is compiled, but before it is executed, a +# call to DB::postponed(*{"_<$filename"}) is emulated. Here the +# $filename is the expanded name of the `require'd file (as found as +# value of %INC). +# +# Additional services from Perl interpreter: +# +# if caller() is called from the package DB, it provides some +# additional data. +# +# The array @{"_<$filename"} is the line-by-line contents of +# $filename. +# +# The hash %{"_<$filename"} contains breakpoints and action (it is +# keyed by line number), and individual entries are settable (as +# opposed to the whole hash). Only true/false is important to the +# interpreter, though the values used by perl5db.pl have the form +# "$break_condition\0$action". Values are magical in numeric context. +# +# The scalar ${"_<$filename"} contains "_<$filename". +# # Note that no subroutine call is possible until &DB::sub is defined # (for subroutines defined outside this file). In fact the same is # true if $deep is not defined. @@ -64,8 +85,6 @@ $header = "perl5db.pl patch level $VERSION"; # information into db.out. (If you interrupt it, you would better # reset LineInfo to something "interactive"!) # -# Changes: 0.95: v command shows versions. - ################################################################## # Changelog: @@ -82,6 +101,26 @@ $header = "perl5db.pl patch level $VERSION"; # the deletion of data may be postponed until the next function call, # due to the need to examine the return value. +# Changes: 0.95: `v' command shows versions. +# Changes: 0.96: `v' command shows version of readline. +# primitive completion works (dynamic variables, subs for `b' and `l', +# options). Can `p %var' +# Better help (`h <' now works). New commands <<, >>, {, {{. +# {dump|print}_trace() coded (to be able to do it from <<cmd). +# `c sub' documented. +# At last enough magic combined to stop after the end of debuggee. +# !! should work now (thanks to Emacs bracket matching an extra +# `]' in a regexp is caught). +# `L', `D' and `A' span files now (as documented). +# Breakpoints in `require'd code are possible (used in `R'). +# Some additional words on internal work of debugger. +# `b load filename' implemented. +# `b postpone subr' implemented. +# now only `q' exits debugger (overwriteable on $inhibit_exit). +# When restarting debugger breakpoints/actions persist. +# Buglet: When restarting debugger only one breakpoint/action per +# autoloaded function persists. + #################################################################### # Needed for the statement after exec(): @@ -111,11 +150,7 @@ warn ( # Do not ;-) $trace = $signal = $single = 0; # Uninitialized warning suppression # (local $^W cannot help - other packages!). -$doret = -2; -$frame = 0; -@stack = (0); - -$option{PrintRet} = 1; +$inhibit_exit = $option{PrintRet} = 1; @options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages compactDump veryCompact quote HighBit undefPrint @@ -165,6 +200,9 @@ $rl = 1 unless defined $rl; $warnLevel = 1 unless defined $warnLevel; $dieLevel = 1 unless defined $dieLevel; $signalLevel = 1 unless defined $signalLevel; +$pre = [] unless defined $pre; +$post = [] unless defined $post; +$pretype = [] unless defined $pretype; warnLevel($warnLevel); dieLevel($dieLevel); signalLevel($signalLevel); @@ -194,9 +232,11 @@ if (exists $ENV{PERLDB_RESTART}) { delete $ENV{PERLDB_RESTART}; # $restart = 1; @hist = get_list('PERLDB_HIST'); - my @visited = get_list("PERLDB_VISITED"); - for (0 .. $#visited) { - %{$postponed{$visited[$_]}} = get_list("PERLDB_FILE_$_"); + %break_on_load = get_list("PERLDB_ON_LOAD"); + %postponed = get_list("PERLDB_POSTPONE"); + my @had_breakpoints= get_list("PERLDB_VISITED"); + for (0 .. $#had_breakpoints) { + %{$postponed_file{$had_breakpoints[$_]}} = get_list("PERLDB_FILE_$_"); } my %opt = get_list("PERLDB_OPT"); my ($opt,$val); @@ -285,14 +325,6 @@ sub DB { $single = 0; return; } - # Define a subroutine in which we will stop -# eval <<'EOE'; -# sub at_end::db {"Debuggee terminating";} -# END { -# $DB::step = 1; -# print $OUT "Debuggee terminating.\n"; -# &at_end::db;} -# EOE } &save; ($package, $filename, $line) = caller; @@ -300,7 +332,6 @@ sub DB { $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' . "package $package;"; # this won't let them modify, alas local(*dbline) = "::_<$filename"; - install_breakpoints($filename) unless $visited{$filename}++; $max = $#dbline; if (($stop,$action) = split(/\0/,$dbline{$line})) { if ($stop eq '1') { @@ -342,23 +373,23 @@ sub DB { $evalarg = $action, &eval if $action; if ($single || $signal) { local $level = $level + 1; - $evalarg = $pre, &eval if $pre; + map {$evalarg = $_, &eval} @$pre; print $OUT $#stack . " levels deep in subroutine calls!\n" if $single & 4; $start = $line; + @typeahead = @$pretype, @typeahead; CMD: while (($term || &setterm), defined ($cmd=&readline(" DB" . ('<' x $level) . ($#hist+1) . ('>' x $level) . " "))) { - #{ # <-- Do we know what this brace is for? $single = 0; $signal = 0; $cmd =~ s/\\$/\n/ && do { $cmd .= &readline(" cont: "); redo CMD; }; - $cmd =~ /^q$/ && exit 0; + $cmd =~ /^q$/ && ($exiting = 1) && exit 0; $cmd =~ /^$/ && ($cmd = $laststep); push(@hist,$cmd) if length($cmd) > 1; PIPE: { @@ -372,8 +403,10 @@ sub DB { next CMD; }; $cmd =~ /^h\s+(\S)$/ && do { my $asked = "\Q$1"; - if ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/m) { + if ($help =~ /^$asked/m) { + while ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/mg) { print $OUT $1; + } } else { print $OUT "`$asked' is not a debugger command.\n"; } @@ -429,7 +462,6 @@ sub DB { next CMD; } elsif ($file ne $filename) { *dbline = "::_<$file"; - $visited{$file}++; $max = $#dbline; $filename = $file; $start = 1; @@ -445,7 +477,6 @@ sub DB { $file = join(':', @pieces); if ($file ne $filename) { *dbline = "::_<$file"; - $visited{$file}++; $max = $#dbline; $filename = $file; } @@ -508,7 +539,13 @@ sub DB { $start = $max if $start > $max; next CMD; }; $cmd =~ /^D$/ && do { - print $OUT "Deleting all breakpoints...\n"; + print $OUT "Deleting all breakpoints...\n"; + my $file; + for $file (keys %had_breakpoints) { + local *dbline = "::_<$file"; + my $max = $#dbline; + my $was; + for ($i = 1; $i <= $max ; $i++) { if (defined $dbline{$i}) { $dbline{$i} =~ s/^[^\0]+//; @@ -517,19 +554,89 @@ sub DB { } } } - next CMD; }; + } + undef %postponed; + undef %postponed_file; + undef %break_on_load; + undef %had_breakpoints; + next CMD; }; $cmd =~ /^L$/ && do { + my $file; + for $file (keys %had_breakpoints) { + local *dbline = "::_<$file"; + my $max = $#dbline; + my $was; + for ($i = 1; $i <= $max; $i++) { if (defined $dbline{$i}) { - print $OUT "$i:\t", $dbline[$i]; + print "$file:\n" unless $was++; + print $OUT " $i:\t", $dbline[$i]; ($stop,$action) = split(/\0/, $dbline{$i}); - print $OUT " break if (", $stop, ")\n" + print $OUT " break if (", $stop, ")\n" if $stop; - print $OUT " action: ", $action, "\n" + print $OUT " action: ", $action, "\n" if $action; last if $signal; } } + } + if (%postponed) { + print $OUT "Postponed breakpoints in subroutines:\n"; + my $subname; + for $subname (keys %postponed) { + print $OUT " $subname\t$postponed{$subname}\n"; + last if $signal; + } + } + my @have = map { # Combined keys + keys %{$postponed_file{$_}} + } keys %postponed_file; + if (@have) { + print $OUT "Postponed breakpoints in files:\n"; + my ($file, $line); + for $file (keys %postponed_file) { + my %db = %{$postponed_file{$file}}; + next unless keys %db; + print $OUT " $file:\n"; + for $line (sort {$a <=> $b} keys %db) { + print $OUT " $i:\n"; + my ($stop,$action) = split(/\0/, $db{$line}); + print $OUT " break if (", $stop, ")\n" + if $stop; + print $OUT " action: ", $action, "\n" + if $action; + last if $signal; + } + last if $signal; + } + } + if (%break_on_load) { + print $OUT "Breakpoints on load:\n"; + my $file; + for $file (keys %break_on_load) { + print $OUT " $file\n"; + last if $signal; + } + } + next CMD; }; + $cmd =~ /^b\b\s*load\b\s*(.*)/ && do { + my $file = $1; + { + $break_on_load{$file} = 1; + $break_on_load{$::INC{$file}} = 1 if $::INC{$file}; + $file .= '.pm', redo unless $file =~ /\./; + } + $had_breakpoints{$file} = 1; + print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n"; + next CMD; }; + $cmd =~ /^b\b\s*postpone\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do { + my $cond = $2 || '1'; + my $subname = $1; + $subname =~ s/\'/::/; + $subname = "${'package'}::" . $subname + unless $subname =~ /::/; + $subname = "main".$subname if substr($subname,0,2) eq "::"; + $postponed{$subname} = "break +0 if $cond"; next CMD; }; $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do { $subname = $1; @@ -544,7 +651,7 @@ sub DB { if ($i) { $filename = $file; *dbline = "::_<$filename"; - $visited{$filename}++; + $had_breakpoints{$filename} = 1; $max = $#dbline; ++$i while $dbline[$i] == 0 && $i < $max; $dbline{$i} =~ s/^[^\0]*/$cond/; @@ -558,6 +665,7 @@ sub DB { if ($dbline[$i] == 0) { print $OUT "Line $i not breakable.\n"; } else { + $had_breakpoints{$filename} = 1; $dbline{$i} =~ s/^[^\0]*/$cond/; } next CMD; }; @@ -567,13 +675,20 @@ sub DB { delete $dbline{$i} if $dbline{$i} eq ''; next CMD; }; $cmd =~ /^A$/ && do { + my $file; + for $file (keys %had_breakpoints) { + local *dbline = "::_<$file"; + my $max = $#dbline; + my $was; + for ($i = 1; $i <= $max ; $i++) { if (defined $dbline{$i}) { $dbline{$i} =~ s/\0[^\0]*//; delete $dbline{$i} if $dbline{$i} eq ''; } } - next CMD; }; + } + next CMD; }; $cmd =~ /^O\s*$/ && do { for (@options) { &dump_option($_); @@ -582,11 +697,26 @@ sub DB { $cmd =~ /^O\s*(\S.*)/ && do { parse_options($1); next CMD; }; + $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE + push @$pre, action($1); + next CMD; }; + $cmd =~ /^>>\s*(.*)/ && do { + push @$post, action($1); + next CMD; }; $cmd =~ /^<\s*(.*)/ && do { - $pre = action($1); + $pre = [], next CMD unless $1; + $pre = [action($1)]; next CMD; }; $cmd =~ /^>\s*(.*)/ && do { - $post = action($1); + $post = [], next CMD unless $1; + $post = [action($1)]; + next CMD; }; + $cmd =~ /^\{\{\s*(.*)/ && do { + push @$pretype, $1; + next CMD; }; + $cmd =~ /^\{\s*(.*)/ && do { + $pretype = [], next CMD unless $1; + $pretype = [$1]; next CMD; }; $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do { $i = $1; $j = $3; @@ -598,14 +728,17 @@ sub DB { } next CMD; }; $cmd =~ /^n$/ && do { + next CMD if $finished and $level <= 1; $single = 2; $laststep = $cmd; last CMD; }; $cmd =~ /^s$/ && do { + next CMD if $finished and $level <= 1; $single = 1; $laststep = $cmd; last CMD; }; $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do { + next CMD if $finished and $level <= 1; $i = $1; if ($i =~ /\D/) { # subroutine name ($file,$i) = ($sub{$i} =~ /^(.*):(.*)$/); @@ -613,7 +746,7 @@ sub DB { if ($i) { $filename = $file; *dbline = "::_<$filename"; - $visited{$filename}++; + $had_breakpoints{$filename}++; $max = $#dbline; ++$i while $dbline[$i] == 0 && $i < $max; } else { @@ -633,11 +766,12 @@ sub DB { } last CMD; }; $cmd =~ /^r$/ && do { + next CMD if $finished and $level <= 1; $stack[$#stack] |= 1; $doret = $option{PrintRet} ? $#stack - 1 : -2; last CMD; }; $cmd =~ /^R$/ && do { - print $OUT "Warning: a lot of settings and command-line options may be lost!\n"; + print $OUT "Warning: some settings and command-line options may be lost!\n"; my (@script, @flags, $cl); push @flags, '-w' if $ini_warn; # Put all the old includes at the start to get @@ -658,52 +792,63 @@ sub DB { set_list("PERLDB_HIST", $term->Features->{getHistory} ? $term->GetHistory : @hist); - my @visited = keys %visited; - set_list("PERLDB_VISITED", @visited); + my @had_breakpoints = keys %had_breakpoints; + set_list("PERLDB_VISITED", @had_breakpoints); set_list("PERLDB_OPT", %option); - for (0 .. $#visited) { - *dbline = "::_<$visited[$_]"; - set_list("PERLDB_FILE_$_", %dbline); + set_list("PERLDB_ON_LOAD", %break_on_load); + my @hard; + for (0 .. $#had_breakpoints) { + my $file = $had_breakpoints[$_]; + *dbline = "::_<$file"; + next unless %dbline or %{$postponed_file{$file}}; + (push @hard, $file), next + if $file =~ /^\(eval \d+\)$/; + my @add; + @add = %{$postponed_file{$file}} + if %{$postponed_file{$file}}; + set_list("PERLDB_FILE_$_", %dbline, @add); + } + for (@hard) { # Yes, really-really... + # Find the subroutines in this eval + *dbline = "::_<$_"; + my ($quoted, $sub, %subs, $line) = quotemeta $_; + for $sub (keys %sub) { + next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/; + $subs{$sub} = [$1, $2]; + } + unless (%subs) { + print $OUT + "No subroutines in $_, ignoring breakpoints.\n"; + next; + } + LINES: for $line (keys %dbline) { + # One breakpoint per sub only: + my ($offset, $sub, $found); + SUBS: for $sub (keys %subs) { + if ($subs{$sub}->[1] >= $line # Not after the subroutine + and (not defined $offset # Not caught + or $offset < 0 )) { # or badly caught + $found = $sub; + $offset = $line - $subs{$sub}->[0]; + $offset = "+$offset", last SUBS if $offset >= 0; + } + } + if (defined $offset) { + $postponed{$found} = + "break $offset if $dbline{$line}"; + } else { + print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n"; + } + } } + set_list("PERLDB_POSTPONE", %postponed); $ENV{PERLDB_RESTART} = 1; #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS"; exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS; print $OUT "exec failed: $!\n"; last CMD; }; $cmd =~ /^T$/ && do { - local($p,$f,$l,$s,$h,$a,$e,$r,@a,@sub); - for ($i = 1; - ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); - $i++) { - @a = (); - for $arg (@args) { - $_ = "$arg"; - s/([\'\\])/\\$1/g; - s/([^\0]*)/'$1'/ - unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; - s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; - s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; - push(@a, $_); - } - $w = $w ? '@ = ' : '$ = '; - $a = $h ? '(' . join(', ', @a) . ')' : ''; - $e =~ s/\n\s*\;\s*\Z// if $e; - $e =~ s/[\\\']/\\$1/g if $e; - if ($r) { - $s = "require '$e'"; - } elsif (defined $r) { - $s = "eval '$e'"; - } elsif ($s eq '(eval)') { - $s = "eval {...}"; - } - $f = "file `$f'" unless $f eq '-e'; - push(@sub, "$w$s$a called from $f line $l\n"); - last if $signal; - } - for ($i=0; $i <= $#sub; $i++) { - last if $signal; - print $OUT $sub[$i]; - } + print_trace($OUT, 3); # skip DB print_trace dump_trace next CMD; }; $cmd =~ /^\/(.*)$/ && do { $inpat = $1; @@ -767,7 +912,7 @@ sub DB { $cmd = $hist[$i] . "\n"; print $OUT $cmd; redo CMD; }; - $cmd =~ /^$sh$sh\s*([\x00-\xff]]*)/ && do { + $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do { &system($1); next CMD; }; $cmd =~ /^$rc([^$rc].*)$/ && do { @@ -844,7 +989,6 @@ sub DB { $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'}; $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'}; } # PIPE: - #} # <-- Do we know what this brace is for? $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval; if ($onetimeDump) { $onetimeDump = undef; @@ -872,9 +1016,7 @@ sub DB { $piped= ""; } } # CMD: - if ($post) { - $evalarg = $post; &eval; - } + map {$evalarg = $_; &eval} @$post; } # if ($single || $signal) ($@, $!, $,, $/, $\, $^W) = @saved; (); @@ -937,16 +1079,44 @@ sub eval { } } -sub install_breakpoints { - my $filename = shift; - return unless exists $postponed{$filename}; - my %break = %{$postponed{$filename}}; - for (keys %break) { - my $i = $_; - #if (/\D/) { # Subroutine name - #} - $dbline{$i} = $break{$_}; # Cannot be done before the file is around +sub postponed_sub { + my $subname = shift; + if ($postponed{$subname} =~ s/break\s([+-]?\d+)\s+if\s//) { + my $offset = $1 || 0; + # Filename below can contain ':' + my ($file,$i) = ($sub{$subname} =~ /^(.*):(\d+)-.*$/); + $i += $offset; + if ($i) { + local *dbline = "::_<$file"; + local $^W = 0; # != 0 is magical below + $had_breakpoints{$file}++; + my $max = $#dbline; + ++$i until $dbline[$i] != 0 or $i >= $max; + $dbline{$i} = delete $postponed{$subname}; + } else { + print $OUT "Subroutine $subname not found.\n"; + } + return; + } + print $OUT "In postponed_sub for `$subname'.\n"; +} + +sub postponed { + return &postponed_sub + unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled. + # Cannot be done before the file is compiled + local *dbline = shift; + my $filename = $dbline; + $filename =~ s/^_<//; + $signal = 1, print $OUT "'$filename' loaded...\n" if $break_on_load{$filename}; + return unless %{$postponed_file{$filename}}; + $had_breakpoints{$filename}++; + #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic + my $key; + for $key (keys %{$postponed_file{$filename}}) { + $dbline{$key} = $ {$postponed_file{$filename}}{$key}; } + undef %{$postponed_file{$filename}}; } sub dumpit { @@ -969,6 +1139,57 @@ sub dumpit { select ($savout); } +sub print_trace { + my $fh = shift; + my @sub = dump_trace(@_); + for ($i=0; $i <= $#sub; $i++) { + last if $signal; + local $" = ', '; + my $args = defined $sub[$i]{args} + ? "(@{ $sub[$i]{args} })" + : '' ; + $file = $sub[$i]{file} eq '-e' ? $sub[$i]{file} : + "file `$sub[$i]{file}'"; + print $fh "$sub[$i]{context}$sub[$i]{sub}$args" . + " called from $file" . + " line $sub[$i]{line}\n"; + } +} + +sub dump_trace { + my $skip = shift; + my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context); + for ($i = $skip; + ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i); + $i++) { + @a = (); + for $arg (@args) { + $_ = "$arg"; + s/([\'\\])/\\$1/g; + s/([^\0]*)/'$1'/ + unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; + s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; + push(@a, $_); + } + $context = $context ? '@ = ' : '$ = '; + $args = $h ? [@a] : undef; + $e =~ s/\n\s*\;\s*\Z// if $e; + $e =~ s/[\\\']/\\$1/g if $e; + if ($r) { + $sub = "require '$e'"; + } elsif (defined $r) { + $sub = "eval '$e'"; + } elsif ($sub eq '(eval)') { + $sub = "eval {...}"; + } + push(@sub, {context => $context, sub => $sub, args => $args, + file => $file, line => $line}); + last if $signal; + } + @sub; +} + sub action { my $action = shift; while ($action =~ s/\\$//) { @@ -1032,6 +1253,12 @@ sub setterm { $readline::rl_basic_word_break_characters .= "[:" if defined $readline::rl_basic_word_break_characters and index($readline::rl_basic_word_break_characters, ":") == -1; + $readline::rl_special_prefixes = + $readline::rl_special_prefixes = '$@&%'; + $readline::rl_completer_word_break_characters = + $readline::rl_completer_word_break_characters . '$@&%'; + $readline::rl_completion_function = + $readline::rl_completion_function = \&db_complete; } $LINEINFO = $OUT unless defined $LINEINFO; $lineinfo = $console unless defined $lineinfo; @@ -1057,6 +1284,14 @@ sub readline { sub dump_option { my ($opt, $val)= @_; + $val = option_val($opt,'N/A'); + $val =~ s/([\\\'])/\\$1/g; + printf $OUT "%20s = '%s'\n", $opt, $val; +} + +sub option_val { + my ($opt, $default)= @_; + my $val; if (defined $optionVars{$opt} and defined $ {$optionVars{$opt}}) { $val = $ {$optionVars{$opt}}; @@ -1067,12 +1302,11 @@ sub dump_option { and not defined $option{$opt} or defined $optionVars{$opt} and not defined $ {$optionVars{$opt}}) { - $val = 'N/A'; + $val = $default; } else { $val = $option{$opt}; } - $val =~ s/([\\\'])/\\$1/g; - printf $OUT "%20s = '%s'\n", $opt, $val; + $val } sub parse_options { @@ -1244,6 +1478,7 @@ sub list_versions { s,\.p[lm]$,,i ; s,/,::,g ; s/^perl5db$/DB/; + s/^Term::ReadLine::readline$/readline/; if (defined $ { $_ . '::VERSION' }) { $version{$file} = "$ { $_ . '::VERSION' } from "; } @@ -1265,8 +1500,8 @@ s [expr] Single step [in expr]. n [expr] Next, steps over subroutine calls [in expr]. <CR> Repeat last n or s command. r Return from current subroutine. -c [line] Continue; optionally inserts a one-time-only breakpoint - at the specified line. +c [line|sub] Continue; optionally inserts a one-time-only breakpoint + at the specified position. l min+incr List incr+1 lines starting at min. l min-max List lines min through max. l line List single line. @@ -1287,6 +1522,10 @@ b [line] [condition] condition breaks if it evaluates to true, defaults to '1'. b subname [condition] Set breakpoint at first line of subroutine. +b load filename Set breakpoint on `require'ing the given file. +b postpone subname [condition] + Set breakpoint at first line of subroutine after + it is compiled. d [line] Delete the breakpoint for line. D Delete all breakpoints. a [line] command @@ -1317,8 +1556,12 @@ O [opt[=val]] [opt\"val\"] [opt?]... During startup options are initialized from \$ENV{PERLDB_OPTS}. You can put additional initialization options TTY, noTTY, ReadLine, and NonStop there. -< command Define command to run before each prompt. -> command Define command to run after each prompt. +< command Define Perl command to run before each prompt. +<< command Add to the list of Perl commands to run before each prompt. +> command Define Perl command to run after each prompt. +>> command Add to the list of Perl commands to run after each prompt. +\{ commandline Define debugger command to run before each prompt. +\{{ commandline Add to the list of debugger commands to run before each prompt. $prc number Redo a previous command (default previous command). $prc -number Redo number'th-to-last command. $prc pattern Redo last command that started with pattern. @@ -1334,8 +1577,8 @@ 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. v Show versions of loaded modules. -R Pure-man-restart of debugger, debugger state and command-line - options are lost. +R Pure-man-restart of debugger, some of debugger state + and command-line options may be lost. h [db_command] Get help [on a specific debugger command], enter |h to page. h h Summary of debugger commands. q or ^D Quit. @@ -1348,11 +1591,11 @@ List/search source lines: Control script execution: w [line] List around line n [expr] Next, steps over subs f filename View source in file <CR> Repeat last n or s /pattern/ ?patt? Search forw/backw r Return from subroutine - v Show versions of modules c [line] Continue until line + v Show versions of modules c [ln|sub] Continue until position Debugger controls: L List break pts & actions O [...] Set debugger options t [expr] Toggle trace [trace expr] - < command Command for before prompt b [ln] [c] Set breakpoint - > command Command for after prompt b sub [c] Set breakpoint for sub + <[<] or {[{] [cmd] Do before prompt b [ln/event] [c] Set breakpoint + >[>] [cmd] Do after prompt b sub [c] Set breakpoint for sub $prc [N|pat] Redo a previous command d [line] Delete a breakpoint H [-num] Display last num commands D Delete all breakpoints = [a val] Define/list an alias a [ln] cmd Do cmd before line @@ -1360,13 +1603,13 @@ Debugger controls: L List break pts & actions |[|]dbcmd Send output to pager $psh\[$psh\] syscmd Run cmd in a subprocess q or ^D Quit R Attempt a restart Data Examination: expr Execute perl code, also see: s,n,t expr + x expr Evals expression in array context, dumps the result. + p expr Print expression (uses script's current package). S [[!]pat] List subroutine names [not] matching pattern V [Pk [Vars]] List Variables in Package. Vars can be ~pattern or !pattern. X [Vars] Same as \"V current_package [Vars]\". - x expr Evals expression in array context, dumps the result. - p expr Print expression (uses script's current package). END_SUM - # '); # Fix balance of Emacs parsing + # ')}}; # Fix balance of Emacs parsing } sub diesignal { @@ -1500,10 +1743,86 @@ BEGIN { # This does not compile, alas. $db_stop = 0; # Compiler warning $db_stop = 1 << 30; $level = 0; # Level of recursive debugging + # @stack and $doret are needed in sub sub, which is called for DB::postponed. + # Triggers bug (?) in perl is we postpone this until runtime: + @postponed = @stack = (0); + $doret = -2; + $frame = 0; } BEGIN {$^W = $ini_warn;} # Switch warnings back #use Carp; # This did break, left for debuggin +sub db_complete { + my($text, $line, $start) = @_; + my ($itext, $prefix, $pack) = $text; + + if ((substr $text, 0, 1) eq '&') { # subroutines + $text = substr $text, 1; + $prefix = "&"; + return map "$prefix$_", grep /^\Q$text/, keys %sub; + } + if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package + $pack = ($1 eq 'main' ? '' : $1) . '::'; + $prefix = (substr $text, 0, 1) . $1 . '::'; + $text = $2; + my @out + = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ; + if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) { + return db_complete($out[0], $line, $start); + } + return @out; + } + if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main) + $pack = ($package eq 'main' ? '' : $package) . '::'; + $prefix = substr $text, 0, 1; + $text = substr $text, 1; + my @out = map "$prefix$_", grep /^\Q$text/, + (grep /^_?[a-zA-Z]/, keys %$pack), + ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ; + if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) { + return db_complete($out[0], $line, $start); + } + return @out; + } + return grep /^\Q$text/, (keys %sub), qw(postpone load) # subroutines + if (substr $line, 0, $start) =~ /^[bl]\s+(postpone\s+)?$/; + return grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # packages + if (substr $line, 0, $start) =~ /^V\s+$/; + if ((substr $line, 0, $start) =~ /^O\b.*\s$/) { # Options after a space + my @out = grep /^\Q$text/, @options; + my $val = option_val($out[0], undef); + my $out = '? '; + if (not defined $val or $val =~ /[\n\r]/) { + # Can do nothing better + } elsif ($val =~ /\s/) { + my $found; + foreach $l (split //, qq/\"\'\#\|/) { + $out = "$l$val$l ", last if (index $val, $l) == -1; + } + } else { + $out = "=$val "; + } + # Default to value if one completion, to question if many + $readline::rl_completer_terminator_character + = $readline::rl_completer_terminator_character + = (@out == 1 ? $out : '? '); + return @out; + } + return &readline::rl_filename_list($text); # filenames +} + +END { + $finished = $inhibit_exit; # So that some keys may be disabled. + $DB::single = 1; + DB::fake::at_exit() unless $exiting; +} + +package DB::fake; + +sub at_exit { + "Debuggee terminated. Use `q' to quit and `R' to restart."; +} + 1; diff --git a/lib/sigtrap.pm b/lib/sigtrap.pm index 378ca899a0..ed5925b0ab 100644 --- a/lib/sigtrap.pm +++ b/lib/sigtrap.pm @@ -8,7 +8,7 @@ sigtrap - Perl pragma to enable simple signal handling use Carp; -$VERSION = 1.01; +$VERSION = 1.02; $Verbose ||= 0; sub import { @@ -29,13 +29,16 @@ sub import { } } elsif ($_ eq 'normal-signals') { - unshift @_, qw(HUP INT PIPE TERM); + unshift @_, grep(exists $SIG{$_}, qw(HUP INT PIPE TERM)); } elsif ($_ eq 'error-signals') { - unshift @_, qw(ABRT BUS EMT FPE ILL QUIT SEGV SYS TRAP); + unshift @_, grep(exists $SIG{$_}, + qw(ABRT BUS EMT FPE ILL QUIT SEGV SYS TRAP)); } elsif ($_ eq 'old-interface-signals') { - unshift @_, qw(ABRT BUS EMT FPE ILL PIPE QUIT SEGV SYS TERM TRAP); + unshift @_, + grep(exists $SIG{$_}, + qw(ABRT BUS EMT FPE ILL PIPE QUIT SEGV SYS TERM TRAP)); } elsif ($_ eq 'stack-trace') { $handler = \&handler_traceback; @@ -204,10 +207,15 @@ QUIT, SEGV, SYS and TRAP. These are the signals which were trapped by default by the old B<sigtrap> interface, they are ABRT, BUS, EMT, FPE, ILL, PIPE, QUIT, SEGV, SYS, TERM, and TRAP. If no signals or signals lists are passed to -B<sigtrap> this list is used. +B<sigtrap>, this list is used. =back +For each of these three lists, the collection of signals set to be +trapped is checked before trapping; if your architecture does not +implement a particular signal, it will not be trapped but rather +silently ignored. + =head2 OTHER =over 4 diff --git a/lib/strict.pm b/lib/strict.pm index 4aa55eb4f3..e261e92f67 100644 --- a/lib/strict.pm +++ b/lib/strict.pm @@ -11,7 +11,6 @@ strict - Perl pragma to restrict unsafe constructs use strict "vars"; use strict "refs"; use strict "subs"; - use strict "untie"; use strict; no strict "vars"; @@ -20,8 +19,8 @@ strict - Perl pragma to restrict unsafe constructs If no import list is supplied, all possible restrictions are assumed. (This is the safest mode to operate in, but is sometimes too strict for -casual programming.) Currently, there are four possible things to be -strict about: "subs", "vars", "refs", and "untie". +casual programming.) Currently, there are three possible things to be +strict about: "subs", "vars", and "refs". =over 6 @@ -66,24 +65,6 @@ appears in curly braces or on the left hand side of the "=E<gt>" symbol. -=item C<strict untie> - -This generates a runtime error if any references to the object returned -by C<tie> (or C<tied>) still exist when C<untie> is called. Note that -to get this strict behaviour, the C<use strict 'untie'> statement must -be in the same scope as the C<untie>. See L<perlfunc/tie>, -L<perlfunc/untie>, L<perlfunc/tied> and L<perltie>. - - use strict 'untie'; - $a = tie %a, 'SOME_PKG'; - $b = tie %b, 'SOME_PKG'; - $b = 0; - tie %c, PKG; - $c = tied %c; - untie %a ; # blows up, $a is a valid object reference. - untie %b; # ok, $b is not a reference to the object. - untie %c ; # blows up, $c is a valid object reference. - =back See L<perlmod/Pragmatic Modules>. @@ -97,19 +78,18 @@ sub bits { $bits |= 0x00000002 if $sememe eq 'refs'; $bits |= 0x00000200 if $sememe eq 'subs'; $bits |= 0x00000400 if $sememe eq 'vars'; - $bits |= 0x00000800 if $sememe eq 'untie'; } $bits; } sub import { shift; - $^H |= bits(@_ ? @_ : qw(refs subs vars untie)); + $^H |= bits(@_ ? @_ : qw(refs subs vars)); } sub unimport { shift; - $^H &= ~ bits(@_ ? @_ : qw(refs subs vars untie)); + $^H &= ~ bits(@_ ? @_ : qw(refs subs vars)); } 1; diff --git a/lib/subs.pm b/lib/subs.pm index 84c913a346..aa4c7e751e 100644 --- a/lib/subs.pm +++ b/lib/subs.pm @@ -15,7 +15,12 @@ This will predeclare all the subroutine whose names are in the list, allowing you to use them without parentheses even before they're declared. -See L<perlmod/Pragmatic Modules> and L<strict/subs>. +Unlike pragmas that affect the C<$^H> hints variable, the C<use vars> and +C<use subs> declarations are not BLOCK-scoped. They are thus effective +for the entire file in which they appear. You may not rescind such +declarations with C<no vars> or C<no subs>. + +See L<perlmod/Pragmatic Modules> and L<strict/strict subs>. =cut require 5.000; diff --git a/lib/syslog.pl b/lib/syslog.pl index 614068e7fc..8807ef027d 100644 --- a/lib/syslog.pl +++ b/lib/syslog.pl @@ -140,7 +140,7 @@ sub main'syslog { sub xlate { local($name) = @_; - $name =~ y/a-z/A-Z/; + $name = uc $name; $name = "LOG_$name" unless $name =~ /^LOG_/; $name = "syslog'$name"; eval(&$name) || -1; diff --git a/lib/termcap.pl b/lib/termcap.pl index e8f108df06..c36575aa45 100644 --- a/lib/termcap.pl +++ b/lib/termcap.pl @@ -63,6 +63,9 @@ sub Tgetent { $entry = $1; $_ = $2; s/\\E/\033/g; + s/\\(200)/pack('c',0)/eg; # NUL character + s/\\(0\d\d)/pack('c',oct($1))/eg; # octal + s/\\(0x[0-9A-Fa-f][0-9A-Fa-f])/pack('c',hex($1))/eg; # hex s/\\(\d\d\d)/pack('c',$1 & 0177)/eg; s/\\n/\n/g; s/\\r/\r/g; diff --git a/lib/timelocal.pl b/lib/timelocal.pl index 75f1ac1851..ad322756e3 100644 --- a/lib/timelocal.pl +++ b/lib/timelocal.pl @@ -4,106 +4,15 @@ ;# $time = timelocal($sec,$min,$hours,$mday,$mon,$year); ;# $time = timegm($sec,$min,$hours,$mday,$mon,$year); -;# These routines are quite efficient and yet are always guaranteed to agree -;# with localtime() and gmtime(). We manage this by caching the start times -;# of any months we've seen before. If we know the start time of the month, -;# we can always calculate any time within the month. The start times -;# themselves are guessed by successive approximation starting at the -;# current time, since most dates seen in practice are close to the -;# current date. Unlike algorithms that do a binary search (calling gmtime -;# once for each bit of the time value, resulting in 32 calls), this algorithm -;# calls it at most 6 times, and usually only once or twice. If you hit -;# the month cache, of course, it doesn't call it at all. +;# This file has been superseded by the Time::Local library module. +;# It is implemented as a call to that module for backwards compatibility +;# with code written for perl4; new code should use Time::Local directly. -;# timelocal is implemented using the same cache. We just assume that we're -;# translating a GMT time, and then fudge it when we're done for the timezone -;# and daylight savings arguments. The timezone is determined by examining -;# the result of localtime(0) when the package is initialized. The daylight -;# savings offset is currently assumed to be one hour. +;# The current implementation shares with the original the questionable +;# behavior of defining the timelocal() and timegm() functions in the +;# namespace of whatever package was current when the first instance of +;# C<require 'timelocal.pl';> was executed in a program. -;# Both routines return -1 if the integer limit is hit. I.e. for dates -;# after the 1st of January, 2038 on most machines. +use Time::Local; -CONFIG: { - package timelocal; - - local($[) = 0; - @epoch = localtime(0); - $tzmin = $epoch[2] * 60 + $epoch[1]; # minutes east of GMT - if ($tzmin > 0) { - $tzmin = 24 * 60 - $tzmin; # minutes west of GMT - $tzmin -= 24 * 60 if $epoch[5] == 70; # account for the date line - } - - $SEC = 1; - $MIN = 60 * $SEC; - $HR = 60 * $MIN; - $DAYS = 24 * $HR; - $YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0; - 1; -} - -sub timegm { - package timelocal; - - local($[) = 0; - $ym = pack(C2, @_[5,4]); - $cheat = $cheat{$ym} || &cheat; - return -1 if $cheat<0; - $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAYS; -} - -sub timelocal { - package timelocal; - - local($[) = 0; - $time = &main'timegm + $tzmin*$MIN; - return -1 if $cheat<0; - @test = localtime($time); - $time -= $HR if $test[2] != $_[2]; - $time; -} - -package timelocal; - -sub cheat { - $year = $_[5]; - $month = $_[4]; - die "Month out of range 0..11 in timelocal.pl\n" - if $month > 11 || $month < 0; - die "Day out of range 1..31 in timelocal.pl\n" - if $_[3] > 31 || $_[3] < 1; - die "Hour out of range 0..23 in timelocal.pl\n" - if $_[2] > 23 || $_[2] < 0; - die "Minute out of range 0..59 in timelocal.pl\n" - if $_[1] > 59 || $_[1] < 0; - die "Second out of range 0..59 in timelocal.pl\n" - if $_[0] > 59 || $_[0] < 0; - $guess = $^T; - @g = gmtime($guess); - $year += $YearFix if $year < $epoch[5]; - $lastguess = ""; - while ($diff = $year - $g[5]) { - $guess += $diff * (363 * $DAYS); - @g = gmtime($guess); - if (($thisguess = "@g") eq $lastguess){ - return -1; #date beyond this machine's integer limit - } - $lastguess = $thisguess; - } - while ($diff = $month - $g[4]) { - $guess += $diff * (27 * $DAYS); - @g = gmtime($guess); - if (($thisguess = "@g") eq $lastguess){ - return -1; #date beyond this machine's integer limit - } - $lastguess = $thisguess; - } - @gfake = gmtime($guess-1); #still being sceptic - if ("@gfake" eq $lastguess){ - return -1; #date beyond this machine's integer limit - } - $g[3]--; - $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAYS; - $cheat{$ym} = $guess; -} +*timelocal::cheat = \&Time::Local::cheat; diff --git a/lib/vars.pm b/lib/vars.pm index 0dd5758297..f0a6e54988 100644 --- a/lib/vars.pm +++ b/lib/vars.pm @@ -14,6 +14,11 @@ This will predeclare all the variables whose names are in the list, allowing you to use them under "use strict", and disabling any typo warnings. +Unlike pragmas that affect the C<$^H> hints variable, the C<use vars> and +C<use subs> declarations are not BLOCK-scoped. They are thus effective +for the entire file in which they appear. You may not rescind such +declarations with C<no vars> or C<no subs>. + Packages such as the B<AutoLoader> and B<SelfLoader> that delay loading of subroutines within packages can create problems with package lexicals defined using C<my()>. While the B<vars> pragma cannot duplicate the @@ -145,6 +145,79 @@ static u_int start_slack; # define M_OVERHEAD (sizeof(union overhead) + RSLOP) /* + * Big allocations are often of the size 2^n bytes. To make them a + * little bit better, make blocks of size 2^n+pagesize for big n. + */ + +#ifdef TWO_POT_OPTIMIZE + +# define PERL_PAGESIZE 4096 +# define FIRST_BIG_TWO_POT 14 /* 16K */ +# define FIRST_BIG_BLOCK (1<<FIRST_BIG_TWO_POT) /* 16K */ +/* If this value or more, check against bigger blocks. */ +# define FIRST_BIG_BOUND (FIRST_BIG_BLOCK - M_OVERHEAD) +/* If less than this value, goes into 2^n-overhead-block. */ +# define LAST_SMALL_BOUND ((FIRST_BIG_BLOCK>>1) - M_OVERHEAD) + +#endif /* TWO_POT_OPTIMIZE */ + +#ifdef PERL_EMERGENCY_SBRK + +#ifndef BIG_SIZE +# define BIG_SIZE (1<<16) /* 64K */ +#endif + +static char *emergency_buffer; +static MEM_SIZE emergency_buffer_size; + +static char * +emergency_sbrk(size) + MEM_SIZE size; +{ + if (size >= BIG_SIZE) { + /* Give the possibility to recover: */ + die("Out of memory during request for %i bytes", size); + /* croak may eat too much memory. */ + } + + if (!emergency_buffer) { + /* First offense, give a possibility to recover by dieing. */ + /* No malloc involved here: */ + GV **gvp = (GV**)hv_fetch(defstash, "^M", 2, 0); + SV *sv; + char *pv; + + if (!gvp) gvp = (GV**)hv_fetch(defstash, "\015", 1, 0); + if (!gvp || !(sv = GvSV(*gvp)) || !SvPOK(sv) + || (SvLEN(sv) < (1<<11) - M_OVERHEAD)) + return (char *)-1; /* Now die die die... */ + + /* Got it, now detach SvPV: */ + pv = SvPV(sv); + /* Check alignment: */ + if ((pv - M_OVERHEAD) & (1<<11 - 1)) { + PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n"); + return -1; /* die die die */ + } + + emergency_buffer = pv - M_OVERHEAD; + emergency_buffer_size = SvLEN(sv) + M_OVERHEAD; + SvPOK_off(sv); + SvREADONLY_on(sv); + die("Out of memory!"); /* croak may eat too much memory. */ + } else if (emergency_buffer_size >= size) { + emergency_buffer_size -= size; + return emergency_buffer + emergency_buffer_size; + } + + return (char *)-1; /* poor guy... */ +} + +#else /* !PERL_EMERGENCY_SBRK */ +# define emergency_sbrk(size) -1 +#endif /* !PERL_EMERGENCY_SBRK */ + +/* * nextf[i] is the pointer to the next free block of size 2^(i+3). The * smallest allocatable block is 8 bytes. The overhead information * precedes the data area returned to the user. @@ -188,22 +261,22 @@ malloc(nbytes) register int bucket = 0; register MEM_SIZE shiftr; -#ifdef safemalloc +#ifdef PERL_CORE #ifdef DEBUGGING MEM_SIZE size = nbytes; #endif -#ifdef MSDOS +#ifdef HAS_64K_LIMIT if (nbytes > 0xffff) { PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", (long)nbytes); my_exit(1); } -#endif /* MSDOS */ +#endif /* HAS_64K_LIMIT */ #ifdef DEBUGGING if ((long)nbytes < 0) croak("panic: malloc"); #endif -#endif /* safemalloc */ +#endif /* PERL_CORE */ /* * Convert amount of memory requested into @@ -214,6 +287,11 @@ malloc(nbytes) #ifdef PACK_MALLOC if (nbytes > MAX_2_POT_ALGO) { #endif +#ifdef TWO_POT_OPTIMIZE + if (nbytes >= FIRST_BIG_BOUND) { + nbytes -= PERL_PAGESIZE; + } +#endif nbytes += M_OVERHEAD; nbytes = (nbytes + 3) &~ 3; #ifdef PACK_MALLOC @@ -232,7 +310,7 @@ malloc(nbytes) if (nextf[bucket] == NULL) morecore(bucket); if ((p = (union overhead *)nextf[bucket]) == NULL) { -#ifdef safemalloc +#ifdef PERL_CORE if (!nomemok) { PerlIO_puts(PerlIO_stderr(),"Out of memory!\n"); my_exit(1); @@ -242,10 +320,10 @@ malloc(nbytes) #endif } -#ifdef safemalloc +#ifdef PERL_CORE DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n", (unsigned long)(p+1),an++,(long)size)); -#endif /* safemalloc */ +#endif /* PERL_CORE */ /* remove from linked list */ #ifdef RCHECK @@ -289,6 +367,9 @@ morecore(bucket) if (nextf[bucket]) return; + if (bucket == (sizeof(MEM_SIZE)*8 - 3)) { + croak("Allocation too large"); + } /* * Insure memory is allocated * on a page boundary. Should @@ -323,9 +404,16 @@ morecore(bucket) nblks = 1 << (rnu - (bucket + 3)); /* how many blocks to get */ /* if (rnu < bucket) rnu = bucket; Why anyone needs this? */ +#ifdef TWO_POT_OPTIMIZE + op = (union overhead *)sbrk((1L << rnu) + + ( bucket >= (FIRST_BIG_TWO_POT - 3) + ? PERL_PAGESIZE : 0)); +#else op = (union overhead *)sbrk(1L << rnu); +#endif /* no more room! */ - if ((int)op == -1) + if ((int)op == -1 && + (int)(op = (union overhead *)emergency_sbrk(size)) == -1) return; /* * Round up to minimum allocation size boundary @@ -390,9 +478,9 @@ free(mp) u_char bucket; #endif -#ifdef safemalloc +#ifdef PERL_CORE DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",(unsigned long)cp,an++)); -#endif /* safemalloc */ +#endif /* PERL_CORE */ if (cp == NULL) return; @@ -461,30 +549,30 @@ realloc(mp, nbytes) int was_alloced = 0; char *cp = (char*)mp; -#ifdef safemalloc +#ifdef PERL_CORE #ifdef DEBUGGING MEM_SIZE size = nbytes; #endif -#ifdef MSDOS +#ifdef HAS_64K_LIMIT if (nbytes > 0xffff) { PerlIO_printf(PerlIO_stderr(), "Reallocation too large: %lx\n", size); my_exit(1); } -#endif /* MSDOS */ +#endif /* HAS_64K_LIMIT */ if (!cp) return malloc(nbytes); #ifdef DEBUGGING if ((long)nbytes < 0) croak("panic: realloc"); #endif -#endif /* safemalloc */ +#endif /* PERL_CORE */ op = (union overhead *)((caddr_t)cp - sizeof (union overhead) * CHUNK_SHIFT); i = OV_INDEX(op); if (OV_MAGIC(op, i) == MAGIC) { - was_alloced++; + was_alloced = 1; } else { /* * Already free, doing "compaction". @@ -507,10 +595,24 @@ realloc(mp, nbytes) #else M_OVERHEAD #endif +#ifdef TWO_POT_OPTIMIZE + + (i >= (FIRST_BIG_TWO_POT - 3) ? PERL_PAGESIZE : 0) +#endif ; - /* avoid the copy if same size block */ + /* + * avoid the copy if same size block. + * We are not agressive with boundary cases. Note that it is + * possible for small number of cases give false negative if + * both new size and old one are in the bucket for + * FIRST_BIG_TWO_POT, but the new one is near the lower end. + */ if (was_alloced && - nbytes <= onb && nbytes > (onb >> 1) - M_OVERHEAD) { + nbytes <= onb && (nbytes > ( (onb >> 1) - M_OVERHEAD ) +#ifdef TWO_POT_OPTIMIZE + || (i == (FIRST_BIG_TWO_POT - 3) + && nbytes >= LAST_SMALL_BOUND ) +#endif + )) { #ifdef RCHECK /* * Record new allocated size of block and @@ -540,7 +642,7 @@ realloc(mp, nbytes) free(cp); } -#ifdef safemalloc +#ifdef PERL_CORE #ifdef DEBUGGING if (debug & 128) { PerlIO_printf(PerlIO_stderr(), "0x%lx: (%05d) rfree\n",(unsigned long)res,an++); @@ -548,7 +650,7 @@ realloc(mp, nbytes) (unsigned long)res,an++,(long)size); } #endif -#endif /* safemalloc */ +#endif /* PERL_CORE */ return ((Malloc_t)res); } @@ -681,7 +783,7 @@ int size; int small, reqsize; if (!size) return 0; -#ifdef safemalloc +#ifdef PERL_CORE reqsize = size; /* just for the DEBUG_m statement */ #endif if (size <= Perl_sbrk_oldsize) { @@ -692,7 +794,7 @@ int size; if (size >= PERLSBRK_32_K) { small = 0; } else { -#ifndef safemalloc +#ifndef PERL_CORE reqsize = size; #endif size = PERLSBRK_64_K; @@ -706,7 +808,7 @@ int size; } } -#ifdef safemalloc +#ifdef PERL_CORE DEBUG_m(PerlIO_printf(PerlIO_stderr(), "sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%lx\n", size, reqsize, Perl_sbrk_oldsize, got)); #endif @@ -1161,6 +1161,16 @@ MAGIC* mg; } int +magic_setfm(sv,mg) +SV* sv; +MAGIC* mg; +{ + sv_unmagic(sv, 'f'); + SvCOMPILED_off(sv); + return 0; +} + +int magic_setuvar(sv,mg) SV* sv; MAGIC* mg; diff --git a/old_embed.pl b/old_embed.pl index e69de29bb2..eb3d30636d 100755 --- a/old_embed.pl +++ b/old_embed.pl @@ -0,0 +1,104 @@ +#!/usr/bin/perl +# +# FOR BACKWARDS COMPATIBILITY WITH OLD VERSIONS OF PERL +# +# This script uses an old method of creating "embed.h". Use it +# if you need to maintain binary compatibility with older versions +# Perl with the EMBED feature enabled. +# + +open(EM, ">embed.h") || die "Can't create embed.h: $!\n"; + +print EM <<'END'; +/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! + This file is built by old_embed.pl from old_global.sym and interp.sym. + Any changes made here will be lost. + THIS FILE IS FOR BINARY COMPATIBILITY WITH OLD PERL VERSIONS. + Run "embed.pl" to get an up-to-date version. +*/ + +/* (Doing namespace management portably in C is really gross.) */ + +/* EMBED has no run-time penalty, but helps keep the Perl namespace + from colliding with that used by other libraries pulled in + by extensions or by embedding perl. Allow a cc -DNO_EMBED + override, however, to keep binary compatability with previous + versions of perl. +*/ +#ifndef NO_EMBED +# define EMBED 1 +#endif + +#ifdef EMBED + +/* globals we need to hide from the world */ +END + +open(GL, "<old_global.sym") || die "Can't open old_global.sym: $!\n"; + +while(<GL>) { + s/[ \t]*#.*//; # Delete comments. + next unless /\S/; + s/^\s*(\S+).*$/#define $1\t\tPerl_$1/; + $global{$1} = 1; + s/(................\t)\t/$1/; + print EM $_; +} + +close(GL) || warn "Can't close old_global.sym: $!\n"; + +print EM <<'END'; + +#endif /* EMBED */ + +/* Put interpreter specific symbols into a struct? */ + +#ifdef MULTIPLICITY + +/* Undefine symbols that were defined by EMBED. Somewhat ugly */ + +END + + +open(INT, "<interp.sym") || die "Can't open interp.sym: $!\n"; +while (<INT>) { + s/[ \t]*#.*//; # Delete comments. + next unless /\S/; + s/^\s*(\S*).*$/#undef $1/; + print EM $_ if (exists $global{$1}); +} +close(INT) || warn "Can't close interp.sym: $!\n"; + +print EM "\n"; + +open(INT, "<interp.sym") || die "Can't open interp.sym: $!\n"; +while (<INT>) { + s/[ \t]*#.*//; # Delete comments. + next unless /\S/; + s/^\s*(\S+).*$/#define $1\t\t(curinterp->I$1)/; + s/(................\t)\t/$1/; + print EM $_; +} +close(INT) || warn "Can't close interp.sym: $!\n"; + +print EM <<'END'; + +#else /* not multiple, so translate interpreter symbols the other way... */ + +END + +open(INT, "<interp.sym") || die "Can't open interp.sym: $!\n"; +while (<INT>) { + s/[ \t]*#.*//; # Delete comments. + next unless /\S/; + s/^\s*(\S+).*$/#define I$1\t\t$1/; + s/(................\t)\t/$1/; + print EM $_; +} +close(INT) || warn "Can't close interp.sym: $!\n"; + +print EM <<'END'; + +#endif /* MULTIPLICITY */ +END + diff --git a/old_global.sym b/old_global.sym new file mode 100644 index 0000000000..4a9dd48463 --- /dev/null +++ b/old_global.sym @@ -0,0 +1,1082 @@ +# Global symbols that need to be hidden in embedded applications. + +# Variables + +AMG_names +No +Sv +He +Xpv +Yes +abs_amg +add_amg +add_ass_amg +additem +amagic_generation +an +atan2_amg +band_amg +bool__amg +bor_amg +buf +bufend +bufptr +bxor_amg +check +compiling +compl_amg +compcv +comppad +comppad_name +comppad_name_fill +comppad_name_floor +concat_amg +concat_ass_amg +cop_seqmax +cos_amg +cryptseen +cshlen +cshname +curcop +curcopdb +curinterp +curpad +cv_const_sv +dc +debug +dec_amg +di +div_amg +div_ass_amg +do_undump +ds +egid +envgv +eq_amg +error_count +euid +evalseq +exp_amg +expect +expectterm +fallback_amg +filter_add +filter_del +filter_read +fold +freq +ge_amg +gid +gt_amg +hexdigit +hints +in_my +inc_amg +io_close +know_next +last_lop +last_lop_op +last_uni +le_amg +lex_state +lex_defer +lex_expect +lex_brackets +lex_formbrack +lex_fakebrack +lex_casemods +lex_dojoin +lex_starts +lex_stuff +lex_repl +lex_op +lex_inpat +lex_inwhat +lex_brackstack +lex_casestack +linestr +log_amg +lshift_amg +lshift_ass_amg +lt_amg +markstack +markstack_max +markstack_ptr +maxo +max_intro_pending +min_intro_pending +mod_amg +mod_ass_amg +mult_amg +mult_ass_amg +multi_close +multi_end +multi_open +multi_start +na +ncmp_amg +nextval +nexttype +nexttoke +ne_amg +neg_amg +nexttype +nextval +no_aelem +no_dir_func +no_func +no_helem +no_mem +no_modify +no_security +no_sock_func +no_usym +nointrp +nomem +nomemok +nomethod_amg +not_amg +numer_amg +oldbufptr +oldoldbufptr +op +op_desc +op_name +op_seqmax +opargs +origalen +origenviron +osname +padix +patleave +pow_amg +pow_ass_amg +ppaddr +profiledata +provide_ref +psig_ptr +psig_name +qrt_amg +rcsid +reall_srchlen +regarglen +regbol +regcode +regdummy +regendp +regeol +regfold +reginput +regkind +reglastparen +regmyendp +regmyp_size +regmystartp +regnarrate +regnaughty +regnpar +regparse +regprecomp +regprev +regsawback +regsize +regstartp +regtill +regxend +repeat_amg +repeat_ass_amg +retstack +retstack_ix +retstack_max +rsfp +rsfp_filters +rshift_amg +rshift_ass_amg +save_pptr +savestack +savestack_ix +savestack_max +saw_return +scmp_amg +scopestack +scopestack_ix +scopestack_max +scrgv +seq_amg +sge_amg +sgt_amg +sig_name +sig_num +siggv +sighandler +simple +sin_amg +sle_amg +slt_amg +sne_amg +stack_base +stack_max +stack_sp +statbuf +string_amg +sub_generation +subline +subname +subtr_amg +subtr_ass_amg +sv_no +sv_undef +sv_yes +tainting +thisexpr +timesbuf +tokenbuf +uid +varies +vert +vtbl_amagic +vtbl_amagicelem +vtbl_arylen +vtbl_bm +vtbl_dbline +vtbl_env +vtbl_envelem +vtbl_glob +vtbl_isa +vtbl_isaelem +vtbl_mglob +vtbl_pack +vtbl_packelem +vtbl_pos +vtbl_sig +vtbl_sigelem +vtbl_substr +vtbl_sv +vtbl_taint +vtbl_uvar +vtbl_vec +warn_nl +warn_nosemi +warn_reserved +watchaddr +watchok +yychar +yycheck +yydebug +yydefred +yydgoto +yyerrflag +yygindex +yylen +yylhs +yylval +yyname +yynerrs +yyrindex +yyrule +yysindex +yytable +yyval + +# Functions + +Gv_AMupdate +amagic_call +append_elem +append_list +apply +assertref +av_clear +av_extend +av_fake +av_fetch +av_fill +av_len +av_make +av_pop +av_push +av_shift +av_store +av_undef +av_unshift +bind_match +block_end +block_start +calllist +cando +cast_ulong +check_uni +checkcomma +ck_aelem +ck_concat +ck_delete +ck_eof +ck_eval +ck_exec +ck_formline +ck_ftst +ck_fun +ck_glob +ck_grep +ck_gvconst +ck_index +ck_lengthconst +ck_lfun +ck_listiob +ck_match +ck_null +ck_repeat +ck_require +ck_retarget +ck_rfun +ck_rvconst +ck_select +ck_shift +ck_sort +ck_spair +ck_split +ck_subr +ck_svconst +ck_trunc +convert +cpytill +croak +cv_clone +cv_undef +cx_dump +cxinc +deb +deb_growlevel +debop +debprofdump +debstack +debstackptrs +deprecate +die +die_where +do_aexec +do_chomp +do_chop +do_close +do_eof +do_exec +do_execfree +do_ipcctl +do_ipcget +do_join +do_kv +do_msgrcv +do_msgsnd +do_open +do_pipe +do_print +do_readline +do_seek +do_semop +do_shmio +do_sprintf +do_tell +do_trans +do_vecset +do_vop +doeval +dofindlabel +dopoptoeval +dounwind +dowantarray +dump_all +dump_eval +dump_fds +dump_form +dump_gv +dump_mstats +dump_op +dump_packsubs +dump_pm +dump_sub +fbm_compile +fbm_instr +fetch_gv +fetch_io +filter_add +filter_del +filter_read +fold_constants +force_ident +force_list +force_next +force_word +free_tmps +gen_constant_list +gp_free +gp_ref +gv_AVadd +gv_HVadd +gv_IOadd +gv_check +gv_efullname +gv_fetchfile +gv_fetchmeth +gv_fetchmethod +gv_fetchpv +gv_fullname +gv_init +gv_stashpv +gv_stashpvn +gv_stashsv +he_delayfree +he_free +he_root +hoistmust +hv_clear +hv_delete +hv_delete_ent +hv_exists +hv_exists_ent +hv_fetch +hv_fetch_ent +hv_iterinit +hv_iterkey +hv_iterkeysv +hv_iternext +hv_iternextsv +hv_iterval +hv_magic +hv_stashpv +hv_store +hv_store_ent +hv_undef +ibcmp +ingroup +instr +intuit_more +invert +jmaybe +keyword +leave_scope +lex_end +lex_start +linklist +list +listkids +localize +looks_like_number +magic_clearenv +magic_clearpack +magic_clearsig +magic_existspack +magic_get +magic_getarylen +magic_getglob +magic_getpack +magic_getpos +magic_getsig +magic_gettaint +magic_getuvar +magic_len +magic_nextpack +magic_set +magic_setamagic +magic_setarylen +magic_setbm +magic_setdbline +magic_setenv +magic_setglob +magic_setisa +magic_setmglob +magic_setpack +magic_setpos +magic_setsig +magic_setsubstr +magic_settaint +magic_setuvar +magic_setvec +magic_wipepack +magicname +markstack_grow +mess +mg_clear +mg_copy +mg_find +mg_free +mg_get +mg_len +mg_magical +mg_set +mod +modkids +moreswitches +mstats +my +my_bcopy +my_bzero +my_chsize +my_exit +my_htonl +my_lstat +my_memcmp +my_ntohl +my_pclose +my_popen +my_setenv +my_stat +my_swap +my_unexec +newANONHASH +newANONLIST +newANONSUB +newASSIGNOP +newAV +newAVREF +newBINOP +newCONDOP +newCVREF +newFORM +newFOROP +newGVOP +newGVREF +newGVgen +newHV +newHVREF +newIO +newLISTOP +newLOGOP +newLOOPEX +newLOOPOP +newNULLLIST +newOP +newPMOP +newPROG +newPVOP +newRANGE +newRV +newSLICEOP +newSTATEOP +newSUB +newSV +newSVOP +newSVREF +newSViv +newSVnv +newSVpv +newSVrv +newSVsv +newUNOP +newWHILEOP +newXS +newXSUB +nextargv +ninstr +no_fh_allowed +no_op +oopsAV +oopsCV +oopsHV +op_free +package +pad_alloc +pad_allocmy +pad_findmy +pad_free +pad_leavemy +pad_reset +pad_sv +pad_swipe +peep +pidgone +pmflag +pmruntime +pmtrans +pop_return +pop_scope +pp_aassign +pp_abs +pp_accept +pp_add +pp_aelem +pp_aelemfast +pp_alarm +pp_and +pp_andassign +pp_anoncode +pp_anonhash +pp_anonlist +pp_aslice +pp_atan2 +pp_av2arylen +pp_backtick +pp_bind +pp_binmode +pp_bit_and +pp_bit_or +pp_bit_xor +pp_bless +pp_caller +pp_chdir +pp_chmod +pp_chomp +pp_chop +pp_chown +pp_chr +pp_chroot +pp_close +pp_closedir +pp_complement +pp_concat +pp_cond_expr +pp_connect +pp_const +pp_cos +pp_crypt +pp_cswitch +pp_dbmclose +pp_dbmopen +pp_dbstate +pp_defined +pp_delete +pp_die +pp_divide +pp_dofile +pp_dump +pp_each +pp_egrent +pp_ehostent +pp_enetent +pp_enter +pp_entereval +pp_enteriter +pp_enterloop +pp_entersub +pp_entersubr +pp_entertry +pp_enterwrite +pp_eof +pp_eprotoent +pp_epwent +pp_eq +pp_eservent +pp_evalonce +pp_exec +pp_exists +pp_exit +pp_exp +pp_fcntl +pp_fileno +pp_flip +pp_flock +pp_flop +pp_fork +pp_formline +pp_ftatime +pp_ftbinary +pp_ftblk +pp_ftchr +pp_ftctime +pp_ftdir +pp_fteexec +pp_fteowned +pp_fteread +pp_ftewrite +pp_ftfile +pp_ftis +pp_ftlink +pp_ftmtime +pp_ftpipe +pp_ftrexec +pp_ftrowned +pp_ftrread +pp_ftrwrite +pp_ftsgid +pp_ftsize +pp_ftsock +pp_ftsuid +pp_ftsvtx +pp_fttext +pp_fttty +pp_ftzero +pp_ge +pp_gelem +pp_getc +pp_getlogin +pp_getpeername +pp_getpgrp +pp_getppid +pp_getpriority +pp_getsockname +pp_ggrent +pp_ggrgid +pp_ggrnam +pp_ghbyaddr +pp_ghbyname +pp_ghostent +pp_glob +pp_gmtime +pp_gnbyaddr +pp_gnbyname +pp_gnetent +pp_goto +pp_gpbyname +pp_gpbynumber +pp_gprotoent +pp_gpwent +pp_gpwnam +pp_gpwuid +pp_grepstart +pp_grepwhile +pp_gsbyname +pp_gsbyport +pp_gservent +pp_gsockopt +pp_gt +pp_gv +pp_gvsv +pp_helem +pp_hex +pp_hslice +pp_i_add +pp_i_divide +pp_i_eq +pp_i_ge +pp_i_gt +pp_i_le +pp_i_lt +pp_i_modulo +pp_i_multiply +pp_i_ncmp +pp_i_ne +pp_i_negate +pp_i_subtract +pp_index +pp_indread +pp_int +pp_interp +pp_ioctl +pp_iter +pp_join +pp_keys +pp_kill +pp_last +pp_lc +pp_lcfirst +pp_le +pp_leave +pp_leaveeval +pp_leaveloop +pp_leavesub +pp_leavetry +pp_leavewrite +pp_left_shift +pp_length +pp_lineseq +pp_link +pp_list +pp_listen +pp_localtime +pp_log +pp_lslice +pp_lstat +pp_lt +pp_map +pp_mapstart +pp_mapwhile +pp_match +pp_method +pp_mkdir +pp_modulo +pp_msgctl +pp_msgget +pp_msgrcv +pp_msgsnd +pp_multiply +pp_ncmp +pp_ne +pp_negate +pp_next +pp_nextstate +pp_not +pp_nswitch +pp_null +pp_oct +pp_open +pp_open_dir +pp_or +pp_orassign +pp_ord +pp_pack +pp_padany +pp_padav +pp_padhv +pp_padsv +pp_pipe_op +pp_pop +pp_pos +pp_postdec +pp_postinc +pp_pow +pp_predec +pp_preinc +pp_print +pp_prototype +pp_prtf +pp_push +pp_pushmark +pp_pushre +pp_quotemeta +pp_rand +pp_range +pp_rcatline +pp_read +pp_readdir +pp_readline +pp_readlink +pp_recv +pp_redo +pp_ref +pp_refgen +pp_regcmaybe +pp_regcomp +pp_rename +pp_repeat +pp_require +pp_reset +pp_return +pp_reverse +pp_rewinddir +pp_right_shift +pp_rindex +pp_rmdir +pp_rv2av +pp_rv2cv +pp_rv2gv +pp_rv2hv +pp_rv2sv +pp_sassign +pp_scalar +pp_schomp +pp_schop +pp_scmp +pp_scope +pp_seek +pp_seekdir +pp_select +pp_semctl +pp_semget +pp_semop +pp_send +pp_seq +pp_setpgrp +pp_setpriority +pp_sge +pp_sgrent +pp_sgt +pp_shift +pp_shmctl +pp_shmget +pp_shmread +pp_shmwrite +pp_shostent +pp_shutdown +pp_sin +pp_sle +pp_sleep +pp_slt +pp_sne +pp_snetent +pp_socket +pp_sockpair +pp_sort +pp_splice +pp_split +pp_sprintf +pp_sprotoent +pp_spwent +pp_sqrt +pp_srand +pp_srefgen +pp_sselect +pp_sservent +pp_ssockopt +pp_stat +pp_stringify +pp_stub +pp_study +pp_subst +pp_substcont +pp_substr +pp_subtract +pp_symlink +pp_syscall +pp_sysopen +pp_sysread +pp_system +pp_syswrite +pp_tell +pp_telldir +pp_tie +pp_tied +pp_time +pp_tms +pp_trans +pp_truncate +pp_uc +pp_ucfirst +pp_umask +pp_undef +pp_unlink +pp_unpack +pp_unshift +pp_unstack +pp_untie +pp_utime +pp_values +pp_vec +pp_wait +pp_waitpid +pp_wantarray +pp_warn +pp_xor +pregcomp +pregexec +pregfree +prepend_elem +push_return +push_scope +q +ref +refkids +regdump +regnext +regprop +repeatcpy +rninstr +runops +same_dirent +save_I32 +save_aptr +save_ary +save_clearsv +save_delete +save_destructor +save_freeop +save_freepv +save_freesv +save_hash +save_hptr +save_int +save_item +save_list +save_long +save_nogv +save_pptr +save_scalar +save_sptr +save_svref +savepv +savepvn +savestack_grow +sawparens +scalar +scalarkids +scalarseq +scalarvoid +scan_const +scan_formline +scan_heredoc +scan_hex +scan_ident +scan_inputsymbol +scan_num +scan_oct +scan_pat +scan_prefix +scan_str +scan_subst +scan_trans +scan_word +scope +screaminstr +setdefout +setenv_getix +sharepvn +sighandler +skipspace +stack_grow +start_subparse +sublex_done +sublex_start +sv_2bool +sv_2cv +sv_2io +sv_2iv +sv_2mortal +sv_2nv +sv_2pv +sv_add_arena +sv_backoff +sv_bless +sv_catpv +sv_catpvn +sv_catsv +sv_chop +sv_clean_all +sv_clean_objs +sv_clear +sv_cmp +sv_dec +sv_dump +sv_eq +sv_free +sv_free_arenas +sv_gets +sv_grow +sv_inc +sv_insert +sv_isa +sv_isobject +sv_len +sv_magic +sv_mortalcopy +sv_newmortal +sv_newref +sv_peek +sv_pvn_force +sv_ref +sv_reftype +sv_replace +sv_report_used +sv_reset +sv_setiv +sv_setnv +sv_setptrobj +sv_setpv +sv_setpvn +sv_setref_iv +sv_setref_nv +sv_setref_pv +sv_setref_pvn +sv_setsv +sv_unmagic +sv_unref +sv_upgrade +sv_usepvn +taint_env +taint_not +taint_proper +too_few_arguments +too_many_arguments +unlnk +unsharepvn +utilize +wait4pid +warn +watch +whichsig +xiv_arenaroot +xiv_root +xnv_root +xpv_root +xrv_root +yyerror +yylex +yyparse +yywarn @@ -1269,22 +1269,25 @@ OP *o; } int -block_start() +block_start(full) +int full; { int retval = savestack_ix; - SAVEINT(comppad_name_floor); - if ((comppad_name_fill = AvFILL(comppad_name)) > 0) - comppad_name_floor = comppad_name_fill; - else - comppad_name_floor = 0; - SAVEINT(min_intro_pending); - SAVEINT(max_intro_pending); + SAVEI32(comppad_name_floor); + if (full) { + if ((comppad_name_fill = AvFILL(comppad_name)) > 0) + comppad_name_floor = comppad_name_fill; + else + comppad_name_floor = 0; + } + SAVEI32(min_intro_pending); + SAVEI32(max_intro_pending); min_intro_pending = 0; - SAVEINT(comppad_name_fill); - SAVEINT(padix_floor); + SAVEI32(comppad_name_fill); + SAVEI32(padix_floor); padix_floor = padix; pad_reset_pending = FALSE; - SAVEINT(hints); + SAVEI32(hints); hints &= ~HINT_BLOCK_SCOPE; return retval; } @@ -2976,6 +2979,9 @@ OP *block; if (perldb && curstash != debstash) { SV *sv; SV *tmpstr = sv_newmortal(); + static GV *db_postponed; + CV *cv; + HV *hv; sprintf(buf,"%s:%ld",SvPVX(GvSV(curcop->cop_filegv)), (long)subline); sv = newSVpv(buf,0); @@ -2984,6 +2990,18 @@ OP *block; sv_catpv(sv,buf); gv_efullname3(tmpstr, gv, Nullch); hv_store(GvHV(DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0); + if (!db_postponed) { + db_postponed = gv_fetchpv("DB::postponed", TRUE, SVt_PVHV); + } + hv = GvHVn(db_postponed); + if (HvFILL(hv) >= 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr)) + && (cv = GvCV(db_postponed))) { + dSP; + PUSHMARK(sp); + XPUSHs(tmpstr); + PUTBACK; + perl_call_sv((SV*)cv, G_DISCARD); + } } op_free(op); copline = NOLINE; @@ -3261,6 +3279,14 @@ OP *o; /* Check routines. */ OP * +ck_bitop(op) +OP *op; +{ + op->op_private = hints; + return op; +} + +OP * ck_concat(op) OP *op; { @@ -1052,6 +1052,7 @@ EXT char *op_desc[] = { }; #endif +OP * ck_bitop _((OP* op)); OP * ck_concat _((OP* op)); OP * ck_delete _((OP* op)); OP * ck_eof _((OP* op)); @@ -1845,8 +1846,8 @@ EXT OP * (*check[]) _((OP *op)) = { ck_null, /* i_subtract */ ck_concat, /* concat */ ck_fun, /* stringify */ - ck_null, /* left_shift */ - ck_null, /* right_shift */ + ck_bitop, /* left_shift */ + ck_bitop, /* right_shift */ ck_null, /* lt */ ck_null, /* i_lt */ ck_null, /* gt */ @@ -1868,13 +1869,13 @@ EXT OP * (*check[]) _((OP *op)) = { ck_null, /* seq */ ck_null, /* sne */ ck_null, /* scmp */ - ck_null, /* bit_and */ - ck_null, /* bit_xor */ - ck_null, /* bit_or */ + ck_bitop, /* bit_and */ + ck_bitop, /* bit_xor */ + ck_bitop, /* bit_or */ ck_null, /* negate */ ck_null, /* i_negate */ ck_null, /* not */ - ck_null, /* complement */ + ck_bitop, /* complement */ ck_fun, /* atan2 */ ck_fun, /* sin */ ck_fun, /* cos */ @@ -2195,8 +2196,8 @@ EXT U32 opargs[] = { 0x0000111e, /* i_subtract */ 0x0000110e, /* concat */ 0x0000010e, /* stringify */ - 0x0000111e, /* left_shift */ - 0x0000111e, /* right_shift */ + 0x0000110e, /* left_shift */ + 0x0000110e, /* right_shift */ 0x00001136, /* lt */ 0x00001116, /* i_lt */ 0x00001136, /* gt */ @@ -2247,11 +2248,11 @@ EXT U32 opargs[] = { 0x0000099e, /* ord */ 0x0000098e, /* chr */ 0x0000110e, /* crypt */ - 0x0000010e, /* ucfirst */ - 0x0000010e, /* lcfirst */ - 0x0000010e, /* uc */ - 0x0000010e, /* lc */ - 0x0000010e, /* quotemeta */ + 0x0000098e, /* ucfirst */ + 0x0000098e, /* lcfirst */ + 0x0000098e, /* uc */ + 0x0000098e, /* lc */ + 0x0000098e, /* quotemeta */ 0x00000048, /* rv2av */ 0x00001304, /* aelemfast */ 0x00001304, /* aelem */ @@ -278,8 +278,8 @@ i_subtract integer subtraction ck_null ifst S S concat concatenation ck_concat fst S S stringify string ck_fun fst S -left_shift left bitshift ck_null ifst S S -right_shift right bitshift ck_null ifst S S +left_shift left bitshift ck_bitop fst S S +right_shift right bitshift ck_bitop fst S S lt numeric lt ck_null Iifs S S i_lt integer lt ck_null ifs S S @@ -304,14 +304,14 @@ seq string eq ck_null ifs S S sne string ne ck_null ifs S S scmp string comparison ck_null ifst S S -bit_and bitwise and ck_null fst S S -bit_xor bitwise xor ck_null fst S S -bit_or bitwise or ck_null fst S S +bit_and bitwise and ck_bitop fst S S +bit_xor bitwise xor ck_bitop fst S S +bit_or bitwise or ck_bitop fst S S negate negate ck_null Ifst S i_negate integer negate ck_null ifst S not not ck_null ifs S -complement 1's complement ck_null fst S +complement 1's complement ck_bitop fst S # High falutin' math. @@ -343,11 +343,11 @@ formline formline ck_formline ms S L ord ord ck_fun ifstu S? chr chr ck_fun fstu S? crypt crypt ck_fun fst S S -ucfirst upper case first ck_fun fst S -lcfirst lower case first ck_fun fst S -uc upper case ck_fun fst S -lc lower case ck_fun fst S -quotemeta quote metachars ck_fun fst S +ucfirst upper case first ck_fun fstu S? +lcfirst lower case first ck_fun fstu S? +uc upper case ck_fun fstu S? +lc lower case ck_fun fstu S? +quotemeta quote metachars ck_fun fstu S? # Arrays. diff --git a/os2/Changes b/os2/Changes index 9a9524f161..2bd48b2942 100644 --- a/os2/Changes +++ b/os2/Changes @@ -104,3 +104,11 @@ after 5.003_05: perl___ - cannot fork, can dynalink. The build of the first one - perl - is rather convoluted, and requires a build of miniperl_. + +after 5.003_07: + custom tmpfile and tmpname which may use $TMP, $TEMP. + all the calls to OS/2 API wrapped so that it is safe to use + them under DOS (may die(), though). + Tested that popen works under DOS with modified PDKSH and RSX. + File::Copy works under DOS. + MakeMaker modified to work under DOS (perlmain.c.tmp and sh -c true). diff --git a/os2/Makefile.SHs b/os2/Makefile.SHs index a1fcaa49ed..c498706627 100644 --- a/os2/Makefile.SHs +++ b/os2/Makefile.SHs @@ -49,6 +49,8 @@ perl5.def: perl.linkexp echo ' "dlsym"' >>$@ echo ' "dlerror"' >>$@ echo ' "perl_init_i18nl10n"' >>$@ + echo ' "my_tmpfile"' >>$@ + echo ' "my_tmpnam"' >>$@ !NO!SUBS! if [ ! -z "$myttyname" ] ; then @@ -73,6 +73,7 @@ setpriority(int which, int pid, int val) prio = sys_prio(pid); + if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */ if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) { /* Do not change class. */ return CheckOSError(DosSetPriority((pid < 0) @@ -114,6 +115,7 @@ getpriority(int which /* ignored */, int pid) PIB *pib; ULONG rc, ret; + if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */ /* DosGetInfoBlocks has old priority! */ /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */ /* if (pid != pib->pib_ulpid) { */ @@ -409,6 +411,8 @@ tcp0(char *name) { static BYTE buf[20]; PFN fcn; + + if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */ if (!htcp) DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) @@ -421,6 +425,8 @@ tcp1(char *name, int arg) { static BYTE buf[20]; PFN fcn; + + if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */ if (!htcp) DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) @@ -601,6 +607,7 @@ os2error(int rc) static char buf[300]; ULONG len; + if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */ if (rc == 0) return NULL; if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len)) @@ -947,8 +954,12 @@ Xs_OS2_init() char *file = __FILE__; { GV *gv; - - newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file); + + if (_emx_env & 0x200) { /* OS/2 */ + newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file); + newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file); + newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file); + } newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file); newXS("Cwd::current_drive", XS_Cwd_current_drive, file); newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file); @@ -958,8 +969,6 @@ Xs_OS2_init() newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file); newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file); newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file); - newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file); - newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file); gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); GvMULTI_on(gv); #ifdef PERL_IS_AOUT @@ -992,3 +1001,33 @@ Perl_OS2_init() } } +#undef tmpnam +#undef tmpfile + +char * +my_tmpnam (char *str) +{ + char *p = getenv("TMP"), *tpath; + int len; + + if (!p) p = getenv("TEMP"); + tpath = tempnam(p, "pltmp"); + if (str && tpath) { + strcpy(str, tpath); + return str; + } + return tpath; +} + +FILE * +my_tmpfile () +{ + struct stat s; + + stat(".", &s); + if (s.st_mode & S_IWOTH) { + return tmpfile(); + } + return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but + grants TMP. */ +} diff --git a/os2/os2ish.h b/os2/os2ish.h index 6510a1f145..0597fdcd39 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -99,6 +99,11 @@ extern char *tmppath; PerlIO *my_syspopen(char *cmd, char *mode); /* Cannot prototype with I32 at this point. */ int my_syspclose(PerlIO *f); +FILE *my_tmpfile (void); +char *my_tmpnam (char *); + +#define tmpfile my_tmpfile +#define tmpnam my_tmpnam /* * fwrite1() should be a routine with the same calling sequence as fwrite(), diff --git a/patchlevel.h b/patchlevel.h index 30bb120609..e1a4da8d15 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1,5 +1,5 @@ #define PATCHLEVEL 3 -#define SUBVERSION 7 +#define SUBVERSION 8 /* local_patches -- list of locally applied less-than-subversion patches. @@ -524,7 +524,7 @@ setuid perl scripts securely.\n"); else if (scriptname == Nullch) { #ifdef MSDOS if ( isatty(PerlIO_fileno(PerlIO_stdin())) ) - moreswitches("v"); + moreswitches("h"); #endif scriptname = "-"; } @@ -1299,7 +1299,10 @@ char *s; printf("\n\nCopyright 1987-1996, Larry Wall\n"); printf("\n\t+ suidperl security patch"); #ifdef MSDOS - printf("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); + printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); +#endif +#ifdef DJGPP + printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"); #endif #ifdef OS2 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" @@ -1311,9 +1314,6 @@ char *s; printf("\n\ Perl may be copied only under the terms of either the Artistic License or the\n\ GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n"); -#ifdef MSDOS - usage(origargv[0]); -#endif exit(0); case 'w': dowarn = TRUE; @@ -16,8 +16,12 @@ * Above symbol is defined via -D in 'x2p/Makefile.SH' * Decouple x2p stuff from some of perls more extreme eccentricities. */ -#undef MULTIPLICITY #undef EMBED +#undef NO_EMBED +#define NO_EMBED +#undef MULTIPLICITY +#undef HIDEMYMALLOC +#undef EMBEDMYMALLOC #undef USE_STDIO #define USE_STDIO #endif /* PERL_FOR_X2P */ @@ -50,6 +54,16 @@ #define VOIDUSED 1 #include "config.h" +/* + * SOFT_CAST can be used for args to prototyped functions to retain some + * type checking; it only casts if the compiler does not know prototypes. + */ +#if defined(CAN_PROTOTYPE) && defined(DEBUGGING_COMPILE) +#define SOFT_CAST(type) +#else +#define SOFT_CAST(type) (type) +#endif + #ifndef BYTEORDER # define BYTEORDER 0x1234 #endif @@ -179,8 +193,6 @@ #include <locale.h> #endif -EXT int lc_collate_active; - #ifdef METHOD /* Defined by OSF/1 v3.0 by ctype.h */ #undef METHOD #endif @@ -200,22 +212,34 @@ EXT int lc_collate_active; # 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. -*/ +/* 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. */ + #ifdef MYMALLOC + # ifdef HIDEMYMALLOC -# define malloc Mymalloc +# define malloc Mymalloc +# define calloc Mycalloc # define realloc Myremalloc -# define free Myfree -# define calloc Mycalloc +# define free Myfree +# endif +# ifdef EMBEDMYMALLOC +# define malloc Perl_malloc +# define calloc Perl_calloc +# define realloc Perl_realloc +# define free Perl_free # endif -# define safemalloc malloc + +# undef safemalloc +# undef safecalloc +# undef saferealloc +# undef safefree +# define safemalloc malloc +# define safecalloc calloc # define saferealloc realloc -# define safefree free -# define safecalloc calloc -#endif +# define safefree free + +#endif /* MYMALLOC */ #define MEM_SIZE Size_t @@ -335,10 +359,8 @@ EXT int lc_collate_active; # endif #endif -#ifndef MSDOS -# if defined(HAS_TIMES) && defined(I_SYS_TIMES) +#if defined(HAS_TIMES) && defined(I_SYS_TIMES) # include <sys/times.h> -# endif #endif #if defined(HAS_STRERROR) && (!defined(HAS_MKDIR) || !defined(HAS_RMDIR)) @@ -367,10 +389,8 @@ EXT int lc_collate_active; # define SETERRNO(errcode,vmserrcode) STMT_START {set_errno(errcode); set_vaxc_errno(vmserrcode);} STMT_END #endif -#ifndef MSDOS -# ifndef errno +#ifndef errno extern int errno; /* ANSI allows errno to be an lvalue expr */ -# endif #endif #ifdef HAS_STRERROR @@ -1140,16 +1160,15 @@ I32 unlnk _((char*)); #define SCAN_TR 1 #define SCAN_REPL 2 -#ifdef MYMALLOC -# ifndef DEBUGGING_MSTATS -# define DEBUGGING_MSTATS -# endif -#endif - #ifdef DEBUGGING # ifndef register # define register # endif +# ifdef MYMALLOC +# ifndef DEBUGGING_MSTATS +# define DEBUGGING_MSTATS +# endif +# endif # define PAD_SV(po) pad_sv(po) #else # define PAD_SV(po) curpad[po] @@ -1173,6 +1192,7 @@ EXT char *** environ_pointer; # endif #endif /* environ processing */ +EXT int lc_collate_active; EXT int uid; /* current real user id */ EXT int euid; /* current effective user id */ EXT int gid; /* current real group id */ @@ -1483,7 +1503,6 @@ EXT U32 hints; /* various compilation flags */ #define HINT_BLOCK_SCOPE 0x00000100 #define HINT_STRICT_SUBS 0x00000200 #define HINT_STRICT_VARS 0x00000400 -#define HINT_STRICT_UNTIE 0x00000800 /**************************************************************************/ /* This regexp stuff is global since it always happens within 1 expr eval */ @@ -1792,6 +1811,8 @@ EXT MGVTBL vtbl_pos = {magic_getpos, 0, 0, 0}; EXT MGVTBL vtbl_bm = {0, magic_setbm, 0, 0, 0}; +EXT MGVTBL vtbl_fm = {0, magic_setfm, + 0, 0, 0}; EXT MGVTBL vtbl_uvar = {magic_getuvar, magic_setuvar, 0, 0, 0}; @@ -1823,6 +1844,7 @@ EXT MGVTBL vtbl_substr; EXT MGVTBL vtbl_vec; EXT MGVTBL vtbl_pos; EXT MGVTBL vtbl_bm; +EXT MGVTBL vtbl_fm; EXT MGVTBL vtbl_uvar; #ifdef OVERLOAD diff --git a/perl_exp.SH b/perl_exp.SH index 3a44e279b2..821c4d5e91 100755 --- a/perl_exp.SH +++ b/perl_exp.SH @@ -28,7 +28,7 @@ sed -n '/^[A-Za-z]/ p' interp.sym >> perl.exp cat <<END >> perl.exp perl_init_ext perl_init_fold -perl_init_i18nl14n +perl_init_i18nl10n perl_alloc perl_construct perl_destruct @@ -14,28 +14,31 @@ dep() #define YYERRCODE 256 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, 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, 22, 22, 23, 23, 23, 20, - 15, 16, 17, 18, 19, 24, 24, 24, 24, + 40, 0, 7, 5, 8, 9, 6, 10, 10, 10, + 11, 11, 11, 11, 23, 23, 23, 23, 23, 23, + 14, 14, 14, 13, 13, 13, 13, 37, 37, 12, + 12, 12, 12, 12, 12, 12, 41, 42, 12, 12, + 25, 25, 26, 26, 27, 28, 29, 30, 39, 39, + 1, 1, 1, 1, 3, 3, 43, 43, 36, 36, + 4, 44, 44, 45, 15, 15, 15, 24, 24, 24, + 34, 34, 34, 34, 34, 34, 34, 34, 35, 35, + 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, + 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, + 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, + 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, + 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, + 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, + 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, + 16, 16, 16, 16, 31, 31, 32, 32, 32, 2, + 2, 38, 22, 17, 18, 19, 20, 21, 33, 33, + 33, 33, }; 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, + 0, 2, 4, 0, 5, 0, 0, 0, 2, 2, + 2, 1, 2, 3, 1, 1, 3, 3, 3, 3, + 0, 2, 6, 7, 7, 4, 4, 0, 2, 8, + 8, 5, 5, 10, 8, 8, 0, 0, 13, 3, + 0, 1, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 4, 3, 5, 5, 0, 1, 0, 3, 2, 6, 3, 3, 1, 2, 3, 1, 3, 5, 6, 3, 5, 2, 4, 4, 1, 1, @@ -46,1071 +49,995 @@ short yylen[] = { 2, 5, 6, 5, 6, 5, 4, 5, 1, 1, 3, 4, 3, 2, 2, 4, 5, 4, 5, 1, 2, 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, + 4, 6, 1, 1, 0, 1, 0, 1, 2, 1, + 1, 1, 2, 2, 2, 2, 2, 2, 1, 1, + 1, 1, }; short yydefred[] = { 1, - 0, 5, 0, 40, 51, 51, 0, 51, 6, 41, - 7, 9, 0, 42, 43, 44, 0, 0, 0, 53, - 0, 12, 4, 143, 0, 0, 118, 0, 138, 0, - 51, 51, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 8, 0, 50, 61, 61, 0, 61, 9, 51, + 10, 12, 0, 52, 53, 54, 0, 0, 0, 63, + 0, 15, 4, 153, 0, 0, 128, 0, 148, 0, + 61, 61, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 160, 161, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 13, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 11, 0, 0, + 0, 0, 118, 120, 0, 0, 0, 0, 154, 0, + 56, 0, 62, 0, 8, 169, 172, 171, 170, 0, + 0, 0, 0, 0, 0, 4, 0, 4, 0, 4, + 0, 4, 0, 4, 4, 0, 0, 0, 0, 0, + 167, 0, 134, 0, 0, 0, 0, 0, 163, 0, + 0, 0, 0, 76, 0, 143, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 108, 0, 164, 165, + 166, 168, 0, 0, 40, 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, 8, 0, 0, 0, 0, - 0, 108, 110, 0, 0, 0, 144, 0, 46, 0, - 52, 0, 5, 156, 159, 158, 157, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 154, 0, 124, - 0, 0, 0, 0, 0, 0, 150, 0, 0, 0, - 0, 66, 0, 133, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 98, 0, 151, 152, 153, 155, - 0, 34, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 90, 91, 0, 0, 0, 0, - 0, 0, 0, 0, 11, 45, 50, 0, 0, 0, - 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 36, 0, 137, 139, - 0, 0, 0, 0, 0, 0, 100, 0, 122, 0, - 0, 0, 97, 26, 0, 0, 0, 0, 0, 0, - 55, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 69, 0, 70, - 0, 0, 0, 0, 0, 0, 0, 120, 0, 48, - 47, 0, 3, 0, 141, 0, 68, 101, 0, 29, - 0, 30, 0, 0, 0, 23, 0, 24, 0, 0, - 0, 140, 149, 67, 0, 125, 0, 127, 0, 99, - 0, 0, 0, 0, 0, 0, 0, 107, 0, 105, - 0, 116, 0, 121, 54, 65, 0, 0, 0, 0, - 19, 0, 0, 0, 0, 0, 62, 126, 128, 115, - 0, 113, 0, 0, 106, 0, 111, 117, 103, 142, - 27, 28, 21, 0, 22, 0, 32, 0, 114, 112, - 63, 0, 0, 31, 0, 0, 20, 33, + 0, 0, 0, 0, 0, 0, 100, 101, 0, 0, + 0, 0, 0, 0, 0, 0, 14, 0, 55, 60, + 0, 0, 0, 74, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 147, + 149, 0, 0, 0, 0, 0, 0, 110, 0, 132, + 0, 0, 0, 107, 29, 0, 0, 20, 0, 0, + 0, 65, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 79, 0, + 80, 0, 0, 0, 0, 0, 0, 0, 130, 0, + 0, 58, 57, 0, 3, 0, 151, 0, 78, 111, + 0, 47, 0, 32, 48, 0, 33, 0, 0, 0, + 0, 26, 0, 27, 162, 0, 0, 42, 0, 0, + 150, 159, 77, 0, 135, 0, 137, 0, 109, 0, + 0, 0, 0, 0, 0, 0, 117, 0, 115, 0, + 126, 0, 131, 64, 75, 0, 0, 0, 0, 6, + 22, 0, 0, 0, 0, 37, 0, 72, 136, 138, + 125, 0, 123, 0, 0, 116, 0, 121, 127, 113, + 152, 0, 0, 0, 7, 0, 0, 0, 0, 0, + 0, 124, 122, 73, 30, 31, 24, 8, 0, 25, + 0, 36, 0, 35, 0, 0, 0, 38, 5, 23, + 34, 0, 0, 0, 39, }; short yydgoto[] = { 1, - 9, 10, 83, 17, 86, 3, 11, 12, 66, 195, - 266, 67, 202, 69, 70, 71, 72, 73, 74, 75, - 197, 122, 203, 88, 187, 77, 241, 178, 13, 142, - 2, 14, 15, 16, + 9, 66, 10, 17, 85, 348, 88, 311, 335, 3, + 11, 12, 68, 272, 203, 70, 71, 72, 73, 74, + 75, 76, 278, 78, 279, 262, 265, 269, 263, 266, + 124, 204, 90, 79, 242, 181, 145, 276, 13, 2, + 340, 362, 14, 15, 16, }; short yysindex[] = { 0, - 0, 0, 303, 0, 0, 0, -53, 0, 0, 0, - 0, 0, 607, 0, 0, 0, -111, -242, -32, 0, - -216, 0, 0, 0, 149, 149, 0, 8, 0, 2109, - 0, 0, -15, -8, 4, 6, 32, 2109, 13, 20, - 57, 149, 994, 2109, 1057, -206, 149, 2109, 938, 1291, - 2109, 2109, 2109, 2109, 2109, 1347, 0, 2109, 2109, 1403, - 149, 149, 149, 149, -203, 0, 68, 664, 491, -67, - -52, 0, 0, -21, 73, 65, 0, 7, 0, -135, - 0, -126, 0, 0, 0, 0, 0, 2109, 92, 2109, - 491, 7, -135, 2109, 7, 2109, 7, 2109, 7, 2109, - 7, 1466, 101, 491, 112, 1700, 938, 0, 102, 0, - 1228, -22, 1228, 39, -58, 2109, 0, 68, 0, 68, - -67, 0, 2109, 0, 1228, 472, 472, 472, -88, -88, - 78, -10, 472, 472, 0, -85, 0, 0, 0, 0, - 7, 0, 2109, 2109, 2109, 2109, 2109, 2109, 2109, 2109, - 2109, 2109, 2109, 2109, 2109, 2109, 2109, 2109, 2109, 2109, - 2109, 2109, 2109, 2109, 0, 0, -29, 2109, 2109, 2109, - 2109, 2109, 2109, 1756, 0, 0, 0, -46, 2109, 391, - 0, 2109, -25, 2109, 7, -214, 129, -203, -5, -203, - 1, -167, 9, -167, 117, 52, 0, 2109, 0, 0, - 23, 60, 132, 2109, 1812, 1875, 0, 53, 0, 68, - 2109, 86, 0, 0, 491, -214, -214, -214, -214, -147, - 0, -54, 382, 1228, 1090, 771, 115, 491, 2942, 1523, - 314, 1554, 392, 677, 472, 472, 2109, 0, 2109, 0, - 141, 89, -42, 99, 46, 114, 64, 0, 26, 0, - 0, 124, 0, 143, 0, 2109, 0, 0, 7, 0, - 7, 0, 7, 7, 146, 0, 7, 0, 2109, 7, - 35, 0, 0, 0, 37, 0, 49, 0, 55, 0, - 130, 2109, 63, 2109, 67, 166, 2109, 0, 66, 0, - 71, 0, 74, 0, 0, 0, 1170, -203, -203, -167, - 0, 2109, -167, 131, -203, 7, 0, 0, 0, 0, - 185, 0, 1119, 76, 0, 161, 0, 0, 0, 0, - 0, 0, 0, 58, 0, 1466, 0, -203, 0, 0, - 0, 7, 162, 0, -167, 7, 0, 0, + 0, 0, 408, 0, 0, 0, -36, 0, 0, 0, + 0, 0, 618, 0, 0, 0, -116, -216, -12, 0, + -203, 0, 0, 0, 68, 68, 0, 16, 0, 1972, + 0, 0, -6, 5, 6, 21, -34, 1972, 22, 26, + 31, 68, 950, 1006, -176, 0, 0, 68, 1972, -21, + 1070, 1972, 1972, 1972, 1972, 1972, 1346, 0, 1972, 1972, + 1402, 68, 68, 68, 68, 1972, -202, 0, 287, 3838, + -59, -56, 0, 0, -35, 57, 41, 63, 0, -9, + 0, -150, 0, -145, 0, 0, 0, 0, 0, 1972, + 87, 1972, 3838, -9, -150, 0, -9, 0, -9, 0, + -9, 0, -9, 0, 0, 90, 3838, 91, 1461, -21, + 0, 103, 0, 267, -7, 23, -50, 1972, 0, 63, + 0, -59, 63, 0, 1972, 0, 267, 611, 611, 611, + -86, -86, 62, -38, 611, 611, 0, -83, 0, 0, + 0, 0, 267, -9, 0, 1972, 1972, 1972, 1972, 1972, + 1972, 1972, 1972, 1972, 1972, 1972, 1972, 1972, 1972, 1972, + 1972, 1972, 1972, 1972, 1972, 1972, 0, 0, -28, 1972, + 1972, 1972, 1972, 1972, 1972, 1521, 0, 1972, 0, 0, + -33, 1972, 225, 0, 1972, 2008, 1972, -9, 1972, -202, + 1972, -202, 1972, -208, 1972, -208, 95, 1797, 1972, 0, + 0, -30, 7, 114, 1972, 1853, 1909, 0, 25, 0, + 63, 1972, 73, 0, 0, -173, -173, 0, -173, -173, + -140, 0, -46, 3340, 267, 2662, 374, 1221, 3838, 3801, + 3898, 1616, 3272, 320, 383, 611, 611, 1972, 0, 1972, + 0, 127, -79, -41, -73, 40, -43, 59, 0, -16, + 3838, 0, 0, 111, 0, 130, 0, 1972, 0, 0, + -173, 0, 136, 0, 0, 138, 0, -173, 142, 58, + 144, 0, 146, 0, 0, 149, 369, 0, 131, -14, + 0, 0, 0, -11, 0, -3, 0, -1, 0, 113, + 1972, 70, 1972, 66, 140, 1972, 0, 71, 0, 72, + 0, 79, 0, 0, 0, 1675, 58, 58, 58, 0, + 0, 1972, 58, 1972, 58, 0, -9, 0, 0, 0, + 0, 182, 0, 3868, 84, 0, 170, 0, 0, 0, + 0, -202, -202, -208, 0, 173, -208, 1, -202, 1972, + -202, 0, 0, 0, 0, 0, 0, 0, 58, 0, + 58, 0, 156, 0, 343, -208, -202, 0, 0, 0, + 0, 1797, 177, 58, 0, }; short yyrindex[] = { 0, - 0, 0, 269, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 165, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 2241, 1964, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 2857, 2901, + 0, 0, 0, 0, 0, 0, 0, 2164, 426, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 2786, + 2862, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 49, 0, 18, 293, + 2907, 2987, 0, 0, 2209, 2062, 0, 373, 0, 0, + 0, -20, 0, 0, 0, 0, 0, 0, 0, 2260, + 0, 0, 1179, 0, 96, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 1299, 0, 0, 179, + 0, 2121, 0, 3614, 2907, 0, 0, 2260, 0, 2319, + 493, 559, 2461, 0, 0, 0, 3653, 3142, 3183, 3222, + 3049, 3097, 2523, 0, 3268, 3316, 0, 0, 0, 0, + 0, 0, 3727, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 107, 0, 360, -1, 62, 3027, - 3078, 0, 0, 2286, 2020, 0, 0, 0, 0, -12, - 0, 0, 0, 0, 0, 0, 0, 2415, 0, 0, - 1251, 0, 82, 173, 0, 0, 0, 0, 0, 0, - 0, 157, 0, 1661, 0, 0, 178, 0, 2150, 0, - 3927, 3027, 3958, 0, 0, 2415, 0, 2537, 454, 2581, - 548, 0, 0, 0, 3989, 3384, 3425, 3461, 3122, 3163, - 2636, 0, 3497, 3533, 0, 0, 0, 0, 0, 0, - 0, 0, 2680, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 2582, 0, 0, + 0, 167, 894, 0, 179, 0, 2260, 0, 190, 49, + 0, 49, 0, 109, 0, 109, 0, 188, 0, 0, + 0, 0, 210, 0, 0, 0, 0, 0, 0, 0, + 2627, 0, 2724, 0, 0, 24, 39, 0, 52, 60, + 1307, 0, 0, 1046, 1187, 1243, 1131, 3503, 1575, 0, + 3770, 1639, 1583, 2399, 3551, 3418, 3457, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 163, 882, - 0, 178, 0, 2415, 0, 2, 0, 107, 0, 107, - 0, 175, 0, 175, 0, 165, 0, 0, 0, 0, - 0, 180, 0, 0, 0, 0, 0, 0, 0, 2723, - 0, 2985, 0, 0, 2785, 11, 14, 33, 59, 833, - 0, 0, -30, 4020, 4036, 3817, 3850, 3275, 0, 1611, - 4179, 4114, 4098, 3894, 3569, 3646, 0, 0, 0, 0, + 1729, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 65, 0, 0, 0, 0, 0, 0, 226, 0, 0, + 0, 0, 0, 0, 0, 0, 215, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 179, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 168, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 178, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 107, 107, 175, - 0, 0, 175, 0, 107, 0, 0, 0, 0, 0, - 0, 0, 2462, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 190, 0, 107, 0, 0, - 0, 0, 0, 0, 175, 0, 0, 0, + 0, 0, 0, 845, 0, 0, 0, 0, 0, 0, + 0, 49, 49, 109, 0, 0, 109, 0, 49, 227, + 49, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 894, 109, 49, 0, 0, 0, + 0, 257, 0, 0, 0, }; short yygindex[] = { 0, - 0, 0, 0, 148, -13, 106, 0, 0, 0, -91, - -184, 452, -11, 4373, 886, 0, 0, 0, 0, 0, - 234, -62, -173, 460, -20, 0, 0, 174, 0, -131, - 0, 0, 0, 0, + 0, 0, 0, 47, 416, 0, 447, 194, 0, -84, + 0, 0, 0, -168, -13, 3819, 917, 0, 0, 0, + 0, 0, 291, 901, -62, -29, 197, 14, 0, 150, + -61, -181, 10, 0, 0, 253, 637, 0, 0, 0, + 0, 0, 0, 0, 0, }; -#define YYTABLESIZE 4657 -short yytable[] = { 65, - 208, 68, 168, 79, 283, 20, 61, 213, 254, 268, - 80, 23, 250, 80, 80, 255, 289, 206, 256, 95, - 97, 99, 101, 170, 94, 181, 81, 80, 80, 110, - 212, 96, 80, 115, 150, 261, 124, 157, 172, 13, - 82, 263, 38, 98, 132, 100, 49, 90, 136, 267, - 116, 16, 105, 209, 17, 169, 260, 13, 262, 106, - 38, 239, 80, 272, 176, 168, 294, 61, 170, 16, - 171, 102, 17, 14, 141, 306, 23, 307, 184, 148, - 149, 188, 186, 190, 189, 192, 191, 194, 193, 308, - 196, 14, 270, 237, 201, 309, 107, 150, 332, 15, - 169, 173, 60, 273, 291, 60, 25, 23, 264, 265, - 49, 143, 174, 316, 23, 323, 252, 15, 325, 60, - 60, 257, 293, 175, 177, 314, 23, 214, 23, 23, - 179, 182, 216, 217, 218, 219, 220, 221, 222, 25, - 198, 205, 25, 25, 25, 78, 25, 149, 25, 25, - 337, 25, 199, 18, 60, 21, 242, 243, 244, 245, - 246, 247, 249, 207, 251, 25, 321, 322, 211, 259, - 25, 258, 274, 327, 18, 269, 282, 280, 92, 93, - 287, 288, 295, 296, 61, 302, 271, 312, 180, 326, - 317, 290, 275, 277, 279, 318, 334, 25, 319, 281, - 330, 331, 336, 19, 49, 168, 292, 18, 148, 149, - 18, 18, 18, 37, 18, 35, 18, 18, 147, 18, - 148, 145, 310, 13, 167, 285, 37, 286, 238, 25, - 35, 25, 25, 18, 333, 148, 149, 150, 18, 148, - 149, 80, 80, 80, 80, 298, 76, 299, 304, 300, - 301, 148, 149, 303, 0, 151, 305, 186, 315, 152, - 153, 154, 155, 80, 80, 18, 185, 80, 2, 0, - 311, 23, 156, 158, 159, 160, 161, 329, 162, 163, - 0, 0, 164, 148, 149, 165, 166, 167, 148, 149, - 324, 0, 328, 0, 148, 149, 0, 18, 0, 18, - 18, 39, 148, 149, 39, 39, 39, 0, 39, 0, - 39, 39, 0, 39, 68, 0, 148, 149, 335, 148, - 149, 0, 338, 144, 145, 146, 147, 39, 148, 149, - 148, 149, 39, 60, 60, 60, 60, 0, 0, 148, - 149, 0, 148, 149, 0, 148, 149, 0, 148, 149, - 0, 148, 149, 148, 149, 60, 60, 148, 149, 39, - 148, 149, 25, 25, 25, 25, 25, 25, 0, 25, - 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, - 25, 25, 148, 149, 0, 25, 25, 0, 25, 25, - 25, 39, 148, 149, 39, 25, 25, 25, 25, 25, - 57, 154, 25, 25, 168, 84, 0, 148, 149, 25, - 85, 0, 0, 25, 0, 25, 25, 0, 57, 163, - 0, 0, 164, 148, 149, 165, 166, 167, 0, 0, - 18, 18, 18, 18, 18, 18, 150, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 0, 0, 57, 18, 18, 0, 18, 18, 18, 148, - 149, 0, 0, 18, 18, 18, 18, 18, 0, 0, - 18, 18, 168, 0, 0, 0, 0, 18, 148, 149, - 0, 18, 168, 18, 18, 89, 156, 0, 0, 156, - 156, 156, 0, 156, 143, 156, 156, 143, 156, 118, - 120, 108, 0, 0, 150, 0, 117, 0, 123, 0, - 0, 143, 143, 0, 150, 253, 143, 156, 0, 0, - 137, 138, 139, 140, 39, 39, 39, 39, 39, 39, - 0, 39, 39, 39, 0, 0, 0, 39, 0, 120, - 39, 39, 39, 39, 143, 0, 143, 39, 39, 0, - 39, 39, 39, 157, 0, 0, 0, 39, 39, 39, - 39, 39, 168, 0, 39, 39, 204, 120, 4, 5, - 6, 39, 7, 8, 210, 39, 143, 39, 39, 156, - 157, 168, 0, 157, 157, 157, 0, 157, 102, 157, - 157, 102, 157, 0, 150, 0, 0, 0, 152, 153, - 154, 155, 0, 0, 0, 102, 102, 0, 0, 0, - 102, 157, 0, 150, 160, 161, 0, 162, 163, 0, - 0, 164, 0, 0, 165, 166, 167, 0, 0, 0, - 120, 57, 57, 57, 57, 120, 0, 0, 0, 51, - 102, 0, 61, 63, 47, 0, 56, 0, 64, 59, - 0, 58, 0, 57, 57, 0, 4, 5, 6, 0, - 7, 8, 0, 0, 0, 57, 152, 153, 154, 155, - 62, 0, 0, 157, 0, 0, 152, 153, 154, 155, - 158, 159, 160, 161, 0, 162, 163, 0, 0, 164, - 0, 0, 165, 166, 167, 162, 163, 60, 0, 164, - 0, 0, 165, 166, 167, 0, 0, 0, 0, 0, - 156, 156, 156, 156, 156, 0, 156, 156, 156, 0, - 0, 0, 156, 0, 0, 143, 143, 143, 143, 23, - 0, 0, 52, 156, 143, 156, 156, 156, 143, 143, - 143, 143, 156, 156, 156, 156, 156, 143, 143, 156, - 156, 143, 143, 143, 143, 143, 156, 143, 143, 0, - 156, 143, 156, 156, 143, 143, 143, 168, 0, 0, - 0, 151, 0, 0, 0, 152, 153, 154, 155, 164, - 0, 0, 165, 166, 167, 0, 0, 0, 156, 158, - 159, 160, 161, 0, 162, 163, 0, 0, 164, 150, - 0, 165, 166, 167, 157, 157, 157, 157, 157, 0, - 157, 157, 157, 0, 0, 0, 157, 0, 0, 102, - 102, 102, 102, 0, 0, 0, 0, 157, 102, 157, - 157, 157, 102, 102, 102, 102, 157, 157, 157, 157, - 157, 102, 102, 157, 157, 102, 102, 102, 102, 102, - 157, 102, 102, 0, 157, 102, 157, 157, 102, 102, - 102, 168, 22, 24, 25, 26, 27, 28, 0, 29, - 30, 31, 0, 56, 0, 32, 56, 0, 33, 34, - 35, 36, 0, 0, 0, 37, 38, 0, 39, 40, - 41, 56, 0, 150, 0, 42, 43, 44, 45, 46, - 0, 0, 48, 49, 0, 0, 0, 0, 0, 50, - 87, 87, 0, 53, 39, 54, 55, 39, 39, 39, - 0, 39, 103, 39, 39, 56, 39, 87, 112, 0, - 0, 0, 87, 0, 121, 144, 145, 146, 147, 0, - 39, 0, 0, 0, 0, 39, 87, 87, 87, 87, - 0, 0, 0, 0, 0, 0, 0, 148, 149, 0, - 0, 0, 0, 154, 155, 0, 0, 0, 0, 0, - 51, 0, 39, 61, 63, 47, 0, 56, 0, 64, - 59, 163, 58, 0, 164, 0, 0, 165, 166, 167, - 0, 0, 121, 0, 0, 0, 0, 0, 0, 0, - 0, 62, 0, 0, 39, 0, 0, 39, 0, 0, +#define YYTABLESIZE 4212 +short yytable[] = { 69, + 183, 62, 213, 256, 170, 105, 23, 62, 209, 214, + 281, 52, 292, 297, 62, 64, 48, 298, 57, 299, + 65, 60, 20, 59, 303, 252, 317, 274, 184, 318, + 117, 172, 207, 96, 174, 91, 152, 319, 59, 320, + 82, 351, 63, 134, 98, 100, 83, 138, 28, 301, + 282, 111, 18, 84, 21, 92, 210, 119, 16, 125, + 102, 108, 240, 171, 19, 109, 173, 270, 271, 61, + 110, 139, 140, 141, 142, 144, 16, 94, 95, 45, + 118, 28, 19, 172, 28, 28, 28, 175, 28, 23, + 28, 28, 17, 28, 238, 202, 176, 45, 300, 177, + 18, 23, 59, 62, 53, 44, 178, 28, 21, 180, + 17, 182, 28, 23, 327, 171, 23, 302, 18, 205, + 254, 150, 151, 44, 325, 259, 185, 23, 23, 199, + 62, 200, 216, 217, 219, 220, 221, 222, 223, 28, + 80, 21, 206, 23, 21, 21, 21, 208, 21, 289, + 21, 21, 212, 21, 283, 151, 243, 244, 245, 246, + 247, 248, 250, 291, 2, 347, 296, 21, 350, 304, + 305, 28, 21, 28, 28, 261, 307, 217, 308, 268, + 310, 217, 309, 312, 277, 280, 313, 360, 314, 316, + 23, 284, 286, 288, 323, 328, 329, 49, 290, 21, + 49, 49, 49, 330, 49, 321, 49, 49, 343, 49, + 344, 150, 151, 349, 358, 150, 151, 364, 59, 157, + 19, 150, 151, 49, 294, 155, 295, 169, 49, 239, + 43, 21, 326, 21, 21, 121, 25, 26, 27, 28, + 87, 29, 30, 31, 150, 151, 41, 32, 150, 151, + 158, 150, 151, 150, 151, 49, 150, 151, 38, 104, + 39, 40, 41, 355, 150, 151, 46, 42, 43, 44, + 45, 46, 47, 16, 342, 49, 50, 322, 150, 151, + 150, 151, 51, 150, 151, 43, 54, 49, 55, 56, + 49, 150, 151, 150, 151, 150, 151, 41, 268, 363, + 338, 150, 151, 77, 28, 28, 28, 28, 28, 28, + 353, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 28, 28, 28, 28, 86, 336, 261, 28, 28, 87, + 28, 28, 28, 70, 150, 151, 70, 28, 28, 28, + 28, 28, 28, 218, 273, 28, 28, 188, 69, 255, + 70, 70, 28, 150, 151, 0, 28, 170, 28, 28, + 150, 151, 0, 0, 21, 21, 21, 21, 21, 21, + 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 0, 70, 0, 21, 21, 152, + 21, 21, 21, 0, 0, 0, 0, 21, 21, 21, + 21, 21, 21, 0, 0, 21, 21, 150, 151, 315, + 170, 0, 21, 67, 0, 0, 21, 0, 21, 21, + 49, 49, 49, 49, 49, 49, 0, 49, 49, 49, + 0, 67, 0, 49, 150, 151, 49, 49, 49, 49, + 0, 0, 152, 49, 49, 0, 49, 49, 49, 0, + 0, 0, 0, 49, 49, 49, 49, 49, 49, 67, + 0, 49, 49, 81, 170, 67, 146, 359, 49, 146, + 0, 0, 49, 170, 49, 49, 150, 151, 0, 97, + 99, 101, 103, 146, 146, 0, 0, 0, 146, 113, + 4, 5, 6, 0, 7, 8, 152, 126, 0, 0, + 332, 333, 334, 0, 0, 152, 337, 0, 339, 0, + 0, 189, 0, 191, 0, 193, 146, 195, 146, 197, + 198, 0, 0, 0, 0, 169, 179, 0, 169, 169, + 169, 0, 169, 153, 169, 169, 153, 169, 0, 0, + 187, 0, 356, 190, 357, 192, 0, 194, 146, 196, + 153, 153, 0, 156, 157, 153, 169, 365, 146, 147, + 148, 149, 0, 0, 70, 70, 70, 70, 0, 0, + 0, 164, 165, 0, 0, 166, 0, 0, 167, 168, + 169, 150, 151, 153, 0, 153, 0, 70, 70, 0, + 215, 170, 0, 0, 170, 170, 170, 0, 170, 112, + 170, 170, 112, 170, 154, 155, 156, 157, 4, 5, + 6, 0, 7, 8, 0, 153, 112, 112, 169, 0, + 0, 112, 170, 0, 164, 165, 0, 253, 166, 0, + 0, 167, 168, 169, 260, 0, 0, 0, 0, 0, + 146, 147, 148, 149, 67, 67, 67, 67, 0, 0, + 52, 112, 0, 62, 64, 48, 0, 57, 0, 65, + 60, 0, 59, 150, 151, 0, 0, 67, 67, 156, + 157, 0, 0, 4, 5, 6, 58, 7, 8, 165, + 0, 63, 166, 0, 170, 167, 168, 169, 165, 0, + 0, 166, 0, 0, 167, 168, 169, 146, 146, 146, + 146, 170, 0, 0, 0, 0, 146, 0, 61, 0, + 146, 146, 146, 146, 0, 0, 0, 0, 0, 0, + 146, 146, 0, 0, 146, 146, 146, 146, 146, 0, + 146, 146, 0, 152, 146, 0, 0, 146, 146, 146, + 23, 0, 0, 53, 0, 0, 0, 0, 0, 169, + 169, 169, 169, 169, 0, 169, 169, 169, 0, 0, + 0, 169, 0, 341, 153, 153, 153, 153, 0, 0, + 0, 0, 169, 153, 169, 169, 169, 153, 153, 153, + 153, 169, 169, 169, 169, 169, 169, 153, 153, 169, + 169, 153, 153, 153, 153, 153, 169, 153, 153, 0, + 169, 153, 169, 169, 153, 153, 153, 0, 0, 0, + 0, 0, 0, 0, 0, 170, 170, 170, 170, 170, + 0, 170, 170, 170, 0, 0, 264, 170, 267, 0, + 112, 112, 112, 112, 0, 0, 0, 0, 170, 112, + 170, 170, 170, 112, 112, 112, 112, 170, 170, 170, + 170, 170, 170, 112, 112, 170, 170, 112, 112, 112, + 112, 112, 170, 112, 112, 0, 170, 112, 170, 170, + 112, 112, 112, 22, 24, 25, 26, 27, 28, 0, + 29, 30, 31, 0, 0, 93, 32, 0, 93, 33, + 34, 35, 36, 0, 0, 0, 37, 38, 0, 39, + 40, 41, 93, 93, 0, 0, 42, 43, 44, 45, + 46, 47, 0, 0, 49, 50, 0, 0, 0, 166, + 0, 51, 167, 168, 169, 54, 49, 55, 56, 49, + 49, 49, 0, 49, 0, 49, 49, 93, 49, 0, + 0, 89, 89, 0, 0, 0, 0, 0, 0, 120, + 123, 0, 49, 106, 0, 0, 0, 49, 89, 115, + 0, 0, 0, 0, 89, 0, 122, 0, 345, 346, + 0, 0, 0, 0, 0, 352, 0, 354, 89, 89, + 89, 89, 52, 0, 49, 62, 64, 48, 0, 57, + 123, 65, 60, 361, 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 51, 0, 60, 61, - 63, 47, 0, 56, 0, 64, 59, 0, 58, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 240, 0, 0, 0, 0, 62, 0, 0, - 23, 0, 0, 52, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 163, 0, 0, 164, 0, - 0, 165, 166, 167, 60, 0, 0, 0, 0, 51, - 0, 0, 61, 63, 47, 0, 56, 0, 64, 59, - 0, 58, 0, 0, 56, 56, 56, 56, 0, 0, - 0, 0, 0, 0, 0, 114, 23, 0, 0, 52, - 62, 0, 0, 0, 0, 0, 56, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 39, 39, 39, - 39, 39, 39, 0, 39, 39, 39, 60, 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, 0, - 168, 157, 52, 0, 39, 0, 0, 0, 39, 0, - 39, 39, 0, 0, 119, 25, 26, 27, 28, 85, - 29, 30, 31, 0, 0, 0, 32, 0, 0, 168, - 320, 0, 150, 0, 0, 0, 0, 38, 0, 39, - 40, 41, 0, 0, 0, 0, 42, 43, 44, 45, - 46, 0, 157, 48, 49, 0, 0, 0, 0, 0, - 50, 150, 0, 0, 53, 0, 54, 55, 0, 0, - 109, 25, 26, 27, 28, 0, 29, 30, 31, 0, - 168, 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, 48, - 49, 135, 150, 0, 135, 0, 50, 0, 0, 0, - 53, 0, 54, 55, 0, 0, 0, 0, 135, 135, - 0, 0, 0, 24, 25, 26, 27, 28, 168, 29, - 30, 31, 0, 51, 0, 32, 61, 63, 47, 0, - 56, 0, 64, 59, 0, 58, 38, 0, 39, 40, - 41, 0, 0, 135, 0, 42, 43, 44, 45, 46, - 150, 0, 48, 49, 62, 0, 0, 0, 0, 50, - 0, 0, 0, 53, 0, 54, 55, 0, 0, 0, - 0, 0, 0, 0, 152, 0, 154, 155, 0, 51, - 0, 60, 61, 63, 47, 0, 56, 131, 64, 59, - 0, 58, 0, 162, 163, 0, 0, 164, 0, 151, - 165, 166, 167, 152, 153, 154, 155, 0, 0, 0, - 62, 0, 0, 23, 0, 0, 52, 158, 159, 160, - 161, 0, 162, 163, 0, 0, 164, 0, 0, 165, - 166, 167, 0, 0, 0, 51, 0, 60, 61, 63, - 47, 0, 56, 0, 64, 59, 0, 58, 0, 0, - 151, 0, 0, 0, 152, 153, 154, 155, 0, 0, - 0, 0, 0, 0, 0, 0, 62, 156, 158, 159, - 160, 161, 52, 162, 163, 0, 0, 164, 0, 0, - 165, 166, 167, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 60, 0, 135, 0, 0, 51, 0, - 0, 61, 63, 47, 0, 56, 0, 64, 59, 0, - 58, 0, 0, 0, 154, 155, 0, 0, 0, 0, - 0, 0, 135, 135, 135, 135, 0, 0, 52, 62, - 0, 162, 163, 0, 0, 164, 0, 0, 165, 166, - 167, 0, 0, 0, 135, 135, 0, 24, 25, 26, - 27, 28, 0, 29, 30, 31, 60, 0, 0, 32, + 0, 0, 0, 63, 0, 0, 49, 0, 123, 49, + 0, 0, 0, 0, 0, 211, 122, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 52, 0, + 61, 62, 64, 48, 0, 57, 0, 65, 60, 0, + 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 116, 0, 0, 0, 0, 63, + 0, 0, 23, 0, 0, 53, 0, 0, 0, 0, + 0, 0, 123, 0, 0, 241, 90, 123, 0, 90, + 0, 0, 0, 0, 0, 0, 61, 0, 0, 0, + 0, 0, 52, 90, 90, 62, 64, 48, 90, 57, + 0, 65, 60, 275, 59, 0, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 53, 0, 63, 0, 0, 0, 0, 90, 93, + 93, 0, 0, 93, 0, 0, 0, 0, 0, 49, + 49, 49, 49, 49, 49, 0, 49, 49, 49, 0, + 61, 0, 49, 0, 0, 49, 49, 49, 49, 0, + 0, 83, 49, 49, 83, 49, 49, 49, 0, 0, + 0, 0, 49, 49, 49, 49, 49, 49, 83, 83, + 49, 49, 23, 83, 0, 53, 0, 49, 0, 0, + 0, 49, 0, 49, 49, 0, 112, 25, 26, 27, + 28, 0, 29, 30, 31, 0, 0, 0, 32, 145, + 0, 0, 145, 83, 0, 0, 0, 86, 0, 38, + 86, 39, 40, 41, 0, 0, 145, 145, 42, 43, + 44, 45, 46, 47, 86, 86, 49, 50, 0, 86, + 0, 0, 0, 51, 0, 0, 0, 54, 0, 55, + 56, 0, 24, 25, 26, 27, 28, 0, 29, 30, + 31, 145, 0, 0, 32, 0, 0, 0, 0, 86, + 0, 0, 0, 87, 0, 38, 87, 39, 40, 41, + 0, 0, 0, 0, 42, 43, 44, 45, 46, 47, + 87, 87, 49, 50, 0, 87, 0, 0, 0, 51, + 0, 170, 0, 54, 0, 55, 56, 90, 90, 90, + 90, 0, 0, 0, 0, 0, 24, 25, 26, 27, + 28, 0, 29, 30, 31, 87, 0, 0, 32, 140, + 90, 90, 140, 152, 90, 0, 0, 66, 0, 38, + 66, 39, 40, 41, 0, 0, 140, 140, 42, 43, + 44, 45, 46, 47, 0, 66, 49, 50, 0, 0, + 0, 0, 0, 51, 0, 0, 0, 54, 52, 55, + 56, 62, 64, 48, 0, 57, 133, 65, 60, 0, + 59, 140, 0, 0, 0, 0, 0, 0, 0, 66, + 0, 0, 83, 83, 83, 83, 0, 0, 0, 63, + 0, 83, 0, 0, 0, 83, 83, 83, 83, 0, + 0, 0, 0, 0, 0, 83, 83, 0, 0, 83, + 83, 83, 83, 83, 52, 83, 61, 62, 64, 48, + 0, 57, 0, 65, 60, 0, 59, 0, 0, 0, + 145, 145, 145, 145, 0, 0, 0, 0, 86, 86, + 86, 86, 0, 0, 0, 63, 0, 86, 0, 0, + 0, 53, 86, 145, 145, 0, 0, 0, 0, 0, + 0, 86, 86, 0, 0, 86, 86, 86, 86, 86, + 0, 0, 61, 52, 137, 0, 62, 64, 48, 0, + 57, 201, 65, 60, 0, 59, 0, 156, 0, 0, + 0, 0, 0, 0, 87, 87, 87, 87, 0, 0, + 0, 0, 0, 87, 63, 0, 165, 53, 0, 166, + 0, 0, 167, 168, 169, 0, 0, 87, 87, 0, + 0, 87, 87, 87, 87, 87, 0, 0, 0, 0, + 0, 61, 0, 52, 0, 0, 62, 64, 48, 0, + 57, 249, 65, 60, 0, 59, 0, 0, 0, 0, + 140, 140, 140, 140, 0, 0, 0, 0, 66, 66, + 66, 66, 0, 0, 63, 0, 53, 0, 0, 0, + 0, 0, 0, 140, 140, 0, 0, 0, 0, 0, + 0, 66, 24, 25, 26, 27, 28, 0, 29, 30, + 31, 61, 0, 0, 32, 81, 0, 0, 81, 0, + 0, 0, 0, 89, 0, 38, 89, 39, 40, 41, + 0, 0, 81, 81, 42, 43, 44, 45, 46, 47, + 89, 89, 49, 50, 0, 89, 53, 0, 0, 51, + 0, 0, 0, 54, 0, 55, 56, 0, 24, 25, + 26, 27, 28, 0, 29, 30, 31, 81, 0, 0, + 32, 0, 0, 0, 0, 89, 0, 0, 0, 91, + 0, 38, 91, 39, 40, 41, 0, 0, 0, 0, + 42, 43, 44, 45, 46, 47, 91, 91, 49, 50, + 0, 91, 0, 0, 0, 51, 170, 0, 0, 54, + 0, 55, 56, 0, 0, 331, 0, 24, 25, 26, + 27, 28, 0, 29, 30, 31, 0, 0, 0, 32, + 0, 91, 0, 0, 0, 0, 0, 159, 152, 0, + 38, 0, 39, 40, 41, 0, 0, 0, 0, 42, + 43, 44, 45, 46, 47, 0, 0, 49, 50, 0, + 0, 0, 0, 0, 51, 170, 0, 0, 54, 69, + 55, 56, 69, 0, 0, 0, 0, 24, 25, 26, + 27, 28, 0, 29, 30, 31, 69, 69, 0, 32, + 0, 0, 0, 0, 0, 0, 0, 152, 0, 0, 38, 0, 39, 40, 41, 0, 0, 0, 0, 42, - 43, 44, 45, 46, 0, 0, 48, 49, 0, 0, - 0, 52, 0, 50, 0, 0, 0, 53, 0, 54, - 55, 0, 0, 24, 25, 26, 27, 28, 0, 29, - 30, 31, 0, 168, 0, 32, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 38, 0, 39, 40, + 43, 44, 45, 46, 47, 0, 0, 49, 50, 0, + 0, 69, 0, 0, 51, 0, 0, 0, 54, 52, + 55, 56, 62, 64, 48, 0, 57, 0, 65, 60, + 0, 59, 0, 0, 0, 0, 81, 81, 81, 81, + 0, 0, 0, 0, 89, 89, 89, 89, 0, 0, + 63, 0, 0, 89, 0, 0, 0, 0, 0, 81, + 81, 0, 0, 0, 0, 0, 0, 89, 89, 0, + 0, 89, 89, 89, 89, 52, 0, 61, 62, 64, + 48, 0, 57, 285, 65, 60, 0, 59, 0, 0, + 154, 155, 156, 157, 0, 0, 0, 0, 0, 0, + 91, 91, 91, 91, 0, 0, 63, 162, 163, 91, + 164, 165, 53, 0, 166, 0, 0, 167, 168, 169, + 0, 0, 0, 91, 91, 0, 0, 91, 91, 91, + 0, 52, 0, 61, 62, 64, 48, 0, 57, 287, + 65, 60, 0, 59, 0, 153, 0, 0, 0, 154, + 155, 156, 157, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 63, 158, 160, 161, 162, 163, 53, 164, + 165, 0, 0, 166, 0, 0, 167, 168, 169, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 61, + 69, 69, 69, 69, 52, 0, 0, 62, 64, 48, + 0, 57, 0, 65, 60, 0, 59, 0, 0, 0, + 0, 0, 0, 69, 69, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 53, 63, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 257, 0, + 0, 258, 22, 24, 25, 26, 27, 28, 0, 29, + 30, 31, 61, 0, 0, 32, 0, 0, 0, 0, + 159, 0, 0, 0, 0, 0, 38, 0, 39, 40, 41, 0, 0, 0, 0, 42, 43, 44, 45, 46, - 0, 0, 48, 49, 168, 150, 0, 0, 0, 50, - 0, 82, 0, 53, 82, 54, 55, 0, 0, 24, - 25, 26, 27, 28, 0, 29, 30, 31, 82, 82, - 0, 32, 0, 82, 0, 0, 150, 0, 0, 0, - 0, 0, 38, 0, 39, 40, 41, 0, 0, 0, - 0, 42, 43, 44, 45, 46, 0, 0, 48, 49, - 0, 130, 0, 82, 130, 50, 0, 0, 0, 53, - 0, 54, 55, 0, 0, 0, 0, 0, 130, 130, - 0, 22, 24, 25, 26, 27, 28, 0, 29, 30, - 31, 0, 51, 0, 32, 61, 63, 47, 0, 56, - 200, 64, 59, 0, 58, 38, 0, 39, 40, 41, - 0, 0, 0, 130, 42, 43, 44, 45, 46, 0, - 0, 48, 49, 62, 0, 0, 0, 0, 50, 0, - 0, 0, 53, 0, 54, 55, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 51, 0, - 60, 61, 63, 47, 0, 56, 248, 64, 59, 0, - 58, 0, 0, 0, 0, 0, 0, 152, 153, 154, - 155, 0, 0, 0, 0, 0, 0, 0, 0, 62, - 0, 0, 159, 160, 161, 52, 162, 163, 0, 0, - 164, 0, 0, 165, 166, 167, 0, 0, 152, 153, - 154, 155, 0, 0, 51, 0, 60, 61, 63, 47, - 0, 56, 276, 64, 59, 161, 58, 162, 163, 0, - 0, 164, 0, 0, 165, 166, 167, 0, 0, 0, - 0, 0, 0, 0, 0, 62, 0, 0, 0, 0, - 0, 52, 82, 82, 82, 82, 0, 0, 0, 0, - 0, 82, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 60, 0, 82, 82, 0, 51, 82, 82, - 61, 63, 47, 0, 56, 278, 64, 59, 0, 58, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 130, 130, 130, 130, 0, 52, 62, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 130, 130, 24, 25, 26, 27, - 28, 0, 29, 30, 31, 60, 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, 48, 49, 0, 0, 0, - 52, 0, 50, 0, 136, 0, 53, 136, 54, 55, - 0, 0, 24, 25, 26, 27, 28, 0, 29, 30, - 31, 136, 136, 0, 32, 0, 136, 0, 0, 0, - 0, 0, 0, 0, 0, 38, 0, 39, 40, 41, - 0, 0, 0, 0, 42, 43, 44, 45, 46, 0, - 0, 48, 49, 0, 136, 0, 136, 0, 50, 0, - 119, 0, 53, 119, 54, 55, 0, 0, 24, 25, - 26, 27, 28, 0, 29, 30, 31, 119, 119, 0, - 32, 0, 119, 0, 0, 0, 136, 0, 0, 0, - 0, 38, 0, 39, 40, 41, 0, 0, 0, 0, - 42, 43, 44, 45, 46, 0, 0, 48, 49, 0, - 119, 0, 119, 0, 50, 0, 0, 0, 53, 0, - 54, 55, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 24, 25, 26, 27, 28, 0, 29, 30, 31, - 0, 51, 119, 32, 61, 63, 47, 0, 56, 0, - 64, 59, 0, 58, 38, 0, 39, 40, 41, 0, - 0, 0, 0, 42, 43, 44, 45, 46, 0, 0, - 48, 49, 62, 0, 0, 0, 0, 50, 0, 0, - 0, 53, 0, 54, 55, 0, 0, 0, 0, 0, - 143, 0, 0, 143, 0, 0, 0, 0, 0, 60, - 0, 0, 0, 0, 0, 0, 0, 143, 143, 0, - 0, 0, 143, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 52, 136, 136, 136, 136, 0, - 143, 0, 143, 0, 136, 0, 0, 0, 136, 136, - 136, 136, 0, 0, 0, 0, 0, 136, 136, 0, - 0, 136, 136, 136, 136, 136, 0, 136, 136, 0, - 0, 136, 143, 0, 136, 136, 136, 0, 0, 0, - 0, 129, 0, 0, 129, 0, 0, 0, 0, 0, - 0, 119, 119, 119, 119, 0, 0, 0, 129, 129, - 119, 0, 0, 129, 119, 119, 119, 119, 0, 0, - 0, 0, 0, 119, 119, 0, 0, 119, 119, 119, - 119, 119, 0, 119, 119, 0, 104, 119, 0, 104, - 119, 119, 119, 129, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 104, 104, 0, 0, 0, 104, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 129, 0, 24, 25, 26, 27, 28, - 0, 29, 30, 31, 0, 0, 104, 32, 104, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 38, 0, + 47, 0, 0, 49, 50, 0, 0, 53, 170, 0, + 51, 0, 129, 0, 54, 129, 55, 56, 0, 24, + 25, 26, 27, 28, 0, 29, 30, 31, 0, 129, + 129, 32, 0, 0, 129, 0, 0, 0, 0, 0, + 152, 0, 38, 0, 39, 40, 41, 0, 0, 0, + 0, 42, 43, 44, 45, 46, 47, 0, 0, 49, + 50, 0, 129, 0, 129, 0, 51, 0, 0, 0, + 54, 153, 55, 56, 153, 24, 25, 26, 27, 28, + 0, 29, 30, 31, 0, 0, 0, 32, 153, 153, + 0, 0, 0, 153, 129, 0, 0, 0, 38, 0, 39, 40, 41, 0, 0, 0, 0, 42, 43, 44, - 45, 46, 0, 0, 48, 49, 0, 0, 0, 0, - 0, 50, 0, 0, 0, 53, 0, 54, 55, 0, - 0, 143, 143, 143, 143, 0, 0, 0, 0, 0, - 143, 0, 0, 0, 143, 143, 143, 143, 0, 0, - 0, 0, 0, 143, 143, 0, 0, 143, 143, 143, - 143, 143, 0, 143, 143, 145, 0, 143, 145, 0, - 143, 143, 143, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 145, 145, 0, 0, 0, 145, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 83, 0, 0, 83, 0, 145, 0, 0, - 0, 0, 129, 129, 129, 129, 0, 0, 0, 83, - 83, 129, 0, 0, 0, 129, 129, 129, 129, 0, - 0, 0, 0, 0, 129, 129, 0, 145, 129, 129, - 129, 129, 129, 0, 129, 129, 0, 0, 129, 0, - 0, 129, 129, 129, 83, 0, 0, 104, 104, 104, - 104, 0, 0, 0, 0, 0, 104, 0, 0, 0, - 104, 104, 104, 104, 0, 0, 0, 131, 0, 104, - 104, 0, 0, 104, 104, 104, 104, 104, 0, 104, - 104, 0, 0, 104, 131, 131, 104, 104, 104, 131, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 146, 0, 0, 0, 0, 0, 131, 0, 131, - 0, 0, 0, 0, 0, 0, 0, 0, 146, 146, - 0, 0, 0, 146, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 131, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 146, 0, 146, 0, 0, 96, 0, 0, 96, - 0, 0, 0, 0, 0, 0, 145, 145, 145, 145, - 0, 0, 0, 96, 96, 145, 0, 0, 96, 145, - 145, 145, 145, 146, 0, 0, 0, 0, 145, 145, - 0, 0, 145, 145, 145, 145, 145, 0, 145, 145, - 58, 0, 145, 58, 0, 145, 145, 145, 96, 0, - 0, 0, 0, 83, 83, 83, 83, 58, 58, 0, - 0, 0, 58, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 83, 83, 0, 96, 83, - 0, 0, 0, 61, 0, 0, 0, 0, 0, 0, - 0, 0, 58, 0, 0, 0, 0, 0, 0, 0, - 61, 61, 0, 0, 0, 61, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 58, 0, 0, 0, 0, 0, 131, 131, - 131, 131, 0, 61, 0, 61, 0, 131, 0, 0, - 0, 131, 131, 131, 131, 59, 0, 0, 59, 0, - 131, 131, 0, 0, 131, 131, 131, 131, 131, 0, - 131, 131, 59, 59, 131, 61, 0, 131, 131, 131, - 0, 0, 146, 146, 146, 146, 0, 0, 0, 0, - 0, 146, 0, 0, 0, 146, 146, 146, 146, 0, - 0, 0, 0, 0, 146, 146, 0, 59, 146, 146, - 146, 146, 146, 0, 146, 146, 0, 0, 146, 0, - 0, 146, 146, 146, 0, 0, 0, 145, 0, 0, - 145, 0, 0, 0, 0, 0, 0, 96, 96, 96, - 96, 0, 0, 0, 145, 145, 96, 0, 0, 145, - 96, 96, 96, 96, 0, 0, 0, 0, 0, 96, - 96, 0, 0, 96, 96, 96, 96, 96, 0, 96, - 96, 132, 0, 96, 132, 0, 96, 96, 96, 145, - 0, 58, 58, 58, 58, 0, 0, 0, 132, 132, - 58, 0, 0, 132, 58, 58, 58, 58, 0, 0, - 0, 0, 0, 58, 58, 0, 0, 58, 58, 58, - 58, 58, 0, 58, 58, 0, 0, 58, 0, 0, - 58, 58, 58, 132, 61, 61, 61, 61, 0, 284, - 0, 0, 0, 61, 157, 0, 0, 61, 61, 61, - 61, 0, 0, 0, 0, 0, 61, 61, 0, 0, - 61, 61, 61, 61, 61, 95, 61, 61, 95, 0, - 61, 0, 168, 61, 61, 61, 0, 0, 0, 0, - 0, 0, 95, 95, 0, 0, 0, 95, 0, 0, - 0, 0, 0, 0, 0, 0, 59, 59, 59, 59, - 0, 0, 0, 0, 150, 0, 0, 102, 0, 0, - 102, 0, 0, 0, 0, 0, 0, 95, 59, 59, - 0, 0, 0, 0, 102, 102, 0, 0, 0, 102, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 95, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 109, 102, - 0, 109, 0, 0, 0, 0, 0, 0, 145, 145, - 145, 145, 0, 0, 0, 109, 109, 145, 0, 0, - 109, 145, 145, 145, 145, 0, 0, 0, 0, 0, - 145, 145, 0, 0, 145, 145, 145, 145, 145, 0, - 145, 145, 92, 0, 145, 92, 0, 145, 145, 145, - 109, 0, 132, 132, 132, 132, 0, 0, 0, 92, - 92, 132, 0, 0, 92, 132, 132, 132, 132, 0, - 0, 0, 0, 0, 132, 132, 0, 0, 132, 132, - 132, 132, 132, 93, 132, 132, 93, 0, 132, 0, - 0, 132, 132, 132, 92, 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, 95, 95, 95, 95, - 0, 0, 0, 0, 0, 95, 0, 0, 0, 95, - 95, 95, 95, 0, 0, 0, 0, 0, 95, 95, - 0, 0, 95, 95, 95, 95, 95, 0, 95, 95, - 0, 0, 95, 0, 0, 95, 95, 95, 102, 102, - 102, 102, 0, 0, 0, 0, 0, 102, 0, 0, - 0, 102, 102, 102, 102, 71, 0, 0, 71, 0, - 102, 102, 0, 0, 102, 102, 102, 102, 102, 0, - 102, 102, 71, 71, 102, 0, 0, 102, 102, 102, - 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, 71, 0, 0, - 0, 109, 109, 0, 0, 109, 109, 109, 109, 109, - 0, 109, 109, 0, 0, 109, 0, 0, 109, 109, - 109, 0, 0, 92, 92, 92, 92, 0, 0, 0, - 0, 0, 92, 0, 0, 0, 92, 92, 92, 92, - 0, 0, 0, 0, 0, 92, 92, 0, 0, 92, - 92, 92, 92, 92, 87, 92, 92, 87, 0, 92, - 0, 0, 0, 0, 93, 93, 93, 93, 0, 0, - 0, 87, 87, 93, 0, 0, 87, 93, 93, 93, - 93, 0, 0, 0, 0, 0, 93, 93, 0, 0, - 93, 93, 93, 93, 93, 88, 93, 93, 88, 0, - 93, 0, 0, 0, 0, 0, 87, 0, 0, 0, - 0, 0, 88, 88, 0, 0, 0, 88, 0, 0, + 45, 46, 47, 0, 139, 49, 50, 139, 0, 0, + 0, 153, 51, 153, 0, 0, 54, 0, 55, 56, + 0, 139, 139, 0, 0, 0, 139, 0, 24, 25, + 26, 27, 28, 0, 29, 30, 31, 0, 0, 0, + 32, 0, 0, 153, 0, 0, 0, 0, 0, 114, + 0, 38, 114, 39, 40, 41, 139, 0, 0, 0, + 42, 43, 44, 45, 46, 47, 114, 114, 49, 50, + 0, 114, 0, 0, 0, 51, 0, 0, 0, 54, + 0, 55, 56, 0, 0, 0, 139, 0, 153, 0, + 0, 0, 154, 155, 156, 157, 0, 0, 0, 114, + 155, 114, 0, 155, 0, 0, 158, 160, 161, 162, + 163, 0, 164, 165, 0, 0, 166, 155, 155, 167, + 168, 169, 155, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 129, 129, 129, 129, 0, 0, 0, + 0, 0, 129, 0, 0, 0, 129, 129, 129, 129, + 0, 0, 155, 0, 0, 0, 129, 129, 0, 141, + 129, 129, 129, 129, 129, 0, 129, 129, 0, 0, + 129, 0, 0, 129, 129, 129, 141, 141, 0, 0, + 0, 141, 155, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 153, 153, 153, 153, 0, 0, 0, 0, + 0, 153, 0, 0, 0, 153, 153, 153, 153, 141, + 0, 141, 0, 0, 0, 153, 153, 0, 0, 153, + 153, 153, 153, 153, 0, 153, 153, 0, 0, 153, + 0, 0, 153, 153, 153, 139, 139, 139, 139, 88, + 0, 141, 88, 0, 139, 0, 0, 0, 139, 139, + 139, 139, 0, 0, 0, 0, 88, 88, 139, 139, + 0, 88, 139, 139, 139, 139, 139, 0, 139, 139, + 0, 0, 139, 0, 0, 139, 139, 139, 0, 0, + 114, 114, 114, 114, 0, 0, 0, 0, 0, 114, + 0, 88, 0, 114, 114, 114, 114, 0, 0, 0, + 0, 156, 0, 114, 114, 0, 0, 114, 114, 114, + 114, 114, 0, 114, 114, 0, 0, 114, 156, 156, + 114, 114, 114, 156, 0, 0, 0, 0, 0, 0, + 0, 155, 155, 155, 155, 0, 0, 0, 0, 0, + 155, 0, 0, 0, 155, 155, 155, 155, 0, 0, + 0, 156, 0, 156, 155, 155, 0, 0, 155, 155, + 155, 155, 155, 106, 155, 155, 106, 0, 155, 0, + 0, 155, 155, 155, 0, 0, 0, 0, 0, 0, + 106, 106, 0, 156, 0, 106, 0, 0, 0, 0, + 141, 141, 141, 141, 0, 0, 0, 0, 0, 141, + 0, 0, 0, 141, 141, 141, 141, 0, 0, 0, + 0, 0, 0, 141, 141, 106, 0, 141, 141, 141, + 141, 141, 68, 141, 141, 68, 0, 141, 0, 0, + 141, 141, 141, 0, 0, 0, 0, 0, 0, 68, + 68, 0, 0, 0, 68, 106, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 89, 0, 0, 89, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 88, 89, 89, - 0, 0, 0, 89, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 85, 0, 0, - 85, 0, 0, 0, 0, 0, 71, 71, 71, 71, - 0, 0, 0, 89, 85, 85, 0, 0, 0, 85, - 0, 0, 0, 0, 0, 0, 0, 0, 71, 71, - 0, 0, 0, 86, 0, 0, 86, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 85, - 86, 86, 0, 0, 0, 86, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 84, - 0, 0, 84, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 86, 84, 84, 0, 0, - 0, 84, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 71, 0, 0, + 88, 88, 88, 88, 68, 0, 0, 0, 0, 88, + 0, 0, 0, 0, 71, 71, 0, 0, 0, 71, + 0, 0, 0, 88, 88, 0, 0, 88, 88, 88, + 88, 88, 0, 0, 68, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 71, 0, 71, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 87, 87, 87, 87, 0, - 0, 84, 0, 0, 87, 0, 0, 0, 87, 87, - 87, 87, 0, 0, 0, 0, 0, 87, 87, 0, - 0, 87, 87, 87, 87, 87, 72, 87, 87, 72, - 0, 0, 0, 0, 0, 0, 88, 88, 88, 88, - 0, 0, 0, 72, 72, 88, 0, 0, 72, 88, - 88, 88, 88, 0, 0, 0, 0, 0, 88, 88, - 0, 0, 88, 88, 88, 88, 88, 0, 88, 88, - 0, 0, 89, 89, 89, 89, 0, 0, 72, 0, - 0, 89, 0, 0, 0, 89, 89, 89, 89, 0, - 0, 0, 0, 0, 89, 89, 0, 0, 89, 89, - 89, 89, 89, 0, 89, 89, 0, 0, 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, 86, 86, 86, 86, 0, 0, - 0, 0, 0, 86, 0, 0, 0, 86, 86, 86, - 86, 0, 0, 0, 0, 0, 86, 86, 0, 0, - 86, 86, 86, 86, 86, 0, 86, 86, 0, 0, - 84, 84, 84, 84, 0, 0, 0, 0, 0, 84, - 0, 0, 0, 84, 84, 84, 84, 73, 0, 0, - 73, 0, 84, 84, 0, 0, 84, 84, 84, 84, - 84, 0, 84, 84, 73, 73, 0, 0, 0, 73, + 0, 0, 156, 156, 156, 156, 0, 0, 0, 0, + 0, 156, 0, 0, 0, 156, 156, 156, 156, 71, + 0, 0, 170, 0, 0, 156, 156, 0, 0, 156, + 156, 156, 156, 156, 105, 156, 156, 105, 0, 156, + 0, 0, 156, 156, 156, 0, 0, 0, 0, 0, + 0, 105, 105, 0, 152, 0, 105, 0, 0, 0, + 0, 0, 0, 0, 106, 106, 106, 106, 0, 0, + 0, 0, 0, 106, 0, 0, 0, 106, 106, 106, + 106, 0, 0, 0, 0, 0, 105, 106, 106, 0, + 0, 106, 106, 106, 106, 106, 155, 106, 106, 155, + 0, 106, 0, 0, 106, 106, 106, 0, 0, 0, + 0, 0, 0, 155, 155, 0, 105, 0, 155, 0, + 0, 0, 0, 68, 68, 68, 68, 0, 0, 0, + 0, 0, 68, 0, 0, 0, 68, 68, 68, 68, + 0, 0, 0, 0, 0, 0, 68, 68, 155, 0, + 68, 68, 68, 68, 68, 0, 68, 68, 0, 0, + 68, 0, 0, 68, 68, 68, 0, 0, 71, 71, + 71, 71, 142, 0, 0, 142, 0, 71, 0, 0, + 0, 71, 71, 71, 71, 0, 0, 0, 0, 142, + 142, 71, 71, 0, 142, 71, 71, 71, 71, 71, + 0, 71, 71, 0, 0, 71, 0, 0, 71, 71, + 71, 0, 0, 0, 0, 0, 154, 112, 156, 157, + 112, 0, 0, 0, 142, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 112, 112, 164, 165, 0, 112, + 166, 0, 0, 167, 168, 169, 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, 0, 0, 0, 0, 0, 74, 74, 73, - 0, 0, 74, 0, 0, 0, 0, 72, 72, 72, - 72, 0, 0, 0, 0, 0, 72, 0, 0, 0, - 72, 72, 72, 72, 75, 0, 0, 75, 0, 72, - 72, 0, 74, 72, 72, 72, 72, 72, 0, 72, - 72, 75, 75, 0, 0, 0, 75, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 123, 0, 0, - 123, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 123, 123, 75, 0, 0, 123, - 0, 0, 0, 0, 0, 0, 0, 0, 94, 0, - 0, 94, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 94, 94, 0, 0, 123, - 94, 0, 0, 0, 0, 0, 0, 0, 0, 134, - 0, 0, 134, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 134, 134, 0, 0, - 94, 134, 0, 0, 0, 0, 0, 0, 0, 0, - 76, 0, 0, 76, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 77, 76, 76, 77, - 0, 134, 76, 0, 0, 0, 0, 0, 73, 73, - 73, 73, 0, 77, 77, 0, 0, 73, 77, 0, - 0, 73, 73, 73, 73, 0, 0, 0, 0, 0, - 73, 73, 76, 0, 73, 73, 73, 73, 73, 0, - 73, 74, 74, 74, 74, 0, 0, 0, 77, 0, - 74, 0, 0, 0, 74, 74, 0, 74, 78, 0, - 0, 78, 0, 74, 74, 0, 0, 74, 74, 74, - 74, 74, 0, 74, 79, 78, 78, 79, 0, 0, - 78, 0, 0, 0, 0, 75, 75, 75, 75, 0, - 0, 79, 79, 0, 75, 0, 79, 0, 75, 75, - 0, 0, 0, 0, 0, 0, 0, 75, 75, 0, - 78, 75, 75, 75, 75, 75, 0, 75, 123, 123, - 123, 123, 0, 0, 0, 0, 79, 123, 0, 0, - 0, 123, 123, 0, 0, 0, 0, 0, 0, 81, - 123, 123, 81, 0, 123, 123, 123, 123, 123, 94, - 94, 94, 94, 0, 0, 0, 81, 81, 94, 0, - 0, 81, 94, 94, 0, 0, 0, 0, 0, 0, - 0, 94, 94, 0, 0, 94, 94, 94, 94, 94, - 134, 134, 134, 134, 0, 0, 0, 0, 0, 134, - 0, 81, 0, 134, 134, 0, 0, 0, 0, 0, - 0, 0, 134, 134, 0, 0, 134, 134, 134, 134, - 134, 76, 76, 76, 76, 0, 0, 0, 0, 0, - 76, 0, 0, 0, 0, 76, 0, 77, 77, 77, - 77, 0, 0, 76, 76, 0, 77, 76, 76, 76, - 76, 76, 0, 0, 0, 0, 0, 0, 0, 77, - 77, 0, 0, 77, 77, 77, 77, 77, 0, 0, + 0, 0, 0, 0, 0, 105, 105, 105, 105, 112, + 0, 0, 0, 0, 105, 0, 0, 0, 105, 105, + 105, 105, 0, 0, 0, 0, 0, 0, 105, 105, + 0, 0, 105, 105, 105, 105, 105, 119, 105, 105, + 119, 0, 105, 0, 0, 105, 105, 105, 0, 0, + 0, 0, 0, 0, 119, 119, 0, 0, 0, 119, + 0, 0, 0, 0, 0, 0, 0, 155, 155, 155, + 155, 0, 0, 0, 0, 0, 155, 0, 0, 0, + 155, 155, 155, 155, 0, 0, 0, 0, 0, 119, + 155, 155, 0, 0, 155, 155, 155, 155, 155, 102, + 155, 155, 102, 0, 155, 0, 0, 155, 155, 155, + 0, 0, 0, 0, 0, 0, 102, 102, 0, 0, + 0, 102, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 142, 142, 142, 142, 103, 0, 0, + 103, 102, 142, 0, 0, 0, 142, 142, 142, 142, + 0, 0, 0, 0, 103, 103, 142, 142, 0, 103, + 142, 142, 142, 142, 142, 0, 142, 142, 0, 0, + 142, 0, 0, 142, 142, 142, 0, 0, 112, 112, + 112, 112, 97, 0, 0, 97, 0, 112, 0, 103, + 0, 112, 112, 112, 112, 0, 0, 0, 0, 97, + 97, 112, 112, 0, 97, 112, 112, 112, 112, 112, + 0, 112, 112, 0, 0, 112, 0, 0, 112, 112, + 112, 0, 0, 98, 0, 0, 98, 0, 0, 0, + 0, 0, 0, 0, 97, 0, 0, 0, 0, 0, + 98, 98, 0, 0, 0, 98, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 119, 119, + 119, 119, 99, 0, 0, 99, 0, 119, 0, 0, + 0, 119, 119, 119, 119, 98, 0, 0, 0, 99, + 99, 119, 119, 0, 99, 119, 119, 119, 119, 119, + 0, 119, 119, 0, 0, 119, 0, 0, 119, 119, + 119, 0, 0, 0, 0, 0, 0, 0, 95, 0, + 0, 95, 0, 0, 99, 0, 0, 0, 0, 0, + 102, 102, 102, 102, 0, 95, 95, 0, 0, 102, + 95, 0, 0, 102, 102, 102, 102, 0, 0, 0, + 0, 0, 0, 102, 102, 0, 0, 102, 102, 102, + 102, 102, 0, 102, 102, 0, 96, 102, 0, 96, + 95, 0, 170, 0, 0, 0, 0, 0, 103, 103, + 103, 103, 0, 96, 96, 0, 0, 103, 96, 0, + 0, 103, 103, 103, 103, 0, 0, 0, 0, 0, + 0, 103, 103, 0, 152, 103, 103, 103, 103, 103, + 0, 103, 103, 0, 0, 103, 0, 0, 96, 0, + 0, 0, 0, 97, 97, 97, 97, 0, 0, 0, + 0, 0, 97, 0, 0, 0, 97, 97, 97, 97, + 170, 0, 0, 0, 0, 0, 97, 97, 0, 0, + 97, 97, 97, 97, 97, 0, 97, 97, 0, 0, + 0, 0, 0, 0, 98, 98, 98, 98, 94, 0, + 0, 94, 152, 98, 0, 0, 0, 98, 98, 98, + 98, 0, 0, 0, 0, 94, 94, 98, 98, 0, + 94, 98, 98, 98, 98, 98, 0, 98, 98, 0, + 0, 0, 0, 99, 99, 99, 99, 82, 0, 0, + 82, 0, 99, 0, 0, 0, 99, 99, 99, 99, + 94, 0, 0, 0, 82, 82, 99, 99, 0, 82, + 99, 99, 99, 99, 99, 0, 99, 99, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 95, + 95, 95, 95, 84, 0, 0, 84, 0, 95, 82, + 0, 0, 95, 95, 95, 95, 154, 155, 156, 157, + 84, 84, 95, 95, 0, 84, 95, 95, 95, 95, + 95, 0, 95, 95, 163, 0, 164, 165, 0, 0, + 166, 0, 0, 167, 168, 169, 0, 96, 96, 96, + 96, 85, 0, 0, 85, 84, 96, 0, 0, 0, + 96, 96, 96, 96, 0, 0, 0, 0, 85, 85, + 96, 96, 0, 85, 96, 96, 96, 96, 96, 0, + 96, 96, 0, 0, 154, 155, 156, 157, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 160, + 161, 162, 163, 85, 164, 165, 0, 0, 166, 0, + 0, 167, 168, 169, 133, 0, 0, 133, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 78, - 78, 78, 78, 0, 0, 0, 0, 0, 78, 0, - 0, 0, 0, 0, 0, 79, 79, 79, 79, 0, - 0, 78, 78, 0, 79, 78, 78, 78, 78, 78, - 0, 0, 91, 0, 0, 0, 0, 79, 79, 0, - 104, 79, 79, 79, 79, 111, 113, 0, 0, 0, - 0, 0, 125, 126, 127, 128, 129, 130, 0, 0, - 133, 134, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 133, 133, 0, 0, 0, 133, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 94, + 94, 94, 94, 144, 0, 0, 144, 0, 94, 0, + 0, 0, 94, 94, 94, 94, 133, 0, 0, 0, + 144, 144, 94, 94, 0, 144, 94, 94, 94, 94, + 94, 0, 94, 94, 0, 0, 0, 0, 82, 82, + 82, 82, 0, 0, 0, 0, 0, 82, 0, 0, + 0, 82, 82, 82, 82, 144, 0, 0, 0, 0, + 0, 82, 82, 0, 0, 82, 82, 82, 82, 82, + 0, 82, 82, 0, 0, 0, 0, 104, 0, 0, + 104, 0, 0, 0, 84, 84, 84, 84, 0, 0, + 0, 0, 0, 84, 104, 104, 0, 84, 84, 104, + 84, 0, 0, 0, 0, 0, 0, 84, 84, 0, + 0, 84, 84, 84, 84, 84, 0, 84, 0, 0, + 92, 0, 0, 92, 0, 0, 0, 0, 0, 104, + 0, 0, 85, 85, 85, 85, 0, 92, 92, 0, + 0, 85, 92, 0, 0, 85, 85, 0, 0, 0, + 0, 0, 0, 0, 0, 85, 85, 0, 93, 85, + 85, 85, 85, 85, 0, 85, 107, 0, 293, 0, + 0, 114, 92, 159, 0, 0, 0, 0, 0, 127, + 128, 129, 130, 131, 132, 0, 0, 135, 136, 0, + 0, 0, 0, 0, 143, 133, 133, 133, 133, 0, + 0, 170, 0, 0, 133, 0, 0, 0, 133, 133, + 159, 0, 0, 0, 0, 0, 0, 0, 133, 133, + 186, 0, 133, 133, 133, 133, 133, 0, 0, 0, + 0, 0, 0, 152, 144, 144, 144, 144, 170, 0, + 159, 0, 0, 144, 0, 0, 0, 144, 144, 0, + 0, 0, 0, 0, 0, 0, 0, 144, 144, 0, + 0, 144, 144, 144, 144, 144, 0, 0, 170, 0, + 152, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 224, 225, 226, 227, 228, 229, 230, 231, 232, + 233, 234, 235, 236, 237, 0, 0, 0, 170, 0, + 152, 0, 0, 0, 0, 0, 251, 0, 104, 104, + 104, 104, 0, 0, 0, 0, 0, 104, 0, 0, + 0, 104, 104, 0, 0, 0, 0, 0, 0, 0, + 152, 104, 104, 0, 0, 104, 104, 104, 104, 104, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 81, 81, 81, 81, 0, 0, 0, 0, 0, 81, - 0, 0, 183, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 81, 81, 0, 0, 81, 81, 81, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 215, 0, 0, 0, 0, - 0, 0, 0, 223, 224, 225, 226, 227, 228, 229, - 230, 231, 232, 233, 234, 235, 236, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 297, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 313, + 0, 92, 92, 92, 92, 0, 0, 0, 0, 0, + 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 92, 92, 0, 0, 92, 92, + 0, 0, 0, 0, 0, 0, 306, 0, 0, 0, + 0, 153, 0, 0, 0, 154, 155, 156, 157, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 158, + 160, 161, 162, 163, 0, 164, 165, 0, 0, 166, + 0, 324, 167, 168, 169, 0, 0, 0, 153, 0, + 0, 0, 154, 155, 156, 157, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 158, 160, 161, 162, + 163, 0, 164, 165, 0, 0, 166, 0, 153, 167, + 168, 169, 154, 155, 156, 157, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 160, 161, 162, + 163, 0, 164, 165, 0, 0, 166, 0, 0, 167, + 168, 169, 154, 155, 156, 157, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 161, 162, + 163, 0, 164, 165, 0, 0, 166, 0, 0, 167, + 168, 169, }; short yycheck[] = { 13, - 59, 13, 91, 17, 59, 59, 36, 93, 182, 194, - 41, 123, 59, 44, 257, 41, 59, 40, 44, 33, - 34, 35, 36, 91, 40, 88, 59, 58, 59, 43, - 41, 40, 63, 45, 123, 41, 50, 63, 91, 41, - 257, 41, 41, 40, 56, 40, 59, 40, 60, 41, - 257, 41, 40, 116, 41, 123, 188, 59, 190, 40, - 59, 91, 93, 41, 78, 91, 41, 36, 91, 59, - 123, 40, 59, 41, 278, 41, 123, 41, 92, 294, - 295, 95, 94, 97, 96, 99, 98, 101, 100, 41, - 102, 59, 41, 123, 106, 41, 40, 123, 41, 41, - 123, 123, 41, 44, 59, 44, 0, 123, 276, 277, - 123, 44, 40, 287, 123, 300, 179, 59, 303, 58, - 59, 184, 59, 59, 260, 59, 123, 141, 123, 123, - 257, 40, 144, 145, 146, 147, 148, 149, 150, 33, - 40, 40, 36, 37, 38, 257, 40, 295, 42, 43, - 335, 45, 41, 6, 93, 8, 168, 169, 170, 171, - 172, 173, 174, 125, 178, 59, 298, 299, 91, 41, - 64, 185, 41, 305, 0, 59, 91, 125, 31, 32, - 40, 93, 59, 41, 36, 40, 198, 125, 83, 59, - 125, 93, 204, 205, 206, 125, 328, 91, 125, 211, - 125, 41, 41, 257, 123, 91, 93, 33, 294, 295, - 36, 37, 38, 41, 40, 59, 42, 43, 41, 45, - 41, 59, 93, 59, 313, 237, 59, 239, 258, 123, - 41, 125, 126, 59, 326, 294, 295, 123, 64, 294, - 295, 272, 273, 274, 275, 259, 13, 261, 269, 263, - 264, 294, 295, 267, -1, 281, 270, 269, 93, 285, - 286, 287, 288, 294, 295, 91, 93, 298, 0, -1, - 282, 123, 298, 299, 300, 301, 302, 93, 304, 305, - -1, -1, 308, 294, 295, 311, 312, 313, 294, 295, - 302, -1, 306, -1, 294, 295, -1, 123, -1, 125, - 126, 33, 294, 295, 36, 37, 38, -1, 40, -1, - 42, 43, -1, 45, 326, -1, 294, 295, 332, 294, - 295, -1, 336, 272, 273, 274, 275, 59, 294, 295, - 294, 295, 64, 272, 273, 274, 275, -1, -1, 294, - 295, -1, 294, 295, -1, 294, 295, -1, 294, 295, - -1, 294, 295, 294, 295, 294, 295, 294, 295, 91, - 294, 295, 256, 257, 258, 259, 260, 261, -1, 263, - 264, 265, 266, 267, 268, 269, 270, 271, 272, 273, - 274, 275, 294, 295, -1, 279, 280, -1, 282, 283, - 284, 123, 294, 295, 126, 289, 290, 291, 292, 293, - 41, 287, 296, 297, 91, 257, -1, 294, 295, 303, - 262, -1, -1, 307, -1, 309, 310, -1, 59, 305, - -1, -1, 308, 294, 295, 311, 312, 313, -1, -1, - 256, 257, 258, 259, 260, 261, 123, 263, 264, 265, - 266, 267, 268, 269, 270, 271, 272, 273, 274, 275, - -1, -1, 93, 279, 280, -1, 282, 283, 284, 294, - 295, -1, -1, 289, 290, 291, 292, 293, -1, -1, - 296, 297, 91, -1, -1, -1, -1, 303, 294, 295, - -1, 307, 91, 309, 310, 26, 33, -1, -1, 36, - 37, 38, -1, 40, 41, 42, 43, 44, 45, 48, - 49, 42, -1, -1, 123, -1, 47, -1, 49, -1, - -1, 58, 59, -1, 123, 125, 63, 64, -1, -1, - 61, 62, 63, 64, 256, 257, 258, 259, 260, 261, - -1, 263, 264, 265, -1, -1, -1, 269, -1, 88, - 272, 273, 274, 275, 91, -1, 93, 279, 280, -1, - 282, 283, 284, 63, -1, -1, -1, 289, 290, 291, - 292, 293, 91, -1, 296, 297, 107, 116, 266, 267, - 268, 303, 270, 271, 123, 307, 123, 309, 310, 126, - 33, 91, -1, 36, 37, 38, -1, 40, 41, 42, - 43, 44, 45, -1, 123, -1, -1, -1, 285, 286, - 287, 288, -1, -1, -1, 58, 59, -1, -1, -1, - 63, 64, -1, 123, 301, 302, -1, 304, 305, -1, - -1, 308, -1, -1, 311, 312, 313, -1, -1, -1, - 179, 272, 273, 274, 275, 184, -1, -1, -1, 33, - 93, -1, 36, 37, 38, -1, 40, -1, 42, 43, - -1, 45, -1, 294, 295, -1, 266, 267, 268, -1, - 270, 271, -1, -1, -1, 59, 285, 286, 287, 288, - 64, -1, -1, 126, -1, -1, 285, 286, 287, 288, - 299, 300, 301, 302, -1, 304, 305, -1, -1, 308, - -1, -1, 311, 312, 313, 304, 305, 91, -1, 308, - -1, -1, 311, 312, 313, -1, -1, -1, -1, -1, - 257, 258, 259, 260, 261, -1, 263, 264, 265, -1, - -1, -1, 269, -1, -1, 272, 273, 274, 275, 123, - -1, -1, 126, 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, -1, - 307, 308, 309, 310, 311, 312, 313, 91, -1, -1, - -1, 281, -1, -1, -1, 285, 286, 287, 288, 308, - -1, -1, 311, 312, 313, -1, -1, -1, 298, 299, - 300, 301, 302, -1, 304, 305, -1, -1, 308, 123, - -1, 311, 312, 313, 257, 258, 259, 260, 261, -1, - 263, 264, 265, -1, -1, -1, 269, -1, -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, -1, 307, 308, 309, 310, 311, 312, - 313, 91, 256, 257, 258, 259, 260, 261, -1, 263, - 264, 265, -1, 41, -1, 269, 44, -1, 272, 273, - 274, 275, -1, -1, -1, 279, 280, -1, 282, 283, - 284, 59, -1, 123, -1, 289, 290, 291, 292, 293, - -1, -1, 296, 297, -1, -1, -1, -1, -1, 303, - 25, 26, -1, 307, 33, 309, 310, 36, 37, 38, - -1, 40, 37, 42, 43, 93, 45, 42, 43, -1, - -1, -1, 47, -1, 49, 272, 273, 274, 275, -1, - 59, -1, -1, -1, -1, 64, 61, 62, 63, 64, - -1, -1, -1, -1, -1, -1, -1, 294, 295, -1, - -1, -1, -1, 287, 288, -1, -1, -1, -1, -1, - 33, -1, 91, 36, 37, 38, -1, 40, -1, 42, - 43, 305, 45, -1, 308, -1, -1, 311, 312, 313, - -1, -1, 107, -1, -1, -1, -1, -1, -1, -1, - -1, 64, -1, -1, 123, -1, -1, 126, -1, -1, + 85, 36, 41, 185, 91, 40, 123, 36, 59, 93, + 41, 33, 59, 93, 36, 37, 38, 59, 40, 93, + 42, 43, 59, 45, 41, 59, 41, 196, 90, 41, + 44, 91, 40, 40, 91, 26, 123, 41, 59, 41, + 257, 41, 64, 57, 40, 40, 59, 61, 0, 93, + 44, 42, 6, 257, 8, 40, 118, 48, 41, 50, + 40, 40, 91, 123, 41, 40, 123, 276, 277, 91, + 40, 62, 63, 64, 65, 278, 59, 31, 32, 41, + 257, 33, 59, 91, 36, 37, 38, 123, 40, 123, + 42, 43, 41, 45, 123, 109, 40, 59, 59, 59, + 41, 123, 123, 36, 126, 41, 44, 59, 0, 260, + 59, 257, 64, 123, 296, 123, 123, 59, 59, 110, + 182, 295, 296, 59, 59, 187, 40, 123, 123, 40, + 36, 41, 146, 147, 148, 149, 150, 151, 152, 91, + 257, 33, 40, 123, 36, 37, 38, 125, 40, 125, + 42, 43, 91, 45, 41, 296, 170, 171, 172, 173, + 174, 175, 176, 91, 0, 334, 40, 59, 337, 59, + 41, 123, 64, 125, 126, 189, 41, 191, 41, 193, + 123, 195, 41, 40, 198, 199, 41, 356, 40, 59, + 123, 205, 206, 207, 125, 125, 125, 33, 212, 91, + 36, 37, 38, 125, 40, 93, 42, 43, 125, 45, + 41, 295, 296, 41, 59, 295, 296, 41, 123, 41, + 257, 295, 296, 59, 238, 59, 240, 314, 64, 258, + 41, 123, 93, 125, 126, 257, 258, 259, 260, 261, + 262, 263, 264, 265, 295, 296, 59, 269, 295, 296, + 41, 295, 296, 295, 296, 91, 295, 296, 280, 294, + 282, 283, 284, 348, 295, 296, 41, 289, 290, 291, + 292, 293, 294, 59, 93, 297, 298, 291, 295, 296, + 295, 296, 304, 295, 296, 59, 308, 123, 310, 311, + 126, 295, 296, 295, 296, 295, 296, 41, 312, 362, + 314, 295, 296, 13, 256, 257, 258, 259, 260, 261, + 340, 263, 264, 265, 266, 267, 268, 269, 270, 271, + 272, 273, 274, 275, 257, 312, 340, 279, 280, 262, + 282, 283, 284, 41, 295, 296, 44, 289, 290, 291, + 292, 293, 294, 147, 195, 297, 298, 95, 362, 125, + 58, 59, 304, 295, 296, -1, 308, 91, 310, 311, + 295, 296, -1, -1, 256, 257, 258, 259, 260, 261, + -1, 263, 264, 265, 266, 267, 268, 269, 270, 271, + 272, 273, 274, 275, -1, 93, -1, 279, 280, 123, + 282, 283, 284, -1, -1, -1, -1, 289, 290, 291, + 292, 293, 294, -1, -1, 297, 298, 295, 296, 41, + 91, -1, 304, 41, -1, -1, 308, -1, 310, 311, + 256, 257, 258, 259, 260, 261, -1, 263, 264, 265, + -1, 59, -1, 269, 295, 296, 272, 273, 274, 275, + -1, -1, 123, 279, 280, -1, 282, 283, 284, -1, + -1, -1, -1, 289, 290, 291, 292, 293, 294, 13, + -1, 297, 298, 17, 91, 93, 41, 125, 304, 44, + -1, -1, 308, 91, 310, 311, 295, 296, -1, 33, + 34, 35, 36, 58, 59, -1, -1, -1, 63, 43, + 266, 267, 268, -1, 270, 271, 123, 51, -1, -1, + 307, 308, 309, -1, -1, 123, 313, -1, 315, -1, + -1, 96, -1, 98, -1, 100, 91, 102, 93, 104, + 105, -1, -1, -1, -1, 33, 80, -1, 36, 37, + 38, -1, 40, 41, 42, 43, 44, 45, -1, -1, + 94, -1, 349, 97, 351, 99, -1, 101, 123, 103, + 58, 59, -1, 287, 288, 63, 64, 364, 272, 273, + 274, 275, -1, -1, 272, 273, 274, 275, -1, -1, + -1, 305, 306, -1, -1, 309, -1, -1, 312, 313, + 314, 295, 296, 91, -1, 93, -1, 295, 296, -1, + 144, 33, -1, -1, 36, 37, 38, -1, 40, 41, + 42, 43, 44, 45, 285, 286, 287, 288, 266, 267, + 268, -1, 270, 271, -1, 123, 58, 59, 126, -1, + -1, 63, 64, -1, 305, 306, -1, 181, 309, -1, + -1, 312, 313, 314, 188, -1, -1, -1, -1, -1, + 272, 273, 274, 275, 272, 273, 274, 275, -1, -1, + 33, 93, -1, 36, 37, 38, -1, 40, -1, 42, + 43, -1, 45, 295, 296, -1, -1, 295, 296, 287, + 288, -1, -1, 266, 267, 268, 59, 270, 271, 306, + -1, 64, 309, -1, 126, 312, 313, 314, 306, -1, + -1, 309, -1, -1, 312, 313, 314, 272, 273, 274, + 275, 91, -1, -1, -1, -1, 281, -1, 91, -1, + 285, 286, 287, 288, -1, -1, -1, -1, -1, -1, + 295, 296, -1, -1, 299, 300, 301, 302, 303, -1, + 305, 306, -1, 123, 309, -1, -1, 312, 313, 314, + 123, -1, -1, 126, -1, -1, -1, -1, -1, 257, + 258, 259, 260, 261, -1, 263, 264, 265, -1, -1, + -1, 269, -1, 317, 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, 306, -1, + 308, 309, 310, 311, 312, 313, 314, -1, -1, -1, + -1, -1, -1, -1, -1, 257, 258, 259, 260, 261, + -1, 263, 264, 265, -1, -1, 190, 269, 192, -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, 306, -1, 308, 309, 310, 311, + 312, 313, 314, 256, 257, 258, 259, 260, 261, -1, + 263, 264, 265, -1, -1, 41, 269, -1, 44, 272, + 273, 274, 275, -1, -1, -1, 279, 280, -1, 282, + 283, 284, 58, 59, -1, -1, 289, 290, 291, 292, + 293, 294, -1, -1, 297, 298, -1, -1, -1, 309, + -1, 304, 312, 313, 314, 308, 33, 310, 311, 36, + 37, 38, -1, 40, -1, 42, 43, 93, 45, -1, + -1, 25, 26, -1, -1, -1, -1, -1, -1, 49, + 50, -1, 59, 37, -1, -1, -1, 64, 42, 43, + -1, -1, -1, -1, 48, -1, 50, -1, 332, 333, + -1, -1, -1, -1, -1, 339, -1, 341, 62, 63, + 64, 65, 33, -1, 91, 36, 37, 38, -1, 40, + 90, 42, 43, 357, 45, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 33, -1, 91, 36, - 37, 38, -1, 40, -1, 42, 43, -1, 45, -1, + -1, -1, -1, 64, -1, -1, 123, -1, 118, 126, + -1, -1, -1, -1, -1, 125, 110, -1, -1, -1, + -1, -1, -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, -1, + -1, -1, -1, -1, 59, -1, -1, -1, -1, 64, + -1, -1, 123, -1, -1, 126, -1, -1, -1, -1, + -1, -1, 182, -1, -1, 169, 41, 187, -1, 44, + -1, -1, -1, -1, -1, -1, 91, -1, -1, -1, + -1, -1, 33, 58, 59, 36, 37, 38, 63, 40, + -1, 42, 43, 197, 45, -1, 272, 273, 274, 275, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 167, -1, -1, -1, -1, 64, -1, -1, - 123, -1, -1, 126, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 305, -1, -1, 308, -1, - -1, 311, 312, 313, 91, -1, -1, -1, -1, 33, - -1, -1, 36, 37, 38, -1, 40, -1, 42, 43, - -1, 45, -1, -1, 272, 273, 274, 275, -1, -1, - -1, -1, -1, -1, -1, 59, 123, -1, -1, 126, - 64, -1, -1, -1, -1, -1, 294, -1, -1, -1, - -1, -1, -1, -1, -1, -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, -1, - 91, 63, 126, -1, 303, -1, -1, -1, 307, -1, - 309, 310, -1, -1, 257, 258, 259, 260, 261, 262, - 263, 264, 265, -1, -1, -1, 269, -1, -1, 91, - 41, -1, 123, -1, -1, -1, -1, 280, -1, 282, - 283, 284, -1, -1, -1, -1, 289, 290, 291, 292, - 293, -1, 63, 296, 297, -1, -1, -1, -1, -1, - 303, 123, -1, -1, 307, -1, 309, 310, -1, -1, + -1, 126, -1, 64, -1, -1, -1, -1, 93, 295, + 296, -1, -1, 299, -1, -1, -1, -1, -1, 256, 257, 258, 259, 260, 261, -1, 263, 264, 265, -1, - 91, -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, 296, - 297, 41, 123, -1, 44, -1, 303, -1, -1, -1, - 307, -1, 309, 310, -1, -1, -1, -1, 58, 59, - -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, 93, -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, - -1, -1, -1, -1, 285, -1, 287, 288, -1, 33, - -1, 91, 36, 37, 38, -1, 40, 41, 42, 43, - -1, 45, -1, 304, 305, -1, -1, 308, -1, 281, - 311, 312, 313, 285, 286, 287, 288, -1, -1, -1, - 64, -1, -1, 123, -1, -1, 126, 299, 300, 301, - 302, -1, 304, 305, -1, -1, 308, -1, -1, 311, - 312, 313, -1, -1, -1, 33, -1, 91, 36, 37, - 38, -1, 40, -1, 42, 43, -1, 45, -1, -1, - 281, -1, -1, -1, 285, 286, 287, 288, -1, -1, - -1, -1, -1, -1, -1, -1, 64, 298, 299, 300, - 301, 302, 126, 304, 305, -1, -1, 308, -1, -1, - 311, 312, 313, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 91, -1, 93, -1, -1, 33, -1, - -1, 36, 37, 38, -1, 40, -1, 42, 43, -1, - 45, -1, -1, -1, 287, 288, -1, -1, -1, -1, - -1, -1, 272, 273, 274, 275, -1, -1, 126, 64, - -1, 304, 305, -1, -1, 308, -1, -1, 311, 312, - 313, -1, -1, -1, 294, 295, -1, 257, 258, 259, - 260, 261, -1, 263, 264, 265, 91, -1, -1, 269, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 91, -1, 269, -1, -1, 272, 273, 274, 275, -1, + -1, 41, 279, 280, 44, 282, 283, 284, -1, -1, + -1, -1, 289, 290, 291, 292, 293, 294, 58, 59, + 297, 298, 123, 63, -1, 126, -1, 304, -1, -1, + -1, 308, -1, 310, 311, -1, 257, 258, 259, 260, + 261, -1, 263, 264, 265, -1, -1, -1, 269, 41, + -1, -1, 44, 93, -1, -1, -1, 41, -1, 280, + 44, 282, 283, 284, -1, -1, 58, 59, 289, 290, + 291, 292, 293, 294, 58, 59, 297, 298, -1, 63, + -1, -1, -1, 304, -1, -1, -1, 308, -1, 310, + 311, -1, 257, 258, 259, 260, 261, -1, 263, 264, + 265, 93, -1, -1, 269, -1, -1, -1, -1, 93, + -1, -1, -1, 41, -1, 280, 44, 282, 283, 284, + -1, -1, -1, -1, 289, 290, 291, 292, 293, 294, + 58, 59, 297, 298, -1, 63, -1, -1, -1, 304, + -1, 91, -1, 308, -1, 310, 311, 272, 273, 274, + 275, -1, -1, -1, -1, -1, 257, 258, 259, 260, + 261, -1, 263, 264, 265, 93, -1, -1, 269, 41, + 295, 296, 44, 123, 299, -1, -1, 41, -1, 280, + 44, 282, 283, 284, -1, -1, 58, 59, 289, 290, + 291, 292, 293, 294, -1, 59, 297, 298, -1, -1, + -1, -1, -1, 304, -1, -1, -1, 308, 33, 310, + 311, 36, 37, 38, -1, 40, 41, 42, 43, -1, + 45, 93, -1, -1, -1, -1, -1, -1, -1, 93, + -1, -1, 272, 273, 274, 275, -1, -1, -1, 64, + -1, 281, -1, -1, -1, 285, 286, 287, 288, -1, + -1, -1, -1, -1, -1, 295, 296, -1, -1, 299, + 300, 301, 302, 303, 33, 305, 91, 36, 37, 38, + -1, 40, -1, 42, 43, -1, 45, -1, -1, -1, + 272, 273, 274, 275, -1, -1, -1, -1, 272, 273, + 274, 275, -1, -1, -1, 64, -1, 281, -1, -1, + -1, 126, 286, 295, 296, -1, -1, -1, -1, -1, + -1, 295, 296, -1, -1, 299, 300, 301, 302, 303, + -1, -1, 91, 33, 93, -1, 36, 37, 38, -1, + 40, 41, 42, 43, -1, 45, -1, 287, -1, -1, + -1, -1, -1, -1, 272, 273, 274, 275, -1, -1, + -1, -1, -1, 281, 64, -1, 306, 126, -1, 309, + -1, -1, 312, 313, 314, -1, -1, 295, 296, -1, + -1, 299, 300, 301, 302, 303, -1, -1, -1, -1, + -1, 91, -1, 33, -1, -1, 36, 37, 38, -1, + 40, 41, 42, 43, -1, 45, -1, -1, -1, -1, + 272, 273, 274, 275, -1, -1, -1, -1, 272, 273, + 274, 275, -1, -1, 64, -1, 126, -1, -1, -1, + -1, -1, -1, 295, 296, -1, -1, -1, -1, -1, + -1, 295, 257, 258, 259, 260, 261, -1, 263, 264, + 265, 91, -1, -1, 269, 41, -1, -1, 44, -1, + -1, -1, -1, 41, -1, 280, 44, 282, 283, 284, + -1, -1, 58, 59, 289, 290, 291, 292, 293, 294, + 58, 59, 297, 298, -1, 63, 126, -1, -1, 304, + -1, -1, -1, 308, -1, 310, 311, -1, 257, 258, + 259, 260, 261, -1, 263, 264, 265, 93, -1, -1, + 269, -1, -1, -1, -1, 93, -1, -1, -1, 41, + -1, 280, 44, 282, 283, 284, -1, -1, -1, -1, + 289, 290, 291, 292, 293, 294, 58, 59, 297, 298, + -1, 63, -1, -1, -1, 304, 91, -1, -1, 308, + -1, 310, 311, -1, -1, 41, -1, 257, 258, 259, + 260, 261, -1, 263, 264, 265, -1, -1, -1, 269, + -1, 93, -1, -1, -1, -1, -1, 63, 123, -1, + 280, -1, 282, 283, 284, -1, -1, -1, -1, 289, + 290, 291, 292, 293, 294, -1, -1, 297, 298, -1, + -1, -1, -1, -1, 304, 91, -1, -1, 308, 41, + 310, 311, 44, -1, -1, -1, -1, 257, 258, 259, + 260, 261, -1, 263, 264, 265, 58, 59, -1, 269, + -1, -1, -1, -1, -1, -1, -1, 123, -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, 91, -1, 269, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 280, -1, 282, 283, + 290, 291, 292, 293, 294, -1, -1, 297, 298, -1, + -1, 93, -1, -1, 304, -1, -1, -1, 308, 33, + 310, 311, 36, 37, 38, -1, 40, -1, 42, 43, + -1, 45, -1, -1, -1, -1, 272, 273, 274, 275, + -1, -1, -1, -1, 272, 273, 274, 275, -1, -1, + 64, -1, -1, 281, -1, -1, -1, -1, -1, 295, + 296, -1, -1, -1, -1, -1, -1, 295, 296, -1, + -1, 299, 300, 301, 302, 33, -1, 91, 36, 37, + 38, -1, 40, 41, 42, 43, -1, 45, -1, -1, + 285, 286, 287, 288, -1, -1, -1, -1, -1, -1, + 272, 273, 274, 275, -1, -1, 64, 302, 303, 281, + 305, 306, 126, -1, 309, -1, -1, 312, 313, 314, + -1, -1, -1, 295, 296, -1, -1, 299, 300, 301, + -1, 33, -1, 91, 36, 37, 38, -1, 40, 41, + 42, 43, -1, 45, -1, 281, -1, -1, -1, 285, + 286, 287, 288, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 64, 299, 300, 301, 302, 303, 126, 305, + 306, -1, -1, 309, -1, -1, 312, 313, 314, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 91, + 272, 273, 274, 275, 33, -1, -1, 36, 37, 38, + -1, 40, -1, 42, 43, -1, 45, -1, -1, -1, + -1, -1, -1, 295, 296, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 126, 64, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 41, -1, + -1, 44, 256, 257, 258, 259, 260, 261, -1, 263, + 264, 265, 91, -1, -1, 269, -1, -1, -1, -1, + 63, -1, -1, -1, -1, -1, 280, -1, 282, 283, 284, -1, -1, -1, -1, 289, 290, 291, 292, 293, - -1, -1, 296, 297, 91, 123, -1, -1, -1, 303, - -1, 41, -1, 307, 44, 309, 310, -1, -1, 257, - 258, 259, 260, 261, -1, 263, 264, 265, 58, 59, - -1, 269, -1, 63, -1, -1, 123, -1, -1, -1, - -1, -1, 280, -1, 282, 283, 284, -1, -1, -1, - -1, 289, 290, 291, 292, 293, -1, -1, 296, 297, - -1, 41, -1, 93, 44, 303, -1, -1, -1, 307, - -1, 309, 310, -1, -1, -1, -1, -1, 58, 59, - -1, 256, 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, 93, 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, 285, 286, 287, - 288, -1, -1, -1, -1, -1, -1, -1, -1, 64, - -1, -1, 300, 301, 302, 126, 304, 305, -1, -1, - 308, -1, -1, 311, 312, 313, -1, -1, 285, 286, - 287, 288, -1, -1, 33, -1, 91, 36, 37, 38, - -1, 40, 41, 42, 43, 302, 45, 304, 305, -1, - -1, 308, -1, -1, 311, 312, 313, -1, -1, -1, - -1, -1, -1, -1, -1, 64, -1, -1, -1, -1, - -1, 126, 272, 273, 274, 275, -1, -1, -1, -1, - -1, 281, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 91, -1, 294, 295, -1, 33, 298, 299, - 36, 37, 38, -1, 40, 41, 42, 43, -1, 45, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 272, 273, 274, 275, -1, 126, 64, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 294, 295, 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, 296, 297, -1, -1, -1, - 126, -1, 303, -1, 41, -1, 307, 44, 309, 310, - -1, -1, 257, 258, 259, 260, 261, -1, 263, 264, - 265, 58, 59, -1, 269, -1, 63, -1, -1, -1, - -1, -1, -1, -1, -1, 280, -1, 282, 283, 284, - -1, -1, -1, -1, 289, 290, 291, 292, 293, -1, - -1, 296, 297, -1, 91, -1, 93, -1, 303, -1, - 41, -1, 307, 44, 309, 310, -1, -1, 257, 258, - 259, 260, 261, -1, 263, 264, 265, 58, 59, -1, - 269, -1, 63, -1, -1, -1, 123, -1, -1, -1, - -1, 280, -1, 282, 283, 284, -1, -1, -1, -1, - 289, 290, 291, 292, 293, -1, -1, 296, 297, -1, - 91, -1, 93, -1, 303, -1, -1, -1, 307, -1, - 309, 310, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 257, 258, 259, 260, 261, -1, 263, 264, 265, - -1, 33, 123, 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, -1, -1, 303, -1, -1, - -1, 307, -1, 309, 310, -1, -1, -1, -1, -1, - 41, -1, -1, 44, -1, -1, -1, -1, -1, 91, - -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, -1, -1, -1, - -1, -1, -1, -1, 126, 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, -1, 304, 305, -1, - -1, 308, 123, -1, 311, 312, 313, -1, -1, -1, - -1, 41, -1, -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, -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, -1, -1, -1, 63, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 123, -1, 257, 258, 259, 260, 261, - -1, 263, 264, 265, -1, -1, 91, 269, 93, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 280, -1, + 294, -1, -1, 297, 298, -1, -1, 126, 91, -1, + 304, -1, 41, -1, 308, 44, 310, 311, -1, 257, + 258, 259, 260, 261, -1, 263, 264, 265, -1, 58, + 59, 269, -1, -1, 63, -1, -1, -1, -1, -1, + 123, -1, 280, -1, 282, 283, 284, -1, -1, -1, + -1, 289, 290, 291, 292, 293, 294, -1, -1, 297, + 298, -1, 91, -1, 93, -1, 304, -1, -1, -1, + 308, 41, 310, 311, 44, 257, 258, 259, 260, 261, + -1, 263, 264, 265, -1, -1, -1, 269, 58, 59, + -1, -1, -1, 63, 123, -1, -1, -1, 280, -1, 282, 283, 284, -1, -1, -1, -1, 289, 290, 291, - 292, 293, -1, -1, 296, 297, -1, -1, -1, -1, - -1, 303, -1, -1, -1, 307, -1, 309, 310, -1, + 292, 293, 294, -1, 41, 297, 298, 44, -1, -1, + -1, 91, 304, 93, -1, -1, 308, -1, 310, 311, + -1, 58, 59, -1, -1, -1, 63, -1, 257, 258, + 259, 260, 261, -1, 263, 264, 265, -1, -1, -1, + 269, -1, -1, 123, -1, -1, -1, -1, -1, 41, + -1, 280, 44, 282, 283, 284, 93, -1, -1, -1, + 289, 290, 291, 292, 293, 294, 58, 59, 297, 298, + -1, 63, -1, -1, -1, 304, -1, -1, -1, 308, + -1, 310, 311, -1, -1, -1, 123, -1, 281, -1, + -1, -1, 285, 286, 287, 288, -1, -1, -1, 91, + 41, 93, -1, 44, -1, -1, 299, 300, 301, 302, + 303, -1, 305, 306, -1, -1, 309, 58, 59, 312, + 313, 314, 63, -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, -1, 93, -1, -1, -1, 295, 296, -1, 41, + 299, 300, 301, 302, 303, -1, 305, 306, -1, -1, + 309, -1, -1, 312, 313, 314, 58, 59, -1, -1, + -1, 63, 123, -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, 91, + -1, 93, -1, -1, -1, 295, 296, -1, -1, 299, + 300, 301, 302, 303, -1, 305, 306, -1, -1, 309, + -1, -1, 312, 313, 314, 272, 273, 274, 275, 41, + -1, 123, 44, -1, 281, -1, -1, -1, 285, 286, + 287, 288, -1, -1, -1, -1, 58, 59, 295, 296, + -1, 63, 299, 300, 301, 302, 303, -1, 305, 306, + -1, -1, 309, -1, -1, 312, 313, 314, -1, -1, + 272, 273, 274, 275, -1, -1, -1, -1, -1, 281, + -1, 93, -1, 285, 286, 287, 288, -1, -1, -1, + -1, 41, -1, 295, 296, -1, -1, 299, 300, 301, + 302, 303, -1, 305, 306, -1, -1, 309, 58, 59, + 312, 313, 314, 63, -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, -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, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 41, -1, -1, 44, -1, 93, -1, -1, - -1, -1, 272, 273, 274, 275, -1, -1, -1, 58, - 59, 281, -1, -1, -1, 285, 286, 287, 288, -1, - -1, -1, -1, -1, 294, 295, -1, 123, 298, 299, - 300, 301, 302, -1, 304, 305, -1, -1, 308, -1, - -1, 311, 312, 313, 93, -1, -1, 272, 273, 274, - 275, -1, -1, -1, -1, -1, 281, -1, -1, -1, - 285, 286, 287, 288, -1, -1, -1, 41, -1, 294, - 295, -1, -1, 298, 299, 300, 301, 302, -1, 304, - 305, -1, -1, 308, 58, 59, 311, 312, 313, 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, -1, -1, -1, 91, -1, 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, -1, -1, -1, 123, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 91, -1, 93, -1, -1, 41, -1, -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, 123, -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, 272, 273, 274, 275, 58, 59, -1, - -1, -1, 63, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 294, 295, -1, 123, 298, - -1, -1, -1, 41, -1, -1, -1, -1, -1, -1, - -1, -1, 93, -1, -1, -1, -1, -1, -1, -1, - 58, 59, -1, -1, -1, 63, -1, -1, -1, -1, + -1, 91, -1, 93, 295, 296, -1, -1, 299, 300, + 301, 302, 303, 41, 305, 306, 44, -1, 309, -1, + -1, 312, 313, 314, -1, -1, -1, -1, -1, -1, + 58, 59, -1, 123, -1, 63, -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, -1, 295, 296, 93, -1, 299, 300, 301, + 302, 303, 41, 305, 306, 44, -1, 309, -1, -1, + 312, 313, 314, -1, -1, -1, -1, -1, -1, 58, + 59, -1, -1, -1, 63, 123, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 123, -1, -1, -1, -1, -1, 272, 273, - 274, 275, -1, 91, -1, 93, -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, 308, 123, -1, 311, 312, 313, - -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, 93, 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, -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, 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, -1, 308, -1, -1, - 311, 312, 313, 93, 272, 273, 274, 275, -1, 58, - -1, -1, -1, 281, 63, -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, -1, 91, 311, 312, 313, -1, -1, -1, -1, - -1, -1, 58, 59, -1, -1, -1, 63, -1, -1, - -1, -1, -1, -1, -1, -1, 272, 273, 274, 275, - -1, -1, -1, -1, 123, -1, -1, 41, -1, -1, - 44, -1, -1, -1, -1, -1, -1, 93, 294, 295, + -1, -1, -1, -1, -1, -1, -1, 41, -1, -1, + 272, 273, 274, 275, 93, -1, -1, -1, -1, 281, -1, -1, -1, -1, 58, 59, -1, -1, -1, 63, + -1, -1, -1, 295, 296, -1, -1, 299, 300, 301, + 302, 303, -1, -1, 123, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 91, -1, 93, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 123, -1, -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, -1, - 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, 41, 304, 305, 44, -1, 308, -1, - -1, 311, 312, 313, 93, -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, 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, - -1, -1, 308, -1, -1, 311, 312, 313, 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, 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, 93, -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, 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, 41, 304, 305, 44, -1, 308, + -1, -1, 272, 273, 274, 275, -1, -1, -1, -1, + -1, 281, -1, -1, -1, 285, 286, 287, 288, 123, + -1, -1, 91, -1, -1, 295, 296, -1, -1, 299, + 300, 301, 302, 303, 41, 305, 306, 44, -1, 309, + -1, -1, 312, 313, 314, -1, -1, -1, -1, -1, + -1, 58, 59, -1, 123, -1, 63, -1, -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, -1, 294, 295, -1, -1, - 298, 299, 300, 301, 302, 41, 304, 305, 44, -1, - 308, -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, 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, 41, -1, -1, - 44, -1, -1, -1, -1, -1, 272, 273, 274, 275, - -1, -1, -1, 93, 58, 59, -1, -1, -1, 63, - -1, -1, -1, -1, -1, -1, -1, -1, 294, 295, - -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, 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, -1, -1, -1, 272, 273, 274, 275, -1, - -1, 93, -1, -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, -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, -1, 294, 295, - -1, -1, 298, 299, 300, 301, 302, -1, 304, 305, - -1, -1, 272, 273, 274, 275, -1, -1, 93, -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, -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, -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, -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, + 288, -1, -1, -1, -1, -1, 93, 295, 296, -1, + -1, 299, 300, 301, 302, 303, 41, 305, 306, 44, + -1, 309, -1, -1, 312, 313, 314, -1, -1, -1, + -1, -1, -1, 58, 59, -1, 123, -1, 63, -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, -1, 295, 296, 93, -1, + 299, 300, 301, 302, 303, -1, 305, 306, -1, -1, + 309, -1, -1, 312, 313, 314, -1, -1, 272, 273, + 274, 275, 41, -1, -1, 44, -1, 281, -1, -1, + -1, 285, 286, 287, 288, -1, -1, -1, -1, 58, + 59, 295, 296, -1, 63, 299, 300, 301, 302, 303, + -1, 305, 306, -1, -1, 309, -1, -1, 312, 313, + 314, -1, -1, -1, -1, -1, 285, 41, 287, 288, + 44, -1, -1, -1, 93, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 58, 59, 305, 306, -1, 63, + 309, -1, -1, 312, 313, 314, -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, -1, -1, -1, -1, -1, 58, 59, 93, - -1, -1, 63, -1, -1, -1, -1, 272, 273, 274, + -1, -1, -1, -1, -1, 272, 273, 274, 275, 93, + -1, -1, -1, -1, 281, -1, -1, -1, 285, 286, + 287, 288, -1, -1, -1, -1, -1, -1, 295, 296, + -1, -1, 299, 300, 301, 302, 303, 41, 305, 306, + 44, -1, 309, -1, -1, 312, 313, 314, -1, -1, + -1, -1, -1, -1, 58, 59, -1, -1, -1, 63, + -1, -1, -1, -1, -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, 93, 298, 299, 300, 301, 302, -1, 304, - 305, 58, 59, -1, -1, -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, 41, -1, - -1, 44, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 58, 59, -1, -1, 93, - 63, -1, -1, -1, -1, -1, -1, -1, -1, 41, - -1, -1, 44, -1, -1, -1, -1, -1, -1, -1, + 285, 286, 287, 288, -1, -1, -1, -1, -1, 93, + 295, 296, -1, -1, 299, 300, 301, 302, 303, 41, + 305, 306, 44, -1, 309, -1, -1, 312, 313, 314, -1, -1, -1, -1, -1, -1, 58, 59, -1, -1, - 93, 63, -1, -1, -1, -1, -1, -1, -1, -1, - 41, -1, -1, 44, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 41, 58, 59, 44, - -1, 93, 63, -1, -1, -1, -1, -1, 272, 273, + -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 272, 273, 274, 275, 41, -1, -1, + 44, 93, 281, -1, -1, -1, 285, 286, 287, 288, + -1, -1, -1, -1, 58, 59, 295, 296, -1, 63, + 299, 300, 301, 302, 303, -1, 305, 306, -1, -1, + 309, -1, -1, 312, 313, 314, -1, -1, 272, 273, + 274, 275, 41, -1, -1, 44, -1, 281, -1, 93, + -1, 285, 286, 287, 288, -1, -1, -1, -1, 58, + 59, 295, 296, -1, 63, 299, 300, 301, 302, 303, + -1, 305, 306, -1, -1, 309, -1, -1, 312, 313, + 314, -1, -1, 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, 272, 273, + 274, 275, 41, -1, -1, 44, -1, 281, -1, -1, + -1, 285, 286, 287, 288, 93, -1, -1, -1, 58, + 59, 295, 296, -1, 63, 299, 300, 301, 302, 303, + -1, 305, 306, -1, -1, 309, -1, -1, 312, 313, + 314, -1, -1, -1, -1, -1, -1, -1, 41, -1, + -1, 44, -1, -1, 93, -1, -1, -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, -1, 295, 296, -1, -1, 299, 300, 301, + 302, 303, -1, 305, 306, -1, 41, 309, -1, 44, + 93, -1, 91, -1, -1, -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, 93, -1, 298, 299, 300, 301, 302, -1, - 304, 272, 273, 274, 275, -1, -1, -1, 93, -1, - 281, -1, -1, -1, 285, 286, -1, 288, 41, -1, - -1, 44, -1, 294, 295, -1, -1, 298, 299, 300, - 301, 302, -1, 304, 41, 58, 59, 44, -1, -1, - 63, -1, -1, -1, -1, 272, 273, 274, 275, -1, - -1, 58, 59, -1, 281, -1, 63, -1, 285, 286, - -1, -1, -1, -1, -1, -1, -1, 294, 295, -1, - 93, 298, 299, 300, 301, 302, -1, 304, 272, 273, - 274, 275, -1, -1, -1, -1, 93, 281, -1, -1, - -1, 285, 286, -1, -1, -1, -1, -1, -1, 41, - 294, 295, 44, -1, 298, 299, 300, 301, 302, 272, - 273, 274, 275, -1, -1, -1, 58, 59, 281, -1, - -1, 63, 285, 286, -1, -1, -1, -1, -1, -1, - -1, 294, 295, -1, -1, 298, 299, 300, 301, 302, - 272, 273, 274, 275, -1, -1, -1, -1, -1, 281, - -1, 93, -1, 285, 286, -1, -1, -1, -1, -1, - -1, -1, 294, 295, -1, -1, 298, 299, 300, 301, - 302, 272, 273, 274, 275, -1, -1, -1, -1, -1, - 281, -1, -1, -1, -1, 286, -1, 272, 273, 274, - 275, -1, -1, 294, 295, -1, 281, 298, 299, 300, - 301, 302, -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, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 295, 296, -1, 123, 299, 300, 301, 302, 303, + -1, 305, 306, -1, -1, 309, -1, -1, 93, -1, + -1, -1, -1, 272, 273, 274, 275, -1, -1, -1, + -1, -1, 281, -1, -1, -1, 285, 286, 287, 288, + 91, -1, -1, -1, -1, -1, 295, 296, -1, -1, + 299, 300, 301, 302, 303, -1, 305, 306, -1, -1, + -1, -1, -1, -1, 272, 273, 274, 275, 41, -1, + -1, 44, 123, 281, -1, -1, -1, 285, 286, 287, + 288, -1, -1, -1, -1, 58, 59, 295, 296, -1, + 63, 299, 300, 301, 302, 303, -1, 305, 306, -1, + -1, -1, -1, 272, 273, 274, 275, 41, -1, -1, + 44, -1, 281, -1, -1, -1, 285, 286, 287, 288, + 93, -1, -1, -1, 58, 59, 295, 296, -1, 63, + 299, 300, 301, 302, 303, -1, 305, 306, -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, -1, -1, 272, 273, 274, 275, -1, - -1, 294, 295, -1, 281, 298, 299, 300, 301, 302, - -1, -1, 30, -1, -1, -1, -1, 294, 295, -1, - 38, 298, 299, 300, 301, 43, 44, -1, -1, -1, - -1, -1, 50, 51, 52, 53, 54, 55, -1, -1, - 58, 59, -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, - -1, -1, 90, -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, -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, -1, -1, -1, 256, -1, + 273, 274, 275, 41, -1, -1, 44, -1, 281, 93, + -1, -1, 285, 286, 287, 288, 285, 286, 287, 288, + 58, 59, 295, 296, -1, 63, 299, 300, 301, 302, + 303, -1, 305, 306, 303, -1, 305, 306, -1, -1, + 309, -1, -1, 312, 313, 314, -1, 272, 273, 274, + 275, 41, -1, -1, 44, 93, 281, -1, -1, -1, + 285, 286, 287, 288, -1, -1, -1, -1, 58, 59, + 295, 296, -1, 63, 299, 300, 301, 302, 303, -1, + 305, 306, -1, -1, 285, 286, 287, 288, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 300, + 301, 302, 303, 93, 305, 306, -1, -1, 309, -1, + -1, 312, 313, 314, 41, -1, -1, 44, -1, -1, -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, -1, -1, -1, 272, + 273, 274, 275, 41, -1, -1, 44, -1, 281, -1, + -1, -1, 285, 286, 287, 288, 93, -1, -1, -1, + 58, 59, 295, 296, -1, 63, 299, 300, 301, 302, + 303, -1, 305, 306, -1, -1, -1, -1, 272, 273, + 274, 275, -1, -1, -1, -1, -1, 281, -1, -1, + -1, 285, 286, 287, 288, 93, -1, -1, -1, -1, + -1, 295, 296, -1, -1, 299, 300, 301, 302, 303, + -1, 305, 306, -1, -1, -1, -1, 41, -1, -1, + 44, -1, -1, -1, 272, 273, 274, 275, -1, -1, + -1, -1, -1, 281, 58, 59, -1, 285, 286, 63, + 288, -1, -1, -1, -1, -1, -1, 295, 296, -1, + -1, 299, 300, 301, 302, 303, -1, 305, -1, -1, + 41, -1, -1, 44, -1, -1, -1, -1, -1, 93, + -1, -1, 272, 273, 274, 275, -1, 58, 59, -1, + -1, 281, 63, -1, -1, 285, 286, -1, -1, -1, + -1, -1, -1, -1, -1, 295, 296, -1, 30, 299, + 300, 301, 302, 303, -1, 305, 38, -1, 58, -1, + -1, 43, 93, 63, -1, -1, -1, -1, -1, 51, + 52, 53, 54, 55, 56, -1, -1, 59, 60, -1, + -1, -1, -1, -1, 66, 272, 273, 274, 275, -1, + -1, 91, -1, -1, 281, -1, -1, -1, 285, 286, + 63, -1, -1, -1, -1, -1, -1, -1, 295, 296, + 92, -1, 299, 300, 301, 302, 303, -1, -1, -1, + -1, -1, -1, 123, 272, 273, 274, 275, 91, -1, + 63, -1, -1, 281, -1, -1, -1, 285, 286, -1, + -1, -1, -1, -1, -1, -1, -1, 295, 296, -1, + -1, 299, 300, 301, 302, 303, -1, -1, 91, -1, + 123, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 153, 154, 155, 156, 157, 158, 159, 160, 161, + 162, 163, 164, 165, 166, -1, -1, -1, 91, -1, + 123, -1, -1, -1, -1, -1, 178, -1, 272, 273, + 274, 275, -1, -1, -1, -1, -1, 281, -1, -1, + -1, 285, 286, -1, -1, -1, -1, -1, -1, -1, + 123, 295, 296, -1, -1, 299, 300, 301, 302, 303, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 284, + -1, 272, 273, 274, 275, -1, -1, -1, -1, -1, + 281, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 295, 296, -1, -1, 299, 300, + -1, -1, -1, -1, -1, -1, 258, -1, -1, -1, + -1, 281, -1, -1, -1, 285, 286, 287, 288, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 299, + 300, 301, 302, 303, -1, 305, 306, -1, -1, 309, + -1, 293, 312, 313, 314, -1, -1, -1, 281, -1, + -1, -1, 285, 286, 287, 288, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 299, 300, 301, 302, + 303, -1, 305, 306, -1, -1, 309, -1, 281, 312, + 313, 314, 285, 286, 287, 288, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 300, 301, 302, + 303, -1, 305, 306, -1, -1, 309, -1, -1, 312, + 313, 314, 285, 286, 287, 288, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 301, 302, + 303, -1, 305, 306, -1, -1, 309, -1, -1, 312, + 313, 314, }; #define YYFINAL 1 #ifndef YYDEBUG #define YYDEBUG 0 #endif -#define YYMAXTOKEN 313 +#define YYMAXTOKEN 314 #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, @@ -1124,7 +1051,7 @@ char *yyname[] = { "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", +"MULOP","ADDOP","DOLSHARP","DO","HASHBRACK","NOAMP","LOCAL","MY","OROP","ANDOP", "NOTOP","LSTOP","ASSIGNOP","OROR","ANDAND","BITOROP","BITANDOP","UNIOP", "SHIFTOP","MATCHOP","UMINUS","REFGEN","POWOP","PREINC","PREDEC","POSTINC", "POSTDEC","ARROW", @@ -1135,6 +1062,9 @@ char *yyrule[] = { "prog : $$1 lineseq", "block : '{' remember lineseq '}'", "remember :", +"mblock : '{' mintro mremember lineseq '}'", +"mintro :", +"mremember :", "lineseq :", "lineseq : lineseq decl", "lineseq : lineseq line", @@ -1147,28 +1077,35 @@ char *yyrule[] = { "sideff : expr IF expr", "sideff : expr UNLESS expr", "sideff : expr WHILE expr", -"sideff : expr UNTIL expr", +"sideff : expr UNTIL iexpr", "else :", -"else : ELSE block", -"else : ELSIF '(' expr ')' block else", -"cond : IF '(' expr ')' block else", -"cond : UNLESS '(' expr ')' block else", +"else : ELSE mblock", +"else : ELSIF '(' mexpr ')' mblock else", +"cond : IF '(' remember mexpr ')' mblock else", +"cond : UNLESS '(' remember miexpr ')' mblock 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 '(' remember mtexpr ')' mblock cont", +"loop : label UNTIL '(' remember miexpr ')' mblock cont", "loop : label WHILE block block cont", "loop : label UNTIL block block cont", +"loop : label FOR MY remember my_scalar '(' expr ')' mblock cont", "loop : label FOR scalar '(' expr ')' block cont", -"loop : label FOR '(' expr ')' block cont", -"loop : label FOR '(' nexpr ';' texpr ';' nexpr ')' block", +"loop : label FOR '(' remember expr ')' mblock cont", +"$$2 :", +"$$3 :", +"loop : label FOR '(' remember nexpr ';' $$2 texpr ';' $$3 nexpr ')' mblock", "loop : label block cont", "nexpr :", "nexpr : sideff", "texpr :", "texpr : expr", +"iexpr : expr", +"mexpr : expr", +"mtexpr : texpr", +"miexpr : iexpr", "label :", "label : LABEL", "decl : format", @@ -1224,7 +1161,7 @@ char *yyrule[] = { "term : term POSTDEC", "term : PREINC term", "term : PREDEC term", -"term : LOCAL term", +"term : local term", "term : '(' expr ')'", "term : '(' ')'", "term : '[' expr ']'", @@ -1280,6 +1217,9 @@ char *yyrule[] = { "listexprcom :", "listexprcom : expr", "listexprcom : expr ','", +"local : LOCAL", +"local : MY", +"my_scalar : scalar", "amper : '&' indirob", "scalar : '$' indirob", "ary : '@' indirob", @@ -1312,9 +1252,9 @@ int yyerrflag; int yychar; YYSTYPE yyval; YYSTYPE yylval; -#line 571 "perly.y" +#line 631 "perly.y" /* PROGRAM */ -#line 1388 "y.tab.c" +#line 1329 "perly.c" #define YYABORT goto yyabort #define YYACCEPT goto yyaccept #define YYERROR goto yyerrlab @@ -1539,7 +1479,7 @@ yyreduce: switch (yyn) { case 1: -#line 84 "perly.y" +#line 85 "perly.y" { #if defined(YYDEBUG) && defined(DEBUGGING) yydebug = (debug & 1); @@ -1548,38 +1488,55 @@ case 1: } break; case 2: -#line 91 "perly.y" +#line 92 "perly.y" { newPROG(yyvsp[0].opval); } break; case 3: -#line 95 "perly.y" +#line 96 "perly.y" { yyval.opval = block_end(yyvsp[-3].ival,yyvsp[-2].ival,yyvsp[-1].opval); } break; case 4: -#line 99 "perly.y" -{ yyval.ival = block_start(); } +#line 100 "perly.y" +{ yyval.ival = block_start(TRUE); } break; case 5: -#line 103 "perly.y" -{ yyval.opval = Nullop; } +#line 104 "perly.y" +{ if (yyvsp[-3].opval) + yyvsp[-1].opval = yyvsp[-1].opval ? append_list(OP_LINESEQ, + (LISTOP*)yyvsp[-3].opval, (LISTOP*)yyvsp[-1].opval) : yyvsp[-3].opval; + yyval.opval = block_end(yyvsp[-4].ival, yyvsp[-2].ival, yyvsp[-1].opval); } break; case 6: -#line 105 "perly.y" -{ yyval.opval = yyvsp[-1].opval; } +#line 111 "perly.y" +{ yyval.opval = min_intro_pending + ? newSTATEOP(0, Nullch, newOP(OP_NULL, 0)) + : NULL; } break; case 7: -#line 107 "perly.y" +#line 117 "perly.y" +{ yyval.ival = block_start(FALSE); } +break; +case 8: +#line 121 "perly.y" +{ yyval.opval = Nullop; } +break; +case 9: +#line 123 "perly.y" +{ yyval.opval = yyvsp[-1].opval; } +break; +case 10: +#line 125 "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 114 "perly.y" +case 11: +#line 132 "perly.y" { yyval.opval = newSTATEOP(0, yyvsp[-1].pval, yyvsp[0].opval); } break; -case 10: -#line 117 "perly.y" +case 13: +#line 135 "perly.y" { if (yyvsp[-1].pval != Nullch) { yyval.opval = newSTATEOP(0, yyvsp[-1].pval, newOP(OP_NULL, 0)); } @@ -1589,467 +1546,507 @@ case 10: } expect = XSTATE; } break; -case 11: -#line 126 "perly.y" +case 14: +#line 144 "perly.y" { yyval.opval = newSTATEOP(0, yyvsp[-2].pval, yyvsp[-1].opval); expect = XSTATE; } break; -case 12: -#line 131 "perly.y" +case 15: +#line 149 "perly.y" { yyval.opval = Nullop; } break; -case 13: -#line 133 "perly.y" +case 16: +#line 151 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 14: -#line 135 "perly.y" +case 17: +#line 153 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); } break; -case 15: -#line 137 "perly.y" +case 18: +#line 155 "perly.y" { yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); } break; -case 16: -#line 139 "perly.y" +case 19: +#line 157 "perly.y" { yyval.opval = newLOOPOP(OPf_PARENS, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); } break; -case 17: -#line 141 "perly.y" -{ yyval.opval = newLOOPOP(OPf_PARENS, 1, invert(scalar(yyvsp[0].opval)), yyvsp[-2].opval);} +case 20: +#line 159 "perly.y" +{ yyval.opval = newLOOPOP(OPf_PARENS, 1, yyvsp[0].opval, yyvsp[-2].opval);} break; -case 18: -#line 145 "perly.y" +case 21: +#line 163 "perly.y" { yyval.opval = Nullop; } break; -case 19: -#line 147 "perly.y" +case 22: +#line 165 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; -case 20: -#line 149 "perly.y" +case 23: +#line 167 "perly.y" { copline = yyvsp[-5].ival; - yyval.opval = newSTATEOP(0, 0, - newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); + yyval.opval = newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval); hints |= HINT_BLOCK_SCOPE; } break; -case 21: -#line 156 "perly.y" -{ copline = yyvsp[-5].ival; - yyval.opval = newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval); } +case 24: +#line 173 "perly.y" +{ copline = yyvsp[-6].ival; + yyval.opval = block_end(yyvsp[-6].ival, yyvsp[-4].ival, + newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); } break; -case 22: -#line 159 "perly.y" -{ copline = yyvsp[-5].ival; - yyval.opval = newCONDOP(0, - invert(scalar(yyvsp[-3].opval)), scope(yyvsp[-1].opval), yyvsp[0].opval); } +case 25: +#line 177 "perly.y" +{ copline = yyvsp[-6].ival; + yyval.opval = block_end(yyvsp[-6].ival, yyvsp[-4].ival, + newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); } break; -case 23: -#line 163 "perly.y" +case 26: +#line 181 "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 167 "perly.y" +case 27: +#line 185 "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 174 "perly.y" +case 28: +#line 192 "perly.y" { yyval.opval = Nullop; } break; -case 26: -#line 176 "perly.y" +case 29: +#line 194 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; -case 27: -#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) ); } +case 30: +#line 198 "perly.y" +{ copline = yyvsp[-6].ival; + yyval.opval = block_end(yyvsp[-6].ival, yyvsp[-4].ival, + newSTATEOP(0, yyvsp[-7].pval, + newWHILEOP(0, 1, (LOOP*)Nullop, + yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval) )); } break; -case 28: -#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) ); } +case 31: +#line 204 "perly.y" +{ copline = yyvsp[-6].ival; + yyval.opval = block_end(yyvsp[-6].ival, yyvsp[-4].ival, + newSTATEOP(0, yyvsp[-7].pval, + newWHILEOP(0, 1, (LOOP*)Nullop, + yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval) )); } break; -case 29: -#line 190 "perly.y" +case 32: +#line 210 "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 195 "perly.y" +case 33: +#line 215 "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 200 "perly.y" +case 34: +#line 220 "perly.y" +{ yyval.opval = block_end(yyvsp[-8].ival, yyvsp[-6].ival, + newFOROP(0, yyvsp[-9].pval, yyvsp[-8].ival, yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); } +break; +case 35: +#line 223 "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 203 "perly.y" -{ yyval.opval = newFOROP(0, yyvsp[-6].pval, yyvsp[-5].ival, Nullop, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval); } +case 36: +#line 226 "perly.y" +{ yyval.opval = block_end(yyvsp[-6].ival, yyvsp[-4].ival, + newFOROP(0, yyvsp[-7].pval, yyvsp[-6].ival, Nullop, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); } break; -case 33: -#line 206 "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)) )); } +case 37: +#line 229 "perly.y" +{ if (yyvsp[-1].opval) { + yyvsp[-1].opval = scalar(yyvsp[-1].opval); + if (min_intro_pending) + yyvsp[-1].opval = newSTATEOP(0, Nullch, yyvsp[-1].opval); } } break; -case 34: -#line 213 "perly.y" +case 38: +#line 234 "perly.y" +{ yyvsp[-1].opval = scalar(yyvsp[-1].opval); + if (min_intro_pending) + yyvsp[-1].opval = newSTATEOP(0, Nullch, yyvsp[-1].opval); } +break; +case 39: +#line 239 "perly.y" +{ copline = yyvsp[-11].ival; + yyval.opval = block_end(yyvsp[-11].ival, yyvsp[-9].ival, + append_elem(OP_LINESEQ, yyvsp[-8].opval, + newSTATEOP(0, yyvsp[-12].pval, + newWHILEOP(0, 1, (LOOP*)Nullop, + yyvsp[-5].opval, yyvsp[0].opval, scalar(yyvsp[-2].opval))))); } +break; +case 40: +#line 246 "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 219 "perly.y" +case 41: +#line 252 "perly.y" { yyval.opval = Nullop; } break; -case 37: -#line 224 "perly.y" +case 43: +#line 257 "perly.y" { (void)scan_num("1"); yyval.opval = yylval.opval; } break; -case 39: -#line 229 "perly.y" +case 45: +#line 262 "perly.y" +{ yyval.opval = invert(scalar(yyvsp[0].opval)); } +break; +case 46: +#line 266 "perly.y" +{ yyval.opval = min_intro_pending + ? newSTATEOP(0, Nullch, yyvsp[0].opval) : yyvsp[0].opval; } +break; +case 47: +#line 271 "perly.y" +{ yyval.opval = min_intro_pending + ? newSTATEOP(0, Nullch, yyvsp[0].opval) : yyvsp[0].opval; } +break; +case 48: +#line 276 "perly.y" +{ yyval.opval = min_intro_pending + ? newSTATEOP(0, Nullch, yyvsp[0].opval) : yyvsp[0].opval; } +break; +case 49: +#line 281 "perly.y" { yyval.pval = Nullch; } break; -case 41: -#line 234 "perly.y" +case 51: +#line 286 "perly.y" { yyval.ival = 0; } break; -case 42: -#line 236 "perly.y" +case 52: +#line 288 "perly.y" { yyval.ival = 0; } break; -case 43: -#line 238 "perly.y" +case 53: +#line 290 "perly.y" { yyval.ival = 0; } break; -case 44: -#line 240 "perly.y" +case 54: +#line 292 "perly.y" { yyval.ival = 0; } break; -case 45: -#line 244 "perly.y" +case 55: +#line 296 "perly.y" { newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } break; -case 46: -#line 246 "perly.y" +case 56: +#line 298 "perly.y" { newFORM(yyvsp[-1].ival, Nullop, yyvsp[0].opval); } break; -case 47: -#line 250 "perly.y" +case 57: +#line 302 "perly.y" { newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); } break; -case 48: -#line 252 "perly.y" +case 58: +#line 304 "perly.y" { newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, Nullop); expect = XSTATE; } break; -case 49: -#line 256 "perly.y" +case 59: +#line 308 "perly.y" { yyval.opval = Nullop; } break; -case 51: -#line 261 "perly.y" +case 61: +#line 313 "perly.y" { yyval.ival = start_subparse(); } break; -case 52: -#line 265 "perly.y" +case 62: +#line 317 "perly.y" { package(yyvsp[-1].opval); } break; -case 53: -#line 267 "perly.y" +case 63: +#line 319 "perly.y" { package(Nullop); } break; -case 54: -#line 271 "perly.y" +case 64: +#line 323 "perly.y" { utilize(yyvsp[-5].ival, yyvsp[-4].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); } break; -case 55: -#line 275 "perly.y" +case 65: +#line 327 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 56: -#line 277 "perly.y" +case 66: +#line 329 "perly.y" { yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 58: -#line 282 "perly.y" +case 68: +#line 334 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; -case 59: -#line 284 "perly.y" +case 69: +#line 336 "perly.y" { yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 61: -#line 289 "perly.y" +case 71: +#line 341 "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 62: -#line 292 "perly.y" +case 72: +#line 344 "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 63: -#line 295 "perly.y" +case 73: +#line 347 "perly.y" { yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, - prepend_elem(OP_LIST, yyvsp[-5].opval, yyvsp[-1].opval), + prepend_elem(OP_LIST, scalar(yyvsp[-5].opval), yyvsp[-1].opval), newUNOP(OP_METHOD, 0, yyvsp[-3].opval))); } break; -case 64: -#line 300 "perly.y" +case 74: +#line 352 "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 65: -#line 305 "perly.y" +case 75: +#line 357 "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 66: -#line 310 "perly.y" +case 76: +#line 362 "perly.y" { yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; -case 67: -#line 312 "perly.y" +case 77: +#line 364 "perly.y" { yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; -case 68: -#line 314 "perly.y" +case 78: +#line 366 "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 71: -#line 325 "perly.y" +case 81: +#line 377 "perly.y" { yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); } break; -case 72: -#line 327 "perly.y" +case 82: +#line 379 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 73: -#line 329 "perly.y" +case 83: +#line 381 "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 74: -#line 333 "perly.y" +case 84: +#line 385 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 75: -#line 335 "perly.y" +case 85: +#line 387 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 76: -#line 337 "perly.y" +case 86: +#line 389 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 77: -#line 339 "perly.y" +case 87: +#line 391 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 78: -#line 341 "perly.y" +case 88: +#line 393 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 79: -#line 343 "perly.y" +case 89: +#line 395 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; -case 80: -#line 345 "perly.y" +case 90: +#line 397 "perly.y" { yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));} break; -case 81: -#line 347 "perly.y" +case 91: +#line 399 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 82: -#line 349 "perly.y" +case 92: +#line 401 "perly.y" { yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 83: -#line 351 "perly.y" +case 93: +#line 403 "perly.y" { yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 84: -#line 353 "perly.y" +case 94: +#line 405 "perly.y" { yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 85: -#line 356 "perly.y" +case 95: +#line 408 "perly.y" { yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); } break; -case 86: -#line 358 "perly.y" +case 96: +#line 410 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 87: -#line 360 "perly.y" +case 97: +#line 412 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; -case 88: -#line 362 "perly.y" +case 98: +#line 414 "perly.y" { yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));} break; -case 89: -#line 364 "perly.y" +case 99: +#line 416 "perly.y" { yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); } break; -case 90: -#line 366 "perly.y" +case 100: +#line 418 "perly.y" { yyval.opval = newUNOP(OP_POSTINC, 0, mod(scalar(yyvsp[-1].opval), OP_POSTINC)); } break; -case 91: -#line 369 "perly.y" +case 101: +#line 421 "perly.y" { yyval.opval = newUNOP(OP_POSTDEC, 0, mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); } break; -case 92: -#line 372 "perly.y" +case 102: +#line 424 "perly.y" { yyval.opval = newUNOP(OP_PREINC, 0, mod(scalar(yyvsp[0].opval), OP_PREINC)); } break; -case 93: -#line 375 "perly.y" +case 103: +#line 427 "perly.y" { yyval.opval = newUNOP(OP_PREDEC, 0, mod(scalar(yyvsp[0].opval), OP_PREDEC)); } break; -case 94: -#line 378 "perly.y" +case 104: +#line 430 "perly.y" { yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); } break; -case 95: -#line 380 "perly.y" +case 105: +#line 432 "perly.y" { yyval.opval = sawparens(yyvsp[-1].opval); } break; -case 96: -#line 382 "perly.y" +case 106: +#line 434 "perly.y" { yyval.opval = sawparens(newNULLLIST()); } break; -case 97: -#line 384 "perly.y" +case 107: +#line 436 "perly.y" { yyval.opval = newANONLIST(yyvsp[-1].opval); } break; -case 98: -#line 386 "perly.y" +case 108: +#line 438 "perly.y" { yyval.opval = newANONLIST(Nullop); } break; -case 99: -#line 388 "perly.y" +case 109: +#line 440 "perly.y" { yyval.opval = newANONHASH(yyvsp[-2].opval); } break; -case 100: -#line 390 "perly.y" +case 110: +#line 442 "perly.y" { yyval.opval = newANONHASH(Nullop); } break; -case 101: -#line 392 "perly.y" +case 111: +#line 444 "perly.y" { yyval.opval = newANONSUB(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } break; -case 102: -#line 394 "perly.y" +case 112: +#line 446 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 103: -#line 396 "perly.y" +case 113: +#line 448 "perly.y" { yyval.opval = newBINOP(OP_GELEM, 0, newGVREF(0,yyvsp[-4].opval), yyvsp[-2].opval); } break; -case 104: -#line 398 "perly.y" +case 114: +#line 450 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 105: -#line 400 "perly.y" +case 115: +#line 452 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); } break; -case 106: -#line 402 "perly.y" +case 116: +#line 454 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-4].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; -case 107: -#line 406 "perly.y" +case 117: +#line 458 "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 410 "perly.y" +case 118: +#line 462 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 109: -#line 412 "perly.y" +case 119: +#line 464 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 110: -#line 414 "perly.y" +case 120: +#line 466 "perly.y" { yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));} break; -case 111: -#line 416 "perly.y" +case 121: +#line 468 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; -case 112: -#line 419 "perly.y" +case 122: +#line 471 "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 424 "perly.y" +case 123: +#line 476 "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 429 "perly.y" +case 124: +#line 481 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); } break; -case 115: -#line 431 "perly.y" +case 125: +#line 483 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); } break; -case 116: -#line 433 "perly.y" +case 126: +#line 485 "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 439 "perly.y" +case 127: +#line 491 "perly.y" { yyval.opval = prepend_elem(OP_HSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_HSLICE, 0, @@ -2057,38 +2054,38 @@ case 117: ref(oopsHV(yyvsp[-4].opval), OP_HSLICE))); expect = XOPERATOR; } break; -case 118: -#line 446 "perly.y" +case 128: +#line 498 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 119: -#line 448 "perly.y" +case 129: +#line 500 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); } break; -case 120: -#line 450 "perly.y" +case 130: +#line 502 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); } break; -case 121: -#line 452 "perly.y" +case 131: +#line 504 "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" +case 132: +#line 507 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; -case 123: -#line 458 "perly.y" +case 133: +#line 510 "perly.y" { yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); } break; -case 124: -#line 460 "perly.y" +case 134: +#line 512 "perly.y" { yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); } break; -case 125: -#line 462 "perly.y" +case 135: +#line 514 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, @@ -2097,8 +2094,8 @@ case 125: scalar(yyvsp[-2].opval) )),Nullop)); dep();} break; -case 126: -#line 470 "perly.y" +case 136: +#line 522 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, append_elem(OP_LIST, @@ -2108,139 +2105,151 @@ case 126: scalar(yyvsp[-3].opval) )))); dep();} break; -case 127: -#line 479 "perly.y" +case 137: +#line 531 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, scalar(newCVREF(0,scalar(yyvsp[-2].opval))), Nullop)); dep();} break; -case 128: -#line 483 "perly.y" +case 138: +#line 535 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, yyvsp[-1].opval, scalar(newCVREF(0,scalar(yyvsp[-3].opval))))); dep();} break; -case 129: -#line 488 "perly.y" +case 139: +#line 540 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL); hints |= HINT_BLOCK_SCOPE; } break; -case 130: -#line 491 "perly.y" +case 140: +#line 543 "perly.y" { yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); } break; -case 131: -#line 493 "perly.y" +case 141: +#line 545 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; -case 132: -#line 495 "perly.y" +case 142: +#line 547 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; -case 133: -#line 497 "perly.y" +case 143: +#line 549 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; -case 134: -#line 499 "perly.y" +case 144: +#line 551 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; -case 135: -#line 501 "perly.y" +case 145: +#line 553 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; -case 136: -#line 504 "perly.y" +case 146: +#line 556 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; -case 137: -#line 506 "perly.y" +case 147: +#line 558 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, 0); } break; -case 138: -#line 508 "perly.y" +case 148: +#line 560 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); } break; -case 139: -#line 511 "perly.y" +case 149: +#line 563 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); } break; -case 140: -#line 513 "perly.y" +case 150: +#line 565 "perly.y" { yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; -case 141: -#line 515 "perly.y" +case 151: +#line 567 "perly.y" { yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); } break; -case 142: -#line 517 "perly.y" +case 152: +#line 569 "perly.y" { yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); } break; -case 145: -#line 523 "perly.y" +case 155: +#line 575 "perly.y" { yyval.opval = Nullop; } break; -case 146: -#line 525 "perly.y" +case 156: +#line 577 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 147: -#line 529 "perly.y" +case 157: +#line 581 "perly.y" { yyval.opval = Nullop; } break; -case 148: -#line 531 "perly.y" +case 158: +#line 583 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 149: -#line 533 "perly.y" +case 159: +#line 585 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; -case 150: -#line 537 "perly.y" +case 160: +#line 588 "perly.y" +{ yyval.ival = 0; } +break; +case 161: +#line 589 "perly.y" +{ yyval.ival = 1; } +break; +case 162: +#line 593 "perly.y" +{ in_my = 0; yyval.opval = my(yyvsp[0].opval); } +break; +case 163: +#line 597 "perly.y" { yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); } break; -case 151: -#line 541 "perly.y" +case 164: +#line 601 "perly.y" { yyval.opval = newSVREF(yyvsp[0].opval); } break; -case 152: -#line 545 "perly.y" +case 165: +#line 605 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; -case 153: -#line 549 "perly.y" +case 166: +#line 609 "perly.y" { yyval.opval = newHVREF(yyvsp[0].opval); } break; -case 154: -#line 553 "perly.y" +case 167: +#line 613 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; -case 155: -#line 557 "perly.y" +case 168: +#line 617 "perly.y" { yyval.opval = newGVREF(0,yyvsp[0].opval); } break; -case 156: -#line 561 "perly.y" +case 169: +#line 621 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; -case 157: -#line 563 "perly.y" +case 170: +#line 623 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; -case 158: -#line 565 "perly.y" +case 171: +#line 625 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; -case 159: -#line 568 "perly.y" +case 172: +#line 628 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -#line 2230 "y.tab.c" +#line 2240 "perly.c" } yyssp -= yym; yystate = *yyssp; diff --git a/perly.c.diff b/perly.c.diff index f31072a25f..cc55c40ba9 100644 --- a/perly.c.diff +++ b/perly.c.diff @@ -1,7 +1,6 @@ -*** perly.c.orig Sun Jul 7 23:27:45 1996 ---- perly.c Sun Jul 7 23:27:46 1996 +Index: perly.c *************** -*** 12,82 **** +*** 12,83 **** deprecate("\"do\" to call subroutines"); } @@ -47,35 +46,36 @@ - #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 HASHBRACK 291 +- #define NOAMP 292 +- #define LOCAL 293 +- #define MY 294 +- #define OROP 295 +- #define ANDOP 296 +- #define NOTOP 297 +- #define LSTOP 298 +- #define ASSIGNOP 299 +- #define OROR 300 +- #define ANDAND 301 +- #define BITOROP 302 +- #define BITANDOP 303 +- #define UNIOP 304 +- #define SHIFTOP 305 +- #define MATCHOP 306 +- #define UMINUS 307 +- #define REFGEN 308 +- #define POWOP 309 +- #define PREINC 310 +- #define PREDEC 311 +- #define POSTINC 312 +- #define POSTDEC 313 +- #define ARROW 314 #define YYERRCODE 256 short yylhs[] = { -1, - 31, 0, 5, 3, 6, 6, 6, 7, 7, 7, + 40, 0, 7, 5, 8, 9, 6, 10, 10, 10, --- 12,17 ---- *************** -*** 1375,1387 **** +*** 1316,1342 **** int yynerrs; int yyerrflag; int yychar; @@ -86,13 +86,32 @@ - short yyss[YYSTACKSIZE]; - YYSTYPE yyvs[YYSTACKSIZE]; - #define yystacksize YYSTACKSIZE - #line 571 "perly.y" + #line 631 "perly.y" /* PROGRAM */ - #line 1388 "y.tab.c" ---- 1310,1317 ---- -*************** -*** 1388,1401 **** ---- 1318,1376 ---- + #line 1329 "y.tab.c" + #define YYABORT goto yyabort + #define YYACCEPT goto yyaccept + #define YYERROR goto yyerrlab + int + yyparse() + { + register int yym, yyn, yystate; + #if YYDEBUG + register char *yys; + extern char *getenv(); + + if (yys = getenv("YYDEBUG")) + { + yyn = *yys; +--- 1250,1316 ---- + int yynerrs; + int yyerrflag; + int yychar; + YYSTYPE yyval; + YYSTYPE yylval; + #line 631 "perly.y" + /* PROGRAM */ + #line 1329 "y.tab.c" #define YYABORT goto yyabort #define YYACCEPT goto yyaccept #define YYERROR goto yyerrlab @@ -138,7 +157,7 @@ register char *yys; extern char *getenv(); + #endif - ++ + struct ysv *ysave = (struct ysv*)safemalloc(sizeof(struct ysv)); + SAVEDESTRUCTOR(yydestruct, ysave); + ysave->oldyydebug = yydebug; @@ -147,14 +166,14 @@ + ysave->oldyychar = yychar; + ysave->oldyyval = yyval; + ysave->oldyylval = yylval; -+ + + #if YYDEBUG if (yys = getenv("YYDEBUG")) { yyn = *yys; *************** -*** 1408,1413 **** ---- 1383,1396 ---- +*** 1349,1354 **** +--- 1323,1336 ---- yyerrflag = 0; yychar = (-1); @@ -170,7 +189,7 @@ yyvsp = yyvs; *yyssp = yystate = 0; *************** -*** 1423,1429 **** +*** 1364,1370 **** yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; @@ -178,7 +197,7 @@ yychar, yys); } #endif ---- 1406,1412 ---- +--- 1346,1352 ---- yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; @@ -187,7 +206,7 @@ } #endif *************** -*** 1433,1444 **** +*** 1374,1385 **** { #if YYDEBUG if (yydebug) @@ -200,7 +219,7 @@ } *++yyssp = yystate = yytable[yyn]; *++yyvsp = yylval; ---- 1416,1441 ---- +--- 1356,1381 ---- { #if YYDEBUG if (yydebug) @@ -228,7 +247,7 @@ *++yyssp = yystate = yytable[yyn]; *++yyvsp = yylval; *************** -*** 1474,1485 **** +*** 1415,1426 **** { #if YYDEBUG if (yydebug) @@ -241,7 +260,7 @@ } *++yyssp = yystate = yytable[yyn]; *++yyvsp = yylval; ---- 1471,1497 ---- +--- 1411,1437 ---- { #if YYDEBUG if (yydebug) @@ -270,7 +289,7 @@ *++yyssp = yystate = yytable[yyn]; *++yyvsp = yylval; *************** -*** 1489,1496 **** +*** 1430,1437 **** { #if YYDEBUG if (yydebug) @@ -279,7 +298,7 @@ #endif if (yyssp <= yyss) goto yyabort; --yyssp; ---- 1501,1509 ---- +--- 1441,1449 ---- { #if YYDEBUG if (yydebug) @@ -290,7 +309,7 @@ if (yyssp <= yyss) goto yyabort; --yyssp; *************** -*** 1507,1514 **** +*** 1448,1455 **** yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; @@ -299,7 +318,7 @@ } #endif yychar = (-1); ---- 1520,1528 ---- +--- 1460,1468 ---- yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; @@ -310,7 +329,7 @@ #endif yychar = (-1); *************** -*** 1517,1523 **** +*** 1458,1464 **** yyreduce: #if YYDEBUG if (yydebug) @@ -318,7 +337,7 @@ yystate, yyn, yyrule[yyn]); #endif yym = yylen[yyn]; ---- 1531,1537 ---- +--- 1471,1477 ---- yyreduce: #if YYDEBUG if (yydebug) @@ -327,7 +346,7 @@ #endif yym = yylen[yyn]; *************** -*** 2236,2243 **** +*** 2246,2253 **** { #if YYDEBUG if (yydebug) @@ -336,7 +355,7 @@ #endif yystate = YYFINAL; *++yyssp = YYFINAL; ---- 2250,2258 ---- +--- 2259,2267 ---- { #if YYDEBUG if (yydebug) @@ -347,7 +366,7 @@ yystate = YYFINAL; *++yyssp = YYFINAL; *************** -*** 2251,2257 **** +*** 2261,2267 **** yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; @@ -355,7 +374,7 @@ YYFINAL, yychar, yys); } #endif ---- 2266,2272 ---- +--- 2275,2281 ---- yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; @@ -364,7 +383,7 @@ } #endif *************** -*** 2266,2285 **** +*** 2276,2295 **** yystate = yydgoto[yym]; #if YYDEBUG if (yydebug) @@ -385,7 +404,7 @@ yyaccept: ! return (0); } ---- 2281,2315 ---- +--- 2290,2324 ---- yystate = yydgoto[yym]; #if YYDEBUG if (yydebug) @@ -32,29 +32,30 @@ #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 HASHBRACK 291 +#define NOAMP 292 +#define LOCAL 293 +#define MY 294 +#define OROP 295 +#define ANDOP 296 +#define NOTOP 297 +#define LSTOP 298 +#define ASSIGNOP 299 +#define OROR 300 +#define ANDAND 301 +#define BITOROP 302 +#define BITANDOP 303 +#define UNIOP 304 +#define SHIFTOP 305 +#define MATCHOP 306 +#define UMINUS 307 +#define REFGEN 308 +#define POWOP 309 +#define PREINC 310 +#define PREDEC 311 +#define POSTINC 312 +#define POSTDEC 313 +#define ARROW 314 typedef union { I32 ival; char *pval; @@ -62,3 +63,4 @@ typedef union { GV *gvval; } YYSTYPE; extern YYSTYPE yylval; +extern YYSTYPE yylval; @@ -43,15 +43,16 @@ dep() %token <ival> LOOPEX DOTDOT %token <ival> FUNC0 FUNC1 FUNC %token <ival> RELOP EQOP MULOP ADDOP -%token <ival> DOLSHARP DO LOCAL HASHBRACK NOAMP +%token <ival> DOLSHARP DO HASHBRACK NOAMP +%token LOCAL MY -%type <ival> prog decl format remember startsub '&' -%type <opval> block lineseq line loop cond nexpr else argexpr +%type <ival> prog decl local format startsub remember mremember '&' +%type <opval> block mblock mintro lineseq line loop cond else %type <opval> expr term scalar ary hsh arylen star amper sideff +%type <opval> argexpr nexpr texpr iexpr mexpr mtexpr miexpr %type <opval> listexpr listexprcom indirob -%type <opval> texpr listop method proto +%type <opval> listop method proto cont my_scalar %type <pval> label -%type <opval> cont %left <ival> OROP %left ANDOP @@ -95,8 +96,25 @@ block : '{' remember lineseq '}' { $$ = block_end($1,$2,$3); } ; -remember: /* NULL */ /* start a lexical scope */ - { $$ = block_start(); } +remember: /* NULL */ /* start a full lexical scope */ + { $$ = block_start(TRUE); } + ; + +mblock : '{' mintro mremember lineseq '}' + { if ($2) + $4 = $4 ? append_list(OP_LINESEQ, + (LISTOP*)$2, (LISTOP*)$4) : $2; + $$ = block_end($1, $3, $4); } + ; + +mintro : /* NULL */ /* introduce pending lexicals */ + { $$ = min_intro_pending + ? newSTATEOP(0, Nullch, newOP(OP_NULL, 0)) + : NULL; } + ; + +mremember: /* NULL */ /* start a partial lexical scope */ + { $$ = block_start(FALSE); } ; lineseq : /* NULL */ @@ -137,28 +155,28 @@ sideff : error { $$ = newLOGOP(OP_OR, 0, $3, $1); } | expr WHILE expr { $$ = newLOOPOP(OPf_PARENS, 1, scalar($3), $1); } - | expr UNTIL expr - { $$ = newLOOPOP(OPf_PARENS, 1, invert(scalar($3)), $1);} + | expr UNTIL iexpr + { $$ = newLOOPOP(OPf_PARENS, 1, $3, $1);} ; else : /* NULL */ { $$ = Nullop; } - | ELSE block + | ELSE mblock { $$ = scope($2); } - | ELSIF '(' expr ')' block else + | ELSIF '(' mexpr ')' mblock 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 +cond : IF '(' remember mexpr ')' mblock else { copline = $1; - $$ = newCONDOP(0, $3, scope($5), $6); } - | UNLESS '(' expr ')' block else + $$ = block_end($1, $3, + newCONDOP(0, $4, scope($6), $7)); } + | UNLESS '(' remember miexpr ')' mblock else { copline = $1; - $$ = newCONDOP(0, - invert(scalar($3)), scope($5), $6); } + $$ = block_end($1, $3, + newCONDOP(0, $4, scope($6), $7)); } | IF block block else { copline = $1; deprecate("if BLOCK BLOCK"); @@ -176,16 +194,18 @@ cont : /* NULL */ { $$ = scope($2); } ; -loop : label WHILE '(' texpr ')' block cont +loop : label WHILE '(' remember mtexpr ')' mblock cont { copline = $2; - $$ = newSTATEOP(0, $1, - newWHILEOP(0, 1, (LOOP*)Nullop, - $4, $6, $7) ); } - | label UNTIL '(' expr ')' block cont + $$ = block_end($2, $4, + newSTATEOP(0, $1, + newWHILEOP(0, 1, (LOOP*)Nullop, + $5, $7, $8) )); } + | label UNTIL '(' remember miexpr ')' mblock cont { copline = $2; - $$ = newSTATEOP(0, $1, - newWHILEOP(0, 1, (LOOP*)Nullop, - invert(scalar($4)), $6, $7) ); } + $$ = block_end($2, $4, + newSTATEOP(0, $1, + newWHILEOP(0, 1, (LOOP*)Nullop, + $5, $7, $8) )); } | label WHILE block block cont { copline = $2; $$ = newSTATEOP(0, $1, @@ -196,19 +216,32 @@ loop : label WHILE '(' texpr ')' block cont $$ = newSTATEOP(0, $1, newWHILEOP(0, 1, (LOOP*)Nullop, invert(scalar(scope($3))), $4, $5)); } + | label FOR MY remember my_scalar '(' expr ')' mblock cont + { $$ = block_end($2, $4, + newFOROP(0, $1, $2, $5, $7, $9, $10)); } | label FOR scalar '(' expr ')' block cont { $$ = newFOROP(0, $1, $2, mod($3, OP_ENTERLOOP), $5, $7, $8); } - | label FOR '(' expr ')' block cont - { $$ = newFOROP(0, $1, $2, Nullop, $4, $6, $7); } - | label FOR '(' nexpr ';' texpr ';' nexpr ')' block + | label FOR '(' remember expr ')' mblock cont + { $$ = block_end($2, $4, + newFOROP(0, $1, $2, Nullop, $5, $7, $8)); } + | label FOR '(' remember nexpr ';' + { if ($5) { + $5 = scalar($5); + if (min_intro_pending) + $5 = newSTATEOP(0, Nullch, $5); } } + texpr ';' + { $8 = scalar($8); + if (min_intro_pending) + $8 = newSTATEOP(0, Nullch, $8); } + nexpr ')' mblock /* basically fake up an initialize-while lineseq */ - { copline = $2; - $$ = append_elem(OP_LINESEQ, - newSTATEOP(0, $1, scalar($4)), - newSTATEOP(0, $1, - newWHILEOP(0, 1, (LOOP*)Nullop, - scalar($6), $10, scalar($8)) )); } + { copline = $2; + $$ = block_end($2, $4, + append_elem(OP_LINESEQ, $5, + newSTATEOP(0, $1, + newWHILEOP(0, 1, (LOOP*)Nullop, + $8, $13, scalar($11))))); } | label block cont /* a block is a loop that happens once */ { $$ = newSTATEOP(0, $1, newWHILEOP(0, 1, (LOOP*)Nullop, @@ -225,6 +258,25 @@ texpr : /* NULL means true */ | expr ; +iexpr : expr + { $$ = invert(scalar($1)); } + ; + +mexpr : expr + { $$ = min_intro_pending + ? newSTATEOP(0, Nullch, $1) : $1; } + ; + +mtexpr : texpr + { $$ = min_intro_pending + ? newSTATEOP(0, Nullch, $1) : $1; } + ; + +miexpr : iexpr + { $$ = min_intro_pending + ? newSTATEOP(0, Nullch, $1) : $1; } + ; + label : /* empty */ { $$ = Nullch; } | LABEL @@ -294,7 +346,7 @@ listop : LSTOP indirob argexpr | term ARROW method '(' listexprcom ')' { $$ = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, - prepend_elem(OP_LIST, $1, $5), + prepend_elem(OP_LIST, scalar($1), $5), newUNOP(OP_METHOD, 0, $3))); } | METHOD indirob listexpr { $$ = convert(OP_ENTERSUB, OPf_STACKED, @@ -374,7 +426,7 @@ term : term ASSIGNOP term | PREDEC term { $$ = newUNOP(OP_PREDEC, 0, mod(scalar($2), OP_PREDEC)); } - | LOCAL term %prec UNIOP + | local term %prec UNIOP { $$ = localize($2,$1); } | '(' expr ')' { $$ = sawparens($2); } @@ -533,6 +585,14 @@ listexprcom: /* NULL */ { $$ = $1; } ; +local : LOCAL { $$ = 0; } + | MY { $$ = 1; } + ; + +my_scalar: scalar + { in_my = 0; $$ = my($1); } + ; + amper : '&' indirob { $$ = newCVREF($1,$2); } ; diff --git a/pod/buildtoc b/pod/buildtoc index 8a9b7ff5cb..daf26c1c57 100644 --- a/pod/buildtoc +++ b/pod/buildtoc @@ -126,7 +126,7 @@ podset( @modules[ sort { $modname[$a] cmp $modname[$b] } 0 .. $#modules ] ); =head1 AUTHOR - Larry Wall E<lt>F<lwall\@sems.com>E<gt>, with the help of oodles + Larry Wall E<lt>F<larry\@wall.org>E<gt>, with the help of oodles of other folks. diff --git a/pod/perldata.pod b/pod/perldata.pod index 34fd199005..c1144715d8 100644 --- a/pod/perldata.pod +++ b/pod/perldata.pod @@ -239,12 +239,13 @@ integer formats: 0377 # octal 4_294_967_296 # underline for legibility -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 -characters such as newline, tab, etc., as well as some more exotic -forms. See L<perlop/qq> for a list. +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 characters such as +newline, tab, etc., as well as some more exotic forms. See +L<perlop/Quote and Quotelike Operators> for a list. You can also embed newlines directly in your strings, i.e. they can end on a different line than they begin. This is nice, but if you forget @@ -324,17 +325,18 @@ and is almost always right. If it does guess wrong, or if you're just plain paranoid, you can force the correct interpretation with curly brackets as above. -A line-oriented form of quoting is based on the shell "here-doc" syntax. -Following a C<E<lt>E<lt>> you specify a string to terminate the quoted material, -and all lines following the current line down to the terminating string -are the value of the item. The terminating string may be either an -identifier (a word), or some quoted text. If quoted, the type of -quotes you use determines the treatment of the text, just as in regular -quoting. An unquoted identifier works like double quotes. There must -be no space between the C<E<lt>E<lt>> and the identifier. (If you put a space it -will be treated as a null identifier, which is valid, and matches the -first blank line.) The terminating string must appear by itself -(unquoted and with no surrounding whitespace) on the terminating line. +A line-oriented form of quoting is based on the shell "here-doc" +syntax. Following a C<E<lt>E<lt>> you specify a string to terminate +the quoted material, and all lines following the current line down to +the terminating string are the value of the item. The terminating +string may be either an identifier (a word), or some quoted text. If +quoted, the type of quotes you use determines the treatment of the +text, just as in regular quoting. An unquoted identifier works like +double quotes. There must be no space between the C<E<lt>E<lt>> and +the identifier. (If you put a space it will be treated as a null +identifier, which is valid, and matches the first blank line.) The +terminating string must appear by itself (unquoted and with no +surrounding whitespace) on the terminating line. print <<EOF; The price is $Price. @@ -511,34 +513,16 @@ Note that just because a hash is initialized in that order doesn't mean that it comes out in that order. See L<perlfunc/sort> for examples of how to arrange for an output ordering. -=head2 Typeglobs and FileHandles +=head2 Typeglobs Perl uses an internal type called a I<typeglob> to hold an entire symbol table entry. The type prefix of a typeglob is a C<*>, because it represents all types. This used to be the preferred way to pass arrays and hashes by reference into a function, but now that -we have real references, this is seldom needed. +we have real references, this is seldom needed. It also used to be the +preferred way to pass filehandles into a function, but now +that we have the *foo{THING} notation it isn't often needed for that, +either. -One place where you still use typeglobs (or references thereto) -is for passing or storing filehandles. If you want to save away -a filehandle, do it this way: - - $fh = *STDOUT; - -or perhaps as a real reference, like this: - - $fh = \*STDOUT; - -This is also the way to create a local filehandle. For example: - - sub newopen { - my $path = shift; - local *FH; # not my! - open (FH, $path) || return undef; - return \*FH; - } - $fh = newopen('/etc/passwd'); - -See L<perlref>, L<perlsub>, and L<perlmod/"Symbols Tables"> for more -discussion on typeglobs. See L<perlfunc/open> for other ways of -generating filehandles. +See L<perlref>, L<perlsub>, and L<perlmod/"Symbol Tables"> for more +discussion on typeglobs. diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 4eed9deb98..240ebcc3a7 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -162,7 +162,11 @@ the return value of your socket() call? See L<perlfunc/accept>. =item Allocation too large: %lx -(F) You can't allocate more than 64K on an MSDOS machine. +(X) You can't allocate more than 64K on an MSDOS machine. + +=item Allocation too large + +(F) You can't allocate more than 2^31+"small amount" bytes. =item Arg too short for msgsnd @@ -387,7 +391,7 @@ that you can chdir to, possibly because it doesn't exist. =item Can't coerce %s to integer in %s (F) Certain types of SVs, in particular real symbol table entries -(type GLOB), can't be forced to stop being what they are. So you can't +(typeglobs), can't be forced to stop being what they are. So you can't say things like: *foo += 1; @@ -402,12 +406,12 @@ but then $foo no longer contains a glob. =item Can't coerce %s to number in %s (F) Certain types of SVs, in particular real symbol table entries -(type GLOB), can't be forced to stop being what they are. +(typeglobs), can't be forced to stop being what they are. =item Can't coerce %s to string in %s (F) Certain types of SVs, in particular real symbol table entries -(type GLOB), can't be forced to stop being what they are. +(typeglobs), can't be forced to stop being what they are. =item Can't create pipe mailbox @@ -692,11 +696,6 @@ redefined subroutine while the old routine is running. Go figure. (F) You tried to unshift an "unreal" array that can't be unshifted, such as the main Perl stack. -=item Can't untie: %d inner references still exist - -(F) With "use strict untie" in effect, a copy of the object returned -from C<tie> (or C<tied>) was still valid when C<untie> was called. - =item Can't upgrade that kind of scalar (P) The internal sv_upgrade routine adds "members" to an SV, making @@ -1344,7 +1343,7 @@ format, but this indicates you did, and that it didn't exist. =item Not a GLOB reference -(F) Perl was trying to evaluate a reference to a "type glob" (that is, +(F) Perl was trying to evaluate a reference to a "typeglob" (that is, a symbol table entry that looks like C<*foo>), but found a reference to something else instead. You can use the ref() function to find out what kind of ref it really was. See L<perlref>. @@ -1399,6 +1398,12 @@ See L<perlform>. (F) You can't require the null filename, especially since on many machines that means the current directory! See L<perlfunc/require>. +=item Null picture in formline + +(F) The first argument to formline must be a valid format picture +specification. It was found to be empty, which probably means you +supplied it an uninitialized value. See L<perlform>. + =item NULL OP IN RUN (P) Some internal routine called run() with a null opcode pointer. @@ -1448,8 +1453,29 @@ but realloc() wouldn't give it more memory, virtual or otherwise. =item Out of memory! -(X) The malloc() function returned 0, indicating there was insufficient -remaining memory (or virtual memory) to satisfy the request. +(X|F) The malloc() function returned 0, indicating there was insufficient +remaining memory (or virtual memory) to satisfy the request. Depending +on the way perl was compiled it may use the contents of C<$^M> as an +emergency pool after die()ing with this message. In this case the +error is trappable I<once>. + +=item Out of memory during request for %s + +(F) The malloc() function returned 0, indicating there was insufficient +remaining memory (or virtual memory) to satisfy the request. However, +the request was judged large enough (compile-time default is 64K), so +a possibility to shut down by trapping this error is granted. + +=item Out of memory! + +(X|F) The malloc() function returned 0, indicating there was insufficient +remaining memory (or virtual memory) to satisfy the request. + +The request was judged to be small, so the possibility to trap it +depends on the way perl was compiled. By default it is not +trappable. However, if compiled for this, Perl may use the contents of +C<$^M> as an emergency pool after die()ing with this message. In this +case the error is trappable I<once>. =item page overflow @@ -2259,6 +2285,11 @@ a scalar context, the comma is treated like C's comma operator, which throws away the left argument, which is not what you want. See L<perlref> for more on this. +=item untie attempted while %d inner references still exist + +(W) A copy of the object returned from C<tie> (or C<tied>) was still +valid when C<untie> was called. + =item Variable "%s" is not exported (F) While "use strict" in effect, you referred to a global variable diff --git a/pod/perlembed.pod b/pod/perlembed.pod index d636a151f4..186dc88a7b 100644 --- a/pod/perlembed.pod +++ b/pod/perlembed.pod @@ -20,8 +20,8 @@ Read about backquotes and about C<system> and C<exec> in L<perlfunc>. =item B<Use Perl from Perl?> -Read about C<do> and C<eval> in L<perlfunc> and C<use> -and C<require> in L<perlmod>. +Read about C<do> and C<eval> in L<perlfunc/do> and L<perlfunc/eval> and C<use> +and C<require> in L<perlmod> and L<perlfunc/require>, L<perlfunc/use>. =item B<Use C from C?> @@ -236,7 +236,7 @@ ours I<perl_eval()>) that wraps around Perl's L<perlfunc/eval>. Arguably, this is the only routine you'll ever need to execute snippets of Perl code from within your C program. Your string can be as long as you wish; it can contain multiple statements; it can -use L<perlmod/require> or L<perlfunc/do> to include external Perl +use L<perlfunc/require> or L<perlfunc/do> to include external Perl files. Our I<perl_eval()> lets us evaluate individual Perl strings, and then diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index cb2d93fef1..d4998cf44b 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -845,7 +845,9 @@ EXPR is parsed and executed as if it were a little Perl program. It is executed in the context of the current Perl program, so that any variable settings, subroutine or format definitions remain afterwards. The value returned is the value of the last expression evaluated, or a -return statement may be used, just as with subroutines. +return statement may be used, just as with subroutines. The last +expression is evaluated in scalar or array context, depending on the +context of the eval. If there is a syntax error or runtime error, or a die() statement is executed, an undefined value is returned by eval(), and C<$@> is set to the @@ -898,8 +900,10 @@ instead, as in case 6. =item exec LIST -The exec() function executes a system command I<AND NEVER RETURNS>. Use -the system() function if you want it to return. +The exec() function executes a system command I<AND NEVER RETURNS>, +unless the command does not exist and is executed directly instead of +via C</bin/sh -c> (see below). Use system() instead of exec() if you +want it to return. If there is more than one argument in LIST, or if LIST is an array with more than one value, calls execvp(3) with the arguments in LIST. If @@ -1447,6 +1451,21 @@ function. Here's a descending numeric sort of a hash by its values: printf "%4d %s\n", $hash{$key}, $key; } +As an lvalue C<keys> allows you to increase the number of hash buckets +allocated for the given associative array. This can gain you a measure +of efficiency if you know the hash is going to get big. (This is +similar to pre-extending an array by assigning a larger number to +$#array.) If you say + + keys %hash = 200; + +then C<%hash> will have at least 200 buckets allocated for it. These +buckets will be retained even if you do C<%hash = ()>, use C<undef +%hash> if you want to free the storage while C<%hash> is still in scope. +You can't shrink the number of buckets allocated for the hash using +C<keys> in this way (but you needn't worry about doing this by accident, +as trying has no effect). + =item kill LIST Sends a signal to a list of processes. The first element of @@ -2653,6 +2672,13 @@ but if you're in the C<FooPack> package, it's @articles = sort {$FooPack::b <=> $FooPack::a} @files; +The comparison function is required to behave. If it returns +inconsistent results (sometimes saying $x[1] is less than $x[2] and +sometimes saying the opposite, for example) the Perl interpreter will +probably crash and dump core. This is entirely due to and dependent +upon your system's qsort(3) library routine; this routine often avoids +sanity checks in the interest of speed. + =item splice ARRAY,OFFSET,LENGTH,LIST =item splice ARRAY,OFFSET,LENGTH @@ -3236,7 +3262,9 @@ call into the "Module" package to tell the module to import the list of features back into the current package. The module can implement its import method any way it likes, though most modules just choose to derive their import method via inheritance from the Exporter class that -is defined in the Exporter module. See L<Exporter>. +is defined in the Exporter module. See L<Exporter>. If no import +method can be found then the error is currently silently ignored. This +may change to a fatal error in a future version. If you don't want your namespace altered, explicitly supply an empty list: @@ -3269,6 +3297,8 @@ by use, i.e. it calls C<unimport Module LIST> instead of C<import>. no integer; no strict 'refs'; +If no unimport method can be found the call fails with a fatal error. + See L<perlmod> for a list of standard modules and pragmas. =item utime LIST diff --git a/pod/perlguts.pod b/pod/perlguts.pod index 2e89807dd3..3f3639667b 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -146,11 +146,11 @@ Take this code: This code tries to return a new SV (which contains the value 42) if it should return a real value, or undef otherwise. Instead it has returned a null pointer which, somewhere down the line, will cause a segmentation violation, -or just weird results. Change the zero to C<&sv_undef> in the first line and -all will be well. +bus error, or just plain weird results. Change the zero to C<&sv_undef> in +the first line and all will be well. To free an SV that you've created, call C<SvREFCNT_dec(SV*)>. Normally this -call is not necessary. See the section on B<MORTALITY>. +call is not necessary. See the section on L<Mortality>. =head2 What's Really Stored in an SV? @@ -345,7 +345,7 @@ A reference can be blessed into a package with the following function: SV* sv_bless(SV* sv, HV* stash); The C<sv> argument must be a reference. The C<stash> argument specifies -which class the reference will belong to. See the L<"Stashes"> +which class the reference will belong to. See the section on L<Stashes> for information on converting class names into stashes. /* Still under construction */ @@ -448,31 +448,205 @@ to use the macros: XPUSHp(char*, I32) XPUSHs(SV*) -These macros automatically adjust the stack for you, if needed. +These macros automatically adjust the stack for you, if needed. Thus, you +do not need to call C<EXTEND> to extend the stack. For more information, consult L<perlxs>. -=head1 Mortality +=head1 Localizing Changes + +Perl has a very handy construction + + { + local $var = 2; + ... + } + +This construction is I<approximately> equivalent to + + { + my $oldvar = $var; + $var = 2; + ... + $var = $oldvar; + } + +The biggest difference is that the first construction would would +reinstate the initial value of $var, irrespective of how control exits +the block: C<goto>, C<return>, C<die>/C<eval> etc. It is a little bit +more efficient as well. + +There is a way to achieve a similar task from C via Perl API: create a +I<pseudo-block>, and arrange for some changes to be automatically +undone at the end of it, either explicit, or via a non-local exit (via +die()). A I<block>-like construct is created by a pair of +C<ENTER>/C<LEAVE> macros (see L<perlcall/EXAMPLE/"Returning a +Scalar">). Such a construct may be created specially for some +important localized task, or an existing one (like boundaries of +enclosing Perl subroutine/block, or an existing pair for freeing TMPs) +may be used. (In the second case the overhead of additional +localization must be almost negligible.) Note that any XSUB is +automatically enclosed in an C<ENTER>/C<LEAVE> pair. + +Inside such a I<pseudo-block> the following service is available: + +=over + +=item C<SAVEINT(int i)> + +=item C<SAVEIV(IV i)> + +=item C<SAVEI16(I16 i)> + +=item C<SAVEI32(I32 i)> + +=item C<SAVELONG(long i)> + +These macros arrange things to restore the value of integer variable +C<i> at the end of enclosing I<pseudo-block>. + +=item C<SAVESPTR(p)> + +=item C<SAVEPPTR(s)> + +These macros arrange things to restore the value of pointers C<s> and +C<p>. C<p> must be a pointer of a type which survives conversion to +C<SV*> and back, C<s> should be able to survive conversion to C<char*> +and back. + +=item C<SAVEFREESV(SV *sv)> + +The refcount of C<sv> would be decremented at the end of +I<pseudo-block>. This is similar to C<sv_2mortal>, which should (?) be +used instead. + +=item C<SAVEFREEOP(OP *op)> + +The C<OP *> is op_free()ed at the end of I<pseudo-block>. + +=item C<SAVEFREEPV(p)> + +The chunk of memory which is pointed to by C<p> is Safefree()ed at the +end of I<pseudo-block>. + +=item C<SAVECLEARSV(SV *sv)> + +Clears a slot in the current scratchpad which corresponds to C<sv> at +the end of I<pseudo-block>. + +=item C<SAVEDELETE(HV *hv, char *key, I32 length)> -In Perl, values are normally "immortal" -- that is, they are not freed unless -explicitly done so (via the Perl C<undef> call or other routines in Perl -itself). +The key C<key> of C<hv> is deleted at the end of I<pseudo-block>. The +string pointed to by C<key> is Safefree()ed. If one has a I<key> in +short-lived storage, the corresponding string may be reallocated like +this: -Add cruft about reference counts. - int SvREFCNT(SV* sv); - void SvREFCNT_inc(SV* sv); - void SvREFCNT_dec(SV* sv); + SAVEDELETE(defstash, savepv(tmpbuf), strlen(tmpbuf)); -In the above example with C<tzname>, we needed to create two new SVs to push -onto the argument stack, that being the two strings. However, we don't want -these new SVs to stick around forever because they will eventually be -copied into the SVs that hold the two scalar variables. +=item C<SAVEDESTRUCTOR(f,p)> + +At the end of I<pseudo-block> the function C<f> is called with the +only argument (of type C<void*>) C<p>. + +=item C<SAVESTACK_POS()> + +The current offset on the Perl internal stack (cf. C<SP>) is restored +at the end of I<pseudo-block>. + +=back + +The following API list contains functions, thus one needs to +provide pointers to the modifiable data explicitly (either C pointers, +or Perlish C<GV *>s): + +=over + +=item C<SV* save_scalar(GV *gv)> + +Equivalent to Perl code C<local $gv>. + +=item C<AV* save_ary(GV *gv)> + +=item C<HV* save_hash(GV *gv)> + +Similar to C<save_scalar>, but localize C<@gv> and C<%gv>. + +=item C<void save_item(SV *item)> + +Duplicates the current value of C<SV>, on the exit from the current +C<ENTER>/C<LEAVE> I<pseudo-block> will restore the value of C<SV> +using the stored value. + +=item C<void save_list(SV **sarg, I32 maxsarg)> + +A variant of C<save_item> which takes multiple arguments via an array +C<sarg> of C<SV*> of length C<maxsarg>. + +=item C<SV* save_svref(SV **sptr)> + +Similar to C<save_scalar>, but will reinstate a C<SV *>. + +=item C<void save_aptr(AV **aptr)> + +=item C<void save_hptr(HV **hptr)> + +Similar to C<save_svref>, but localize C<AV *> and C<HV *>. + +=item C<void save_nogv(GV *gv)> + +Will postpone destruction of a I<stub> glob. + +=back + +=head1 Mortality -An SV (or AV or HV) that is "mortal" acts in all ways as a normal "immortal" -SV, AV, or HV, but is only valid in the "current context". When the Perl -interpreter leaves the current context, the mortal SV, AV, or HV is -automatically freed. Generally the "current context" means a single -Perl statement. +Perl uses an reference count-driven garbage collection mechanism. SV's, +AV's, or HV's (xV for short in the following) start their life with a +reference count of 1. If the reference count of an xV ever drops to 0, +then they will be destroyed and their memory made available for reuse. + +This normally doesn't happen at the Perl level unless a variable is +undef'ed. At the internal level, however, reference counts can be +manipulated with the following macros: + + int SvREFCNT(SV* sv); + void SvREFCNT_inc(SV* sv); + void SvREFCNT_dec(SV* sv); + +However, there is one other function which manipulates the reference +count of its argument. The C<newRV> function, as you should recall, +creates a reference to the specified argument. As a side effect, it +increments the argument's reference count, which is ok in most +circumstances. But imagine you want to return a reference from an XS +function. You create a new SV which initially has a reference count +of 1. Then you call C<newRV>, passing the just-created SV. This returns +the reference as a new SV, but the reference count of the SV you passed +to C<newRV> has been incremented to 2. Now you return the reference and +forget about the SV. But Perl hasn't! Whenever the returned reference +is destroyed, the reference count of the original SV is decreased to 1 +and nothing happens. The SV will hang around without any way to access +it until Perl itself terminates. This is a memory leak. + +The correct procedure, then, is to call C<SvREFCNT_dec> on the SV after +C<newRV> has returned. Then, if and when the reference is destroyed, +the reference count of the SV will go to 0 and also be destroyed, stopping +any memory leak. + +There are some convenience functions available that can help with this +process. These functions introduce the concept of "mortality". An xV +that is mortal has had its reference count marked to be decremented, +but not actually decremented, until the "current context" is left. +Generally the "current context" means a single Perl statement, such as +a call to an XSUB function. + +"Mortalization" then is at its simplest a deferred C<SvREFCNT_dec>. +However, if you mortalize a variable twice, the reference count will +later be decremented twice. + +You should be careful about creating mortal variables. Strange things +can happen if you make the same value mortal within multiple contexts, +or if you make a variable mortal multiple times. Doing the latter can +cause a variable to become invalid prematurely. To create a mortal variable, use the functions: @@ -487,7 +661,7 @@ The mortal routines are not just for SVs -- AVs and HVs can be made mortal by passing their address (and casting them to C<SV*>) to the C<sv_2mortal> or C<sv_mortalcopy> routines. -From Ilya: +I<From Ilya:> Beware that the sv_2mortal() call is eventually equivalent to svREFCNT_dec(). A value can happily be mortal in two different contexts, and it will be svREFCNT_dec()ed twice, once on exit from these @@ -496,9 +670,6 @@ that you should be very careful to make a value mortal exactly as many times as it is needed. The value that go to the Perl stack I<should> be mortal. -You should be careful about creating mortal variables. It is possible for -strange things to happen should you make the same value mortal within -multiple contexts. =head1 Stashes @@ -597,7 +768,7 @@ associated with an SV. The C<name> and C<namlem> arguments are used to associate a string with the magic, typically the name of a variable. C<namlem> is stored in the -C<mg_len> field and if C<name> is non-null and C<namlem> E<gt>= 0 a malloc'd +C<mg_len> field and if C<name> is non-null and C<namlem> >= 0 a malloc'd copy of the name is stored in C<mg_ptr> field. The sv_magic function uses C<how> to determine which, if any, predefined @@ -2398,14 +2569,14 @@ destination, C<n> is the number of items, and C<t> is the type. =head1 AUTHOR -Jeff Okamoto E<lt>F<okamoto@corp.hp.com>E<gt> +Jeff Okamoto <okamoto@corp.hp.com> With lots of help and suggestions from Dean Roehrich, Malcolm Beattie, Andreas Koenig, Paul Hudson, Ilya Zakharevich, Paul Marquess, Neil -Bowers, Matthew Green, Tim Bunce, and Spider Boardman. +Bowers, Matthew Green, Tim Bunce, Spider Boardman, and Ulrich Pfeifer. -API Listing by Dean Roehrich E<lt>F<roehrich@cray.com>E<gt>. +API Listing by Dean Roehrich <roehrich@cray.com>. =head1 DATE -Version 22: 1996/9/23 +Version 23.1: 1996/10/19 diff --git a/pod/perlmod.pod b/pod/perlmod.pod index 731b25e67c..7cb3a4907e 100644 --- a/pod/perlmod.pod +++ b/pod/perlmod.pod @@ -155,6 +155,25 @@ Another use of symbol tables is for making "constant" scalars. Now you cannot alter $PI, which is probably a good thing all in all. +You can say C<*foo{PACKAGE}> and C<*foo{NAME}> to find out what name and +package the *foo symbol table entry comes from. This may be useful +in a subroutine which is passed typeglobs as arguments + + sub identify_typeglob { + my $glob = shift; + print 'You gave me ', *{$glob}{PACKAGE}, '::', *{$glob}{NAME}, "\n"; + } + identify_typeglob *foo; + identify_typeglob *bar::baz; + +This prints + + You gave me main::foo + You gave me bar::baz + +The *foo{THING} notation can also be used to obtain references to the +individual elements of *foo, see L<perlref>. + =head2 Package Constructors and Destructors There are two special subroutine definitions that function as package @@ -316,53 +335,64 @@ conversion, but it's just a mechanical process, so is far from bulletproof. They work somewhat like pragmas in that they tend to affect the compilation of your program, and thus will usually only work well when used within a -C<use>, or C<no>. These are locally scoped, so an inner BLOCK -may countermand any of these by saying +C<use>, or C<no>. Most of these are locally scoped, so an inner BLOCK +may countermand any of these by saying: no integer; no strict 'refs'; which lasts until the end of that BLOCK. -The following programs are defined (and have their own documentation). +Unlike the pragrmas that effect the C<$^H> hints variable, the C<use +vars> and C<use subs> declarations are not BLOCK-scoped. They allow +you to pre-declare a variables or subroutines within a particular +<I>file</I> rather than just a block. Such declarations are effective +for the entire file for which they were declared. You cannot rescind +them with C<no vars> or C<no subs>. + +The following pragmas are defined (and have their own documentation). =over 12 =item diagnostics -Pragma to produce enhanced diagnostics +force verbose warning diagnostics =item integer -Pragma to compute arithmetic in integer instead of double +compute arithmetic in integer instead of double =item less -Pragma to request less of something from the compiler +request less of something from the compiler + +=item lib + +manipulate @INC at compile time =item ops -Pragma to restrict use of unsafe opcodes +restrict unsafe operations when compiling =item overload -Pragma for overloading operators +package for overloading perl operations =item sigtrap -Pragma to enable stack backtrace on unexpected signals +enable simple signal handling =item strict -Pragma to restrict unsafe constructs +restrict unsafe constructs =item subs -Pragma to predeclare sub names +predeclare sub names =item vars -Pragma to predeclare global symbols +predeclare global variable names =back @@ -396,7 +426,7 @@ warn of errors (from perspective of caller) =item Config -access Perl configuration option +access Perl configuration information =item Cwd @@ -404,27 +434,39 @@ get pathname of current working directory =item DB_File -Perl access to Berkeley DB +access to Berkeley DB =item Devel::SelfStubber generate stubs for a SelfLoading module +=item DirHandle + +supply object methods for directory handles + =item DynaLoader Dynamically load C libraries into Perl code =item English -use nice English (or B<awk>) names for ugly punctuation variables +use nice English (or awk) names for ugly punctuation variables =item Env -perl module that imports environment variables +import environment variables =item Exporter -provide import/export controls for Perl modules +implements default import method for modules + +=item ExtUtils::Embed + +Utilities for embedding Perl in C/C++ applications + +=item ExtUtils::Install + +install files from here to there =item ExtUtils::Liblist @@ -438,13 +480,37 @@ create an extension Makefile utilities to write and check a MANIFEST file +=item ExtUtils::Miniperl + +write the C code for perlmain.c + =item ExtUtils::Mkbootstrap make a bootstrap file for use by DynaLoader -=item ExtUtils::Miniperl +=item ExtUtils::Mksymlists + +write linker options files for dynamic extension + +=item ExtUtils::MM_OS2 + +methods to override UN*X behaviour in ExtUtils::MakeMaker + +=item ExtUtils::MM_Unix + +methods used by ExtUtils::MakeMaker + +=item ExtUtils::MM_VMS + +methods to override UN*X behaviour in ExtUtils::MakeMaker -!!!GOOD QUESTION!!! +=item ExtUtils::testlib + +add blib/* directories to @INC + +=item Fatal + +replace functions with equivalents which succeed or die =item Fcntl @@ -454,10 +520,18 @@ load the C Fcntl.h defines parse file specifications +=item FileCache + +keep more files open than the system permits + =item File::CheckTree run many filetest checks on a tree +=item File::Copy + +Copy files or filehandles + =item File::Find traverse a file tree @@ -470,46 +544,146 @@ supply object methods for filehandles create or remove a series of directories +=item FindBin + +locate directory of original perl script + +=item GDBM_File + +access to the gdbm library. + =item Getopt::Long -extended getopt processing +extended processing of command line options =item Getopt::Std -Process single-character switches with switch clustering +process single-character switches with switch clustering =item I18N::Collate compare 8-bit scalar data according to the current locale +=item IO + +load various IO modules + +=item IO::File + +supply object methods for filehandles + +=item IO::Handle + +supply object methods for I/O handles + +=item IO::Pipe + +supply object methods for pipes + +=item IO::Seekable + +supply seek based methods for I/O objects + +=item IO::Select + +OO interface to the select system call + +=item IO::Socket + +object interface to socket communications + =item IPC::Open2 -a process for both reading and writing +open a process for both reading and writing =item IPC::Open3 open a process for reading, writing, and error handling +=item Math::BigFloat + +arbitrary length float math package + +=item Math::BigInt + +arbitrary size integer math package + +=item Math::Complex + +complex numbers and associated mathematical functions + +=item NDBM_File + +tied access to ndbm files + =item Net::Ping check a host for upness +=item Opcode + +disable named opcodes when compiling perl code + +=item Pod::Text + +convert POD data to formatted ASCII text + =item POSIX -Perl interface to IEEE Std 1003.1 +interface to IEEE Std 1003.1 + +=item Safe + +compile and execute code in restricted compartments + +=item SDBM_File + +tied access to sdbm files + +=item Search::Dict + +search for key in dictionary file + +=item SelectSaver + +save and restore selected file handle =item SelfLoader load functions only on demand -=item Safe +=item Shell -Creation controlled compartments in which perl code can be evaluated. +run shell commands transparently within perl =item Socket load the C socket.h defines and structure manipulators +=item Symbol + +manipulate Perl symbols and their names + +=item Sys::Hostname + +try every conceivable way to get hostname + +=item Sys::Syslog + +interface to the UNIX syslog(3) calls + +=item Term::Cap + +Perl termcap interface + +=item Term::Complete + +word completion module + +=item Term::ReadLine + +interface to various readline packages. + =item Test::Harness run perl standard test scripts with statistics @@ -518,6 +692,42 @@ run perl standard test scripts with statistics create an abbreviation table from a list +=item Text::ParseWords + +parse text into an array of tokens + +=item Text::Soundex + +implementation of the Soundex Algorithm as Described by Knuth + +=item Text::Tabs + +expand and unexpand tabs per the unix expand(1) and unexpand(1) + +=item Text::Wrap + +line wrapping to form simple paragraphs + +=item Tie::Hash + +base class definitions for tied hashes + +=item Tie::Scalar + +base class definitions for tied scalars + +=item Tie::SubstrHash + +fixed-table-size, fixed-key-length hashing + +=item Time::Local + +efficiently compute time from local and GMT time + +=item UNIVERSAL + +base class for ALL classes (blessed references) + =back To find out I<all> the modules installed on your system, including @@ -927,7 +1137,7 @@ Copying, ToDo etc. =item Adding a Copyright Notice. -How you choose to license your work is a personal decision. +How you choose to licence your work is a personal decision. The general mechanism is to assert your Copyright and then make a declaration of how others may copy/use/modify your work. diff --git a/pod/perlobj.pod b/pod/perlobj.pod index 54e052ff45..d504d9ce2a 100644 --- a/pod/perlobj.pod +++ b/pod/perlobj.pod @@ -24,7 +24,7 @@ with object references. =item 3. A method is simply a subroutine that expects an object reference (or -a package name, for static methods) as the first argument. +a package name, for class methods) as the first argument. =back @@ -156,17 +156,18 @@ Unlike say C++, Perl doesn't provide any special syntax for method definition. (It does provide a little syntax for method invocation though. More on that later.) A method expects its first argument to be the object or package it is being invoked on. There are just two -types of methods, which we'll call static and virtual, in honor of -the two C++ method types they most closely resemble. +types of methods, which we'll call class and instance. +(Sometimes you'll hear these called static and virtual, in honor of +the two C++ method types they most closely resemble.) -A static method expects a class name as the first argument. It +A class method expects a class name as the first argument. It provides functionality for the class as a whole, not for any individual -object belonging to the class. Constructors are typically static -methods. Many static methods simply ignore their first argument, since +object belonging to the class. Constructors are typically class +methods. Many class methods simply ignore their first argument, since they already know what package they're in, and don't care what package they were invoked via. (These aren't necessarily the same, since -static methods follow the inheritance tree just like ordinary virtual -methods.) Another typical use for static methods is to look up an +class methods follow the inheritance tree just like ordinary instance +methods.) Another typical use for class methods is to look up an object by name: sub find { @@ -174,7 +175,7 @@ object by name: $objtable{$name}; } -A virtual method expects an object reference as its first argument. +An instance method expects an object reference as its first argument. Typically it shifts the first argument into a "self" or "this" variable, and then uses that as an ordinary reference. @@ -194,9 +195,9 @@ already had an "indirect object" syntax that you use when you say print STDERR "help!!!\n"; -This same syntax can be used to call either static or virtual methods. -We'll use the two methods defined above, the static method to lookup -an object reference and the virtual method to print out its attributes. +This same syntax can be used to call either class or instance methods. +We'll use the two methods defined above, the class method to lookup +an object reference and the instance method to print out its attributes. $fred = find Critter "Fred"; display $fred 'Height', 'Weight'; @@ -300,7 +301,7 @@ I<undef> is returned. C<VERSION> returns the VERSION number of the class (package). If an argument is given then it will check that the current version is not -less that the given argument. This method is normally called as a static +less that the given argument. This method is normally called as a class method. This method is also called when the C<VERSION> form of C<use> is used. diff --git a/pod/perlop.pod b/pod/perlop.pod index 4752148dbe..5645234bf4 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -145,6 +145,7 @@ is returned. One effect of these rules is that C<-bareword> is equivalent to C<"-bareword">. Unary "~" performs bitwise negation, i.e. 1's complement. +(See also L<Integer Arithmetic>.) Unary "+" has no effect whatsoever, even on strings. It is useful syntactically for separating a function name from a parenthesized expression @@ -204,13 +205,13 @@ Binary "." concatenates two strings. =head2 Shift Operators -Binary "E<lt>E<lt>" returns the value of its left argument shifted left by the -number of bits specified by the right argument. Arguments should be -integers. +Binary "<<" returns the value of its left argument shifted left by the +number of bits specified by the right argument. Arguments should be +integers. (See also L<Integer Arithmetic>.) -Binary "E<gt>E<gt>" returns the value of its left argument shifted right by the -number of bits specified by the right argument. Arguments should be -integers. +Binary ">>" returns the value of its left argument shifted right by +the number of bits specified by the right argument. Arguments should +be integers. (See also L<Integer Arithmetic>.) =head2 Named Unary Operators @@ -292,12 +293,15 @@ less than, equal to, or greater than the right argument. =head2 Bitwise And Binary "&" returns its operators ANDed together bit by bit. +(See also L<Integer Arithmetic>.) =head2 Bitwise Or and Exclusive Or Binary "|" returns its operators ORed together bit by bit. +(See also L<Integer Arithmetic>.) Binary "^" returns its operators XORed together bit by bit. +(See also L<Integer Arithmetic>.) =head2 C-style Logical And @@ -1103,7 +1107,7 @@ expression represents so that the interpreter won't have to. -=head2 Integer arithmetic +=head2 Integer Arithmetic By default Perl assumes that it must do most of its arithmetic in floating point. But by saying @@ -1118,3 +1122,9 @@ countermand this by saying which lasts until the end of that BLOCK. +The bitwise operators ("&", "|", "^", "~", "<<", and ">>") always +produce integral results. However, C<use integer> still has meaning +for them. By default, their results are interpreted as unsigned +integers. However, if C<use integer> is in effect, their results are +interpeted as signed integers. For example, C<~0> usually evaluates +to a large integral value. However, C<use integer; ~0> is -1. diff --git a/pod/perlre.pod b/pod/perlre.pod index 55dc1209bc..c4dbac63c6 100644 --- a/pod/perlre.pod +++ b/pod/perlre.pod @@ -13,10 +13,28 @@ The matching operations can have various modifiers, some of which relate to the interpretation of the regular expression inside. These are: - i Do case-insensitive pattern matching. - m Treat string as multiple lines. - s Treat string as single line. - x Extend your pattern's legibility with whitespace and comments. +=over 4 + +=item i + +Do case-insensitive pattern matching. + +=item m + +Treat string as multiple lines. That is, change "^" and "$" from matching +only at the very start or end of the string to the start or end of any +line anywhere within the string, + +=item s + +Treat string as single line. That is, change "." to match any character +whatsoever, even a newline, which it normally would not match. + +=item x + +Extend your pattern's legibility by permitting whitespace and comments. + +=back These are usually written as "the C</x> modifier", even though the delimiter in question might not actually be a slash. In fact, any of these @@ -24,13 +42,15 @@ 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 +the regular expression parser to ignore whitespace that is neither +backslashed nor 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>. +just as in ordinary Perl code. This also means that if you want real +whitespace or C<#> characters in the pattern that you'll have to either +escape them or encode them using octal or hex escapes. Taken together, +these features go a long way towards making Perl's regular expressions +more readable. See the C comment deletion code in L<perlop>. =head2 Regular Expressions @@ -63,7 +83,7 @@ on the pattern match operator. (Older programs did this by setting C<$*>, but this practice is deprecated in Perl 5.) To facilitate multi-line substitutions, the "." character never matches a -newline unless you use the C</s> modifier, which tells Perl to pretend +newline unless you use the C</s> modifier, which in effect tells Perl to pretend the string is a single line--even if it isn't. The C</s> modifier also overrides the setting of C<$*>, in case you have some (badly behaved) older code that sets it in another module. diff --git a/pod/perlref.pod b/pod/perlref.pod index a7c7f438d8..18e355376e 100644 --- a/pod/perlref.pod +++ b/pod/perlref.pod @@ -53,8 +53,11 @@ reference that the backslash returned. Here are some examples: $arrayref = \@ARGV; $hashref = \%ENV; $coderef = \&handler; - $globref = \*STDOUT; + $globref = \*foo; +It isn't possible to create a reference to a filehandle using the +backslash operator. See the explanation of the *foo{THING} syntax +below. =item 2. @@ -188,22 +191,37 @@ talked about dereferencing yet, we can't show you any examples yet. =item 7. -References to filehandles can be created by taking a reference to -a typeglob. This is currently the best way to pass filehandles into or -out of subroutines, or to store them in larger data structures. +A reference can be created by using a special syntax, lovingly known as +the *foo{THING} syntax. *foo{THING} returns a reference to the THING +slot in *foo (which is the symbol table entry which holds everything +known as foo). - splutter(\*STDOUT); + $scalarref = *foo{SCALAR}; + $arrayref = *ARGV{ARRAY}; + $hashref = *ENV{HASH}; + $coderef = *handler{CODE}; + $fhref = *STDIN{FILEHANDLE}; + $globref = *foo{GLOB}; + +Using *foo{FILEHANDLE} is the best way to pass filehandles into or out +of subroutines, or to store them in larger data structures. + + splutter(*STDOUT{FILEHANDLE}); sub splutter { my $fh = shift; print $fh "her um well a hmmm\n"; } - $rec = get_rec(\*STDIN); + $rec = get_rec(*STDIN{FILEHANDLE}); sub get_rec { my $fh = shift; return scalar <$fh>; } +The best way to do this used to be to use the entire *foo typeglob (or a +reference to it), so you'll probably come accross old code which does it +that way. + =back That's it for creating references. By now you're probably dying to diff --git a/pod/perlrun.pod b/pod/perlrun.pod index 5042d67bd7..c69a03eb53 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -100,7 +100,7 @@ Switches include: =item B<-0>[I<digits>] -specifies the record separator (C<$/>) as an octal number. If there are +specifies the input record separator (C<$/>) as an octal number. If there are no digits, the null character is the separator. Other switches may precede or follow the digits. For example, if you have a version of B<find> which can print filenames terminated by the null character, you @@ -245,9 +245,10 @@ searches /usr/include and /usr/lib/perl. =item B<-l>[I<octnum>] enables automatic line-ending processing. It has two effects: first, -it automatically chomps the line terminator when used with B<-n> or -B<-p>, and second, it assigns "C<$\>" to have the value of I<octnum> so that -any print statements will have that line terminator added back on. If +it automatically chomps "C<$/>" (the input record separator) when used +with B<-n> or B<-p>, and second, it assigns "C<$\>" +(the output record separator) to have the value of I<octnum> so that +any print statements will have that separator added back on. If I<octnum> is omitted, sets "C<$\>" to the current value of "C<$/>". For instance, to trim lines to 80 columns: diff --git a/pod/perlsub.pod b/pod/perlsub.pod index 870b2b5af9..1c3a3c0709 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -187,11 +187,12 @@ Synopsis: my @oof = @bar; # declare @oof lexical, and init it A "my" declares the listed variables to be confined (lexically) to the -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 -listed elements must be legal lvalues. Only alphanumeric identifiers may -be lexically scoped--magical builtins like $/ must currently be localized with -"local" instead. +enclosing block, conditional (C<if/unless/elsif/else>), loop +(C<for/foreach/while/until/continue>), 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 listed elements must be legal lvalues. +Only alphanumeric identifiers may be lexically scoped--magical +builtins like $/ must currently be localized with "local" instead. Unlike dynamic variables created by the "local" statement, lexical variables declared with "my" are totally hidden from the outside world, @@ -250,6 +251,49 @@ the expression is false unless the old $x happened to have the value 123. +Lexical scopes of control structures are not bounded precisely by the +braces that delimit their controlled blocks; control expressions are +part of the scope, too. Thus in the loop + + while (my $line = <>) { + $line = lc $line; + } continue { + print $line; + } + +the scope of $line extends from its declaration throughout the rest of +the loop construct (including the C<continue> clause), but not beyond +it. Similarly, in the conditional + + if ((my $answer = <STDIN>) =~ /^yes$/i) { + user_agrees(); + } elsif ($answer =~ /^no$/i) { + user_disagrees(); + } else { + chomp $answer; + die "'$answer' is neither 'yes' nor 'no'"; + } + +the scope of $answer extends from its declaration throughout the rest +of the conditional (including C<elsif> and C<else> clauses, if any), +but not beyond it. + +(None of the foregoing applies to C<if/unless> or C<while/until> +modifiers appended to simple statements. Such modifiers are not +control structures and have no effect on scoping.) + +The C<foreach> loop defaults to dynamically scoping its index variable +(in the manner of C<local>; see below). However, if the index +variable is prefixed with the keyword "my", then it is lexically +scoped instead. Thus in the loop + + for my $i (1, 2, 3) { + some_function(); + } + +the scope of $i extends to the end of the loop, but not beyond it, and +so the value of $i is unavailable in some_function(). + Some users may wish to encourage the use of lexically scoped variables. As an aid to catching implicit references to package variables, if you say @@ -422,11 +466,11 @@ Sometimes you don't want to pass the value of an array to a subroutine but rather the name of it, so that the subroutine can modify the global copy of it rather than working with a local copy. In perl you can refer to all objects of a particular name by prefixing the name -with a star: C<*foo>. This is often known as a "type glob", since the +with a star: C<*foo>. This is often known as a "typeglob", since the star on the front can be thought of as a wildcard match for all the funny prefix characters on variables and subroutines and such. -When evaluated, the type glob produces a scalar value that represents +When evaluated, the typeglob produces a scalar value that represents all the objects of that name, including any filehandle, format or subroutine. When assigned to, it causes the name mentioned to refer to whatever "*" value was assigned to it. Example: @@ -450,14 +494,15 @@ an array. It will certainly be faster to pass the typeglob (or reference). Even if you don't want to modify an array, this mechanism is useful for passing multiple arrays in a single LIST, since normally the LIST mechanism will merge all the array values so that you can't extract out -the individual arrays. For more on typeglobs, see L<perldata/"Typeglobs">. +the individual arrays. For more on typeglobs, see +L<perldata/"Typeglobs and FileHandles">. =head2 Pass by Reference -If you want to pass more than one array or hash into a function--or -return them from it--and have them maintain their integrity, -then you're going to have to use an explicit pass-by-reference. -Before you do that, you need to understand references as detailed in L<perlref>. +If you want to pass more than one array or hash into a function--or +return them from it--and have them maintain their integrity, then +you're going to have to use an explicit pass-by-reference. Before you +do that, you need to understand references as detailed in L<perlref>. This section may not make much sense to you otherwise. Here are a few simple examples. First, let's pass in several @@ -538,34 +583,6 @@ Here we're using the typeglobs to do symbol table aliasing. It's a tad subtle, though, and also won't work if you're using my() variables, since only globals (well, and local()s) are in the symbol table. -If you're passing around filehandles, you could usually just use the bare -typeglob, like *STDOUT, but typeglobs references would be better because -they'll still work properly under C<use strict 'refs'>. For example: - - splutter(\*STDOUT); - sub splutter { - my $fh = shift; - print $fh "her um well a hmmm\n"; - } - - $rec = get_rec(\*STDIN); - sub get_rec { - my $fh = shift; - return scalar <$fh>; - } - -If you're planning on generating new filehandles, you could do this: - - sub openit { - my $name = shift; - local *FH; - return open (FH, $path) ? \*FH : undef; - } - -Although that will actually produce a small memory leak. See the bottom -of L<perlfunc/open()> for a somewhat cleaner way using the FileHandle -functions supplied with the POSIX package. - =head2 Prototypes As of the 5.002 release of perl, if you declare @@ -645,7 +662,7 @@ The interesting thing about & is that you can generate new syntax with it: &$catch; } } - sub catch (&) { @_ } + sub catch (&) { $_[0] } try { die "phooey"; diff --git a/pod/perlsyn.pod b/pod/perlsyn.pod index 459795e7cd..b0f77f4149 100644 --- a/pod/perlsyn.pod +++ b/pod/perlsyn.pod @@ -244,6 +244,9 @@ is the same as this: $i++; } +(There is one minor difference: The first form implies a lexical scope +for variables declared with C<my> in the initialization expression.) + Besides the normal array index looping, C<for> can lend itself to many other interesting applications. Here's one that avoids the problem you get into if you explicitly test for end-of-file on @@ -259,12 +262,14 @@ hang. =head2 Foreach Loops 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. -This can cause problems if you have subroutine or format declarations -within that block's scope. +variable VAR to be each element of the list in turn. If the variable +is preceded with the keyword C<my>, then it is lexically scoped, and +is therefore visible only within the loop. Otherwise, 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. (Note that a lexically scoped variable can cause problems +with you have subroutine or format declarations.) 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 @@ -278,7 +283,7 @@ Examples: for (@ary) { s/foo/bar/ } - foreach $elem (@elements) { + foreach my $elem (@elements) { $elem *= 2; } @@ -294,8 +299,8 @@ Examples: 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++) { + for (my $i = 0; $i < @ary1; $i++) { + for (my $j = 0; $j < @ary2; $j++) { if ($ary1[$i] > $ary2[$j]) { last; # can't go to outer :-( } @@ -307,8 +312,8 @@ Here's how a C programmer might code up a particular algorithm in Perl: Whereas here's how a Perl programmer more comfortable with the idiom might do it: - OUTER: foreach $wid (@ary1) { - INNER: foreach $jet (@ary2) { + OUTER: foreach my $wid (@ary1) { + INNER: foreach my $jet (@ary2) { next OUTER if $wid > $jet; $wid += $jet; } @@ -324,12 +329,12 @@ 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. (Note that this -is I<NOT> true in C<eval{}>, C<sub{}>, or contrary to popular belief C<do{}> blocks, -which do I<NOT> count as loops.) The C<continue> block -is optional. +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. (Note that this is +I<NOT> true in C<eval{}>, C<sub{}>, or contrary to popular belief +C<do{}> blocks, which do I<NOT> count as loops.) The C<continue> +block is optional. The BLOCK construct is particularly nice for doing case structures. diff --git a/pod/perltoc.pod b/pod/perltoc.pod index 81b81ccb42..7c16f94edc 100644 --- a/pod/perltoc.pod +++ b/pod/perltoc.pod @@ -232,7 +232,7 @@ y/SEARCHLIST/REPLACEMENTLIST/cds =item Constant Folding -=item Integer arithmetic +=item Integer Arithmetic @@ -247,6 +247,8 @@ y/SEARCHLIST/REPLACEMENTLIST/cds =item DESCRIPTION +i, m, s, x + =over =item Regular Expressions @@ -742,6 +744,11 @@ structures, objects =item Method Invocation +=item Default UNIVERSAL methods + +isa(CLASS), can(METHOD), VERSION([VERSION]), class(), is_instance() + + =item Destructors @@ -857,20 +864,43 @@ FIRSTKEY this, NEXTKEY this, lastkey, DESTROY this =item DESCRIPTION +=item The Perl Debugger + + =over -=item Debugging +=item Debugger Commands + + +h [command], p expr, x expr, V [pkg [vars]], X [vars], T, s [expr], n, +E<lt>CRE<gt>, c [line], l, l min+incr, l min-max, l line, l subname, +-, w [line], f filename, /pattern/, ?pattern?, L, S [[!]pattern], t, t +expr, b [line] [condition], b subname [condition], d [line], D, a +[line] command, A, O [opt[=val]] [opt"val"] [opt?].., recallCommand, +ShellBang, pager, arrayDepth, hashDepth, compactDump, veryCompact, +globPrint, DumpDBFiles, DumpPackages, quote, HighBit, undefPrint, +tkRunning, signalLevel, warnLevel. dieLevel, E<lt> command, E<gt> +command, ! number, ! -number, ! pattern, !! cmd, H -number, q or ^D, +R, |dbcmd, ||dbcmd, = [alias value], command, p expr -h, T, s, n, f, c, c line, <CR>, l min+incr, l min-max, l line, l, -, w -line, l subname, /pattern/, ?pattern?, L, S, t, b line [ condition ], b -subname [ condition ], d line, D, a line command, A, < command, > -command, V package [symbols], X [symbols], ! number, ! -number, H --number, q or ^D, command, p expr +=item Debugger Customization -=item Customization +=item Readline Support + +=item Editor Support for Debugging + + +=item The Perl Profiler + + +=item Debugger Internals + +TTY, noTTY, ReadLine, NonStop, LineInfo + + =item Other resources @@ -899,10 +929,14 @@ command, V package [symbols], X [symbols], ! number, ! -number, H =over -=item Format Variables +=item Laundering and Detecting Tainted Data + +=item Cleaning Up Your Path +=item Security Bugs + =back @@ -3147,7 +3181,7 @@ have man pages yet: =head1 AUTHOR -Larry Wall E<lt><F<larry@wall.org>E<gt>, with the help of oodles of +Larry Wall E<lt>F<larry@wall.org>E<gt>, with the help of oodles of other folks. diff --git a/pod/perltrap.pod b/pod/perltrap.pod index 3d31173584..e85f5c9007 100644 --- a/pod/perltrap.pod +++ b/pod/perltrap.pod @@ -549,6 +549,36 @@ behave like C<split /\s+/> (which does). # perl4 prints: :hi:mom # perl5 prints: hi:mom +=item * BugFix + +Perl 4 would ignore any text which was attached to an C<-e> switch, +always taking the code snippet from the following arg. Additionally, it +would silently accept an C<-e> switch without a following arg. Both of +these behaviors have been fixed. + + perl -e'print "attached to -e"' 'print "separate arg"' + + # perl4 prints: separate arg + # perl5 prints: attached to -e + + perl -e + + # perl4 prints: + # perl5 dies: No code specified for -e. + +=item * Discontinuance + +In Perl 4 the return value of C<push> was undocumented, but it was +actually the last value being pushed onto the target list. In Perl 5 +the return value of C<push> is documented, but has changed, it is the +number of elements in the resulting list. + + @x = ('existing'); + print push(@x, 'first new', 'second new'); + + # perl4 prints: second new + # perl5 prints: 3 + =item * Deprecation Some error messages will be different. @@ -640,8 +670,8 @@ Logical tests now return an null, instead of 0 # perl4 prints: 0 # perl5 prints: -Also see the L<General Regular Expression Traps> tests for another example -of this new feature... +Also see the L<General Regular Expression Traps using s///, etc.> +tests for another example of this new feature... =back diff --git a/pod/pod2man.PL b/pod/pod2man.PL index a4a3c25eeb..0a51fc8efd 100644 --- a/pod/pod2man.PL +++ b/pod/pod2man.PL @@ -15,7 +15,7 @@ use File::Basename qw(&basename &dirname); chdir(dirname($0)); ($file = basename($0)) =~ s/\.PL$//; $file =~ s/\.pl$// - if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving" + if ($^O eq 'VMS' or $^O eq 'os2' or $^O eq 'amigaos'); # "case-forgiving" open OUT,">$file" or die "Can't create $file: $!"; @@ -388,8 +388,11 @@ $wanna_see{SYNOPSIS}++ if $section =~ /^3/; $name = @ARGV ? $ARGV[0] : "<STDIN>"; $Filename = $name; -$name = uc($name) if $section =~ /^1/; -$name =~ s/\.[^.]*$//; +if ($section =~ /^1/) { + require File::Basename; + $name = uc File::Basename::basename($name); +} +$name =~ s/\.(pod|p[lm])$//i; $name =~ s(/)(::)g; # translate Getopt/Long to Getopt::Long, etc. if ($name ne 'something') { @@ -575,14 +575,11 @@ PP(pp_undef) PP(pp_predec) { dSP; - if (SvIOK(TOPs)) { - if (SvIVX(TOPs) == IV_MIN) { - sv_setnv(TOPs, (double)SvIVX(TOPs) - 1.0); - } - else { - --SvIVX(TOPs); - SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); - } + if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && + SvIVX(TOPs) != IV_MIN) + { + --SvIVX(TOPs); + SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else sv_dec(TOPs); @@ -594,14 +591,11 @@ PP(pp_postinc) { dSP; dTARGET; sv_setsv(TARG, TOPs); - if (SvIOK(TOPs)) { - if (SvIVX(TOPs) == IV_MAX) { - sv_setnv(TOPs, (double)SvIVX(TOPs) + 1.0); - } - else { - ++SvIVX(TOPs); - SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); - } + if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && + SvIVX(TOPs) != IV_MAX) + { + ++SvIVX(TOPs); + SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else sv_inc(TOPs); @@ -616,14 +610,11 @@ PP(pp_postdec) { dSP; dTARGET; sv_setsv(TARG, TOPs); - if (SvIOK(TOPs)) { - if (SvIVX(TOPs) == IV_MIN) { - sv_setnv(TOPs, (double)SvIVX(TOPs) - 1.0); - } - else { - --SvIVX(TOPs); - SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); - } + if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && + SvIVX(TOPs) != IV_MIN) + { + --SvIVX(TOPs); + SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else sv_dec(TOPs); @@ -773,9 +764,12 @@ PP(pp_left_shift) { dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); { - dPOPTOPiirl; - SETi( left << right ); - RETURN; + dPOPTOPiirl; + if (op->op_private & HINT_INTEGER) + SETi( left << right ); + else + SETu( (UV)left << right ); + RETURN; } } @@ -784,7 +778,10 @@ PP(pp_right_shift) dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); { dPOPTOPiirl; - SETi( left >> right ); + if (op->op_private & HINT_INTEGER) + SETi( left >> right ); + else + SETu( (UV)left >> right ); RETURN; } } @@ -917,17 +914,17 @@ PP(pp_scmp) } } -PP(pp_bit_and) { +PP(pp_bit_and) +{ dSP; dATARGET; tryAMAGICbin(band,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { - unsigned long value = U_L(SvNV(left)); - value = value & U_L(SvNV(right)); - if ((IV)value == value) - SETi(value); + UV value = SvIV(left) & SvIV(right); + if (op->op_private & HINT_INTEGER) + SETi( (IV)value ); else - SETn((double)value); + SETu( value ); } else { do_vop(op->op_type, TARG, left, right); @@ -943,12 +940,11 @@ PP(pp_bit_xor) { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { - unsigned long value = U_L(SvNV(left)); - value = value ^ U_L(SvNV(right)); - if ((IV)value == value) - SETi(value); + UV value = SvIV(left) ^ SvIV(right); + if (op->op_private & HINT_INTEGER) + SETi( (IV)value ); else - SETn((double)value); + SETu( value ); } else { do_vop(op->op_type, TARG, left, right); @@ -964,12 +960,11 @@ PP(pp_bit_or) { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { - unsigned long value = U_L(SvNV(left)); - value = value | U_L(SvNV(right)); - if ((IV)value == value) - SETi(value); + UV value = SvIV(left) | SvIV(right); + if (op->op_private & HINT_INTEGER) + SETi( (IV)value ); else - SETn((double)value); + SETu( value ); } else { do_vop(op->op_type, TARG, left, right); @@ -986,7 +981,9 @@ PP(pp_negate) dTOPss; if (SvGMAGICAL(sv)) mg_get(sv); - if (SvNIOKp(sv)) + if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN) + SETi(-SvIVX(sv)); + else if (SvNIOKp(sv)) SETn(-SvNV(sv)); else if (SvPOKp(sv)) { STRLEN len; @@ -1023,18 +1020,17 @@ PP(pp_complement) dSP; dTARGET; tryAMAGICun(compl); { dTOPss; - register I32 anum; - if (SvNIOKp(sv)) { - UV value = ~SvIV(sv); - if ((IV)value == value) - SETi(value); + UV value = ~(UV)SvIV(sv); + if (op->op_private & HINT_INTEGER) + SETi( (IV)value ); else - SETn((double)value); + SETu( value ); } else { register char *tmps; register long *tmpl; + register I32 anum; STRLEN len; SvSetSV(TARG, sv); @@ -1371,22 +1367,17 @@ PP(pp_hex) { dSP; dTARGET; char *tmps; - unsigned long value; I32 argtype; tmps = POPp; - value = scan_hex(tmps, 99, &argtype); - if ((IV)value >= 0) - XPUSHi(value); - else - XPUSHn(U_V(value)); + XPUSHu(scan_hex(tmps, 99, &argtype)); RETURN; } PP(pp_oct) { dSP; dTARGET; - unsigned long value; + UV value; I32 argtype; char *tmps; @@ -1399,10 +1390,7 @@ PP(pp_oct) value = scan_hex(++tmps, 99, &argtype); else value = scan_oct(tmps, 99, &argtype); - if ((IV)value >= 0) - XPUSHi(value); - else - XPUSHn(U_V(value)); + XPUSHu(value); RETURN; } @@ -2330,6 +2318,35 @@ PP(pp_reverse) RETURN; } +static SV * +mul128(sv, m) + SV *sv; + U8 m; +{ + STRLEN len; + char *s = SvPV(sv, len); + char *t; + U32 i = 0; + + if (!strnEQ(s, "0000", 4)) { /* need to grow sv */ + SV *new = newSVpv("0000000000", 10); + + sv_catsv(new, sv); + SvREFCNT_dec(sv); /* free old sv */ + sv = new; + s = SvPV(sv, len); + } + t = s + len - 1; + while (!*t) /* trailing '\0'? */ + t--; + while (t > s) { + i = ((*t - '0') << 7) + m; + *(t--) = '0' + (i % 10); + m = i / 10; + } + return (sv); +} + /* Explosives and implosives. */ PP(pp_unpack) @@ -2800,7 +2817,7 @@ PP(pp_unpack) while (len > 0) { if (s >= strend) { if (auint) { - DIE("Unterminated compressed integer"); + croak("Unterminated compressed integer"); } else { break; } @@ -2813,17 +2830,29 @@ PP(pp_unpack) len--; auint = 0; bytes = 0; - } else if (++bytes >= sizeof(auint)) { /* promote to double */ - adouble = auint; + } else if (++bytes >= sizeof(auint)) { /* promote to string */ + char zero[10]; + (void) sprintf(zero, "%010ld", auint); + sv = newSVpv(zero, 10); + while (*s & 0x80) { - adouble = (adouble * 128) + (*(++s) & 0x7f); + sv = mul128(sv, (U8) (*(++s) & 0x7f)); if (s >= strend) { - DIE("Unterminated compressed integer"); + croak("Unterminated compressed integer"); } } - sv = NEWSV(40, 0); - sv_setnv(sv, adouble); + /* remove leading '0's */ + { + char *s = SvPV(sv, na); + + while (*s == '0') { + s++; + na--; + } + /* overlapping copy !! */ + sv_setpvn(sv, s, na); + } PUSHs(sv_2mortal(sv)); len--; auint = 0; @@ -3029,6 +3058,85 @@ register I32 len; sv_catpvn(sv, "\n", 1); } +static SV * +is_an_int(s, l) + char *s; + STRLEN l; +{ + SV *result = newSVpv("", l); + char *result_c = SvPV(result, na); /* convenience */ + char *out = result_c; + bool skip = 1; + bool ignore = 0; + + while (*s) { + switch (*s) { + case ' ': + break; + case '+': + if (!skip) { + SvREFCNT_dec(result); + return (NULL); + } + break; + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + skip = 0; + if (!ignore) { + *(out++) = *s; + } + break; + case '.': + ignore = 1; + break; + default: + SvREFCNT_dec(result); + return (NULL); + } + s++; + } + *(out++) = '\0'; + SvCUR_set(result, out - result_c); + return (result); +} + +static int +div128(pnum, done) + SV *pnum; /* must be '\0' terminated */ + bool *done; +{ + STRLEN len; + char *s = SvPV(pnum, len); + int m = 0; + int r = 0; + char *t = s; + + *done = 1; + while (*t) { + int i; + + i = m * 10 + (*t - '0'); + m = i & 0x7F; + r = (i >> 7); /* r < 10 */ + if (r) { + *done = 0; + } + *(t++) = '0' + r; + } + *(t++) = '\0'; + SvCUR_set(pnum, (STRLEN) (t - s)); + return (m); +} + + PP(pp_pack) { dSP; dMARK; dORIGMARK; dTARGET; @@ -3313,34 +3421,64 @@ PP(pp_pack) fromstr = NEXTFROM; adouble = floor((double)SvNV(fromstr)); - if (adouble < 268435456) { /* we can use integers */ - unsigned char buf[4]; /* buffer for compressed int */ - unsigned char *in = buf + 3; + if (adouble <= PERL_ULONG_MAX) { /* we can use integers */ + unsigned char buf[5]; /* buffer for compressed int */ + unsigned char *in = buf + 4; + auint = U_I(adouble); + do { *(in--) = (unsigned char) ((auint & 0x7f) | 0x80); auint >>= 7; } while (auint); - buf[3] &= 0x7f; /* clear continue bit */ - sv_catpvn(cat, (char*) in+1, buf+3-in); + buf[4] &= 0x7f; /* clear continue bit */ + sv_catpvn(cat, (char *) in + 1, buf + 4 - in); + } else if (SvPOKp(fromstr)) { /* decimal string arithmetics */ + char *from; + SV *norm; + STRLEN len; + + /* Copy string and check for compliance */ + from = SvPV(fromstr, len); + if ((norm = is_an_int(from, len)) == NULL) { + croak("can compress only unsigned integer"); } else { - unsigned char buf[sizeof(double)*2]; /* buffer for compressed int */ - I8 msize = sizeof(double)*2; /* 8/7 would be enough */ + bool done = 0; + char *result, *in; + + New('w', result, len, char); + in = result + len; + while (!done) { + U8 digit = div128(norm, &done); + + *(--in) = digit | 0x80; + } + result[len - 1] &= 0x7F; + sv_catpvn(cat, in, result + len - in); + SvREFCNT_dec(norm); /* free norm */ + } + } else if (SvNOKp(fromstr)) { + I8 msize = sizeof(double) * 2; /* 8/7 <= 2 */ + unsigned char buf[sizeof(double) * 2]; unsigned char *in = buf + msize -1; + if (adouble<0) { croak("Cannot compress negative numbers"); } do { double next = adouble/128; + *in = (unsigned char) (adouble - floor(next)*128); *in |= 0x80; /* set continue bit */ if (--in < buf) { /* this cannot happen ;-) */ croak ("Cannot compress integer"); } adouble = next; - } while (floor(adouble)>0); /* floor() not necessary? */ + } while (floor(adouble)); /* floor() not necessary? */ buf[msize-1] &= 0x7f; /* clear continue bit */ sv_catpvn(cat, (char*) in+1, buf+msize-in-1); + } else { + croak("Cannot compress non integer"); } } break; @@ -55,12 +55,14 @@ #define POPp (SvPVx(POPs, na)) #define POPn (SvNVx(POPs)) #define POPi ((IV)SvIVx(POPs)) +#define POPu ((UV)SvIVx(POPs)) #define POPl ((long)SvIVx(POPs)) #define TOPs (*sp) #define TOPp (SvPV(TOPs, na)) #define TOPn (SvNV(TOPs)) #define TOPi ((IV)SvIV(TOPs)) +#define TOPu ((UV)SvIV(TOPs)) #define TOPl ((long)SvIV(TOPs)) /* Go to some pains in the rare event that we must extend the stack. */ @@ -80,18 +82,21 @@ #define PUSHp(p,l) STMT_START { sv_setpvn(TARG, (p), (l)); PUSHTARG; } STMT_END #define PUSHn(n) STMT_START { sv_setnv(TARG, (double)(n)); PUSHTARG; } STMT_END #define PUSHi(i) STMT_START { sv_setiv(TARG, (IV)(i)); PUSHTARG; } STMT_END +#define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END #define XPUSHs(s) STMT_START { EXTEND(sp,1); (*++sp = (s)); } STMT_END #define XPUSHTARG STMT_START { SvSETMAGIC(TARG); XPUSHs(TARG); } STMT_END #define XPUSHp(p,l) STMT_START { sv_setpvn(TARG, (p), (l)); XPUSHTARG; } STMT_END #define XPUSHn(n) STMT_START { sv_setnv(TARG, (double)(n)); XPUSHTARG; } STMT_END #define XPUSHi(i) STMT_START { sv_setiv(TARG, (IV)(i)); XPUSHTARG; } STMT_END +#define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END #define SETs(s) (*sp = s) #define SETTARG STMT_START { SvSETMAGIC(TARG); SETs(TARG); } STMT_END #define SETp(p,l) STMT_START { sv_setpvn(TARG, (p), (l)); SETTARG; } STMT_END #define SETn(n) STMT_START { sv_setnv(TARG, (double)(n)); SETTARG; } STMT_END #define SETi(i) STMT_START { sv_setiv(TARG, (IV)(i)); SETTARG; } STMT_END +#define SETu(u) STMT_START { sv_setuv(TARG, (UV)(u)); SETTARG; } STMT_END #define dTOPss SV *sv = TOPs #define dPOPss SV *sv = POPs @@ -99,14 +104,18 @@ #define dPOPnv double value = POPn #define dTOPiv IV value = TOPi #define dPOPiv IV value = POPi +#define dTOPuv UV value = TOPu +#define dPOPuv UV value = POPu #define dPOPPOPssrl SV *right = POPs; SV *left = POPs #define dPOPPOPnnrl double right = POPn; double left = POPn #define dPOPPOPiirl IV right = POPi; IV left = POPi +#define dPOPPOPuurl UV right = POPu; UV left = POPu #define dPOPTOPssrl SV *right = POPs; SV *left = TOPs #define dPOPTOPnnrl double right = POPn; double left = TOPn #define dPOPTOPiirl IV right = POPi; IV left = TOPi +#define dPOPTOPuurl UV right = POPu; UV left = TOPu #define RETPUSHYES RETURNX(PUSHs(&sv_yes)) #define RETPUSHNO RETURNX(PUSHs(&sv_no)) @@ -174,7 +174,7 @@ PP(pp_formline) bool gotsome; STRLEN len; - if (!SvCOMPILED(form)) { + if (!SvMAGICAL(form) || !SvCOMPILED(form)) { SvREADONLY_off(form); doparseform(form); } @@ -708,12 +708,16 @@ PP(pp_flop) if (SvNIOKp(left) || !SvPOKp(left) || (looks_like_number(left) && *SvPVX(left) != '0') ) { + SV *sv_iv; + i = SvIV(left); max = SvIV(right); if (max > i) EXTEND(SP, max - i + 1); + sv_iv = sv_2mortal(newSViv(i)); + if (i++ <= max) PUSHs(sv_iv); while (i <= max) { - sv = sv_mortalcopy(&sv_no); + sv = sv_mortalcopy(sv_iv); sv_setiv(sv,i++); PUSHs(sv); } @@ -1295,7 +1299,7 @@ PP(pp_dbstate) SAVETMPS; SAVEI32(debug); - SAVESPTR(stack_sp); + SAVESTACK_POS(); debug = 0; hasargs = 0; sp = stack_sp; @@ -1996,13 +2000,13 @@ int gimme; /* set up a scratch pad */ - SAVEINT(padix); + SAVEI32(padix); SAVESPTR(curpad); SAVESPTR(comppad); SAVESPTR(comppad_name); - SAVEINT(comppad_name_fill); - SAVEINT(min_intro_pending); - SAVEINT(max_intro_pending); + SAVEI32(comppad_name_fill); + SAVEI32(min_intro_pending); + SAVEI32(max_intro_pending); SAVESPTR(compcv); compcv = (CV*)NEWSV(1104,0); @@ -2080,6 +2084,20 @@ int gimme; DEBUG_x(dump_eval()); + /* Register with debugger: */ + + if (perldb && saveop->op_type == OP_REQUIRE) { + CV *cv = perl_get_cv("DB::postponed", FALSE); + + if (cv) { + dSP; + PUSHMARK(sp); + XPUSHs((SV*)compiling.cop_filegv); + PUTBACK; + perl_call_sv((SV*)cv, G_DISCARD); + } + } + /* compiled okay, so do it */ SP = stack_base + POPMARK; /* pop original mark */ @@ -2213,9 +2231,10 @@ PP(pp_entereval) dSP; register CONTEXT *cx; dPOPss; - I32 gimme = GIMME; - char tmpbuf[32]; + I32 gimme = GIMME, was = sub_generation; + char tmpbuf[32], *safestr; STRLEN len; + OP *ret; if (!SvPV(sv,len) || !len) RETPUSHUNDEF; @@ -2231,7 +2250,13 @@ PP(pp_entereval) sprintf(tmpbuf, "_<(eval %d)", ++evalseq); compiling.cop_filegv = gv_fetchfile(tmpbuf+2); compiling.cop_line = 1; - SAVEDELETE(defstash, savepv(tmpbuf), strlen(tmpbuf)); + /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up + deleting the eval's FILEGV from the stash before gv_check() runs + (i.e. before run-time proper). To work around the coredump that + ensues, we always turn GvMULTI_on for any globals that were + introduced within evals. See force_ident(). GSAR 96-10-12 */ + safestr = savepv(tmpbuf); + SAVEDELETE(defstash, safestr, strlen(safestr)); SAVEI32(hints); hints = op->op_targ; @@ -2244,7 +2269,11 @@ PP(pp_entereval) if (perldb && curstash != debstash) save_lines(GvAV(compiling.cop_filegv), linestr); PUTBACK; - return doeval(gimme); + ret = doeval(gimme); + if (perldb && was != sub_generation) { /* Some subs defined here. */ + strcpy(safestr, "_<(eval )"); /* Anything fake and short. */ + } + return ret; } PP(pp_leaveeval) @@ -2388,7 +2417,10 @@ SV *sv; register I32 arg; bool ischop; - New(804, fops, (send - s)*3+2, U16); /* Almost certainly too long... */ + if (len == 0) + die("Null picture in formline"); + + New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */ fpc = fops; if (s < send) { @@ -2543,5 +2575,6 @@ SV *sv; } Copy(fops, s, arg, U16); Safefree(fops); + sv_magic(sv, Nullsv, 'f', Nullch, 0); SvCOMPILED_on(sv); } @@ -251,14 +251,11 @@ PP(pp_eq) PP(pp_preinc) { dSP; - if (SvIOK(TOPs)) { - if (SvIVX(TOPs) == IV_MAX) { - sv_setnv(TOPs, (double)(SvIVX(TOPs)) + 1.0 ); - } - else { - ++SvIVX(TOPs); - SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); - } + if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && + SvIVX(TOPs) != IV_MAX) + { + ++SvIVX(TOPs); + SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else sv_inc(TOPs); @@ -98,6 +98,12 @@ static int dooneliner _((char *cmd, char *filename)); # define my_chsize chsize #endif +#if !defined(HAS_FLOCK) && defined(HAS_LOCKF) + static int lockf_emulate_flock _((int fd, int operation)); +# define flock lockf_emulate_flock +#endif + + /* Pushy I/O. */ PP(pp_backtick) @@ -156,7 +162,7 @@ PP(pp_glob) #ifndef CSH *SvPVX(rs) = '\n'; #endif /* !CSH */ -#endif /* !MSDOS */ +#endif /* !DOSISH */ result = do_readline(); LEAVE; @@ -372,7 +378,7 @@ PP(pp_binmode) EXTEND(SP, 1); if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) - RETSETUNDEF; + RETPUSHUNDEF; #ifdef DOSISH #ifdef atarist @@ -467,8 +473,8 @@ PP(pp_untie) SV * sv ; sv = POPs; - if (hints & HINT_STRICT_UNTIE) - { + + if (dowarn) { MAGIC * mg ; if (SvMAGICAL(sv)) { if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) @@ -477,7 +483,7 @@ PP(pp_untie) mg = mg_find(sv, 'q') ; if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1) - croak("Can't untie: %d inner references still exist", + warn("untie attempted while %d inner references still exist", SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ; } } @@ -486,7 +492,7 @@ PP(pp_untie) sv_unmagic(sv, 'P'); else sv_unmagic(sv, 'q'); - RETSETYES; + RETPUSHYES; } PP(pp_tied) @@ -1357,18 +1363,14 @@ PP(pp_ioctl) DIE("ioctl is not implemented"); #endif else -#if defined(DOSISH) && !defined(OS2) - DIE("fcntl is not implemented"); -#else -# ifdef HAS_FCNTL -# if defined(OS2) && defined(__EMX__) +#ifdef HAS_FCNTL +#if defined(OS2) && defined(__EMX__) retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s); -# else +#else retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s); -# endif -# else +#endif +#else DIE("fcntl is not implemented"); -# endif #endif if (SvPOK(argsv)) { @@ -1398,10 +1400,6 @@ PP(pp_flock) GV *gv; PerlIO *fp; -#if !defined(HAS_FLOCK) && defined(HAS_LOCKF) -# define flock lockf_emulate_flock -#endif - #if defined(HAS_FLOCK) || defined(flock) argtype = POPi; if (MAXARG <= 0) @@ -2842,7 +2840,7 @@ PP(pp_system) Signal_t (*ihand)(); /* place to save signal during system() */ Signal_t (*qhand)(); /* place to save signal during system() */ -#if defined(HAS_FORK) && !defined(VMS) && !defined(OS2) +#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) if (SP - MARK == 1) { if (tainting) { char *junk = SvPV(TOPs, na); @@ -3084,7 +3082,7 @@ PP(pp_tms) { dSP; -#if defined(MSDOS) || !defined(HAS_TIMES) +#ifndef HAS_TIMES DIE("times not implemented"); #else EXTEND(SP, 4); @@ -3104,7 +3102,7 @@ PP(pp_tms) PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cstime)/HZ))); } RETURN; -#endif /* MSDOS */ +#endif /* HAS_TIMES */ } PP(pp_localtime) @@ -4106,7 +4104,7 @@ PP(pp_syscall) # define LOCK_UN 8 # endif -int +static int lockf_emulate_flock (fd, operation) int fd; int operation; @@ -29,7 +29,7 @@ void av_undef _((AV* ar)); void av_unshift _((AV* ar, I32 num)); OP* bind_match _((I32 type, OP* left, OP* pat)); OP* block_end _((int line, int floor, OP* seq)); -int block_start _((void)); +int block_start _((int full)); void boot_core_UNIVERSAL _((void)); void calllist _((AV* list)); I32 cando _((I32 bit, I32 effective, struct stat* statbufp)); @@ -195,6 +195,7 @@ int magic_setarylen _((SV* sv, MAGIC* mg)); int magic_setbm _((SV* sv, MAGIC* mg)); int magic_setdbline _((SV* sv, MAGIC* mg)); int magic_setenv _((SV* sv, MAGIC* mg)); +int magic_setfm _((SV* sv, MAGIC* mg)); int magic_setisa _((SV* sv, MAGIC* mg)); int magic_setglob _((SV* sv, MAGIC* mg)); int magic_setmglob _((SV* sv, MAGIC* mg)); @@ -209,15 +210,6 @@ int magic_setvec _((SV* sv, MAGIC* mg)); int magic_wipepack _((SV* sv, MAGIC* mg)); void magicname _((char* sym, char* name, I32 namlen)); int main _((int argc, char** argv, char** env)); -#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)); -extern Malloc_t calloc _((MEM_SIZE, MEM_SIZE)); -#endif void markstack_grow _((void)); char* mem_collxfrm _((const char *m, const Size_t n, Size_t * nx)); char* mess _((char* pat, va_list* args)); @@ -329,7 +321,7 @@ 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_init_fold _(()); +void perl_init_fold _(()); int perl_init_i18nl10n _((int printwarn)); int perl_parse _((PerlInterpreter* sv_interp, void(*xsinit)(void), int argc, char** argv, char** env)); void perl_require_pv _((char* pv)); @@ -356,22 +348,6 @@ char* regprop _((char* op)); void repeatcpy _((char* to, char* from, I32 len, I32 count)); char* rninstr _((char* big, char* bigend, char* little, char* lend)); int runops _((void)); -#ifndef safemalloc -void safefree _((Malloc_t where)); -Malloc_t safemalloc _((MEM_SIZE size)); -#ifndef MSDOS -Malloc_t saferealloc _((Malloc_t where, MEM_SIZE size)); -#else -Malloc_t saferealloc _((Malloc_t where, unsigned long size)); -#endif -Malloc_t safecalloc _((MEM_SIZE cnt, MEM_SIZE size)); -#endif -#ifdef LEAKTEST -void safexfree _((Malloc_t where)); -Malloc_t safexmalloc _((I32 x, MEM_SIZE size)); -Malloc_t safexrealloc _((Malloc_t where, MEM_SIZE size)); -Malloc_t safexcalloc _((I32 x, MEM_SIZE size, MEM_SIZE size)); -#endif #ifndef HAS_RENAME I32 same_dirent _((char* a, char* b)); #endif @@ -392,9 +368,11 @@ void save_freeop _((OP* op)); void save_freepv _((char* pv)); HV* save_hash _((GV* gv)); void save_hptr _((HV** hptr)); +void save_I16 _((I16* intp)); void save_I32 _((I32* intp)); void save_int _((int* intp)); void save_item _((SV* item)); +void save_iv _((IV* iv)); void save_list _((SV** sarg, I32 maxsarg)); void save_long _((long *longp)); void save_nogv _((GV* gv)); @@ -407,9 +385,9 @@ OP* scalar _((OP* o)); OP* scalarkids _((OP* op)); OP* scalarseq _((OP* o)); OP* scalarvoid _((OP* op)); -unsigned long scan_hex _((char* start, I32 len, I32* retlen)); +UV scan_hex _((char* start, I32 len, I32* retlen)); char* scan_num _((char* s)); -unsigned long scan_oct _((char* start, I32 len, I32* retlen)); +UV scan_oct _((char* start, I32 len, I32* retlen)); OP* scope _((OP* o)); char* screaminstr _((SV* bigsv, SV* littlesv)); #ifndef VMS @@ -439,6 +417,7 @@ void sv_clear _((SV* sv)); I32 sv_cmp _((SV* sv1, SV* sv2)); void sv_dec _((SV* sv)); void sv_dump _((SV* sv)); +bool sv_derived_from _((SV* sv, char* name)); I32 sv_eq _((SV* sv1, SV* sv2)); void sv_free _((SV* sv)); void sv_free_arenas _((void)); @@ -464,6 +443,7 @@ void sv_replace _((SV* sv, SV* nsv)); void sv_report_used _((void)); void sv_reset _((char* s, HV* stash)); void sv_setiv _((SV* sv, IV num)); +void sv_setuv _((SV* sv, UV num)); void sv_setnv _((SV* sv, double num)); SV* sv_setref_iv _((SV *rv, char *classname, IV iv)); SV* sv_setref_nv _((SV *rv, char *classname, double nv)); @@ -491,3 +471,17 @@ int yyerror _((char* s)); int yylex _((void)); int yyparse _((void)); int yywarn _((char* s)); + +#if defined(MYMALLOC) || !defined(STANDARD_C) +Malloc_t malloc _((MEM_SIZE nbytes)); +Malloc_t calloc _((MEM_SIZE elements, MEM_SIZE size)); +Malloc_t realloc _((Malloc_t where, MEM_SIZE nbytes)); +Free_t free _((Malloc_t where)); +#endif + +#ifdef LEAKTEST +Malloc_t safexmalloc _((I32 x, MEM_SIZE size)); +Malloc_t safexcalloc _((I32 x, MEM_SIZE elements, MEM_SIZE size)); +Malloc_t safexrealloc _((Malloc_t where, MEM_SIZE size)); +void safexfree _((Malloc_t where)); +#endif @@ -82,10 +82,10 @@ static CURCUR* regcc; typedef I32 CHECKPOINT; -CHECKPOINT regcppush _((I32 parenfloor)); -char * regcppop _((void)); +static CHECKPOINT regcppush _((I32 parenfloor)); +static char * regcppop _((void)); -CHECKPOINT +static CHECKPOINT regcppush(parenfloor) I32 parenfloor; { @@ -107,7 +107,7 @@ I32 parenfloor; return retval; } -char* +static char * regcppop() { I32 i = SSPOPINT; @@ -272,6 +272,16 @@ I32 *intp; } void +save_I16(intp) +I16 *intp; +{ + SSCHECK(3); + SSPUSHINT(*intp); + SSPUSHPTR(intp); + SSPUSHINT(SAVEt_I16); +} + +void save_iv(ivp) IV *ivp; { @@ -496,6 +506,10 @@ I32 base; ptr = SSPOPPTR; *(I32*)ptr = (I32)SSPOPINT; break; + case SAVEt_I16: /* I16 reference */ + ptr = SSPOPPTR; + *(I16*)ptr = (I16)SSPOPINT; + break; case SAVEt_IV: /* IV reference */ ptr = SSPOPPTR; *(IV*)ptr = (IV)SSPOPIV; @@ -601,6 +615,12 @@ I32 base; savestack_ix -= delta; /* regexp must have croaked */ } break; + case SAVEt_STACK_POS: /* Position on Perl stack */ + { + I32 delta = SSPOPINT; + stack_sp = stack_base + delta; + } + break; default: croak("panic: leave_scope inconsistency"); } @@ -20,6 +20,8 @@ #define SAVEt_DELETE 19 #define SAVEt_DESTRUCTOR 20 #define SAVEt_REGCONTEXT 21 +#define SAVEt_STACK_POS 22 +#define SAVEt_I16 23 #define SSCHECK(need) if (savestack_ix + need > savestack_max) savestack_grow() #define SSPUSHINT(i) (savestack[savestack_ix++].any_i32 = (I32)(i)) @@ -43,16 +45,28 @@ #define LEAVE pop_scope() #define LEAVE_SCOPE(old) if (savestack_ix > old) leave_scope(old) -#define SAVEINT(i) save_int((int*)(&i)); -#define SAVEIV(i) save_iv((IV*)(&i)); -#define SAVEI32(i) save_I32((I32*)(&i)); -#define SAVELONG(l) save_long((long*)(&l)); -#define SAVESPTR(s) save_sptr((SV**)(&s)) -#define SAVEPPTR(s) save_pptr((char**)(&s)) -#define SAVEFREESV(s) save_freesv((SV*)(s)) -#define SAVEFREEOP(o) save_freeop((OP*)(o)) -#define SAVEFREEPV(p) save_freepv((char*)(p)) -#define SAVECLEARSV(sv) save_clearsv((SV**)(&sv)) -#define SAVEDELETE(h,k,l) save_delete((HV*)(h), (char*)(k), (I32)l) -#define SAVEDESTRUCTOR(f,p) save_destructor((void(*)_((void*)))f,(void*)p) +/* + * Not using SOFT_CAST on SAVEFREESV and SAVEFREESV + * because these are used for several kinds of pointer values + */ +#define SAVEI16(i) save_I16(SOFT_CAST(I16*)&(i)); +#define SAVEI32(i) save_I32(SOFT_CAST(I32*)&(i)); +#define SAVEINT(i) save_int(SOFT_CAST(int*)&(i)); +#define SAVEIV(i) save_iv(SOFT_CAST(IV*)&(i)); +#define SAVELONG(l) save_long(SOFT_CAST(long*)&(l)); +#define SAVESPTR(s) save_sptr((SV**)&(s)) +#define SAVEPPTR(s) save_pptr(SOFT_CAST(char**)&(s)) +#define SAVEFREESV(s) save_freesv((SV*)(s)) +#define SAVEFREEOP(o) save_freeop(SOFT_CAST(OP*)(o)) +#define SAVEFREEPV(p) save_freepv(SOFT_CAST(char*)(p)) +#define SAVECLEARSV(sv) save_clearsv(SOFT_CAST(SV**)&(sv)) +#define SAVEDELETE(h,k,l) \ + save_delete(SOFT_CAST(HV*)(h), SOFT_CAST(char*)(k), (I32)(l)) +#define SAVEDESTRUCTOR(f,p) \ + save_destructor(SOFT_CAST(void(*)_((void*)))(f),SOFT_CAST(void*)(p)) +#define SAVESTACK_POS() STMT_START { \ + SSCHECK(2); \ + SSPUSHINT(stack_sp - stack_base); \ + SSPUSHINT(SAVEt_STACK_POS); \ + } STMT_END @@ -1045,12 +1045,12 @@ unsigned long newlen; { register char *s; -#ifdef MSDOS +#ifdef HAS_64K_LIMIT if (newlen >= 0x10000) { PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen); my_exit(1); } -#endif /* MSDOS */ +#endif /* HAS_64K_LIMIT */ if (SvROK(sv)) sv_unref(sv); if (SvTYPE(sv) < SVt_PV) { @@ -1119,6 +1119,17 @@ IV i; } void +sv_setuv(sv,u) +register SV *sv; +UV u; +{ + if (u <= IV_MAX) + sv_setiv(sv, u); + else + sv_setnv(sv, (double)u); +} + +void sv_setnv(sv,num) register SV *sv; double num; @@ -1283,7 +1294,6 @@ register SV *sv; warn(warn_uninit); return 0; } - (void)SvIOK_on(sv); DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n", (unsigned long)sv,(long)SvIVX(sv))); return SvIVX(sv); @@ -2090,7 +2100,7 @@ I32 namlen; { MAGIC* mg; - if (SvREADONLY(sv) && curcop != &compiling && !strchr("gB", how)) + if (SvREADONLY(sv) && curcop != &compiling && !strchr("gBf", how)) croak(no_modify); if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) { if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { @@ -2142,6 +2152,9 @@ I32 namlen; case 'E': mg->mg_virtual = &vtbl_env; break; + case 'f': + mg->mg_virtual = &vtbl_fm; + break; case 'e': mg->mg_virtual = &vtbl_envelem; break; @@ -2954,14 +2967,18 @@ register SV *sv; if (SvGMAGICAL(sv)) mg_get(sv); flags = SvFLAGS(sv); - if (flags & SVp_IOK) { - (void)SvIOK_only(sv); - ++SvIVX(sv); - return; - } if (flags & SVp_NOK) { - SvNVX(sv) += 1.0; (void)SvNOK_only(sv); + SvNVX(sv) += 1.0; + return; + } + if (flags & SVp_IOK) { + if (SvIVX(sv) == IV_MAX) + sv_setnv(sv, (double)IV_MAX + 1.0); + else { + (void)SvIOK_only(sv); + ++SvIVX(sv); + } return; } if (!(flags & SVp_POK) || !*SvPVX(sv)) { @@ -3024,16 +3041,20 @@ register SV *sv; if (SvGMAGICAL(sv)) mg_get(sv); flags = SvFLAGS(sv); - if (flags & SVp_IOK) { - (void)SvIOK_only(sv); - --SvIVX(sv); - return; - } if (flags & SVp_NOK) { SvNVX(sv) -= 1.0; (void)SvNOK_only(sv); return; } + if (flags & SVp_IOK) { + if (SvIVX(sv) == IV_MIN) + sv_setnv(sv, (double)IV_MIN - 1.0); + else { + (void)SvIOK_only(sv); + --SvIVX(sv); + } + return; + } if (!(flags & SVp_POK)) { if ((flags & SVTYPEMASK) < SVt_PVNV) sv_upgrade(sv, SVt_NV); @@ -3052,7 +3073,7 @@ register SV *sv; static void sv_mortalgrow() { - tmps_max += 128; + tmps_max += (tmps_max < 512) ? 128 : 512; Renew(tmps_stack, tmps_max, SV*); } @@ -3681,8 +3702,27 @@ SV* sv; if (CvCLONE(sv)) strcat(d, "CLONE,"); if (CvCLONED(sv)) strcat(d, "CLONED,"); break; + case SVt_PVHV: + if (HvSHAREKEYS(sv)) strcat(d, "SHAREKEYS,"); + if (HvLAZYDEL(sv)) strcat(d, "LAZYDEL,"); + break; case SVt_PVGV: - if (GvMULTI(sv)) strcat(d, "MULTI,"); + if (GvINTRO(sv)) strcat(d, "INTRO,"); + if (GvMULTI(sv)) strcat(d, "MULTI,"); + if (GvASSUMECV(sv)) strcat(d, "ASSUMECV,"); + if (GvIMPORTED(sv)) { + strcat(d, "IMPORT"); + if (GvIMPORTED(sv) == GVf_IMPORTED) + strcat(d, "ALL,"); + else { + strcat(d, "("); + if (GvIMPORTED_SV(sv)) strcat(d, " SV"); + if (GvIMPORTED_AV(sv)) strcat(d, " AV"); + if (GvIMPORTED_HV(sv)) strcat(d, " HV"); + if (GvIMPORTED_CV(sv)) strcat(d, " CV"); + strcat(d, " ),"); + } + } #ifdef OVERLOAD if (flags & SVpgv_AM) strcat(d, "withOVERLOAD,"); #endif /* OVERLOAD */ @@ -3846,8 +3886,7 @@ SV* sv; PerlIO_printf(Perl_debug_log, " CVGEN = 0x%lx\n", (long)GvCVGEN(sv)); PerlIO_printf(Perl_debug_log, " LASTEXPR = %ld\n", (long)GvLASTEXPR(sv)); PerlIO_printf(Perl_debug_log, " LINE = %ld\n", (long)GvLINE(sv)); - PerlIO_printf(Perl_debug_log, " FLAGS = 0x%x\n", (int)GvFLAGS(sv)); - PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(GvSTASH(sv))); + PerlIO_printf(Perl_debug_log, " FILEGV = 0x%lx\n", (long)GvFILEGV(sv)); PerlIO_printf(Perl_debug_log, " EGV = 0x%lx\n", (long)GvEGV(sv)); break; case SVt_PVIO: @@ -80,6 +80,8 @@ struct io { (Sv && ++SvREFCNT(Sv)), (SV*)Sv) #define SvREFCNT_dec(sv) sv_free((SV*)sv) #endif +#define newRV_noinc(sv) ((Sv = newRV(sv)), \ + (--SvREFCNT(sv)), (SV*)Sv) #define SVTYPEMASK 0xff #define SvTYPE(sv) ((sv)->sv_flags & SVTYPEMASK) @@ -8,4 +8,4 @@ If you put out extra lines with a '#' character on the front, you don't have to worry about removing the extra print statements later since TEST ignores lines beginning with '#'. -If you come up with new tests, send them to lwall@sems.com. +If you come up with new tests, send them to larry@wall.org. @@ -41,7 +41,7 @@ while ($test = shift) { } $te = $test; chop($te); - print "$te" . '.' x (15 - length($te)); + print "$te" . '.' x (18 - length($te)); if ($sharpbang) { open(results,"./$test |") || (print "can't run.\n"); } else { @@ -50,6 +50,10 @@ while ($test = shift) { close(script); if (/#!..perl(.*)/) { $switch = $1; + if ($^O eq 'VMS') { + # Must protect uppercase switches with "" on command line + $switch =~ s/-([A-Z]\S*)/"-$1"/g; + } } else { $switch = ''; } diff --git a/t/io/read.t b/t/io/read.t index 16d32b189c..b27fde17c7 100755 --- a/t/io/read.t +++ b/t/io/read.t @@ -15,8 +15,12 @@ read(A,$b,1,4); close(A); +unlink("a"); + if ($b eq "\000\000\000\000_") { print "ok 1\n"; } else { # Probably "\000bcd_" print "not ok 1\n"; } + +unlink 'a'; diff --git a/t/lib/db-btree.t b/t/lib/db-btree.t index 81d32c415b..e20cfaba06 100755 --- a/t/lib/db-btree.t +++ b/t/lib/db-btree.t @@ -1,7 +1,7 @@ #!./perl -w BEGIN { - @INC = '../lib'; + @INC = '../lib' if -d '../lib' ; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { print "1..0\n"; @@ -23,6 +23,21 @@ sub ok print "ok $no\n" ; } +sub lexical +{ + my(@a) = unpack ("C*", $a) ; + my(@b) = unpack ("C*", $b) ; + + my $len = (@a > @b ? @b : @a) ; + my $i = 0 ; + + foreach $i ( 0 .. $len -1) { + return $a[$i] - $b[$i] if $a[$i] != $b[$i] ; + } + + return @a - @b ; +} + $Dfile = "dbbtree.tmp"; unlink $Dfile; @@ -31,13 +46,13 @@ umask(0); # Check the interface to BTREEINFO my $dbh = new DB_File::BTREEINFO ; +ok(1, $dbh->{flags} == 0) ; +ok(2, $dbh->{cachesize} == 0) ; +ok(3, $dbh->{psize} == 0) ; +ok(4, $dbh->{lorder} == 0) ; +ok(5, $dbh->{minkeypage} == 0) ; +ok(6, $dbh->{maxkeypage} == 0) ; $^W = 0 ; -ok(1, $dbh->{flags} == undef) ; -ok(2, $dbh->{cachesize} == undef) ; -ok(3, $dbh->{psize} == undef) ; -ok(4, $dbh->{lorder} == undef) ; -ok(5, $dbh->{minkeypage} == undef) ; -ok(6, $dbh->{maxkeypage} == undef) ; ok(7, $dbh->{compare} == undef) ; ok(8, $dbh->{prefix} == undef) ; $^W = 1 ; @@ -170,13 +185,9 @@ ok(28, $i == 30) ; ok(29, $#keys == 31) ; #Check that the keys can be retrieved in order -$ok = 1 ; -foreach (keys %h) -{ - ($ok = 0), last if defined $previous && $previous gt $_ ; - $previous = $_ ; -} -ok(30, $ok ) ; +my @b = keys %h ; +my @c = sort lexical @b ; +ok(30, ArrayCompare(\@b, \@c)) ; $h{'foo'} = ''; ok(31, $h{'foo'} eq '' ) ; @@ -440,7 +451,9 @@ $^W = 1 ; @srt_3 = sort { length $a <=> length $b } @Keys ; foreach (@Keys) { - $^W = 0 ; $h{$_} = 1 ; $^W = 1 ; + $^W = 0 ; + $h{$_} = 1 ; + $^W = 1 ; $g{$_} = 1 ; $k{$_} = 1 ; } diff --git a/t/lib/db-recno.t b/t/lib/db-recno.t index 999ca6021a..9427a43838 100755 --- a/t/lib/db-recno.t +++ b/t/lib/db-recno.t @@ -1,7 +1,7 @@ #!./perl -w BEGIN { - @INC = '../lib'; + @INC = '../lib' if -d '../lib' ; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { print "1..0\n"; @@ -33,15 +33,13 @@ umask(0); # Check the interface to RECNOINFO my $dbh = new DB_File::RECNOINFO ; -$^W = 0 ; -ok(1, $dbh->{bval} == undef ) ; -ok(2, $dbh->{cachesize} == undef) ; -ok(3, $dbh->{psize} == undef) ; -ok(4, $dbh->{flags} == undef) ; -ok(5, $dbh->{lorder} == undef); -ok(6, $dbh->{reclen} == undef); -ok(7, $dbh->{bfname} eq undef); -$^W = 0 ; +ok(1, $dbh->{bval} == 0 ) ; +ok(2, $dbh->{cachesize} == 0) ; +ok(3, $dbh->{psize} == 0) ; +ok(4, $dbh->{flags} == 0) ; +ok(5, $dbh->{lorder} == 0); +ok(6, $dbh->{reclen} == 0); +ok(7, $dbh->{bfname} eq ""); $dbh->{bval} = 3000 ; ok(8, $dbh->{bval} == 3000 ); diff --git a/t/lib/findbin.t b/t/lib/findbin.t index 8d5347cdb7..3e742f9a4f 100755 --- a/t/lib/findbin.t +++ b/t/lib/findbin.t @@ -9,5 +9,5 @@ print "1..1\n"; use FindBin qw($Bin); -print "not " unless $Bin =~ m,t/lib$,; +print "not " unless $Bin =~ m,t[/.]lib\]?$,; print "ok 1\n"; diff --git a/t/lib/getopt.t b/t/lib/getopt.t index ec2ea49059..fb70f10aae 100755 --- a/t/lib/getopt.t +++ b/t/lib/getopt.t @@ -41,7 +41,6 @@ print "ok 7\n"; # Try illegal options, but avoid printing of the error message open(STDERR, ">stderr") || die; -unlink "stderr"; @ARGV = qw(-h help); @@ -69,3 +68,6 @@ print "ok 10\n"; print "not " unless "@ARGV" eq "file"; print "ok 11\n"; + +close STDERR; +unlink "stderr"; diff --git a/t/lib/searchdict.t b/t/lib/searchdict.t index 69329d65c1..447c425b27 100755 --- a/t/lib/searchdict.t +++ b/t/lib/searchdict.t @@ -41,7 +41,7 @@ EOT use Search::Dict; open(DICT, "+>dict-$$") or die "Can't create dict-$$: $!"; -unlink "dict-$$"; +binmode DICT; # To make length expected one. print DICT $DICT; my $pos = look *DICT, "abash"; @@ -60,3 +60,6 @@ chomp($word = <DICT>); print "not " if $pos < 0 || $word ne "Aarhus"; print "ok 3\n"; + +close DICT or die "cannot close"; +unlink "dict-$$"; diff --git a/t/op/bop.t b/t/op/bop.t index 8ebf8d3eeb..7cf200ff25 100755 --- a/t/op/bop.t +++ b/t/op/bop.t @@ -1,24 +1,44 @@ #!./perl # -# test the bit operators '&', '|' and '^' +# test the bit operators '&', '|', '^', '~', '<<', and '>>' # -print "1..9\n"; +print "1..18\n"; # numerics print ((0xdead & 0xbeef) == 0x9ead ? "ok 1\n" : "not ok 1\n"); print ((0xdead | 0xbeef) == 0xfeef ? "ok 2\n" : "not ok 2\n"); print ((0xdead ^ 0xbeef) == 0x6042 ? "ok 3\n" : "not ok 3\n"); +print ((~0xdead & 0xbeef) == 0x2042 ? "ok 4\n" : "not ok 4\n"); + +# shifts +print ((257 << 7) == 32896 ? "ok 5\n" : "not ok 5\n"); +print ((33023 >> 7) == 257 ? "ok 6\n" : "not ok 6\n"); + +# signed vs. unsigned +print ((~0 > 0 && do { use integer; ~0 } == -1) + ? "ok 7\n" : "not ok 7\n"); +print (((2147483648 & -1) > 0 && do { use integer; 2147483648 & -1 } < 0) + ? "ok 8\n" : "not ok 8\n"); +print (((2147483648 | 1) > 0 && do { use integer; 2147483648 | 1 } < 0) + ? "ok 9\n" : "not ok 9\n"); +print (((2147483648 ^ 1) > 0 && do { use integer; 2147483648 ^ 1 } < 0) + ? "ok 10\n" : "not ok 10\n"); +print (((1 << 31) == 2147483648 && do { use integer; 1 << 31 } == -2147483648) + ? "ok 11\n" : "not ok 11\n"); +print (((2147483648 >> 1) == 1073741824 && + do { use integer; 2147483648 >> 1 } == -1073741824) + ? "ok 12\n" : "not ok 12\n"); # short strings -print (("AAAAA" & "zzzzz") eq '@@@@@' ? "ok 4\n" : "not ok 4\n"); -print (("AAAAA" | "zzzzz") eq '{{{{{' ? "ok 5\n" : "not ok 5\n"); -print (("AAAAA" ^ "zzzzz") eq ';;;;;' ? "ok 6\n" : "not ok 6\n"); +print (("AAAAA" & "zzzzz") eq '@@@@@' ? "ok 13\n" : "not ok 13\n"); +print (("AAAAA" | "zzzzz") eq '{{{{{' ? "ok 14\n" : "not ok 14\n"); +print (("AAAAA" ^ "zzzzz") eq ';;;;;' ? "ok 15\n" : "not ok 15\n"); # long strings $foo = "A" x 150; $bar = "z" x 75; -print (($foo & $bar) eq ('@'x75 ) ? "ok 7\n" : "not ok 7\n"); -print (($foo | $bar) eq ('{'x75 . 'A'x75) ? "ok 8\n" : "not ok 8\n"); -print (($foo ^ $bar) eq (';'x75 . 'A'x75) ? "ok 9\n" : "not ok 9\n"); +print (($foo & $bar) eq ('@'x75 ) ? "ok 16\n" : "not ok 16\n"); +print (($foo | $bar) eq ('{'x75 . 'A'x75) ? "ok 17\n" : "not ok 17\n"); +print (($foo ^ $bar) eq (';'x75 . 'A'x75) ? "ok 18\n" : "not ok 18\n"); diff --git a/t/op/pack.t b/t/op/pack.t index f15a7033ab..b11fe234e7 100755 --- a/t/op/pack.t +++ b/t/op/pack.t @@ -2,7 +2,7 @@ # $RCSfile: pack.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:11 $ -print "1..16\n"; +print "1..25\n"; $format = "c2x5CCxsdila6"; # Need the expression in here to force ary[5] to be numeric. This avoids @@ -47,25 +47,26 @@ print +($x = unpack("I",pack("I", 0xFFFFFFFF))) == 0xFFFFFFFF # check 'w' my $test=10; -my @x = (5,130,256,560,32000,3097152,268435455,2**30+20, 2**56+4711); +my @x = (5,130,256,560,32000,3097152,268435455,1073741844, + '4503599627365785','23728385234614992549757750638446'); my $x = pack('w*', @x); -my $y = pack 'C*', 5,129,2,130,0,132,48,129,250,0,129,189,132,64,255,255,255, - 127,132,128,128,128,20,129,128,128,128,128,128,128,164,96; +my $y = pack 'H*', '0581028200843081fa0081bd8440ffffff7f848080801487ffffffffffdb19caefe8e1eeeea0c2e1e3e8ede1ee6e'; print $x eq $y ? "ok $test\n" : "not ok $test\n"; $test++; @y = unpack('w*', $y); -my $a = join ':', @x; -my $b = join ':', @y; - -print $a eq $b ? "ok $test\n" : "not ok $test\n"; $test++; +my $a; +while ($a = pop @x) { + my $b = pop @y; + print $a eq $b ? "ok $test\n" : "not ok $test\n$a\n$b\n"; $test++; +} @y = unpack('w2', $x); print scalar(@y) == 2 ? "ok $test\n" : "not ok $test\n"; $test++; print $y[1] == 130 ? "ok $test\n" : "not ok $test\n"; $test++; -# test exections +# test exeptions eval { $x = unpack 'w', pack 'C*', 0xff, 0xff}; print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++; diff --git a/t/op/tie.t b/t/op/tie.t index cf116519e6..77e74db4e2 100755 --- a/t/op/tie.t +++ b/t/op/tie.t @@ -3,7 +3,7 @@ # This test harness will (eventually) test the "tie" functionality # without the need for a *DBM* implementation. -# Currently it only tests use strict "untie". +# Currently it only tests the untie warning chdir 't' if -d 't'; @INC = "../lib"; @@ -11,6 +11,9 @@ $ENV{PERL5LIB} = "../lib"; $|=1; +# catch warnings into fatal errors +$SIG{__WARN__} = sub { die "WARNING: @_" } ; + undef $/; @prgs = split "\n########\n", <DATA>; print "1..", scalar @prgs, "\n"; @@ -22,7 +25,7 @@ for (@prgs){ $results = $@ ; $results =~ s/\n+$//; $expected =~ s/\n+$//; - if ( $status or $results !~ /^$expected/){ + if ( $status or $results and $results !~ /^WARNING: $expected/){ print STDERR "STATUS: $status\n"; print STDERR "PROG: $prog\n"; print STDERR "EXPECTED:\n$expected\n"; @@ -74,7 +77,8 @@ EXPECT ######## # strict behaviour, without any extra references -use strict 'untie'; +#use warning 'untie'; +local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; untie %h; @@ -82,26 +86,29 @@ EXPECT ######## # strict behaviour, with 1 extra references generating an error -use strict 'untie'; +#use warning 'untie'; +local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; untie %h; EXPECT -Can't untie: 1 inner references still exist at +untie attempted while 1 inner references still exist ######## # strict behaviour, with 1 extra references via tied generating an error -use strict 'untie'; +#use warning 'untie'; +local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; untie %h; EXPECT -Can't untie: 1 inner references still exist at +untie attempted while 1 inner references still exist ######## # strict behaviour, with 1 extra references which are destroyed -use strict 'untie'; +#use warning 'untie'; +local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; $a = 0 ; @@ -110,7 +117,8 @@ EXPECT ######## # strict behaviour, with extra 1 references via tied which are destroyed -use strict 'untie'; +#use warning 'untie'; +local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; @@ -120,22 +128,25 @@ EXPECT ######## # strict error behaviour, with 2 extra references -use strict 'untie'; +#use warning 'untie'; +local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; $b = tied %h ; untie %h; EXPECT -Can't untie: 2 inner references still exist at +untie attempted while 2 inner references still exist ######## # strict behaviour, check scope of strictness. -no strict 'untie'; +#no warning 'untie'; +local $^W = 0 ; use Tie::Hash ; $A = tie %H, Tie::StdHash; $C = $B = tied %H ; { - use strict 'untie'; + #use warning 'untie'; + local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; untie %h; diff --git a/t/op/write.t b/t/op/write.t index d14cef3cd6..46ec8130b9 100755 --- a/t/op/write.t +++ b/t/op/write.t @@ -2,7 +2,7 @@ # $RCSfile: write.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:38 $ -print "1..3\n"; +print "1..5\n"; format OUT = the quick brown @<< @@ -133,3 +133,35 @@ if (`cat Op_write.tmp` eq $right) else { print "not ok 3\n"; } +# formline tests + +$mustbe = <<EOT; +@ a +@> ab +@>> abc +@>>> abc +@>>>> abc +@>>>>> abc +@>>>>>> abc +@>>>>>>> abc +@>>>>>>>> abc +@>>>>>>>>> abc +@>>>>>>>>>> abc +EOT + +$was1 = $was2 = ''; +for (0..10) { + # lexical picture + $^A = ''; + my $format1 = '@' . '>' x $_; + formline $format1, 'abc'; + $was1 .= "$format1 $^A\n"; + # global + $^A = ''; + local $format2 = '@' . '>' x $_; + formline $format2, 'abc'; + $was2 .= "$format2 $^A\n"; +} +print $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n"; +print $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n"; + @@ -40,6 +40,7 @@ static void missingterm _((char *s)); static void no_op _((char *what, char *s)); static void set_csh _((void)); static I32 sublex_done _((void)); +static I32 sublex_push _((void)); static I32 sublex_start _((void)); #ifdef CRIPPLED_CC static int uni _((I32 f, char *s)); @@ -49,20 +50,27 @@ static void restore_rsfp _((void *f)); static char *linestart; /* beg. of most recently read line */ +static struct { + I32 super_state; /* lexer state to save */ + I32 sub_inwhat; /* "lex_inwhat" to use */ + OP *sub_op; /* "lex_op" to use */ +} sublex_info; + /* The following are arranged oddly so that the guard on the switch statement * can get by with a single comparison (if the compiler is smart enough). */ -#define LEX_NORMAL 9 -#define LEX_INTERPNORMAL 8 -#define LEX_INTERPCASEMOD 7 -#define LEX_INTERPSTART 6 -#define LEX_INTERPEND 5 -#define LEX_INTERPENDMAYBE 4 -#define LEX_INTERPCONCAT 3 -#define LEX_INTERPCONST 2 -#define LEX_FORMLINE 1 -#define LEX_KNOWNEXT 0 +#define LEX_NORMAL 10 +#define LEX_INTERPNORMAL 9 +#define LEX_INTERPCASEMOD 8 +#define LEX_INTERPPUSH 7 +#define LEX_INTERPSTART 6 +#define LEX_INTERPEND 5 +#define LEX_INTERPENDMAYBE 4 +#define LEX_INTERPCONCAT 3 +#define LEX_INTERPCONST 2 +#define LEX_FORMLINE 1 +#define LEX_KNOWNEXT 0 #ifdef I_FCNTL #include <fcntl.h> @@ -216,15 +224,15 @@ SV *line; char *s; STRLEN len; - SAVEINT(lex_dojoin); - SAVEINT(lex_brackets); - SAVEINT(lex_fakebrack); - SAVEINT(lex_casemods); - SAVEINT(lex_starts); - SAVEINT(lex_state); + SAVEI32(lex_dojoin); + SAVEI32(lex_brackets); + SAVEI32(lex_fakebrack); + SAVEI32(lex_casemods); + SAVEI32(lex_starts); + SAVEI32(lex_state); SAVESPTR(lex_inpat); - SAVEINT(lex_inwhat); - SAVEINT(curcop->cop_line); + SAVEI32(lex_inwhat); + SAVEI16(curcop->cop_line); SAVEPPTR(bufptr); SAVEPPTR(bufend); SAVEPPTR(oldbufptr); @@ -517,7 +525,10 @@ int kind; force_next(WORD); if (kind) { op->op_private = OPpCONST_ENTERED; - gv_fetchpv(s, TRUE, + /* XXX see note in pp_entereval() for why we forgo typo + warnings if the symbol must be introduced in an eval. + GSAR 96-10-12 */ + gv_fetchpv(s, in_eval ? GV_ADDMULTI : TRUE, kind == '$' ? SVt_PV : kind == '@' ? SVt_PVAV : kind == '%' ? SVt_PVHV : @@ -540,7 +551,7 @@ char *s; if(isDIGIT(*s)) { char *d; int c; - for( d=s, c = 1; isDIGIT(*d) || (*d == '.' && c--); d++); + for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++); if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') { s = scan_num(s); /* real VERSION number -- GBARR */ @@ -605,16 +616,36 @@ sublex_start() return THING; } + sublex_info.super_state = lex_state; + sublex_info.sub_inwhat = op_type; + sublex_info.sub_op = lex_op; + lex_state = LEX_INTERPPUSH; + + expect = XTERM; + if (lex_op) { + yylval.opval = lex_op; + lex_op = Nullop; + return PMFUNC; + } + else + return FUNC; +} + +static I32 +sublex_push() +{ push_scope(); - SAVEINT(lex_dojoin); - SAVEINT(lex_brackets); - SAVEINT(lex_fakebrack); - SAVEINT(lex_casemods); - SAVEINT(lex_starts); - SAVEINT(lex_state); + + lex_state = sublex_info.super_state; + SAVEI32(lex_dojoin); + SAVEI32(lex_brackets); + SAVEI32(lex_fakebrack); + SAVEI32(lex_casemods); + SAVEI32(lex_starts); + SAVEI32(lex_state); SAVESPTR(lex_inpat); - SAVEINT(lex_inwhat); - SAVEINT(curcop->cop_line); + SAVEI32(lex_inwhat); + SAVEI16(curcop->cop_line); SAVEPPTR(bufptr); SAVEPPTR(oldbufptr); SAVEPPTR(oldoldbufptr); @@ -643,21 +674,13 @@ sublex_start() lex_state = LEX_INTERPCONCAT; curcop->cop_line = multi_start; - lex_inwhat = op_type; - if (op_type == OP_MATCH || op_type == OP_SUBST) - lex_inpat = lex_op; + lex_inwhat = sublex_info.sub_inwhat; + if (lex_inwhat == OP_MATCH || lex_inwhat == OP_SUBST) + lex_inpat = sublex_info.sub_op; else - lex_inpat = 0; + lex_inpat = Nullop; - expect = XTERM; - force_next('('); - if (lex_op) { - yylval.opval = lex_op; - lex_op = Nullop; - return PMFUNC; - } - else - return FUNC; + return '('; } static I32 @@ -1008,6 +1031,8 @@ GV *gv; /* filehandle or package name makes it a method */ if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) { s = skipspace(s); + if ((bufend - s) >= 2 && *s == '=' && *(s+1) == '>') + return 0; /* no assumptions -- "=>" quotes bearword */ nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tmpbuf,0)); @@ -1165,7 +1190,8 @@ STRLEN append; { if (rsfp_filters) { - SvCUR_set(sv, 0); /* start with empty line */ + if (!append) + SvCUR_set(sv, 0); /* start with empty line */ if (FILTER_READ(0, sv, 0) > 0) return ( SvPVX(sv) ) ; else @@ -1275,6 +1301,9 @@ yylex() return yylex(); } + case LEX_INTERPPUSH: + return sublex_push(); + case LEX_INTERPSTART: if (bufptr == bufend) return sublex_done(); @@ -1375,6 +1404,8 @@ yylex() goto fake_eof; /* emulate EOF on ^D or ^Z */ case 0: if (!rsfp) { + last_uni = 0; + last_lop = 0; if (lex_brackets) yyerror("Missing right bracket"); TOKEN(0); @@ -2781,10 +2812,16 @@ yylex() case KEY_for: case KEY_foreach: yylval.ival = curcop->cop_line; - while (s < bufend && isSPACE(*s)) - s++; - if (isIDFIRST(*s)) - croak("Missing $ on loop variable"); + s = skipspace(s); + if (isIDFIRST(*s)) { + char *p = s; + if ((bufend - p) >= 3 && + strnEQ(p, "my", 2) && isSPACE(*(p + 2))) + p += 2; + p = skipspace(p); + if (isIDFIRST(*p)) + croak("Missing $ on loop variable"); + } OPERATOR(FOR); case KEY_formline: @@ -2936,7 +2973,6 @@ yylex() UNI(OP_LCFIRST); case KEY_local: - yylval.ival = 0; OPERATOR(LOCAL); case KEY_length: @@ -2987,8 +3023,7 @@ yylex() case KEY_my: in_my = TRUE; - yylval.ival = 1; - OPERATOR(LOCAL); + OPERATOR(MY); case KEY_next: s = force_word(s,WORD,TRUE,FALSE,FALSE); @@ -3077,6 +3112,19 @@ yylex() s = scan_str(s); if (!s) missingterm((char*)0); + if (dowarn && SvLEN(lex_stuff)) { + d = SvPV_force(lex_stuff, len); + for (; len; --len, ++d) { + if (*d == ',') { + warn("Possible attempt to separate words with commas"); + break; + } + if (*d == '#') { + warn("Possible attempt to put comments in qw() list"); + break; + } + } + } force_next(')'); nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, q(lex_stuff)); lex_stuff = Nullsv; @@ -4780,8 +4828,9 @@ char *start; croak("panic: scan_num"); case '0': { - U32 i; + UV u; I32 shift; + bool overflowed = FALSE; if (s[1] == 'x') { shift = 4; @@ -4791,8 +4840,10 @@ char *start; goto decimal; else shift = 3; - i = 0; + u = 0; for (;;) { + UV n, b; + switch (*s) { default: goto out; @@ -4805,25 +4856,27 @@ char *start; /* FALL THROUGH */ case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': - i <<= shift; - i += *s++ & 15; - break; + b = *s++ & 15; + goto digit; case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': if (shift != 4) goto out; - i <<= 4; - i += (*s++ & 7) + 9; + b = (*s++ & 7) + 9; + digit: + n = u << shift; + if (!overflowed && (n >> shift) != u) { + warn("Integer overflow in %s number", + (shift == 4) ? "hex" : "octal"); + overflowed = TRUE; + } + u = n | b; break; } } out: sv = NEWSV(92,0); - tryi32 = i; - if (tryi32 == i && tryi32 >= 0) - sv_setiv(sv,tryi32); - else - sv_setnv(sv,(double)i); + sv_setuv(sv, u); } break; case '1': case '2': case '3': case '4': case '5': @@ -4970,15 +5023,15 @@ start_subparse() #endif save_I32(&subline); save_item(subname); - SAVEINT(padix); + SAVEI32(padix); SAVESPTR(curpad); SAVESPTR(comppad); SAVESPTR(comppad_name); SAVESPTR(compcv); - SAVEINT(comppad_name_fill); - SAVEINT(min_intro_pending); - SAVEINT(max_intro_pending); - SAVEINT(pad_reset_pending); + SAVEI32(comppad_name_fill); + SAVEI32(min_intro_pending); + SAVEI32(max_intro_pending); + SAVEI32(pad_reset_pending); compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)compcv, SVt_PVCV); diff --git a/universal.c b/universal.c index 72087e62a8..ea797aea28 100644 --- a/universal.c +++ b/universal.c @@ -74,36 +74,53 @@ int level; return &sv_no; } +bool +sv_derived_from(sv, name) +SV * sv ; +char * name ; +{ + SV *rv; + char *type; + HV *stash; + + stash = Nullhv; + type = Nullch; + + if (SvGMAGICAL(sv)) + mg_get(sv) ; + + if (SvROK(sv)) { + sv = SvRV(sv); + type = sv_reftype(sv,0); + if(SvOBJECT(sv)) + stash = SvSTASH(sv); + } + else { + stash = gv_stashsv(sv, FALSE); + } + + return (type && strEQ(type,name)) || + (stash && isa_lookup(stash, name, strlen(name), 0) == &sv_yes) + ? TRUE + : FALSE ; + +} + + static XS(XS_UNIVERSAL_isa) { dXSARGS; - SV *sv, *rv; - char *name, *type; - HV *stash; + SV *sv; + char *name; if (items != 2) croak("Usage: UNIVERSAL::isa(reference, kind)"); - stash = Nullhv; - type = Nullch; sv = ST(0); name = (char *)SvPV(ST(1),na); - if (SvROK(sv)) { - sv = SvRV(sv); - type = sv_reftype(sv,0); - if(SvOBJECT(sv)) - stash = SvSTASH(sv); - } - else { - stash = gv_stashsv(sv, FALSE); - } - - ST(0) = (type && strEQ(type,name)) || - (stash && isa_lookup(stash, name, strlen(name), 0) == &sv_yes) - ? &sv_yes - : &sv_no; + ST(0) = (sv_derived_from(sv, name) ? &sv_yes : &sv_no) ; XSRETURN(1); } @@ -48,7 +48,7 @@ static void xstat _((void)); #endif -#ifndef safemalloc +#ifndef MYMALLOC /* paranoid version of malloc */ @@ -60,19 +60,15 @@ static void xstat _((void)); Malloc_t safemalloc(size) -#ifdef MSDOS -unsigned long size; -#else MEM_SIZE size; -#endif /* MSDOS */ { Malloc_t ptr; -#ifdef MSDOS +#ifdef HAS_64K_LIMIT if (size > 0xffff) { PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size) FLUSH; my_exit(1); } -#endif /* MSDOS */ +#endif /* HAS_64K_LIMIT */ #ifdef DEBUGGING if ((long)size < 0) croak("panic: malloc"); @@ -99,23 +95,19 @@ MEM_SIZE size; Malloc_t saferealloc(where,size) Malloc_t where; -#ifndef MSDOS MEM_SIZE size; -#else -unsigned long size; -#endif /* MSDOS */ { Malloc_t ptr; #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) Malloc_t realloc(); #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */ -#ifdef MSDOS +#ifdef HAS_64K_LIMIT if (size > 0xffff) { PerlIO_printf(PerlIO_stderr(), "Reallocation too large: %lx\n", size) FLUSH; my_exit(1); } -#endif /* MSDOS */ +#endif /* HAS_64K_LIMIT */ if (!where) croak("Null realloc"); #ifdef DEBUGGING @@ -173,12 +165,12 @@ MEM_SIZE size; { Malloc_t ptr; -#ifdef MSDOS +#ifdef HAS_64K_LIMIT if (size * count > 0xffff) { PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size * count) FLUSH; my_exit(1); } -#endif /* MSDOS */ +#endif /* HAS_64K_LIMIT */ #ifdef DEBUGGING if ((long)size < 0 || (long)count < 0) croak("panic: calloc"); @@ -203,7 +195,7 @@ MEM_SIZE size; /*NOTREACHED*/ } -#endif /* !safemalloc */ +#endif /* !MYMALLOC */ #ifdef LEAKTEST @@ -405,7 +397,7 @@ char *lend; } /* Initialize the fold[] array. */ -int +void perl_init_fold() { int i; @@ -1576,8 +1568,8 @@ VTOH(vtohs,short) VTOH(vtohl,long) #endif -#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in - VMS.c, same with OS/2. */ +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) \ + && !defined(VMS) /* VMS' my_popen() is in VMS.c, same with OS/2. */ PerlIO * my_popen(cmd,mode) char *cmd; @@ -1587,7 +1579,12 @@ char *mode; register I32 this, that; register I32 pid; SV *sv; - I32 doexec = strNE(cmd,"-"); + I32 doexec = +#ifdef AMIGAOS + 1; +#else + strNE(cmd,"-"); +#endif #ifdef OS2 if (doexec) { @@ -1659,7 +1656,7 @@ char *mode; return PerlIO_fdopen(p[this], mode); } #else -#if defined(atarist) +#if defined(atarist) || defined(DJGPP) FILE *popen(); PerlIO * my_popen(cmd,mode) @@ -1667,7 +1664,8 @@ char *cmd; char *mode; { /* Needs work for PerlIO ! */ - return popen(PerlIO_exportFILE(cmd), mode); + /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */ + return popen(PerlIO_exportFILE(cmd, 0), mode); } #endif @@ -1717,7 +1715,8 @@ int newfd; } #endif -#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in VMS.c */ +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) \ + && !defined(VMS) /* VMS' my_popen() is in VMS.c */ I32 my_pclose(ptr) PerlIO *ptr; @@ -1827,7 +1826,7 @@ int status; return; } -#if defined(atarist) || defined(OS2) +#if defined(atarist) || defined(OS2) || defined(DJGPP) int pclose(); #ifdef HAS_FORK int /* Cannot prototype with I32 @@ -1988,18 +1987,23 @@ char *b; } #endif /* !HAS_RENAME */ -unsigned long +UV scan_oct(start, len, retlen) char *start; I32 len; I32 *retlen; { register char *s = start; - register unsigned long retval = 0; + register UV retval = 0; + bool overflowed = FALSE; while (len && *s >= '0' && *s <= '7') { - retval <<= 3; - retval |= *s++ - '0'; + register UV n = retval << 3; + if (!overflowed && (n >> 3) != retval) { + warn("Integer overflow in octal number"); + overflowed = TRUE; + } + retval = n | (*s++ - '0'); len--; } if (dowarn && len && (*s == '8' || *s == '9')) @@ -2015,12 +2019,17 @@ I32 len; I32 *retlen; { register char *s = start; - register unsigned long retval = 0; + register UV retval = 0; + bool overflowed = FALSE; char *tmp; while (len-- && *s && (tmp = strchr(hexdigit, *s))) { - retval <<= 4; - retval |= (tmp - hexdigit) & 15; + register UV n = retval << 4; + if (!overflowed && (n >> 4) != retval) { + warn("Integer overflow in hex number"); + overflowed = TRUE; + } + retval = n | (tmp - hexdigit) & 15; s++; } *retlen = s - start; diff --git a/utils/h2xs.PL b/utils/h2xs.PL index 96f6421a28..81e27c9407 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -873,6 +873,16 @@ if (!@files) { unless ($@) { @files = readdir(D); closedir(D); } } if (!@files) { @files = map {chomp && $_} `ls`; } +if ($^O eq 'VMS') { + foreach (@files) { + # Clip trailing '.' for portability -- non-VMS OSs don't expect it + s%\.$%%; + # Fix up for case-sensitive file systems + s/$modfname/$modfname/i && next; + $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes'; + $_ = 'Makefile.PL' if $_ = 'makefile.pl'; + } +} print MANI join("\n",@files); close MANI; !NO!SUBS! diff --git a/utils/perldoc.PL b/utils/perldoc.PL index 07540c546b..b364405944 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -28,13 +28,14 @@ print OUT <<"!GROK!THIS!"; $Config{'startperl'} eval 'exec perl -S \$0 "\$@"' if 0; + +\@pagers = (); +push \@pagers, "$Config{'pager'}" if -x "$Config{'pager'}"; !GROK!THIS! # In the following, perl variables are not expanded during extraction. print OUT <<'!NO!SUBS!'; - eval 'exec perl -S $0 "$@"' - if 0; # # Perldoc revision #1 -- look up a piece of documentation in .pod format that @@ -218,14 +219,13 @@ if( ! -t STDOUT ) { $opt_f = 1 } unless($Is_VMS) { $tmp = "/tmp/perldoc1.$$"; + push @pagers, qw( more less pg view cat ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; $goodresult = 0; - @pagers = qw( more less pg view cat ); - unshift(@pagers,$ENV{PAGER}) if $ENV{PAGER}; } else { - require Config; $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$; - @pagers = ($Config::Config{'pager'},qw( most more less type/page )); - unshift(@pagers,$ENV{PERLDOC_PAGER}) if $ENV{PERLDOC_PAGER}; + push @pagers, qw( most more less type/page ); + unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER}; $goodresult = 1; } diff --git a/utils/pl2pm.PL b/utils/pl2pm.PL index e8277bb673..60e66f824d 100644 --- a/utils/pl2pm.PL +++ b/utils/pl2pm.PL @@ -56,7 +56,7 @@ It's just a first step, but it's usually a good first step. =head1 AUTHOR -Larry Wall <lwall@sems.com> +Larry Wall <larry@wall.org> =cut diff --git a/vms/Makefile b/vms/Makefile index 98c0747735..7b9d2b5535 100644 --- a/vms/Makefile +++ b/vms/Makefile @@ -32,7 +32,7 @@ ARCH = VMS_VAX OBJVAL = $@ # Updated by fndvers.com -- do not edit by hand -PERL_VERSION = 5_00304# +PERL_VERSION = 5_00307# ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)] diff --git a/vms/config.vms b/vms/config.vms index b9e51c7c25..792c893b00 100644 --- a/vms/config.vms +++ b/vms/config.vms @@ -8,7 +8,7 @@ * GenConfig.pl when producing Config.pm. * * config.h for VMS - * Version: 5.002_01 + * Version: 5.003_07 */ /* Configuration time: 22-Mar-1996 14:45 @@ -76,7 +76,7 @@ * when Perl is built. Please do not change it by hand; make * any changes to FndVers.Com instead. */ -#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00305" /**/ +#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00307" /**/ #define ARCHLIB ARCHLIB_EXP /*config-skip*/ /* CPPSTDIN: diff --git a/vms/descrip.mms b/vms/descrip.mms index b628c2c265..a162ad03bc 100644 --- a/vms/descrip.mms +++ b/vms/descrip.mms @@ -65,7 +65,7 @@ OBJVAL = $(MMS$TARGET_NAME)$(O) .endif # Updated by fndvers.com -- do not edit by hand -PERL_VERSION = 5_00305# +PERL_VERSION = 5_00307# ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)] @@ -94,6 +94,7 @@ XTRADEF = ,GNUC_ATTRIBUTE_CHECK XTRAOBJS = LIBS1 = GNU_CC:[000000]GCCLIB.OLB/Library LIBS2 = Sys$Share:VAXCRTL/Shareable +POSIX = .else XTRAOBJS = LIBS1 = $(XTRAOBJS) @@ -117,6 +118,7 @@ DBGSPECFLAGS = /Show=(Source,Include,Expansion) LIBS2 = XTRACCFLAGS = /Include=[]/Standard=Relaxed_ANSI/Prefix=All/Obj=$(OBJVAL) XTRADEF = +POSIX = POSIX .else # VAXC .first @ @[.vms]fndvers.com "" "" "[.vms]descrip.mms" @@ -126,6 +128,7 @@ XTRADEF = XTRACCFLAGS = /Include=[]/Object=$(O) XTRADEF = LIBS2 = Sys$Share:VAXCRTL/Shareable +POSIX = .endif .endif @@ -267,7 +270,7 @@ all : base extras libmods utils podxform archcorefiles preplibrary perlpods @ $(NOOP) base : miniperl perl @ $(NOOP) -extras : Fcntl FileHandle IO Opcode libmods utils podxform +extras : Fcntl FileHandle IO Opcode $(POSIX) libmods utils podxform @ $(NOOP) libmods : [.lib]Config.pm $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm @ $(NOOP) @@ -439,6 +442,25 @@ Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E) [.ext.Fcntl]Descrip.MMS : [.ext.Fcntl]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E) $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Fcntl]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" +POSIX : [.lib]POSIX.pm [.lib.auto.POSIX]POSIX$(E) + @ $(NOOP) + +[.lib]POSIX.pm : [.ext.POSIX]Descrip.MMS + @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto] + @ Set Default [.ext.POSIX] + $(MMS) + @ Set Default [--] + +[.lib.auto.POSIX]POSIX$(E) : [.ext.POSIX]Descrip.MMS + @ Set Default [.ext.POSIX] + $(MMS) + @ Set Default [--] + +# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir> +# ${@} necessary to distract different versions of MM[SK]/make +[.ext.POSIX]Descrip.MMS : [.ext.POSIX]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E) + $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.POSIX]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" + IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]Seekable.pm [.lib.IO]Socket.pm [.lib.auto.IO]IO$(E) @ $(NOOP) @@ -1585,6 +1607,11 @@ clean : tidy Set Default [.ext.Opcode] - $(MMS) clean Set Default [--] +.ifdef DECC + Set Default [.ext.POSIX] + - $(MMS) clean + Set Default [--] +.endif - If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_*.Opt - If F$Search("*$(O);*") .nes."" Then Delete/NoConfirm/Log *$(O);* - If F$Search("Config.H").nes."" Then Delete/NoConfirm/Log Config.H;* @@ -1618,6 +1645,11 @@ realclean : clean Set Default [.ext.Opcode] - $(MMS) realclean Set Default [--] +.ifdef DECC + Set Default [.ext.POSIX] + - $(MMS) realclean + Set Default [--] +.endif - If F$Search("*$(OLB)").nes."" Then Delete/NoConfirm/Log *$(OLB);* - If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;* - $(MINIPERL) -e "use File::Path; rmtree(['lib/auto','lib/VMS','lib/$(ARCH)'],1,0);" diff --git a/vms/ext/Stdio/Stdio.pm b/vms/ext/Stdio/Stdio.pm index 275081329c..af71f0bb9e 100644 --- a/vms/ext/Stdio/Stdio.pm +++ b/vms/ext/Stdio/Stdio.pm @@ -32,13 +32,15 @@ sub AUTOLOAD { if ($constname =~ /^O_/) { my($val) = constant($constname); defined $val or croak("Unknown VMS::Stdio constant $constname"); - *$AUTOLOAD = sub { $val }; } else { # We don't know about it; hand off to IO::File require IO::File; my($obj) = shift(@_); - $obj->IO::File::$constname(@_); + + my($val) = eval "\$obj->IO::File::$constname(@_)"; + croak "Error autoloading $constname: $@" if $@; } + *$AUTOLOAD = sub { $val }; goto &$AUTOLOAD; } diff --git a/vms/ext/Stdio/Stdio.xs b/vms/ext/Stdio/Stdio.xs index 79eb95335e..a1ec91f500 100644 --- a/vms/ext/Stdio/Stdio.xs +++ b/vms/ext/Stdio/Stdio.xs @@ -79,8 +79,8 @@ IV *pval; static SV * newFH(FILE *fp, char type) { - SV *rv, *gv = NEWSV(0,0); - GV **stashp; + SV *rv; + GV **stashp, *gv = (GV *)NEWSV(0,0); HV *stash; IO *io; @@ -102,7 +102,7 @@ newFH(FILE *fp, char type) { IoIFP(io) = fp; if (type != '>') IoOFP(io) = fp; IoTYPE(io) = type; - rv = newRV(gv); + rv = newRV((SV *)gv); SvREFCNT_dec(gv); return sv_bless(rv,stash); } diff --git a/vms/genconfig.pl b/vms/genconfig.pl index 17ff2041fa..d2ab5777de 100644 --- a/vms/genconfig.pl +++ b/vms/genconfig.pl @@ -266,7 +266,7 @@ while (<IN>) { elsif (not length $val and not $had_val) { # Wups -- should have been shell var for C preprocessor directive warn "Constant $token not found in config_h.SH\n"; - $token =~ tr/A-Z/a-z/; + $token = lc $token; $token = "d_$token" unless $token =~ /^i_/; print OUT "$token='$state'\n"; } @@ -282,7 +282,7 @@ while (<IN>) { } elsif (!$pp_vars{$token}) { # Haven't seen it previously, either warn "Constant $token not found in config_h.SH (val=|$val|)\n"; - $token =~ tr/A-Z/a-z/; + $token = lc $token; print OUT "$token='$val'\n"; if ($token =~ s/exp$//) {print OUT "$token='$val'\n";} } diff --git a/vms/perlvms.pod b/vms/perlvms.pod index f15bd77cfe..b56d202a7b 100644 --- a/vms/perlvms.pod +++ b/vms/perlvms.pod @@ -238,6 +238,7 @@ directory specifications may use either VMS or Unix syntax. Perl for VMS supports redirection of input and output on the command line, using a subset of Bourne shell syntax: + <F<file> reads stdin from F<file>, >F<file> writes stdout to F<file>, >>F<file> appends stdout to F<file>, @@ -261,6 +262,8 @@ to pass uppercase switches to Perl, you need to enclose them in double-quotes on the command line, since the CRTL downcases all unquoted strings. +=over 4 + =item -i If the C<-i> switch is present but no extension for a backup @@ -286,6 +289,8 @@ The C<-u> switch causes the VMS debugger to be invoked after the Perl program is compiled, but before it has run. It does not create a core dump file. +=back + =head1 Perl functions As of the time this document was last revised, the following @@ -337,6 +342,7 @@ your copy of Perl: getsockopt, listen, recv, select(system call)*, send, setsockopt, shutdown, socket +=over 4 =item File tests @@ -605,8 +611,17 @@ and you invoked Perl with the C<-w> switch, a warning will be issued.) The FLAGS argument is ignored in all cases. +=back + =head1 Perl variables +The following VMS-specific information applies to the indicated +"special" Perl variables, in addition to the general information +in L<perlvar>. Where there is a conflict, this infrmation +takes precedence. + +=over 4 + =item %ENV Reading the elements of the %ENV array returns the @@ -699,6 +714,8 @@ all the way to disk on each write (I<i.e.> not just to the underlying RMS buffers for a file). In other words, it's equivalent to calling fflush() and fsync() from C. +=back + =head1 Revision date This document was last updated on 28-Feb-1996, for Perl 5, diff --git a/vms/test.com b/vms/test.com index 156b2dca81..2afe93cd60 100644 --- a/vms/test.com +++ b/vms/test.com @@ -137,6 +137,8 @@ while ($test = shift) { close(script); if (/#!..perl(.*)/) { $switch = $1; + # Add "" to protect uppercase switches on command line + $switch =~ s/-([A-Z]\S*)/"-$1"/g; } else { $switch = ''; } @@ -2,8 +2,8 @@ * * VMS-specific routines for perl5 * - * Last revised: 18-Jul-1996 by Charles Bailey bailey@genetics.upenn.edu - * Version: 5.3.1 + * Last revised: 14-Oct-1996 by Charles Bailey bailey@genetics.upenn.edu + * Version: 5.3.7 */ #include <acedef.h> @@ -119,7 +119,7 @@ char * my_getenv(char *lnm) { static char __my_getenv_eqv[LNM$C_NAMLENGTH+1]; - char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2; + char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2; unsigned long int idx = 0; int trnsuccess; @@ -3020,7 +3020,7 @@ struct tm * my_gmtime(const time_t *time) { static int gmtime_emulation_type; - static time_t utc_offset_secs; + static long int utc_offset_secs; char *p; time_t when; @@ -3032,7 +3032,7 @@ my_gmtime(const time_t *time) if ((p = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL) gmtime_emulation_type++; else - utc_offset_secs = (time_t) atol(p); + utc_offset_secs = atol(p); } } diff --git a/x2p/Makefile.SH b/x2p/Makefile.SH index ac3625021b..27345f0e8a 100755 --- a/x2p/Makefile.SH +++ b/x2p/Makefile.SH @@ -80,7 +80,7 @@ plextract = find2perl s2p addedbyconf = $(shextract) $(plextract) -h = EXTERN.h INTERN.h ../config.h handy.h hash.h a2p.h str.h util.h +h = EXTERN.h INTERN.h ../config.h ../handy.h hash.h a2p.h str.h util.h c = hash.c $(mallocsrc) str.c util.c walk.c @@ -112,7 +112,8 @@ run_byacc: FORCE a2p.c: a2p.y -@touch a2p.c -a2p$(OBJ_EXT): a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h handy.h ../config.h str.h hash.h +a2p$(OBJ_EXT): 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: @@ -8,7 +8,6 @@ * $Log: a2p.h,v $ */ -#include "../embed.h" #define VOIDUSED 1 #include "../config.h" @@ -31,7 +30,6 @@ # include <sys/types.h> #endif - #ifdef USE_NEXT_CTYPE #if NX_CURRENT_COMPILER_RELEASE >= 400 @@ -46,6 +44,15 @@ #define MEM_SIZE Size_t +#ifdef STANDARD_C +# include <stdlib.h> +#else + Malloc_t malloc _((MEM_SIZE nbytes)); + Malloc_t calloc _((MEM_SIZE elements, MEM_SIZE size)); + Malloc_t realloc _((Malloc_t where, MEM_SIZE nbytes)); + Free_t free _((Malloc_t where)); +#endif + #if defined(I_STRING) || defined(__cplusplus) # include <string.h> #else @@ -105,7 +112,11 @@ char *strchr(), *strrchr(); char *strcpy(), *strcat(); #endif /* ! STANDARD_C */ -#include "handy.h" +#include "../handy.h" + +#undef Nullfp +#define Nullfp Null(FILE*) + #define Nullop 0 #define OPROG 1 diff --git a/x2p/a2p.pod b/x2p/a2p.pod index 3976abab67..4e61fd6ab9 100644 --- a/x2p/a2p.pod +++ b/x2p/a2p.pod @@ -134,7 +134,7 @@ A2p uses no environment variables. =head1 AUTHOR -Larry Wall E<lt>F<lwall@jpl-devvax.Jpl.Nasa.Gov>E<gt> +Larry Wall E<lt>F<larry@wall.org>E<gt> =head1 FILES diff --git a/x2p/s2p.PL b/x2p/s2p.PL index 6664dcd616..9d7297b2ae 100644 --- a/x2p/s2p.PL +++ b/x2p/s2p.PL @@ -95,7 +95,7 @@ S2p uses no environment variables. =head1 AUTHOR -Larry Wall E<lt>F<lwall@jpl-devvax.Jpl.Nasa.Gov>E<gt> +Larry Wall E<lt>F<larry@wall.org>E<gt> =head1 FILES diff --git a/x2p/util.c b/x2p/util.c index 5c3554b7e3..6c817322f2 100644 --- a/x2p/util.c +++ b/x2p/util.c @@ -13,6 +13,9 @@ #include "INTERN.h" #include "util.h" +#ifdef I_STDARG +# include <stdarg.h> +#endif #define FLUSH static char nomem[] = "Out of memory!\n"; @@ -189,32 +192,65 @@ int newlen; } } -/*VARARGS1*/ void +#if defined(I_STDARG) && defined(HAS_VPRINTF) +croak(char *pat,...) +#else /* I_STDARG */ +/*VARARGS1*/ croak(pat,a1,a2,a3,a4) -char *pat; -int a1,a2,a3,a4; + char *pat; + int a1,a2,a3,a4; +#endif /* I_STDARG */ { +#if defined(I_STDARG) && defined(HAS_VPRINTF) + va_list args; + + va_start(args, pat); + vfprintf(stderr,pat,args); +#else fprintf(stderr,pat,a1,a2,a3,a4); +#endif exit(1); } -/*VARARGS1*/ void +#if defined(I_STDARG) && defined(HAS_VPRINTF) +fatal(char *pat,...) +#else /* I_STDARG */ +/*VARARGS1*/ fatal(pat,a1,a2,a3,a4) -char *pat; -int a1,a2,a3,a4; + char *pat; + int a1,a2,a3,a4; +#endif /* I_STDARG */ { +#if defined(I_STDARG) && defined(HAS_VPRINTF) + va_list args; + + va_start(args, pat); + vfprintf(stderr,pat,args); +#else fprintf(stderr,pat,a1,a2,a3,a4); +#endif exit(1); } -/*VARARGS1*/ void +#if defined(I_STDARG) && defined(HAS_VPRINTF) +warn(char *pat,...) +#else /* I_STDARG */ +/*VARARGS1*/ warn(pat,a1,a2,a3,a4) -char *pat; -int a1,a2,a3,a4; + char *pat; + int a1,a2,a3,a4; +#endif /* I_STDARG */ { +#if defined(I_STDARG) && defined(HAS_VPRINTF) + va_list args; + + va_start(args, pat); + vfprintf(stderr,pat,args); +#else fprintf(stderr,pat,a1,a2,a3,a4); +#endif } diff --git a/x2p/util.h b/x2p/util.h index 35f796121c..bdd85c199d 100644 --- a/x2p/util.h +++ b/x2p/util.h @@ -24,10 +24,22 @@ int makedir(); char * cpy2 _(( char *to, char *from, int delim )); char * cpytill _(( char *to, char *from, int delim )); -void croak _(( char *pat, int a1, int a2, int a3, int a4 )); void growstr _(( char **strptr, int *curlen, int newlen )); char * instr _(( char *big, char *little )); -void Myfatal (); char * safecpy _(( char *to, char *from, int len )); char * savestr _(( char *str )); +#if defined(I_STDARG) && defined(HAS_VPRINTF) +void croak _(( char *pat, ... )); +void fatal _(( char *pat, ... )); +void warn _(( char *pat, ... )); +#else /* defined(I_STDARG) && defined(HAS_VPRINTF) */ +void croak _(( char *pat, int a1, int a2, int a3, int a4 )); +void Myfatal (); void warn (); +#endif /* defined(I_STDARG) && defined(HAS_VPRINTF) */ +int prewalk _(( int numit, int level, int node, int *numericptr )); + +Malloc_t safemalloc _((MEM_SIZE nbytes)); +Malloc_t safecalloc _((MEM_SIZE elements, MEM_SIZE size)); +Malloc_t saferealloc _((Malloc_t where, MEM_SIZE nbytes)); +Free_t safefree _((Malloc_t where)); |