home *** CD-ROM | disk | FTP | other *** search
- From: lwall@netlabs.com (Larry Wall)
- Newsgroups: comp.sources.misc
- Subject: v18i039: perl - The perl programming language, Part21/36
- Message-ID: <1991Apr16.185542.1179@sparky.IMD.Sterling.COM>
- Date: 16 Apr 91 18:55:42 GMT
- Approved: kent@sparky.imd.sterling.com
- X-Checksum-Snefru: 9d4a2d27 855efbbe d8382499 572f16a8
-
- Submitted-by: Larry Wall <lwall@netlabs.com>
- Posting-number: Volume 18, Issue 39
- Archive-name: perl/part21
-
- [There are 36 kits for perl version 4.0.]
-
- #! /bin/sh
-
- # Make a new directory for the perl sources, cd to it, and run kits 1
- # thru 36 through sh. When all 36 kits have been run, read README.
-
- echo "This is perl 4.0 kit 21 (of 36). If kit 21 is complete, the line"
- echo '"'"End of kit 21 (of 36)"'" will echo at the end.'
- echo ""
- export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
- mkdir emacs t t/op 2>/dev/null
- echo Extracting emacs/perl-mode.el
- sed >emacs/perl-mode.el <<'!STUFFY!FUNK!' -e 's/X//'
- X;; Perl code editing commands for GNU Emacs
- X;; Copyright (C) 1990 William F. Mann
- X;; Adapted from C code editing commands 'c-mode.el', Copyright 1987 by the
- X;; Free Software Foundation, under terms of its General Public License.
- X
- X;; This file may be made part of GNU Emacs at the option of the FSF, or
- X;; of the perl distribution at the option of Larry Wall.
- X
- X;; This code is distributed in the hope that it will be useful,
- X;; but WITHOUT ANY WARRANTY. No author or distributor
- X;; accepts responsibility to anyone for the consequences of using it
- X;; or for whether it serves any particular purpose or works at all,
- X;; unless he says so in writing. Refer to the GNU Emacs General Public
- X;; License for full details.
- X
- X;; Everyone is granted permission to copy, modify and redistribute
- X;; this code, but only under the conditions described in the
- X;; GNU Emacs General Public License. A copy of this license is
- X;; supposed to have been given to you along with GNU Emacs so you
- X;; can know your rights and responsibilities. It should be in a
- X;; file named COPYING. Among other things, the copyright notice
- X;; and this notice must be preserved on all copies.
- X
- X;; To enter perl-mode automatically, add (autoload 'perl-mode "perl-mode")
- X;; to your .emacs file and change the first line of your perl script to:
- X;; #!/usr/bin/perl -- # -*-Perl-*-
- X;; With argments to perl:
- X;; #!/usr/bin/perl -P- # -*-Perl-*-
- X;; To handle files included with do 'filename.pl';, add something like
- X;; (setq auto-mode-alist (append (list (cons "\\.pl$" 'perl-mode))
- X;; auto-mode-alist))
- X;; to your .emacs file; otherwise the .pl suffix defaults to prolog-mode.
- X
- X;; This code is based on the 18.53 version c-mode.el, with extensive
- X;; rewriting. Most of the features of c-mode survived intact.
- X
- X;; I added a new feature which adds functionality to TAB; it is controlled
- X;; by the variable perl-tab-to-comment. With it enabled, TAB does the
- X;; first thing it can from the following list: change the indentation;
- X;; move past leading white space; delete an empty comment; reindent a
- X;; comment; move to end of line; create an empty comment; tell you that
- X;; the line ends in a quoted string, or has a # which should be a \#.
- X
- X;; If your machine is slow, you may want to remove some of the bindings
- X;; to electric-perl-terminator. I changed the indenting defaults to be
- X;; what Larry Wall uses in perl/lib, but left in all the options.
- X
- X;; I also tuned a few things: comments and labels starting in column
- X;; zero are left there by indent-perl-exp; perl-beginning-of-function
- X;; goes back to the first open brace/paren in column zero, the open brace
- X;; in 'sub ... {', or the equal sign in 'format ... ='; indent-perl-exp
- X;; (meta-^q) indents from the current line through the close of the next
- X;; brace/paren, so you don't need to start exactly at a brace or paren.
- X
- X;; It may be good style to put a set of redundant braces around your
- X;; main program. This will let you reindent it with meta-^q.
- X
- X;; Known problems (these are all caused by limitations in the elisp
- X;; parsing routine (parse-partial-sexp), which was not designed for such
- X;; a rich language; writing a more suitable parser would be a big job):
- X;; 1) Regular expression delimitors do not act as quotes, so special
- X;; characters such as `'"#:;[](){} may need to be backslashed
- X;; in regular expressions and in both parts of s/// and tr///.
- X;; 2) The globbing syntax <pattern> is not recognized, so special
- X;; characters in the pattern string must be backslashed.
- X;; 3) The q, qq, and << quoting operators are not recognized; see below.
- X;; 4) \ (backslash) always quotes the next character, so '\' is
- X;; treated as the start of a string. Use "\\" as a work-around.
- X;; 5) To make variables such a $' and $#array work, perl-mode treats
- X;; $ just like backslash, so '$' is the same as problem 5.
- X;; 6) Unfortunately, treating $ like \ makes ${var} be treated as an
- X;; unmatched }. See below.
- X;; 7) When ' (quote) is used as a package name separator, perl-mode
- X;; doesn't understand, and thinks it is seeing a quoted string.
- X
- X;; Here are some ugly tricks to bypass some of these problems: the perl
- X;; expression /`/ (that's a back-tick) usually evaluates harmlessly,
- X;; but will trick perl-mode into starting a quoted string, which
- X;; can be ended with another /`/. Assuming you have no embedded
- X;; back-ticks, this can used to help solve problem 3:
- X;;
- X;; /`/; $ugly = q?"'$?; /`/;
- X;;
- X;; To solve problem 6, add a /{/; before each use of ${var}:
- X;; /{/; while (<${glob_me}>) ...
- X;;
- X;; Problem 7 is even worse, but this 'fix' does work :-(
- X;; $DB'stop#'
- X;; [$DB'line#'
- X;; ] =~ s/;9$//;
- X
- X
- X(defvar perl-mode-abbrev-table nil
- X "Abbrev table in use in perl-mode buffers.")
- X(define-abbrev-table 'perl-mode-abbrev-table ())
- X
- X(defvar perl-mode-map ()
- X "Keymap used in Perl mode.")
- X(if perl-mode-map
- X ()
- X (setq perl-mode-map (make-sparse-keymap))
- X (define-key perl-mode-map "{" 'electric-perl-terminator)
- X (define-key perl-mode-map "}" 'electric-perl-terminator)
- X (define-key perl-mode-map ";" 'electric-perl-terminator)
- X (define-key perl-mode-map ":" 'electric-perl-terminator)
- X (define-key perl-mode-map "\e\C-a" 'perl-beginning-of-function)
- X (define-key perl-mode-map "\e\C-e" 'perl-end-of-function)
- X (define-key perl-mode-map "\e\C-h" 'mark-perl-function)
- X (define-key perl-mode-map "\e\C-q" 'indent-perl-exp)
- X (define-key perl-mode-map "\177" 'backward-delete-char-untabify)
- X (define-key perl-mode-map "\t" 'perl-indent-command))
- X
- X(autoload 'c-macro-expand "cmacexp"
- X "Display the result of expanding all C macros occurring in the region.
- XThe expansion is entirely correct because it uses the C preprocessor."
- X t)
- X
- X(defvar perl-mode-syntax-table nil
- X "Syntax table in use in perl-mode buffers.")
- X
- X(if perl-mode-syntax-table
- X ()
- X (setq perl-mode-syntax-table (make-syntax-table (standard-syntax-table)))
- X (modify-syntax-entry ?\n ">" perl-mode-syntax-table)
- X (modify-syntax-entry ?# "<" perl-mode-syntax-table)
- X (modify-syntax-entry ?$ "/" perl-mode-syntax-table)
- X (modify-syntax-entry ?% "." perl-mode-syntax-table)
- X (modify-syntax-entry ?& "." perl-mode-syntax-table)
- X (modify-syntax-entry ?\' "\"" perl-mode-syntax-table)
- X (modify-syntax-entry ?* "." perl-mode-syntax-table)
- X (modify-syntax-entry ?+ "." perl-mode-syntax-table)
- X (modify-syntax-entry ?- "." perl-mode-syntax-table)
- X (modify-syntax-entry ?/ "." perl-mode-syntax-table)
- X (modify-syntax-entry ?< "." perl-mode-syntax-table)
- X (modify-syntax-entry ?= "." perl-mode-syntax-table)
- X (modify-syntax-entry ?> "." perl-mode-syntax-table)
- X (modify-syntax-entry ?\\ "\\" perl-mode-syntax-table)
- X (modify-syntax-entry ?` "\"" perl-mode-syntax-table)
- X (modify-syntax-entry ?| "." perl-mode-syntax-table)
- X)
- X
- X(defconst perl-indent-level 4
- X "*Indentation of Perl statements with respect to containing block.")
- X(defconst perl-continued-statement-offset 4
- X "*Extra indent for lines not starting new statements.")
- X(defconst perl-continued-brace-offset -4
- X "*Extra indent for substatements that start with open-braces.
- XThis is in addition to perl-continued-statement-offset.")
- X(defconst perl-brace-offset 0
- X "*Extra indentation for braces, compared with other text in same context.")
- X(defconst perl-brace-imaginary-offset 0
- X "*Imagined indentation of an open brace that actually follows a statement.")
- X(defconst perl-label-offset -2
- X "*Offset of Perl label lines relative to usual indentation.")
- X
- X(defconst perl-tab-always-indent t
- X "*Non-nil means TAB in Perl mode should always indent the current line,
- Xregardless of where in the line point is when the TAB command is used.")
- X
- X(defconst perl-tab-to-comment t
- X "*Non-nil means that for lines which don't need indenting, TAB will
- Xeither indent an existing comment, move to end-of-line, or if at end-of-line
- Xalready, create a new comment.")
- X
- X(defconst perl-nochange ";?#\\|\f\\|\\s(\\|\\(\\w\\|\\s_\\)+:"
- X "*Lines starting with this regular expression will not be auto-indented.")
- X
- X(defun perl-mode ()
- X "Major mode for editing Perl code.
- XExpression and list commands understand all Perl brackets.
- XTab indents for Perl code.
- XComments are delimited with # ... \\n.
- XParagraphs are separated by blank lines only.
- XDelete converts tabs to spaces as it moves back.
- X\\{perl-mode-map}
- XVariables controlling indentation style:
- X perl-tab-always-indent
- X Non-nil means TAB in Perl mode should always indent the current line,
- X regardless of where in the line point is when the TAB command is used.
- X perl-tab-to-comment
- X Non-nil means that for lines which don't need indenting, TAB will
- X either delete an empty comment, indent an existing comment, move
- X to end-of-line, or if at end-of-line already, create a new comment.
- X perl-nochange
- X Lines starting with this regular expression will not be auto-indented.
- X perl-indent-level
- X Indentation of Perl statements within surrounding block.
- X The surrounding block's indentation is the indentation
- X of the line on which the open-brace appears.
- X perl-continued-statement-offset
- X Extra indentation given to a substatement, such as the
- X then-clause of an if or body of a while.
- X perl-continued-brace-offset
- X Extra indentation given to a brace that starts a substatement.
- X This is in addition to perl-continued-statement-offset.
- X perl-brace-offset
- X Extra indentation for line if it starts with an open brace.
- X perl-brace-imaginary-offset
- X An open brace following other text is treated as if it were
- X this far to the right of the start of its line.
- X perl-label-offset
- X Extra indentation for line that is a label.
- X
- XVarious indentation styles: K&R BSD BLK GNU LW
- X perl-indent-level 5 8 0 2 4
- X perl-continued-statement-offset 5 8 4 2 4
- X perl-continued-brace-offset 0 0 0 0 -4
- X perl-brace-offset -5 -8 0 0 0
- X perl-brace-imaginary-offset 0 0 4 0 0
- X perl-label-offset -5 -8 -2 -2 -2
- X
- XTurning on Perl mode calls the value of the variable perl-mode-hook with no
- Xargs, if that value is non-nil."
- X (interactive)
- X (kill-all-local-variables)
- X (use-local-map perl-mode-map)
- X (setq major-mode 'perl-mode)
- X (setq mode-name "Perl")
- X (setq local-abbrev-table perl-mode-abbrev-table)
- X (set-syntax-table perl-mode-syntax-table)
- X (make-local-variable 'paragraph-start)
- X (setq paragraph-start (concat "^$\\|" page-delimiter))
- X (make-local-variable 'paragraph-separate)
- X (setq paragraph-separate paragraph-start)
- X (make-local-variable 'paragraph-ignore-fill-prefix)
- X (setq paragraph-ignore-fill-prefix t)
- X (make-local-variable 'indent-line-function)
- X (setq indent-line-function 'perl-indent-line)
- X (make-local-variable 'require-final-newline)
- X (setq require-final-newline t)
- X (make-local-variable 'comment-start)
- X (setq comment-start "# ")
- X (make-local-variable 'comment-end)
- X (setq comment-end "")
- X (make-local-variable 'comment-column)
- X (setq comment-column 32)
- X (make-local-variable 'comment-start-skip)
- X (setq comment-start-skip "\\(^\\|\\s-\\);?#+ *")
- X (make-local-variable 'comment-indent-hook)
- X (setq comment-indent-hook 'perl-comment-indent)
- X (make-local-variable 'parse-sexp-ignore-comments)
- X (setq parse-sexp-ignore-comments nil)
- X (run-hooks 'perl-mode-hook))
- X
- X;; This is used by indent-for-comment
- X;; to decide how much to indent a comment in Perl code
- X;; based on its context.
- X(defun perl-comment-indent ()
- X (if (and (bolp) (not (eolp)))
- X 0 ;Existing comment at bol stays there.
- X (save-excursion
- X (skip-chars-backward " \t")
- X (max (1+ (current-column)) ;Else indent at comment column
- X comment-column)))) ; except leave at least one space.
- X
- X(defun electric-perl-terminator (arg)
- X "Insert character. If at end-of-line, and not in a comment or a quote,
- Xcorrect the line's indentation."
- X (interactive "P")
- X (let ((insertpos (point)))
- X (and (not arg) ; decide whether to indent
- X (eolp)
- X (save-excursion
- X (beginning-of-line)
- X (and (not ; eliminate comments quickly
- X (re-search-forward comment-start-skip insertpos t))
- X (or (/= last-command-char ?:)
- X ;; Colon is special only after a label ....
- X (looking-at "\\s-*\\(\\w\\|\\s_\\)+$"))
- X (let ((pps (parse-partial-sexp
- X (perl-beginning-of-function) insertpos)))
- X (not (or (nth 3 pps) (nth 4 pps) (nth 5 pps))))))
- X (progn ; must insert, indent, delete
- X (insert-char last-command-char 1)
- X (perl-indent-line)
- X (delete-char -1))))
- X (self-insert-command (prefix-numeric-value arg)))
- X
- X;; not used anymore, but may be useful someday:
- X;;(defun perl-inside-parens-p ()
- X;; (condition-case ()
- X;; (save-excursion
- X;; (save-restriction
- X;; (narrow-to-region (point)
- X;; (perl-beginning-of-function))
- X;; (goto-char (point-max))
- X;; (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\()))
- X;; (error nil)))
- X
- X(defun perl-indent-command (&optional arg)
- X "Indent current line as Perl code, or optionally, insert a tab character.
- X
- XWith an argument, indent the current line, regardless of other options.
- X
- XIf perl-tab-always-indent is nil and point is not in the indentation
- Xarea at the beginning of the line, simply insert a tab.
- X
- XOtherwise, indent the current line. If point was within the indentation
- Xarea it is moved to the end of the indentation area. If the line was
- Xalready indented properly and point was not within the indentation area,
- Xand if perl-tab-to-comment is non-nil (the default), then do the first
- Xpossible action from the following list:
- X
- X 1) delete an empty comment
- X 2) move forward to start of comment, indenting if necessary
- X 3) move forward to end of line
- X 4) create an empty comment
- X 5) move backward to start of comment, indenting if necessary."
- X (interactive "P")
- X (if arg ; If arg, just indent this line
- X (perl-indent-line "\f")
- X (if (and (not perl-tab-always-indent)
- X (<= (current-column) (current-indentation)))
- X (insert-tab)
- X (let (bof lsexp delta (oldpnt (point)))
- X (beginning-of-line)
- X (setq lsexp (point))
- X (setq bof (perl-beginning-of-function))
- X (goto-char oldpnt)
- X (setq delta (perl-indent-line "\f\\|;?#" bof))
- X (and perl-tab-to-comment
- X (= oldpnt (point)) ; done if point moved
- X (if (listp delta) ; if line starts in a quoted string
- X (setq lsexp (or (nth 2 delta) bof))
- X (= delta 0)) ; done if indenting occurred
- X (let (eol state)
- X (end-of-line)
- X (setq eol (point))
- X (if (= (char-after bof) ?=)
- X (if (= oldpnt eol)
- X (message "In a format statement"))
- X (setq state (parse-partial-sexp lsexp eol))
- X (if (nth 3 state)
- X (if (= oldpnt eol) ; already at eol in a string
- X (message "In a string which starts with a %c."
- X (nth 3 state)))
- X (if (not (nth 4 state))
- X (if (= oldpnt eol) ; no comment, create one?
- X (indent-for-comment))
- X (beginning-of-line)
- X (if (re-search-forward comment-start-skip eol 'move)
- X (if (eolp)
- X (progn ; kill existing comment
- X (goto-char (match-beginning 0))
- X (skip-chars-backward " \t")
- X (kill-region (point) eol))
- X (if (or (< oldpnt (point)) (= oldpnt eol))
- X (indent-for-comment) ; indent existing comment
- X (end-of-line)))
- X (if (/= oldpnt eol)
- X (end-of-line)
- X (message "Use backslash to quote # characters.")
- X (ding t))))))))))))
- X
- X(defun perl-indent-line (&optional nochange parse-start)
- X "Indent current line as Perl code. Return the amount the indentation
- Xchanged by, or (parse-state) if line starts in a quoted string."
- X (let ((case-fold-search nil)
- X (pos (- (point-max) (point)))
- X (bof (or parse-start (save-excursion (perl-beginning-of-function))))
- X beg indent shift-amt)
- X (beginning-of-line)
- X (setq beg (point))
- X (setq shift-amt
- X (cond ((= (char-after bof) ?=) 0)
- X ((listp (setq indent (calculate-perl-indent bof))) indent)
- X ((looking-at (or nochange perl-nochange)) 0)
- X (t
- X (skip-chars-forward " \t\f")
- X (cond ((looking-at "\\(\\w\\|\\s_\\)+:")
- X (setq indent (max 1 (+ indent perl-label-offset))))
- X ((= (following-char) ?})
- X (setq indent (- indent perl-indent-level)))
- X ((= (following-char) ?{)
- X (setq indent (+ indent perl-brace-offset))))
- X (- indent (current-column)))))
- X (skip-chars-forward " \t\f")
- X (if (and (numberp shift-amt) (/= 0 shift-amt))
- X (progn (delete-region beg (point))
- X (indent-to indent)))
- X ;; If initial point was within line's indentation,
- X ;; position after the indentation. Else stay at same point in text.
- X (if (> (- (point-max) pos) (point))
- X (goto-char (- (point-max) pos)))
- X shift-amt))
- X
- X(defun calculate-perl-indent (&optional parse-start)
- X "Return appropriate indentation for current line as Perl code.
- XIn usual case returns an integer: the column to indent to.
- XReturns (parse-state) if line starts inside a string."
- X (save-excursion
- X (beginning-of-line)
- X (let ((indent-point (point))
- X (case-fold-search nil)
- X (colon-line-end 0)
- X state containing-sexp)
- X (if parse-start ;used to avoid searching
- X (goto-char parse-start)
- X (perl-beginning-of-function))
- X (while (< (point) indent-point) ;repeat until right sexp
- X (setq parse-start (point))
- X (setq state (parse-partial-sexp (point) indent-point 0))
- X; state = (depth_in_parens innermost_containing_list last_complete_sexp
- X; string_terminator_or_nil inside_commentp following_quotep
- X; minimum_paren-depth_this_scan)
- X; Parsing stops if depth in parentheses becomes equal to third arg.
- X (setq containing-sexp (nth 1 state)))
- X (cond ((nth 3 state) state) ; In a quoted string?
- X ((null containing-sexp) ; Line is at top level.
- X (skip-chars-forward " \t\f")
- X (if (= (following-char) ?{)
- X 0 ; move to beginning of line if it starts a function body
- X ;; indent a little if this is a continuation line
- X (perl-backward-to-noncomment)
- X (if (or (bobp)
- X (memq (preceding-char) '(?\; ?\})))
- X 0 perl-continued-statement-offset)))
- X ((/= (char-after containing-sexp) ?{)
- X ;; line is expression, not statement:
- X ;; indent to just after the surrounding open.
- X (goto-char (1+ containing-sexp))
- X (current-column))
- X (t
- X ;; Statement level. Is it a continuation or a new statement?
- X ;; Find previous non-comment character.
- X (perl-backward-to-noncomment)
- X ;; Back up over label lines, since they don't
- X ;; affect whether our line is a continuation.
- X (while (or (eq (preceding-char) ?\,)
- X (and (eq (preceding-char) ?:)
- X (memq (char-syntax (char-after (- (point) 2)))
- X '(?w ?_))))
- X (if (eq (preceding-char) ?\,)
- X (perl-backward-to-start-of-continued-exp containing-sexp))
- X (beginning-of-line)
- X (perl-backward-to-noncomment))
- X ;; Now we get the answer.
- X (if (not (memq (preceding-char) '(?\; ?\} ?\{)))
- X ;; This line is continuation of preceding line's statement;
- X ;; indent perl-continued-statement-offset more than the
- X ;; previous line of the statement.
- X (progn
- X (perl-backward-to-start-of-continued-exp containing-sexp)
- X (+ perl-continued-statement-offset (current-column)
- X (if (save-excursion (goto-char indent-point)
- X (looking-at "[ \t]*{"))
- X perl-continued-brace-offset 0)))
- X ;; This line starts a new statement.
- X ;; Position at last unclosed open.
- X (goto-char containing-sexp)
- X (or
- X ;; If open paren is in col 0, close brace is special
- X (and (bolp)
- X (save-excursion (goto-char indent-point)
- X (looking-at "[ \t]*}"))
- X perl-indent-level)
- X ;; Is line first statement after an open-brace?
- X ;; If no, find that first statement and indent like it.
- X (save-excursion
- X (forward-char 1)
- X ;; Skip over comments and labels following openbrace.
- X (while (progn
- X (skip-chars-forward " \t\f\n")
- X (cond ((looking-at ";?#")
- X (forward-line 1) t)
- X ((looking-at "\\(\\w\\|\\s_\\)+:")
- X (save-excursion
- X (end-of-line)
- X (setq colon-line-end (point)))
- X (search-forward ":")))))
- X ;; The first following code counts
- X ;; if it is before the line we want to indent.
- X (and (< (point) indent-point)
- X (if (> colon-line-end (point))
- X (- (current-indentation) perl-label-offset)
- X (current-column))))
- X ;; If no previous statement,
- X ;; indent it relative to line brace is on.
- X ;; For open paren in column zero, don't let statement
- X ;; start there too. If perl-indent-level is zero,
- X ;; use perl-brace-offset + perl-continued-statement-offset
- X ;; For open-braces not the first thing in a line,
- X ;; add in perl-brace-imaginary-offset.
- X (+ (if (and (bolp) (zerop perl-indent-level))
- X (+ perl-brace-offset perl-continued-statement-offset)
- X perl-indent-level)
- X ;; Move back over whitespace before the openbrace.
- X ;; If openbrace is not first nonwhite thing on the line,
- X ;; add the perl-brace-imaginary-offset.
- X (progn (skip-chars-backward " \t")
- X (if (bolp) 0 perl-brace-imaginary-offset))
- X ;; If the openbrace is preceded by a parenthesized exp,
- X ;; move to the beginning of that;
- X ;; possibly a different line
- X (progn
- X (if (eq (preceding-char) ?\))
- X (forward-sexp -1))
- X ;; Get initial indentation of the line we are on.
- X (current-indentation))))))))))
- X
- X(defun perl-backward-to-noncomment ()
- X "Move point backward to after the first non-white-space, skipping comments."
- X (interactive)
- X (let (opoint stop)
- X (while (not stop)
- X (setq opoint (point))
- X (beginning-of-line)
- X (if (re-search-forward comment-start-skip opoint 'move 1)
- X (progn (goto-char (match-end 1))
- X (skip-chars-forward ";")))
- X (skip-chars-backward " \t\f")
- X (setq stop (or (bobp)
- X (not (bolp))
- X (forward-char -1))))))
- X
- X(defun perl-backward-to-start-of-continued-exp (lim)
- X (if (= (preceding-char) ?\))
- X (forward-sexp -1))
- X (beginning-of-line)
- X (if (<= (point) lim)
- X (goto-char (1+ lim)))
- X (skip-chars-forward " \t\f"))
- X
- X;; note: this may be slower than the c-mode version, but I can understand it.
- X(defun indent-perl-exp ()
- X "Indent each line of the Perl grouping following point."
- X (interactive)
- X (let* ((case-fold-search nil)
- X (oldpnt (point-marker))
- X (bof-mark (save-excursion
- X (end-of-line 2)
- X (perl-beginning-of-function)
- X (point-marker)))
- X eol last-mark lsexp-mark delta)
- X (if (= (char-after (marker-position bof-mark)) ?=)
- X (message "Can't indent a format statement")
- X (message "Indenting Perl expression...")
- X (save-excursion (end-of-line) (setq eol (point)))
- X (save-excursion ; locate matching close paren
- X (while (and (not (eobp)) (<= (point) eol))
- X (parse-partial-sexp (point) (point-max) 0))
- X (setq last-mark (point-marker)))
- X (setq lsexp-mark bof-mark)
- X (beginning-of-line)
- X (while (< (point) (marker-position last-mark))
- X (setq delta (perl-indent-line nil (marker-position bof-mark)))
- X (if (numberp delta) ; unquoted start-of-line?
- X (progn
- X (if (eolp)
- X (delete-horizontal-space))
- X (setq lsexp-mark (point-marker))))
- X (end-of-line)
- X (setq eol (point))
- X (if (nth 4 (parse-partial-sexp (marker-position lsexp-mark) eol))
- X (progn ; line ends in a comment
- X (beginning-of-line)
- X (if (or (not (looking-at "\\s-*;?#"))
- X (listp delta)
- X (and (/= 0 delta)
- X (= (- (current-indentation) delta) comment-column)))
- X (if (re-search-forward comment-start-skip eol t)
- X (indent-for-comment))))) ; indent existing comment
- X (forward-line 1))
- X (goto-char (marker-position oldpnt))
- X (message "Indenting Perl expression...done"))))
- X
- X(defun perl-beginning-of-function (&optional arg)
- X "Move backward to next beginning-of-function, or as far as possible.
- XWith argument, repeat that many times; negative args move forward.
- XReturns new value of point in all cases."
- X (interactive "p")
- X (or arg (setq arg 1))
- X (if (< arg 0) (forward-char 1))
- X (and (/= arg 0)
- X (re-search-backward "^\\s(\\|^\\s-*sub\\b[^{]+{\\|^\\s-*format\\b[^=]*="
- X nil 'move arg)
- X (goto-char (1- (match-end 0))))
- X (point))
- X
- X;; note: this routine is adapted directly from emacs lisp.el, end-of-defun;
- X;; no bugs have been removed :-)
- X(defun perl-end-of-function (&optional arg)
- X "Move forward to next end-of-function.
- XThe end of a function is found by moving forward from the beginning of one.
- XWith argument, repeat that many times; negative args move backward."
- X (interactive "p")
- X (or arg (setq arg 1))
- X (let ((first t))
- X (while (and (> arg 0) (< (point) (point-max)))
- X (let ((pos (point)) npos)
- X (while (progn
- X (if (and first
- X (progn
- X (forward-char 1)
- X (perl-beginning-of-function 1)
- X (not (bobp))))
- X nil
- X (or (bobp) (forward-char -1))
- X (perl-beginning-of-function -1))
- X (setq first nil)
- X (forward-list 1)
- X (skip-chars-forward " \t")
- X (if (looking-at "[#\n]")
- X (forward-line 1))
- X (<= (point) pos))))
- X (setq arg (1- arg)))
- X (while (< arg 0)
- X (let ((pos (point)))
- X (perl-beginning-of-function 1)
- X (forward-sexp 1)
- X (forward-line 1)
- X (if (>= (point) pos)
- X (if (progn (perl-beginning-of-function 2) (not (bobp)))
- X (progn
- X (forward-list 1)
- X (skip-chars-forward " \t")
- X (if (looking-at "[#\n]")
- X (forward-line 1)))
- X (goto-char (point-min)))))
- X (setq arg (1+ arg)))))
- X
- X(defun mark-perl-function ()
- X "Put mark at end of Perl function, point at beginning."
- X (interactive)
- X (push-mark (point))
- X (perl-end-of-function)
- X (push-mark (point))
- X (perl-beginning-of-function)
- X (backward-paragraph))
- X
- X;;;;;;;; That's all, folks! ;;;;;;;;;
- !STUFFY!FUNK!
- echo Extracting regexec.c
- sed >regexec.c <<'!STUFFY!FUNK!' -e 's/X//'
- X/* NOTE: this is derived from Henry Spencer's regexp code, and should not
- X * confused with the original package (see point 3 below). Thanks, Henry!
- X */
- X
- X/* Additional note: this code is very heavily munged from Henry's version
- X * in places. In some spots I've traded clarity for efficiency, so don't
- X * blame Henry for some of the lack of readability.
- X */
- X
- X/* $RCSfile: regexec.c,v $$Revision: 4.0.1.1 $$Date: 91/04/12 09:07:39 $
- X *
- X * $Log: regexec.c,v $
- X * Revision 4.0.1.1 91/04/12 09:07:39 lwall
- X * patch1: regexec only allocated space for 9 subexpresssions
- X *
- X * Revision 4.0 91/03/20 01:39:16 lwall
- X * 4.0 baseline.
- X *
- X */
- X
- X/*
- X * regcomp and regexec -- regsub and regerror are not used in perl
- X *
- X * Copyright (c) 1986 by University of Toronto.
- X * Written by Henry Spencer. Not derived from licensed software.
- X *
- X * Permission is granted to anyone to use this software for any
- X * purpose on any computer system, and to redistribute it freely,
- X * subject to the following restrictions:
- X *
- X * 1. The author is not responsible for the consequences of use of
- X * this software, no matter how awful, even if they arise
- X * from defects in it.
- X *
- X * 2. The origin of this software must not be misrepresented, either
- X * by explicit claim or by omission.
- X *
- X * 3. Altered versions must be plainly marked as such, and must not
- X * be misrepresented as being the original software.
- X *
- X **** Alterations to Henry's code are...
- X ****
- X **** Copyright (c) 1989, Larry Wall
- X ****
- X **** You may distribute under the terms of the GNU General Public License
- X **** as specified in the README file that comes with the perl 3.0 kit.
- X *
- X * Beware that some of this code is subtly aware of the way operator
- X * precedence is structured in regular expressions. Serious changes in
- X * regular-expression syntax might require a total rethink.
- X */
- X#include "EXTERN.h"
- X#include "perl.h"
- X#include "regcomp.h"
- X
- X#ifndef STATIC
- X#define STATIC static
- X#endif
- X
- X#ifdef DEBUGGING
- Xint regnarrate = 0;
- X#endif
- X
- X#define isALNUM(c) (isascii(c) && (isalpha(c) || isdigit(c) || c == '_'))
- X#define isSPACE(c) (isascii(c) && isspace(c))
- X#define isDIGIT(c) (isascii(c) && isdigit(c))
- X#define isUPPER(c) (isascii(c) && isupper(c))
- X
- X/*
- X * regexec and friends
- X */
- X
- X/*
- X * Global work variables for regexec().
- X */
- Xstatic char *regprecomp;
- Xstatic char *reginput; /* String-input pointer. */
- Xstatic char regprev; /* char before regbol, \n if none */
- Xstatic char *regbol; /* Beginning of input, for ^ check. */
- Xstatic char *regeol; /* End of input, for $ check. */
- Xstatic char **regstartp; /* Pointer to startp array. */
- Xstatic char **regendp; /* Ditto for endp. */
- Xstatic char *reglastparen; /* Similarly for lastparen. */
- Xstatic char *regtill;
- X
- Xstatic int regmyp_size = 0;
- Xstatic char **regmystartp = Null(char**);
- Xstatic char **regmyendp = Null(char**);
- X
- X/*
- X * Forwards.
- X */
- XSTATIC int regtry();
- XSTATIC int regmatch();
- XSTATIC int regrepeat();
- X
- Xextern int multiline;
- X
- X/*
- X - regexec - match a regexp against a string
- X */
- Xint
- Xregexec(prog, stringarg, strend, strbeg, minend, screamer, safebase)
- Xregister regexp *prog;
- Xchar *stringarg;
- Xregister char *strend; /* pointer to null at end of string */
- Xchar *strbeg; /* real beginning of string */
- Xint minend; /* end of match must be at least minend after stringarg */
- XSTR *screamer;
- Xint safebase; /* no need to remember string in subbase */
- X{
- X register char *s;
- X register int i;
- X register char *c;
- X register char *string = stringarg;
- X register int tmp;
- X int minlen = 0; /* must match at least this many chars */
- X int dontbother = 0; /* how many characters not to try at end */
- X
- X /* Be paranoid... */
- X if (prog == NULL || string == NULL) {
- X fatal("NULL regexp parameter");
- X return(0);
- X }
- X
- X if (string == strbeg) /* is ^ valid at stringarg? */
- X regprev = '\n';
- X else {
- X regprev = stringarg[-1];
- X if (!multiline && regprev == '\n')
- X regprev = '\0'; /* force ^ to NOT match */
- X }
- X regprecomp = prog->precomp;
- X /* Check validity of program. */
- X if (UCHARAT(prog->program) != MAGIC) {
- X FAIL("corrupted regexp program");
- X }
- X
- X if (prog->do_folding) {
- X safebase = FALSE;
- X i = strend - string;
- X New(1101,c,i+1,char);
- X (void)bcopy(string, c, i+1);
- X string = c;
- X strend = string + i;
- X for (s = string; s < strend; s++)
- X if (isUPPER(*s))
- X *s = tolower(*s);
- X }
- X
- X /* If there is a "must appear" string, look for it. */
- X s = string;
- X if (prog->regmust != Nullstr &&
- X (!(prog->reganch & 1) || (multiline && prog->regback >= 0)) ) {
- X if (stringarg == strbeg && screamer) {
- X if (screamfirst[prog->regmust->str_rare] >= 0)
- X s = screaminstr(screamer,prog->regmust);
- X else
- X s = Nullch;
- X }
- X#ifndef lint
- X else
- X s = fbminstr((unsigned char*)s, (unsigned char*)strend,
- X prog->regmust);
- X#endif
- X if (!s) {
- X ++prog->regmust->str_u.str_useful; /* hooray */
- X goto phooey; /* not present */
- X }
- X else if (prog->regback >= 0) {
- X s -= prog->regback;
- X if (s < string)
- X s = string;
- X minlen = prog->regback + prog->regmust->str_cur;
- X }
- X else if (--prog->regmust->str_u.str_useful < 0) { /* boo */
- X str_free(prog->regmust);
- X prog->regmust = Nullstr; /* disable regmust */
- X s = string;
- X }
- X else {
- X s = string;
- X minlen = prog->regmust->str_cur;
- X }
- X }
- X
- X /* Mark beginning of line for ^ . */
- X regbol = string;
- X
- X /* Mark end of line for $ (and such) */
- X regeol = strend;
- X
- X /* see how far we have to get to not match where we matched before */
- X regtill = string+minend;
- X
- X /* Allocate our backreference arrays */
- X if ( regmyp_size < prog->nparens + 1 ) {
- X /* Allocate or enlarge the arrays */
- X regmyp_size = prog->nparens + 1;
- X if ( regmyp_size < 10 ) regmyp_size = 10; /* minimum */
- X if ( regmystartp ) {
- X /* reallocate larger */
- X Renew(regmystartp,regmyp_size,char*);
- X Renew(regmyendp, regmyp_size,char*);
- X }
- X else {
- X /* Initial allocation */
- X New(1102,regmystartp,regmyp_size,char*);
- X New(1102,regmyendp, regmyp_size,char*);
- X }
- X
- X }
- X
- X /* Simplest case: anchored match need be tried only once. */
- X /* [unless multiline is set] */
- X if (prog->reganch & 1) {
- X if (regtry(prog, string))
- X goto got_it;
- X else if (multiline) {
- X if (minlen)
- X dontbother = minlen - 1;
- X strend -= dontbother;
- X /* for multiline we only have to try after newlines */
- X if (s > string)
- X s--;
- X while (s < strend) {
- X if (*s++ == '\n') {
- X if (s < strend && regtry(prog, s))
- X goto got_it;
- X }
- X }
- X }
- X goto phooey;
- X }
- X
- X /* Messy cases: unanchored match. */
- X if (prog->regstart) {
- X if (prog->reganch & 2) { /* we have /x+whatever/ */
- X /* it must be a one character string */
- X i = prog->regstart->str_ptr[0];
- X while (s < strend) {
- X if (*s == i) {
- X if (regtry(prog, s))
- X goto got_it;
- X s++;
- X while (s < strend && *s == i)
- X s++;
- X }
- X s++;
- X }
- X }
- X else if (prog->regstart->str_pok == 3) {
- X /* We know what string it must start with. */
- X#ifndef lint
- X while ((s = fbminstr((unsigned char*)s,
- X (unsigned char*)strend, prog->regstart)) != NULL)
- X#else
- X while (s = Nullch)
- X#endif
- X {
- X if (regtry(prog, s))
- X goto got_it;
- X s++;
- X }
- X }
- X else {
- X c = prog->regstart->str_ptr;
- X while ((s = ninstr(s, strend,
- X c, c + prog->regstart->str_cur )) != NULL) {
- X if (regtry(prog, s))
- X goto got_it;
- X s++;
- X }
- X }
- X goto phooey;
- X }
- X if (c = prog->regstclass) {
- X int doevery = (prog->reganch & 2) == 0;
- X
- X if (minlen)
- X dontbother = minlen - 1;
- X strend -= dontbother; /* don't bother with what can't match */
- X tmp = 1;
- X /* We know what class it must start with. */
- X switch (OP(c)) {
- X case ANYOF:
- X c = OPERAND(c);
- X while (s < strend) {
- X i = UCHARAT(s);
- X if (!(c[i >> 3] & (1 << (i&7)))) {
- X if (tmp && regtry(prog, s))
- X goto got_it;
- X else
- X tmp = doevery;
- X }
- X else
- X tmp = 1;
- X s++;
- X }
- X break;
- X case BOUND:
- X if (minlen)
- X dontbother++,strend--;
- X if (s != string) {
- X i = s[-1];
- X tmp = isALNUM(i);
- X }
- X else
- X tmp = isALNUM(regprev); /* assume not alphanumeric */
- X while (s < strend) {
- X i = *s;
- X if (tmp != isALNUM(i)) {
- X tmp = !tmp;
- X if (regtry(prog, s))
- X goto got_it;
- X }
- X s++;
- X }
- X if ((minlen || tmp) && regtry(prog,s))
- X goto got_it;
- X break;
- X case NBOUND:
- X if (minlen)
- X dontbother++,strend--;
- X if (s != string) {
- X i = s[-1];
- X tmp = isALNUM(i);
- X }
- X else
- X tmp = isALNUM(regprev); /* assume not alphanumeric */
- X while (s < strend) {
- X i = *s;
- X if (tmp != isALNUM(i))
- X tmp = !tmp;
- X else if (regtry(prog, s))
- X goto got_it;
- X s++;
- X }
- X if ((minlen || !tmp) && regtry(prog,s))
- X goto got_it;
- X break;
- X case ALNUM:
- X while (s < strend) {
- X i = *s;
- X if (isALNUM(i)) {
- X if (tmp && regtry(prog, s))
- X goto got_it;
- X else
- X tmp = doevery;
- X }
- X else
- X tmp = 1;
- X s++;
- X }
- X break;
- X case NALNUM:
- X while (s < strend) {
- X i = *s;
- X if (!isALNUM(i)) {
- X if (tmp && regtry(prog, s))
- X goto got_it;
- X else
- X tmp = doevery;
- X }
- X else
- X tmp = 1;
- X s++;
- X }
- X break;
- X case SPACE:
- X while (s < strend) {
- X if (isSPACE(*s)) {
- X if (tmp && regtry(prog, s))
- X goto got_it;
- X else
- X tmp = doevery;
- X }
- X else
- X tmp = 1;
- X s++;
- X }
- X break;
- X case NSPACE:
- X while (s < strend) {
- X if (!isSPACE(*s)) {
- X if (tmp && regtry(prog, s))
- X goto got_it;
- X else
- X tmp = doevery;
- X }
- X else
- X tmp = 1;
- X s++;
- X }
- X break;
- X case DIGIT:
- X while (s < strend) {
- X if (isDIGIT(*s)) {
- X if (tmp && regtry(prog, s))
- X goto got_it;
- X else
- X tmp = doevery;
- X }
- X else
- X tmp = 1;
- X s++;
- X }
- X break;
- X case NDIGIT:
- X while (s < strend) {
- X if (!isDIGIT(*s)) {
- X if (tmp && regtry(prog, s))
- X goto got_it;
- X else
- X tmp = doevery;
- X }
- X else
- X tmp = 1;
- X s++;
- X }
- X break;
- X }
- X }
- X else {
- X if (minlen)
- X dontbother = minlen - 1;
- X strend -= dontbother;
- X /* We don't know much -- general case. */
- X do {
- X if (regtry(prog, s))
- X goto got_it;
- X } while (s++ < strend);
- X }
- X
- X /* Failure. */
- X goto phooey;
- X
- X got_it:
- X if ((!safebase && (prog->nparens || sawampersand)) || prog->do_folding){
- X strend += dontbother; /* uncheat */
- X if (safebase) /* no need for $digit later */
- X s = strbeg;
- X else if (strbeg != prog->subbase) {
- X i = strend - string + (stringarg - strbeg);
- X s = nsavestr(strbeg,i); /* so $digit will work later */
- X if (prog->subbase)
- X Safefree(prog->subbase);
- X prog->subbase = s;
- X prog->subend = s+i;
- X }
- X else
- X s = prog->subbase;
- X s += (stringarg - strbeg);
- X for (i = 0; i <= prog->nparens; i++) {
- X if (prog->endp[i]) {
- X prog->startp[i] = s + (prog->startp[i] - string);
- X prog->endp[i] = s + (prog->endp[i] - string);
- X }
- X }
- X if (prog->do_folding)
- X Safefree(string);
- X }
- X return(1);
- X
- X phooey:
- X if (prog->do_folding)
- X Safefree(string);
- X return(0);
- X}
- X
- X/*
- X - regtry - try match at specific point
- X */
- Xstatic int /* 0 failure, 1 success */
- Xregtry(prog, string)
- Xregexp *prog;
- Xchar *string;
- X{
- X register int i;
- X register char **sp;
- X register char **ep;
- X
- X reginput = string;
- X regstartp = prog->startp;
- X regendp = prog->endp;
- X reglastparen = &prog->lastparen;
- X prog->lastparen = 0;
- X
- X sp = prog->startp;
- X ep = prog->endp;
- X if (prog->nparens) {
- X for (i = prog->nparens; i >= 0; i--) {
- X *sp++ = NULL;
- X *ep++ = NULL;
- X }
- X }
- X if (regmatch(prog->program + 1) && reginput >= regtill) {
- X prog->startp[0] = string;
- X prog->endp[0] = reginput;
- X return(1);
- X } else
- X return(0);
- X}
- X
- X/*
- X - regmatch - main matching routine
- X *
- X * Conceptually the strategy is simple: check to see whether the current
- X * node matches, call self recursively to see whether the rest matches,
- X * and then act accordingly. In practice we make some effort to avoid
- X * recursion, in particular by going through "ordinary" nodes (that don't
- X * need to know whether the rest of the match failed) by a loop instead of
- X * by recursion.
- X */
- X/* [lwall] I've hoisted the register declarations to the outer block in order to
- X * maybe save a little bit of pushing and popping on the stack. It also takes
- X * advantage of machines that use a register save mask on subroutine entry.
- X */
- Xstatic int /* 0 failure, 1 success */
- Xregmatch(prog)
- Xchar *prog;
- X{
- X register char *scan; /* Current node. */
- X char *next; /* Next node. */
- X register int nextchar;
- X register int n; /* no or next */
- X register int ln; /* len or last */
- X register char *s; /* operand or save */
- X register char *locinput = reginput;
- X
- X nextchar = *locinput;
- X scan = prog;
- X#ifdef DEBUGGING
- X if (scan != NULL && regnarrate)
- X fprintf(stderr, "%s(\n", regprop(scan));
- X#endif
- X while (scan != NULL) {
- X#ifdef DEBUGGING
- X if (regnarrate)
- X fprintf(stderr, "%s...\n", regprop(scan));
- X#endif
- X
- X#ifdef REGALIGN
- X next = scan + NEXT(scan);
- X if (next == scan)
- X next = NULL;
- X#else
- X next = regnext(scan);
- X#endif
- X
- X switch (OP(scan)) {
- X case BOL:
- X if (locinput == regbol ? regprev == '\n' :
- X ((nextchar || locinput < regeol) &&
- X locinput[-1] == '\n') )
- X {
- X /* regtill = regbol; */
- X break;
- X }
- X return(0);
- X case EOL:
- X if ((nextchar || locinput < regeol) && nextchar != '\n')
- X return(0);
- X if (!multiline && regeol - locinput > 1)
- X return 0;
- X /* regtill = regbol; */
- X break;
- X case ANY:
- X if ((nextchar == '\0' && locinput >= regeol) ||
- X nextchar == '\n')
- X return(0);
- X nextchar = *++locinput;
- X break;
- X case EXACTLY:
- X s = OPERAND(scan);
- X ln = *s++;
- X /* Inline the first character, for speed. */
- X if (*s != nextchar)
- X return(0);
- X if (regeol - locinput < ln)
- X return 0;
- X if (ln > 1 && bcmp(s, locinput, ln) != 0)
- X return(0);
- X locinput += ln;
- X nextchar = *locinput;
- X break;
- X case ANYOF:
- X s = OPERAND(scan);
- X if (nextchar < 0)
- X nextchar = UCHARAT(locinput);
- X if (s[nextchar >> 3] & (1 << (nextchar&7)))
- X return(0);
- X if (!nextchar && locinput >= regeol)
- X return 0;
- X nextchar = *++locinput;
- X break;
- X case ALNUM:
- X if (!nextchar)
- X return(0);
- X if (!isALNUM(nextchar))
- X return(0);
- X nextchar = *++locinput;
- X break;
- X case NALNUM:
- X if (!nextchar && locinput >= regeol)
- X return(0);
- X if (isALNUM(nextchar))
- X return(0);
- X nextchar = *++locinput;
- X break;
- X case NBOUND:
- X case BOUND:
- X if (locinput == regbol) /* was last char in word? */
- X ln = isALNUM(regprev);
- X else
- X ln = isALNUM(locinput[-1]);
- X n = isALNUM(nextchar); /* is next char in word? */
- X if ((ln == n) == (OP(scan) == BOUND))
- X return(0);
- X break;
- X case SPACE:
- X if (!nextchar && locinput >= regeol)
- X return(0);
- X if (!isSPACE(nextchar))
- X return(0);
- X nextchar = *++locinput;
- X break;
- X case NSPACE:
- X if (!nextchar)
- X return(0);
- X if (isSPACE(nextchar))
- X return(0);
- X nextchar = *++locinput;
- X break;
- X case DIGIT:
- X if (!isDIGIT(nextchar))
- X return(0);
- X nextchar = *++locinput;
- X break;
- X case NDIGIT:
- X if (!nextchar && locinput >= regeol)
- X return(0);
- X if (isDIGIT(nextchar))
- X return(0);
- X nextchar = *++locinput;
- X break;
- X case REF:
- X n = ARG1(scan); /* which paren pair */
- X s = regmystartp[n];
- X if (!s)
- X return(0);
- X if (!regmyendp[n])
- X return(0);
- X if (s == regmyendp[n])
- X break;
- X /* Inline the first character, for speed. */
- X if (*s != nextchar)
- X return(0);
- X ln = regmyendp[n] - s;
- X if (locinput + ln > regeol)
- X return 0;
- X if (ln > 1 && bcmp(s, locinput, ln) != 0)
- X return(0);
- X locinput += ln;
- X nextchar = *locinput;
- X break;
- X
- X case NOTHING:
- X break;
- X case BACK:
- X break;
- X case OPEN:
- X n = ARG1(scan); /* which paren pair */
- X reginput = locinput;
- X
- X regmystartp[n] = locinput; /* for REF */
- X if (regmatch(next)) {
- X /*
- X * Don't set startp if some later
- X * invocation of the same parentheses
- X * already has.
- X */
- X if (regstartp[n] == NULL)
- X regstartp[n] = locinput;
- X return(1);
- X } else
- X return(0);
- X /* NOTREACHED */
- X case CLOSE: {
- X n = ARG1(scan); /* which paren pair */
- X reginput = locinput;
- X
- X regmyendp[n] = locinput; /* for REF */
- X if (regmatch(next)) {
- X /*
- X * Don't set endp if some later
- X * invocation of the same parentheses
- X * already has.
- X */
- X if (regendp[n] == NULL) {
- X regendp[n] = locinput;
- X if (n > *reglastparen)
- X *reglastparen = n;
- X }
- X return(1);
- X } else
- X return(0);
- X }
- X /*NOTREACHED*/
- X case BRANCH: {
- X if (OP(next) != BRANCH) /* No choice. */
- X next = NEXTOPER(scan); /* Avoid recursion. */
- X else {
- X do {
- X reginput = locinput;
- X if (regmatch(NEXTOPER(scan)))
- X return(1);
- X#ifdef REGALIGN
- X if (n = NEXT(scan))
- X scan += n;
- X else
- X scan = NULL;
- X#else
- X scan = regnext(scan);
- X#endif
- X } while (scan != NULL && OP(scan) == BRANCH);
- X return(0);
- X /* NOTREACHED */
- X }
- X }
- X break;
- X case CURLY:
- X ln = ARG1(scan); /* min to match */
- X n = ARG2(scan); /* max to match */
- X scan = NEXTOPER(scan) + 4;
- X goto repeat;
- X case STAR:
- X ln = 0;
- X n = 0;
- X scan = NEXTOPER(scan);
- X goto repeat;
- X case PLUS:
- X /*
- X * Lookahead to avoid useless match attempts
- X * when we know what character comes next.
- X */
- X ln = 1;
- X n = 0;
- X scan = NEXTOPER(scan);
- X repeat:
- X if (OP(next) == EXACTLY)
- X nextchar = *(OPERAND(next)+1);
- X else
- X nextchar = -1000;
- X reginput = locinput;
- X n = regrepeat(scan, n);
- X if (!multiline && OP(next) == EOL && ln < n)
- X ln = n; /* why back off? */
- X while (n >= ln) {
- X /* If it could work, try it. */
- X if (nextchar == -1000 || *reginput == nextchar)
- X if (regmatch(next))
- X return(1);
- X /* Couldn't or didn't -- back up. */
- X n--;
- X reginput = locinput + n;
- X }
- X return(0);
- X case END:
- X reginput = locinput; /* put where regtry can find it */
- X return(1); /* Success! */
- X default:
- X printf("%x %d\n",scan,scan[1]);
- X FAIL("regexp memory corruption");
- X }
- X
- X scan = next;
- X }
- X
- X /*
- X * We get here only if there's trouble -- normally "case END" is
- X * the terminating point.
- X */
- X FAIL("corrupted regexp pointers");
- X /*NOTREACHED*/
- X#ifdef lint
- X return 0;
- X#endif
- X}
- X
- X/*
- X - regrepeat - repeatedly match something simple, report how many
- X */
- X/*
- X * [This routine now assumes that it will only match on things of length 1.
- X * That was true before, but now we assume scan - reginput is the count,
- X * rather than incrementing count on every character.]
- X */
- Xstatic int
- Xregrepeat(p, max)
- Xchar *p;
- Xint max;
- X{
- X register char *scan;
- X register char *opnd;
- X register int c;
- X register char *loceol = regeol;
- X
- X scan = reginput;
- X if (max && max < loceol - scan)
- X loceol = scan + max;
- X opnd = OPERAND(p);
- X switch (OP(p)) {
- X case ANY:
- X while (scan < loceol && *scan != '\n')
- X scan++;
- X break;
- X case EXACTLY: /* length of string is 1 */
- X opnd++;
- X while (scan < loceol && *opnd == *scan)
- X scan++;
- X break;
- X case ANYOF:
- X c = UCHARAT(scan);
- X while (scan < loceol && !(opnd[c >> 3] & (1 << (c & 7)))) {
- X scan++;
- X c = UCHARAT(scan);
- X }
- X break;
- X case ALNUM:
- X while (scan < loceol && isALNUM(*scan))
- X scan++;
- X break;
- X case NALNUM:
- X while (scan < loceol && !isALNUM(*scan))
- X scan++;
- X break;
- X case SPACE:
- X while (scan < loceol && isSPACE(*scan))
- X scan++;
- X break;
- X case NSPACE:
- X while (scan < loceol && !isSPACE(*scan))
- X scan++;
- X break;
- X case DIGIT:
- X while (scan < loceol && isDIGIT(*scan))
- X scan++;
- X break;
- X case NDIGIT:
- X while (scan < loceol && !isDIGIT(*scan))
- X scan++;
- X break;
- X default: /* Oh dear. Called inappropriately. */
- X FAIL("internal regexp foulup");
- X /* NOTREACHED */
- X }
- X
- X c = scan - reginput;
- X reginput = scan;
- X
- X return(c);
- X}
- X
- X/*
- X - regnext - dig the "next" pointer out of a node
- X *
- X * [Note, when REGALIGN is defined there are two places in regmatch()
- X * that bypass this code for speed.]
- X */
- Xchar *
- Xregnext(p)
- Xregister char *p;
- X{
- X register int offset;
- X
- X if (p == ®dummy)
- X return(NULL);
- X
- X offset = NEXT(p);
- X if (offset == 0)
- X return(NULL);
- X
- X#ifdef REGALIGN
- X return(p+offset);
- X#else
- X if (OP(p) == BACK)
- X return(p-offset);
- X else
- X return(p+offset);
- X#endif
- X}
- !STUFFY!FUNK!
- echo Extracting t/op/read.t
- sed >t/op/read.t <<'!STUFFY!FUNK!' -e 's/X//'
- X#!./perl
- X
- X# $Header: read.t,v 4.0 91/03/20 01:54:16 lwall Locked $
- X
- Xprint "1..4\n";
- X
- X
- Xopen(FOO,'op/read.t') || open(FOO,'t/op/read.t') || die "Can't open op.read";
- Xseek(FOO,4,0);
- X$got = read(FOO,$buf,4);
- X
- Xprint ($got == 4 ? "ok 1\n" : "not ok 1\n");
- Xprint ($buf eq "perl" ? "ok 2\n" : "not ok 2 :$buf:\n");
- X
- Xseek(FOO,20000,0);
- X$got = read(FOO,$buf,4);
- X
- Xprint ($got == 0 ? "ok 3\n" : "not ok 3\n");
- Xprint ($buf eq "" ? "ok 4\n" : "not ok 4\n");
- !STUFFY!FUNK!
- echo " "
- echo "End of kit 21 (of 36)"
- cat /dev/null >kit21isdone
- run=''
- config=''
- for iskit in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36; do
- if test -f kit${iskit}isdone; then
- run="$run $iskit"
- else
- todo="$todo $iskit"
- fi
- done
- case $todo in
- '')
- echo "You have run all your kits. Please read README and then type Configure."
- for combo in *:AA; do
- if test -f "$combo"; then
- realfile=`basename $combo :AA`
- cat $realfile:[A-Z][A-Z] >$realfile
- rm -rf $realfile:[A-Z][A-Z]
- fi
- done
- rm -rf kit*isdone
- chmod 755 Configure
- ;;
- *) echo "You have run$run."
- echo "You still need to run$todo."
- ;;
- esac
- : Someone might mail this, so...
- exit
-
- exit 0 # Just in case...
- --
- Kent Landfield INTERNET: kent@sparky.IMD.Sterling.COM
- Sterling Software, IMD UUCP: uunet!sparky!kent
- Phone: (402) 291-8300 FAX: (402) 291-4362
- Please send comp.sources.misc-related mail to kent@uunet.uu.net.
-