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
----------------
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
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
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
@ 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
=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>.
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
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
=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.
=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
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
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:
=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
=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
#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.
#
(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'
(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) {
return FALSE;
}
-#endif
+#endif /* OS2 */
I32
apply(type,mark,sp)
#ifdef HAS_KILL
case OP_KILL:
TAINT_PROPER("kill");
+ if (mark == sp)
+ break;
s = SvPVx(*++mark, na);
tot = sp - mark;
if (isUPPER(*s)) {
*/
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))
else if (statbufp->st_mode & bit >> 6)
return TRUE; /* ok as "other" */
return FALSE;
-#endif /* ! MSDOS */
+#endif /* ! DOSISH */
}
#endif /* ! VMS */
#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
;; 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
;; 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:
;;; 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
;;; 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
;;; 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.
;;; 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:
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.")
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'.")
\f
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.")
`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.
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.
;;; 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)))
(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
(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
(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)
["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]
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'.
`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
(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)
(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)))
;;; (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)
(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
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
(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 "{};:"))
;; 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) ?{)
(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)
(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,
(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)
(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
"\\(\\`\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]*$")))
(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
;;; '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
"\\|") ; 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\\|"
"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\\|"
;; "#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;
(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)) ?{)
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_]\\)\\|\\(/\\)\\)"
'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
(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
(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.
(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)))))
;; 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)
found-bad found)))
(not not-found)))
+\ 6
+;;; 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)))
/* 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
#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
#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
#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
#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
#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
#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
#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
#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
#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
#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
#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
#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
#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
#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
#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
#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
#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
#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
#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
#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
#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
#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)
#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 */
#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 $_;
}
/* prepend underscore to s. write into buf. return buf. */
-char *
+static char *
dl_add_underscore(s, buf)
char *s;
char *buf;
=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
L<perlfunc>,
L<perlop/"I/O Operators">,
-L<POSIX/"FileHandle">
+L<FileHandle>
=head1 BUGS
* 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) {
# 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
#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
# Variables
AMG_names
+Error
+He
No
Sv
-He
Xpv
Yes
abs_amg
an
atan2_amg
band_amg
+block_type
bool__amg
bor_amg
buf
bufptr
bxor_amg
check
+compcv
compiling
compl_amg
-compcv
comppad
comppad_name
comppad_name_fill
cryptseen
cshlen
cshname
-curcop
-curcopdb
curinterp
curpad
cv_const_sv
do_undump
ds
egid
-envgv
eq_amg
error_count
euid
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
markstack
markstack_max
markstack_ptr
-maxo
max_intro_pending
+maxo
min_intro_pending
mod_amg
mod_ass_amg
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
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
regdummy
regendp
regeol
+regflags
regfold
reginput
regkind
rsfp_filters
rshift_amg
rshift_ass_amg
+save_iv
save_pptr
savestack
savestack_ix
sgt_amg
sig_name
sig_num
-siggv
sighandler
simple
sin_amg
sv_no
sv_undef
sv_yes
-tainting
thisexpr
timesbuf
tokenbuf
vtbl_dbline
vtbl_env
vtbl_envelem
+vtbl_fm
vtbl_glob
vtbl_isa
vtbl_isaelem
warn_nl
warn_nosemi
warn_reserved
+warn_uninit
watchaddr
watchok
yychar
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
magic_setbm
magic_setdbline
magic_setenv
+magic_setfm
magic_setglob
magic_setisa
magic_setmglob
repeatcpy
rninstr
runops
+safecalloc
+safemalloc
+safefree
+saferealloc
+safexcalloc
+safexmalloc
+safexfree
+safexrealloc
same_dirent
+save_I16
save_I32
save_aptr
save_ary
sv_clear
sv_cmp
sv_dec
+sv_derived_from
sv_dump
sv_eq
sv_free
sv_setref_pv
sv_setref_pvn
sv_setsv
+sv_setuv
sv_unmagic
sv_unref
sv_upgrade
xpv_root
xrv_root
yyerror
+yydestruct
yylex
yyparse
yywarn
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)))), \
#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 *))
#define Copy(s,d,n,t)
#define Zero(d,n,t)
#define Safefree(d) d = d
+
#endif /* lint */
#ifdef USE_STRUCT_COPY
--- /dev/null
+# 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"'
# 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
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
# 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!
#
# 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.
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.
# 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;
$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;
}
}
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 {
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){
$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;
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 {
} 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";
}
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
}
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);
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) {
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') {
*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
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
my($so) = $Config{'so'};
my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
# compute $extralibs, $bsloadlibs and $ldloadlibs from
# $potential_libs
("@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__
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
-
-
};
# 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";
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 {
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;
$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 $@
};
=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
# 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;
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;
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;
#__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
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) {
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
$(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)
} 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;
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)
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;
}
=cut
# Global Constants
-$XSUBPP_version = "1.938";
+$XSUBPP_version = "1.939";
require 5.002;
use vars '$cplusplus';
$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
=head1 NAME
-Basename - parse file specifications
-
fileparse - split a pathname into pieces
basename - extract just the filename from a path
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
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;
$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;
require Exporter;
use Carp;
+use UNIVERSAL qw(isa);
@ISA=qw(Exporter);
@EXPORT=qw(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;
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
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
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
$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;
# $realpath;
#}
-sub abs_path
+sub my_abs_path
{
my $start = shift || '.';
my($dotdots, $cwd, @pst, @cst, $dir, @tst);
{
*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 '-')
{
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:
$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);
}
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' }
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...
$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\]";
}
package Pod::Text;
-# Version 1.01
+# Version 1.02
=head1 NAME
$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
? "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);
}
@EXPORT = qw(openlog closelog setlogmask syslog);
use Socket;
+use Sys::Hostname;
# adapted from syslog.pl
#
=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
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;
last;
}
}
- if (defined $entry) {
- $entry .= $_;
- } else {
- $entry = $_;
- }
+ defined $entry or $entry = '';
+ $entry .= $_;
};
while ($state != 0) {
}
sub Complete {
+ my($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r);
+
$prompt = shift;
if (ref $_[0] || $_[0] =~ /^\*/) {
@cmp_lst = sort @{$_[0]};
last;
}
else {
- while ($_ && !(/^$delim/ || /^['"\\]/)) {
+ while ($_ ne '' && !(/^$delim/ || /^['"\\]/)) {
$snippet .= substr($_, 0, 1);
substr($_, 0, 1) = '';
}
foreach (@s)
{
- tr/a-z/A-Z/;
+ $_ = uc $_;
tr/A-Z//cd;
if ($_ eq '')
=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;
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;
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);
$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;
}
$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);
}
sub Complete {
package Complete;
- local($[,$return) = 0;
+ local($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r);
if ($_[1] =~ /^StB\0/) {
($prompt, *_) = @_;
}
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
}
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[$[] ||
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);
}
$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);
$_ = <FH>;
chop;
s/[^\w\s]//g if $dict;
- y/A-Z/a-z/ if $fold;
+ $_ = lc $_ if $fold;
if ($_ lt $key) {
$min = $mid;
}
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);
}
# 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)
# $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.
# information into db.out. (If you interrupt it, you would better
# reset LineInfo to something "interactive"!)
#
-# Changes: 0.95: v command shows versions.
-
##################################################################
# Changelog:
# 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():
$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
$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);
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);
$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;
$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') {
$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: {
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";
}
next CMD;
} elsif ($file ne $filename) {
*dbline = "::_<$file";
- $visited{$file}++;
$max = $#dbline;
$filename = $file;
$start = 1;
$file = join(':', @pieces);
if ($file ne $filename) {
*dbline = "::_<$file";
- $visited{$file}++;
$max = $#dbline;
$filename = $file;
}
$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]+//;
}
}
}
- 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;
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/;
if ($dbline[$i] == 0) {
print $OUT "Line $i not breakable.\n";
} else {
+ $had_breakpoints{$filename} = 1;
$dbline{$i} =~ s/^[^\0]*/$cond/;
}
next CMD; };
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($_);
$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;
}
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} =~ /^(.*):(.*)$/);
if ($i) {
$filename = $file;
*dbline = "::_<$filename";
- $visited{$filename}++;
+ $had_breakpoints{$filename}++;
$max = $#dbline;
++$i while $dbline[$i] == 0 && $i < $max;
} else {
}
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
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;
$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 {
$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;
$piped= "";
}
} # CMD:
- if ($post) {
- $evalarg = $post; &eval;
- }
+ map {$evalarg = $_; &eval} @$post;
} # if ($single || $signal)
($@, $!, $,, $/, $\, $^W) = @saved;
();
}
}
-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 {
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/\\$//) {
$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;
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}};
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 {
s,\.p[lm]$,,i ;
s,/,::,g ;
s/^perl5db$/DB/;
+ s/^Term::ReadLine::readline$/readline/;
if (defined $ { $_ . '::VERSION' }) {
$version{$file} = "$ { $_ . '::VERSION' } from ";
}
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.
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
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.
\= [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.
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
|[|]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 {
$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;
use Carp;
-$VERSION = 1.01;
+$VERSION = 1.02;
$Verbose ||= 0;
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;
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
use strict "vars";
use strict "refs";
use strict "subs";
- use strict "untie";
use strict;
no strict "vars";
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
-=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>.
$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;
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;
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;
$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;
;# $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;
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
# 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.
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
#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
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);
#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
if (nextf[bucket])
return;
+ if (bucket == (sizeof(MEM_SIZE)*8 - 3)) {
+ croak("Allocation too large");
+ }
/*
* Insure memory is allocated
* on a page boundary. Should
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
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;
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".
#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
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++);
(unsigned long)res,an++,(long)size);
}
#endif
-#endif /* safemalloc */
+#endif /* PERL_CORE */
return ((Malloc_t)res);
}
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) {
if (size >= PERLSBRK_32_K) {
small = 0;
} else {
-#ifndef safemalloc
+#ifndef PERL_CORE
reqsize = size;
#endif
size = PERLSBRK_64_K;
}
}
-#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
}
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;
+#!/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
+
--- /dev/null
+# 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
}
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;
}
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);
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;
/* Check routines. */
OP *
+ck_bitop(op)
+OP *op;
+{
+ op->op_private = hints;
+ return op;
+}
+
+OP *
ck_concat(op)
OP *op;
{
};
#endif
+OP * ck_bitop _((OP* op));
OP * ck_concat _((OP* op));
OP * ck_delete _((OP* op));
OP * ck_eof _((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 */
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 */
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 */
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 */
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
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.
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.
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).
echo ' "dlsym"' >>$@
echo ' "dlerror"' >>$@
echo ' "perl_init_i18nl10n"' >>$@
+ echo ' "my_tmpfile"' >>$@
+ echo ' "my_tmpnam"' >>$@
!NO!SUBS!
if [ ! -z "$myttyname" ] ; then
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)
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) { */
{
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)
{
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)
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))
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);
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
}
}
+#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. */
+}
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(),
#define PATCHLEVEL 3
-#define SUBVERSION 7
+#define SUBVERSION 8
/*
local_patches -- list of locally applied less-than-subversion patches.
else if (scriptname == Nullch) {
#ifdef MSDOS
if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
- moreswitches("v");
+ moreswitches("h");
#endif
scriptname = "-";
}
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"
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;
* 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 */
#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
#include <locale.h>
#endif
-EXT int lc_collate_active;
-
#ifdef METHOD /* Defined by OSF/1 v3.0 by ctype.h */
#undef METHOD
#endif
# include <stdlib.h>
#endif /* STANDARD_C */
-/* Maybe this comes after <stdlib.h> so we don't try to change
- the standard library prototypes?. We'll use our own in
- proto.h instead. I guess. The patch had no explanation.
-*/
+/* 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
# 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))
# 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
#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]
# 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 */
#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 */
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};
EXT MGVTBL vtbl_vec;
EXT MGVTBL vtbl_pos;
EXT MGVTBL vtbl_bm;
+EXT MGVTBL vtbl_fm;
EXT MGVTBL vtbl_uvar;
#ifdef OVERLOAD
cat <<END >> perl.exp
perl_init_ext
perl_init_fold
-perl_init_i18nl14n
+perl_init_i18nl10n
perl_alloc
perl_construct
perl_destruct
#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,
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,<
https://perl5.git.perl.org / perl5.git / commitdiff