From 68423353350767b638399d569001240edcbf4397 Mon Sep 17 00:00:00 2001 From: Don Armstrong Date: Thu, 30 Sep 2010 18:42:43 +0000 Subject: [PATCH] update more stuff; ditch old cperl mode and vc-bzr --- emacs_el/cperl-mode.el | 8911 -------------------------------- emacs_el/google-weather.el | 25 +- emacs_el/org-google-weather.el | 40 +- emacs_el/post.el | 144 +- emacs_el/vc-bzr.el | 596 --- 5 files changed, 130 insertions(+), 9586 deletions(-) delete mode 100644 emacs_el/cperl-mode.el delete mode 100644 emacs_el/vc-bzr.el diff --git a/emacs_el/cperl-mode.el b/emacs_el/cperl-mode.el deleted file mode 100644 index 48234ee..0000000 --- a/emacs_el/cperl-mode.el +++ /dev/null @@ -1,8911 +0,0 @@ -;;; cperl-mode.el --- Perl code editing commands for Emacs - -;; Copyright (C) 1985, 1986, 1987, 1991, 1992, 1993, 1994, 1995, 1996, 1997, -;; 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 -;; Free Software Foundation, Inc. - -;; Author: Ilya Zakharevich and Bob Olson -;; Maintainer: Ilya Zakharevich -;; Keywords: languages, Perl - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Corrections made by Ilya Zakharevich ilyaz@cpan.org - -;;; Commentary: - -;; You can either fine-tune the bells and whistles of this mode or -;; bulk enable them by putting - -;; (setq cperl-hairy t) - -;; in your .emacs file. (Emacs rulers do not consider it politically -;; correct to make whistles enabled by default.) - -;; DO NOT FORGET to read micro-docs (available from `Perl' menu) <<<<<< -;; or as help on variables `cperl-tips', `cperl-problems', <<<<<< -;; `cperl-praise', `cperl-speed'. <<<<<< - -;; The mode information (on C-h m) provides some customization help. -;; If you use font-lock feature of this mode, it is advisable to use -;; either lazy-lock-mode or fast-lock-mode. I prefer lazy-lock. - -;; Faces used now: three faces for first-class and second-class keywords -;; and control flow words, one for each: comments, string, labels, -;; functions definitions and packages, arrays, hashes, and variable -;; definitions. If you do not see all these faces, your font-lock does -;; not define them, so you need to define them manually. - -;; This mode supports font-lock, imenu and mode-compile. In the -;; hairy version font-lock is on, but you should activate imenu -;; yourself (note that mode-compile is not standard yet). Well, you -;; can use imenu from keyboard anyway (M-x imenu), but it is better -;; to bind it like that: - -;; (define-key global-map [M-S-down-mouse-3] 'imenu) - -;;; Font lock bugs as of v4.32: - -;; The following kinds of Perl code erroneously start strings: -;; \$` \$' \$" -;; $opt::s $opt_s $opt{s} (s => ...) /\s+.../ -;; likewise with m, tr, y, q, qX instead of s - -;;; Code: - -(defvar vc-rcs-header) -(defvar vc-sccs-header) - -(eval-when-compile - (condition-case nil - (require 'custom) - (error nil)) - (condition-case nil - (require 'man) - (error nil)) - (defvar cperl-can-font-lock - (or (featurep 'xemacs) - (and (boundp 'emacs-major-version) - (or window-system - (> emacs-major-version 20))))) - (if cperl-can-font-lock - (require 'font-lock)) - (defvar msb-menu-cond) - (defvar gud-perldb-history) - (defvar font-lock-background-mode) ; not in Emacs - (defvar font-lock-display-type) ; ditto - (defvar paren-backwards-message) ; Not in newer XEmacs? - (or (fboundp 'defgroup) - (defmacro defgroup (name val doc &rest arr) - nil)) - (or (fboundp 'custom-declare-variable) - (defmacro defcustom (name val doc &rest arr) - `(defvar ,name ,val ,doc))) - (or (and (fboundp 'custom-declare-variable) - (string< "19.31" emacs-version)) ; Checked with 19.30: defface does not work - (defmacro defface (&rest arr) - nil)) - ;; Avoid warning (tmp definitions) - (or (fboundp 'x-color-defined-p) - (defmacro x-color-defined-p (col) - (cond ((fboundp 'color-defined-p) `(color-defined-p ,col)) - ;; XEmacs >= 19.12 - ((fboundp 'valid-color-name-p) `(valid-color-name-p ,col)) - ;; XEmacs 19.11 - ((fboundp 'x-valid-color-name-p) `(x-valid-color-name-p ,col)) - (t '(error "Cannot implement color-defined-p"))))) - (defmacro cperl-is-face (arg) ; Takes quoted arg - (cond ((fboundp 'find-face) - `(find-face ,arg)) - (;;(and (fboundp 'face-list) - ;; (face-list)) - (fboundp 'face-list) - `(member ,arg (and (fboundp 'face-list) - (face-list)))) - (t - `(boundp ,arg)))) - (defmacro cperl-make-face (arg descr) ; Takes unquoted arg - (cond ((fboundp 'make-face) - `(make-face (quote ,arg))) - (t - `(defvar ,arg (quote ,arg) ,descr)))) - (defmacro cperl-force-face (arg descr) ; Takes unquoted arg - `(progn - (or (cperl-is-face (quote ,arg)) - (cperl-make-face ,arg ,descr)) - (or (boundp (quote ,arg)) ; We use unquoted variants too - (defvar ,arg (quote ,arg) ,descr)))) - (if (featurep 'xemacs) - (defmacro cperl-etags-snarf-tag (file line) - `(progn - (beginning-of-line 2) - (list ,file ,line))) - (defmacro cperl-etags-snarf-tag (file line) - `(etags-snarf-tag))) - (if (featurep 'xemacs) - (defmacro cperl-etags-goto-tag-location (elt) - ;;(progn - ;; (switch-to-buffer (get-file-buffer (elt ,elt 0))) - ;; (set-buffer (get-file-buffer (elt ,elt 0))) - ;; Probably will not work due to some save-excursion??? - ;; Or save-file-position? - ;; (message "Did I get to line %s?" (elt ,elt 1)) - `(goto-line (string-to-int (elt ,elt 1)))) - ;;) - (defmacro cperl-etags-goto-tag-location (elt) - `(etags-goto-tag-location ,elt)))) - -(defvar cperl-can-font-lock - (or (featurep 'xemacs) - (and (boundp 'emacs-major-version) - (or window-system - (> emacs-major-version 20))))) - -(defun cperl-choose-color (&rest list) - (let (answer) - (while list - (or answer - (if (or (x-color-defined-p (car list)) - (null (cdr list))) - (setq answer (car list)))) - (setq list (cdr list))) - answer)) - -(defgroup cperl nil - "Major mode for editing Perl code." - :prefix "cperl-" - :group 'languages - :version "20.3") - -(defgroup cperl-indentation-details nil - "Indentation." - :prefix "cperl-" - :group 'cperl) - -(defgroup cperl-affected-by-hairy nil - "Variables affected by `cperl-hairy'." - :prefix "cperl-" - :group 'cperl) - -(defgroup cperl-autoinsert-details nil - "Auto-insert tuneup." - :prefix "cperl-" - :group 'cperl) - -(defgroup cperl-faces nil - "Fontification colors." - :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces) - :prefix "cperl-" - :group 'cperl) - -(defgroup cperl-speed nil - "Speed vs. validity tuneup." - :prefix "cperl-" - :group 'cperl) - -(defgroup cperl-help-system nil - "Help system tuneup." - :prefix "cperl-" - :group 'cperl) - - -(defcustom cperl-extra-newline-before-brace nil - "*Non-nil means that if, elsif, while, until, else, for, foreach -and do constructs look like: - - if () - { - } - -instead of: - - if () { - }" - :type 'boolean - :group 'cperl-autoinsert-details) - -(defcustom cperl-extra-newline-before-brace-multiline - cperl-extra-newline-before-brace - "*Non-nil means the same as `cperl-extra-newline-before-brace', but -for constructs with multiline if/unless/while/until/for/foreach condition." - :type 'boolean - :group 'cperl-autoinsert-details) - -(defcustom cperl-indent-level 2 - "*Indentation of CPerl statements with respect to containing block." - :type 'integer - :group 'cperl-indentation-details) - -;; Is is not unusual to put both things like perl-indent-level and -;; cperl-indent-level in the local variable section of a file. If only -;; one of perl-mode and cperl-mode is in use, a warning will be issued -;; about the variable. Autoload these here, so that no warning is -;; issued when using either perl-mode or cperl-mode. -;;;###autoload(put 'cperl-indent-level 'safe-local-variable 'integerp) -;;;###autoload(put 'cperl-brace-offset 'safe-local-variable 'integerp) -;;;###autoload(put 'cperl-continued-brace-offset 'safe-local-variable 'integerp) -;;;###autoload(put 'cperl-label-offset 'safe-local-variable 'integerp) -;;;###autoload(put 'cperl-continued-statement-offset 'safe-local-variable 'integerp) -;;;###autoload(put 'cperl-extra-newline-before-brace 'safe-local-variable 'booleanp) -;;;###autoload(put 'cperl-merge-trailing-else 'safe-local-variable 'booleanp) - -(defcustom cperl-lineup-step nil - "*`cperl-lineup' will always lineup at multiple of this number. -If nil, the value of `cperl-indent-level' will be used." - :type '(choice (const nil) integer) - :group 'cperl-indentation-details) - -(defcustom cperl-brace-imaginary-offset 0 - "*Imagined indentation of a Perl open brace that actually follows a statement. -An open brace following other text is treated as if it were this far -to the right of the start of its line." - :type 'integer - :group 'cperl-indentation-details) - -(defcustom cperl-brace-offset 0 - "*Extra indentation for braces, compared with other text in same context." - :type 'integer - :group 'cperl-indentation-details) -(defcustom cperl-label-offset -2 - "*Offset of CPerl label lines relative to usual indentation." - :type 'integer - :group 'cperl-indentation-details) -(defcustom cperl-min-label-indent 1 - "*Minimal offset of CPerl label lines." - :type 'integer - :group 'cperl-indentation-details) -(defcustom cperl-continued-statement-offset 2 - "*Extra indent for lines not starting new statements." - :type 'integer - :group 'cperl-indentation-details) -(defcustom cperl-continued-brace-offset 0 - "*Extra indent for substatements that start with open-braces. -This is in addition to cperl-continued-statement-offset." - :type 'integer - :group 'cperl-indentation-details) -(defcustom cperl-close-paren-offset -1 - "*Extra indent for substatements that start with close-parenthesis." - :type 'integer - :group 'cperl-indentation-details) - -(defcustom cperl-indent-wrt-brace t - "*Non-nil means indent statements in if/etc block relative brace, not if/etc. -Versions 5.2 ... 5.20 behaved as if this were `nil'." - :type 'boolean - :group 'cperl-indentation-details) - -(defcustom cperl-auto-newline nil - "*Non-nil means automatically newline before and after braces, -and after colons and semicolons, inserted in CPerl code. The following -\\[cperl-electric-backspace] will remove the inserted whitespace. -Insertion after colons requires both this variable and -`cperl-auto-newline-after-colon' set." - :type 'boolean - :group 'cperl-autoinsert-details) - -(defcustom cperl-autoindent-on-semi nil - "*Non-nil means automatically indent after insertion of (semi)colon. -Active if `cperl-auto-newline' is false." - :type 'boolean - :group 'cperl-autoinsert-details) - -(defcustom cperl-auto-newline-after-colon nil - "*Non-nil means automatically newline even after colons. -Subject to `cperl-auto-newline' setting." - :type 'boolean - :group 'cperl-autoinsert-details) - -(defcustom cperl-tab-always-indent t - "*Non-nil means TAB in CPerl mode should always reindent the current line, -regardless of where in the line point is when the TAB command is used." - :type 'boolean - :group 'cperl-indentation-details) - -(defcustom cperl-font-lock nil - "*Non-nil (and non-null) means CPerl buffers will use `font-lock-mode'. -Can be overwritten by `cperl-hairy' if nil." - :type '(choice (const null) boolean) - :group 'cperl-affected-by-hairy) - -(defcustom cperl-electric-lbrace-space nil - "*Non-nil (and non-null) means { after $ should be preceded by ` '. -Can be overwritten by `cperl-hairy' if nil." - :type '(choice (const null) boolean) - :group 'cperl-affected-by-hairy) - -(defcustom cperl-electric-parens-string "({[]})<" - "*String of parentheses that should be electric in CPerl. -Closing ones are electric only if the region is highlighted." - :type 'string - :group 'cperl-affected-by-hairy) - -(defcustom cperl-electric-parens nil - "*Non-nil (and non-null) means parentheses should be electric in CPerl. -Can be overwritten by `cperl-hairy' if nil." - :type '(choice (const null) boolean) - :group 'cperl-affected-by-hairy) - -(defvar zmacs-regions) ; Avoid warning - -(defcustom cperl-electric-parens-mark - (and window-system - (or (and (boundp 'transient-mark-mode) ; For Emacs - transient-mark-mode) - (and (boundp 'zmacs-regions) ; For XEmacs - zmacs-regions))) - "*Not-nil means that electric parens look for active mark. -Default is yes if there is visual feedback on mark." - :type 'boolean - :group 'cperl-autoinsert-details) - -(defcustom cperl-electric-linefeed nil - "*If true, LFD should be hairy in CPerl, otherwise C-c LFD is hairy. -In any case these two mean plain and hairy linefeeds together. -Can be overwritten by `cperl-hairy' if nil." - :type '(choice (const null) boolean) - :group 'cperl-affected-by-hairy) - -(defcustom cperl-electric-keywords nil - "*Not-nil (and non-null) means keywords are electric in CPerl. -Can be overwritten by `cperl-hairy' if nil. - -Uses `abbrev-mode' to do the expansion. If you want to use your -own abbrevs in cperl-mode, but do not want keywords to be -electric, you must redefine `cperl-mode-abbrev-table': do -\\[edit-abbrevs], search for `cperl-mode-abbrev-table', and, in -that paragraph, delete the words that appear at the ends of lines and -that begin with \"cperl-electric\". -" - :type '(choice (const null) boolean) - :group 'cperl-affected-by-hairy) - -(defcustom cperl-electric-backspace-untabify t - "*Not-nil means electric-backspace will untabify in CPerl." - :type 'boolean - :group 'cperl-autoinsert-details) - -(defcustom cperl-hairy nil - "*Not-nil means most of the bells and whistles are enabled in CPerl. -Affects: `cperl-font-lock', `cperl-electric-lbrace-space', -`cperl-electric-parens', `cperl-electric-linefeed', `cperl-electric-keywords', -`cperl-info-on-command-no-prompt', `cperl-clobber-lisp-bindings', -`cperl-lazy-help-time'." - :type 'boolean - :group 'cperl-affected-by-hairy) - -(defcustom cperl-comment-column 32 - "*Column to put comments in CPerl (use \\[cperl-indent] to lineup with code)." - :type 'integer - :group 'cperl-indentation-details) - -(defcustom cperl-indent-comment-at-column-0 nil - "*Non-nil means that comment started at column 0 should be indentable." - :type 'boolean - :group 'cperl-indentation-details) - -(defcustom cperl-vc-sccs-header '("($sccs) = ('%W\%' =~ /(\\d+(\\.\\d+)+)/) ;") - "*Special version of `vc-sccs-header' that is used in CPerl mode buffers." - :type '(repeat string) - :group 'cperl) - -(defcustom cperl-vc-rcs-header '("($rcs) = (' $Id\$ ' =~ /(\\d+(\\.\\d+)+)/);") - "*Special version of `vc-rcs-header' that is used in CPerl mode buffers." - :type '(repeat string) - :group 'cperl) - -;; This became obsolete... -(defvar cperl-vc-header-alist nil) -(make-obsolete-variable - 'cperl-vc-header-alist - "use cperl-vc-rcs-header or cperl-vc-sccs-header instead.") - -(defcustom cperl-clobber-mode-lists - (not - (and - (boundp 'interpreter-mode-alist) - (assoc "miniperl" interpreter-mode-alist) - (assoc "\\.\\([pP][Llm]\\|al\\)$" auto-mode-alist))) - "*Whether to install us into `interpreter-' and `extension' mode lists." - :type 'boolean - :group 'cperl) - -(defcustom cperl-info-on-command-no-prompt nil - "*Not-nil (and non-null) means not to prompt on C-h f. -The opposite behavior is always available if prefixed with C-c. -Can be overwritten by `cperl-hairy' if nil." - :type '(choice (const null) boolean) - :group 'cperl-affected-by-hairy) - -(defcustom cperl-clobber-lisp-bindings nil - "*Not-nil (and non-null) means not overwrite C-h f. -The function is available on \\[cperl-info-on-command], \\[cperl-get-help]. -Can be overwritten by `cperl-hairy' if nil." - :type '(choice (const null) boolean) - :group 'cperl-affected-by-hairy) - -(defcustom cperl-lazy-help-time nil - "*Not-nil (and non-null) means to show lazy help after given idle time. -Can be overwritten by `cperl-hairy' to be 5 sec if nil." - :type '(choice (const null) (const nil) integer) - :group 'cperl-affected-by-hairy) - -(defcustom cperl-pod-face 'font-lock-comment-face - "*Face for POD highlighting." - :type 'face - :group 'cperl-faces) - -(defcustom cperl-pod-head-face 'font-lock-variable-name-face - "*Face for POD highlighting. -Font for POD headers." - :type 'face - :group 'cperl-faces) - -(defcustom cperl-here-face 'font-lock-string-face - "*Face for here-docs highlighting." - :type 'face - :group 'cperl-faces) - -;;; Some double-evaluation happened with font-locks... Needed with 21.2... -(defvar cperl-singly-quote-face (featurep 'xemacs)) - -(defcustom cperl-invalid-face 'underline - "*Face for highlighting trailing whitespace." - :type 'face - :version "21.1" - :group 'cperl-faces) - -(defcustom cperl-pod-here-fontify '(featurep 'font-lock) - "*Not-nil after evaluation means to highlight POD and here-docs sections." - :type 'boolean - :group 'cperl-faces) - -(defcustom cperl-fontify-m-as-s t - "*Not-nil means highlight 1arg regular expressions operators same as 2arg." - :type 'boolean - :group 'cperl-faces) - -(defcustom cperl-highlight-variables-indiscriminately nil - "*Non-nil means perform additional highlighting on variables. -Currently only changes how scalar variables are highlighted. -Note that that variable is only read at initialization time for -the variable `cperl-font-lock-keywords-2', so changing it after you've -entered CPerl mode the first time will have no effect." - :type 'boolean - :group 'cperl) - -(defcustom cperl-pod-here-scan t - "*Not-nil means look for POD and here-docs sections during startup. -You can always make lookup from menu or using \\[cperl-find-pods-heres]." - :type 'boolean - :group 'cperl-speed) - -(defcustom cperl-regexp-scan t - "*Not-nil means make marking of regular expression more thorough. -Effective only with `cperl-pod-here-scan'." - :type 'boolean - :group 'cperl-speed) - -(defcustom cperl-hook-after-change t - "*Not-nil means install hook to know which regions of buffer are changed. -May significantly speed up delayed fontification. Changes take effect -after reload." - :type 'boolean - :group 'cperl-speed) - -(defcustom cperl-imenu-addback nil - "*Not-nil means add backreferences to generated `imenu's. -May require patched `imenu' and `imenu-go'. Obsolete." - :type 'boolean - :group 'cperl-help-system) - -(defcustom cperl-max-help-size 66 - "*Non-nil means shrink-wrapping of info-buffer allowed up to these percents." - :type '(choice integer (const nil)) - :group 'cperl-help-system) - -(defcustom cperl-shrink-wrap-info-frame t - "*Non-nil means shrink-wrapping of info-buffer-frame allowed." - :type 'boolean - :group 'cperl-help-system) - -(defcustom cperl-info-page "perl" - "*Name of the info page containing perl docs. -Older version of this page was called `perl5', newer `perl'." - :type 'string - :group 'cperl-help-system) - -(defcustom cperl-use-syntax-table-text-property - (boundp 'parse-sexp-lookup-properties) - "*Non-nil means CPerl sets up and uses `syntax-table' text property." - :type 'boolean - :group 'cperl-speed) - -(defcustom cperl-use-syntax-table-text-property-for-tags - cperl-use-syntax-table-text-property - "*Non-nil means: set up and use `syntax-table' text property generating TAGS." - :type 'boolean - :group 'cperl-speed) - -(defcustom cperl-scan-files-regexp "\\.\\([pP][Llm]\\|xs\\)$" - "*Regexp to match files to scan when generating TAGS." - :type 'regexp - :group 'cperl) - -(defcustom cperl-noscan-files-regexp - "/\\(\\.\\.?\\|SCCS\\|RCS\\|CVS\\|blib\\)$" - "*Regexp to match files/dirs to skip when generating TAGS." - :type 'regexp - :group 'cperl) - -(defcustom cperl-regexp-indent-step nil - "*Indentation used when beautifying regexps. -If nil, the value of `cperl-indent-level' will be used." - :type '(choice integer (const nil)) - :group 'cperl-indentation-details) - -(defcustom cperl-indent-left-aligned-comments t - "*Non-nil means that the comment starting in leftmost column should indent." - :type 'boolean - :group 'cperl-indentation-details) - -(defcustom cperl-under-as-char nil - "*Non-nil means that the _ (underline) should be treated as word char." - :type 'boolean - :group 'cperl) - -(defcustom cperl-extra-perl-args "" - "*Extra arguments to use when starting Perl. -Currently used with `cperl-check-syntax' only." - :type 'string - :group 'cperl) - -(defcustom cperl-message-electric-keyword t - "*Non-nil means that the `cperl-electric-keyword' prints a help message." - :type 'boolean - :group 'cperl-help-system) - -(defcustom cperl-indent-region-fix-constructs 1 - "*Amount of space to insert between `}' and `else' or `elsif' -in `cperl-indent-region'. Set to nil to leave as is. Values other -than 1 and nil will probably not work." - :type '(choice (const nil) (const 1)) - :group 'cperl-indentation-details) - -(defcustom cperl-break-one-line-blocks-when-indent t - "*Non-nil means that one-line if/unless/while/until/for/foreach BLOCKs -need to be reformatted into multiline ones when indenting a region." - :type 'boolean - :group 'cperl-indentation-details) - -(defcustom cperl-fix-hanging-brace-when-indent t - "*Non-nil means that BLOCK-end `}' may be put on a separate line -when indenting a region. -Braces followed by else/elsif/while/until are excepted." - :type 'boolean - :group 'cperl-indentation-details) - -(defcustom cperl-merge-trailing-else t - "*Non-nil means that BLOCK-end `}' followed by else/elsif/continue -may be merged to be on the same line when indenting a region." - :type 'boolean - :group 'cperl-indentation-details) - -(defcustom cperl-indent-parens-as-block nil - "*Non-nil means that non-block ()-, {}- and []-groups are indented as blocks, -but for trailing \",\" inside the group, which won't increase indentation. -One should tune up `cperl-close-paren-offset' as well." - :type 'boolean - :group 'cperl-indentation-details) - -(defcustom cperl-syntaxify-by-font-lock - (and cperl-can-font-lock - (boundp 'parse-sexp-lookup-properties)) - "*Non-nil means that CPerl uses `font-lock's routines for syntaxification." - :type '(choice (const message) boolean) - :group 'cperl-speed) - -(defcustom cperl-syntaxify-unwind - t - "*Non-nil means that CPerl unwinds to a start of a long construction -when syntaxifying a chunk of buffer." - :type 'boolean - :group 'cperl-speed) - -(defcustom cperl-syntaxify-for-menu - t - "*Non-nil means that CPerl syntaxifies up to the point before showing menu. -This way enabling/disabling of menu items is more correct." - :type 'boolean - :group 'cperl-speed) - -(defcustom cperl-ps-print-face-properties - '((font-lock-keyword-face nil nil bold shadow) - (font-lock-variable-name-face nil nil bold) - (font-lock-function-name-face nil nil bold italic box) - (font-lock-constant-face nil "LightGray" bold) - (cperl-array-face nil "LightGray" bold underline) - (cperl-hash-face nil "LightGray" bold italic underline) - (font-lock-comment-face nil "LightGray" italic) - (font-lock-string-face nil nil italic underline) - (cperl-nonoverridable-face nil nil italic underline) - (font-lock-type-face nil nil underline) - (font-lock-warning-face nil "LightGray" bold italic box) - (underline nil "LightGray" strikeout)) - "List given as an argument to `ps-extend-face-list' in `cperl-ps-print'." - :type '(repeat (cons symbol - (cons (choice (const nil) string) - (cons (choice (const nil) string) - (repeat symbol))))) - :group 'cperl-faces) - -(defvar cperl-dark-background - (cperl-choose-color "navy" "os2blue" "darkgreen")) -(defvar cperl-dark-foreground - (cperl-choose-color "orchid1" "orange")) - -(defface cperl-nonoverridable-face - `((((class grayscale) (background light)) - (:background "Gray90" :slant italic :underline t)) - (((class grayscale) (background dark)) - (:foreground "Gray80" :slant italic :underline t :weight bold)) - (((class color) (background light)) - (:foreground "chartreuse3")) - (((class color) (background dark)) - (:foreground ,cperl-dark-foreground)) - (t (:weight bold :underline t))) - "Font Lock mode face used non-overridable keywords and modifiers of regexps." - :group 'cperl-faces) - -(defface cperl-array-face - `((((class grayscale) (background light)) - (:background "Gray90" :weight bold)) - (((class grayscale) (background dark)) - (:foreground "Gray80" :weight bold)) - (((class color) (background light)) - (:foreground "Blue" :background "lightyellow2" :weight bold)) - (((class color) (background dark)) - (:foreground "yellow" :background ,cperl-dark-background :weight bold)) - (t (:weight bold))) - "Font Lock mode face used to highlight array names." - :group 'cperl-faces) - -(defface cperl-hash-face - `((((class grayscale) (background light)) - (:background "Gray90" :weight bold :slant italic)) - (((class grayscale) (background dark)) - (:foreground "Gray80" :weight bold :slant italic)) - (((class color) (background light)) - (:foreground "Red" :background "lightyellow2" :weight bold :slant italic)) - (((class color) (background dark)) - (:foreground "Red" :background ,cperl-dark-background :weight bold :slant italic)) - (t (:weight bold :slant italic))) - "Font Lock mode face used to highlight hash names." - :group 'cperl-faces) - - - -;;; Short extra-docs. - -(defvar cperl-tips 'please-ignore-this-line - "Get maybe newer version of this package from - http://ilyaz.org/software/emacs -Subdirectory `cperl-mode' may contain yet newer development releases and/or -patches to related files. - -For best results apply to an older Emacs the patches from - ftp://ftp.math.ohio-state.edu/pub/users/ilya/cperl-mode/patches -\(this upgrades syntax-parsing abilities of Emacsen v19.34 and -v20.2 up to the level of Emacs v20.3 - a must for a good Perl -mode.) As of beginning of 2003, XEmacs may provide a similar ability. - -Get support packages choose-color.el (or font-lock-extra.el before -19.30), imenu-go.el from the same place. \(Look for other files there -too... ;-). Get a patch for imenu.el in 19.29. Note that for 19.30 and -later you should use choose-color.el *instead* of font-lock-extra.el -\(and you will not get smart highlighting in C :-(). - -Note that to enable Compile choices in the menu you need to install -mode-compile.el. - -If your Emacs does not default to `cperl-mode' on Perl files, and you -want it to: put the following into your .emacs file: - - (defalias 'perl-mode 'cperl-mode) - -Get perl5-info from - $CPAN/doc/manual/info/perl5-old/perl5-info.tar.gz -Also, one can generate a newer documentation running `pod2texi' converter - $CPAN/doc/manual/info/perl5/pod2texi-0.1.tar.gz - -If you use imenu-go, run imenu on perl5-info buffer (you can do it -from Perl menu). If many files are related, generate TAGS files from -Tools/Tags submenu in Perl menu. - -If some class structure is too complicated, use Tools/Hierarchy-view -from Perl menu, or hierarchic view of imenu. The second one uses the -current buffer only, the first one requires generation of TAGS from -Perl/Tools/Tags menu beforehand. - -Run Perl/Tools/Insert-spaces-if-needed to fix your lazy typing. - -Switch auto-help on/off with Perl/Tools/Auto-help. - -Though with contemporary Emaxen CPerl mode should maintain the correct -parsing of Perl even when editing, sometimes it may be lost. Fix this by - - \\[normal-mode] - -In cases of more severe confusion sometimes it is helpful to do - - \\[load-library] cperl-mode RET - \\[normal-mode] - -Before reporting (non-)problems look in the problem section of online -micro-docs on what I know about CPerl problems.") - -(defvar cperl-problems 'please-ignore-this-line - "Description of problems in CPerl mode. -Some faces will not be shown on some versions of Emacs unless you -install choose-color.el, available from - http://ilyaz.org/software/emacs - -`fill-paragraph' on a comment may leave the point behind the -paragraph. It also triggers a bug in some versions of Emacs (CPerl tries -to detect it and bulk out). - -See documentation of a variable `cperl-problems-old-emaxen' for the -problems which disappear if you upgrade Emacs to a reasonably new -version (20.3 for Emacs, and those of 2004 for XEmacs).") - -(defvar cperl-problems-old-emaxen 'please-ignore-this-line - "Description of problems in CPerl mode specific for older Emacs versions. - -Emacs had a _very_ restricted syntax parsing engine until version -20.1. Most problems below are corrected starting from this version of -Emacs, and all of them should be fixed in version 20.3. (Or apply -patches to Emacs 19.33/34 - see tips.) XEmacs was very backward in -this respect (until 2003). - -Note that even with newer Emacsen in some very rare cases the details -of interaction of `font-lock' and syntaxification may be not cleaned -up yet. You may get slightly different colors basing on the order of -fontification and syntaxification. Say, the initial faces is correct, -but editing the buffer breaks this. - -Even with older Emacsen CPerl mode tries to corrects some Emacs -misunderstandings, however, 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 be recognized as a regexp by the indentation -code. Or the opposite case, when a POD section is highlighted, but -may break the indentation of the following code (though indentation -should work if the balance of delimiters is not broken by POD). - -The main trick (to make $ a \"backslash\") makes constructions like -${aaa} look like unbalanced braces. The only trick I can think of is -to insert it as $ {aaa} (valid in perl5, not in perl4). - -Similar problems arise in regexps, when /(\\s|$)/ should be rewritten -as /($|\\s)/. Note that such a transposition is not always possible. - -The solution is to upgrade your Emacs or patch an older one. Note -that Emacs 20.2 has some bugs related to `syntax-table' text -properties. Patches are available on the main CPerl download site, -and on CPAN. - -If these bugs cannot be fixed on your machine (say, you have an inferior -environment and cannot recompile), you may still disable all the fancy stuff -via `cperl-use-syntax-table-text-property'.") - -(defvar cperl-praise 'please-ignore-this-line - "Advantages of CPerl mode. - -0) It uses the newest `syntax-table' property ;-); - -1) It does 99% of Perl syntax correct (as opposed to 80-90% in Perl -mode - but the latter number may have improved too in last years) even -with old Emaxen which do not support `syntax-table' property. - -When using `syntax-table' property for syntax assist hints, it should -handle 99.995% of lines correct - or somesuch. It automatically -updates syntax assist hints when you edit your script. - -2) It is generally believed to be \"the most user-friendly Emacs -package\" whatever it may mean (I doubt that the people who say similar -things tried _all_ the rest of Emacs ;-), but this was not a lonely -voice); - -3) Everything is customizable, one-by-one or in a big sweep; - -4) It has many easily-accessable \"tools\": - a) Can run program, check syntax, start debugger; - b) Can lineup vertically \"middles\" of rows, like `=' in - a = b; - cc = d; - c) Can insert spaces where this impoves readability (in one - interactive sweep over the buffer); - d) Has support for imenu, including: - 1) Separate unordered list of \"interesting places\"; - 2) Separate TOC of POD sections; - 3) Separate list of packages; - 4) Hierarchical view of methods in (sub)packages; - 5) and functions (by the full name - with package); - e) Has an interface to INFO docs for Perl; The interface is - very flexible, including shrink-wrapping of - documentation buffer/frame; - f) Has a builtin list of one-line explanations for perl constructs. - g) Can show these explanations if you stay long enough at the - corresponding place (or on demand); - h) Has an enhanced fontification (using 3 or 4 additional faces - comparing to font-lock - basically, different - namespaces in Perl have different colors); - i) Can construct TAGS basing on its knowledge of Perl syntax, - the standard menu has 6 different way to generate - TAGS (if \"by directory\", .xs files - with C-language - bindings - are included in the scan); - j) Can build a hierarchical view of classes (via imenu) basing - on generated TAGS file; - k) Has electric parentheses, electric newlines, uses Abbrev - for electric logical constructs - while () {} - with different styles of expansion (context sensitive - to be not so bothering). Electric parentheses behave - \"as they should\" in a presence of a visible region. - l) Changes msb.el \"on the fly\" to insert a group \"Perl files\"; - m) Can convert from - if (A) { B } - to - B if A; - - n) Highlights (by user-choice) either 3-delimiters constructs - (such as tr/a/b/), or regular expressions and `y/tr'; - o) Highlights trailing whitespace; - p) Is able to manipulate Perl Regular Expressions to ease - conversion to a more readable form. - q) Can ispell POD sections and HERE-DOCs. - r) Understands comments and character classes inside regular - expressions; can find matching () and [] in a regular expression. - s) Allows indentation of //x-style regular expressions; - t) Highlights different symbols in regular expressions according - to their function; much less problems with backslashitis; - u) Allows to find regular expressions which contain interpolated parts. - -5) The indentation engine was very smart, but most of tricks may be -not needed anymore with the support for `syntax-table' property. Has -progress indicator for indentation (with `imenu' loaded). - -6) Indent-region improves inline-comments as well; also corrects -whitespace *inside* the conditional/loop constructs. - -7) Fill-paragraph correctly handles multi-line comments; - -8) Can switch to different indentation styles by one command, and restore -the settings present before the switch. - -9) When doing indentation of control constructs, may correct -line-breaks/spacing between elements of the construct. - -10) Uses a linear-time algorith for indentation of regions (on Emaxen with -capable syntax engines). - -11) Syntax-highlight, indentation, sexp-recognition inside regular expressions. -") - -(defvar cperl-speed 'please-ignore-this-line - "This is an incomplete compendium of what is available in other parts -of CPerl documentation. (Please inform me if I skept anything.) - -There is a perception that CPerl is slower than alternatives. This part -of documentation is designed to overcome this misconception. - -*By default* CPerl tries to enable the most comfortable settings. -From most points of view, correctly working package is infinitely more -comfortable than a non-correctly working one, thus by default CPerl -prefers correctness over speed. Below is the guide how to change -settings if your preferences are different. - -A) Speed of loading the file. When loading file, CPerl may perform a -scan which indicates places which cannot be parsed by primitive Emacs -syntax-parsing routines, and marks them up so that either - - A1) CPerl may work around these deficiencies (for big chunks, mostly - PODs and HERE-documents), or - A2) On capable Emaxen CPerl will use improved syntax-handlings - which reads mark-up hints directly. - - The scan in case A2 is much more comprehensive, thus may be slower. - - User can disable syntax-engine-helping scan of A2 by setting - `cperl-use-syntax-table-text-property' - variable to nil (if it is set to t). - - One can disable the scan altogether (both A1 and A2) by setting - `cperl-pod-here-scan' - to nil. - -B) Speed of editing operations. - - One can add a (minor) speedup to editing operations by setting - `cperl-use-syntax-table-text-property' - variable to nil (if it is set to t). This will disable - syntax-engine-helping scan, thus will make many more Perl - constructs be wrongly recognized by CPerl, thus may lead to - wrongly matched parentheses, wrong indentation, etc. - - One can unset `cperl-syntaxify-unwind'. This might speed up editing - of, say, long POD sections.") - -(defvar cperl-tips-faces 'please-ignore-this-line - "CPerl mode uses following faces for highlighting: - - `cperl-array-face' Array names - `cperl-hash-face' Hash names - `font-lock-comment-face' Comments, PODs and whatever is considered - syntaxically to be not code - `font-lock-constant-face' HERE-doc delimiters, labels, delimiters of - 2-arg operators s/y/tr/ or of RExen, - `font-lock-warning-face' Special-cased m// and s//foo/, - `font-lock-function-name-face' _ as a target of a file tests, file tests, - subroutine names at the moment of definition - (except those conflicting with Perl operators), - package names (when recognized), format names - `font-lock-keyword-face' Control flow switch constructs, declarators - `cperl-nonoverridable-face' Non-overridable keywords, modifiers of RExen - `font-lock-string-face' Strings, qw() constructs, RExen, POD sections, - literal parts and the terminator of formats - and whatever is syntaxically considered - as string literals - `font-lock-type-face' Overridable keywords - `font-lock-variable-name-face' Variable declarations, indirect array and - hash names, POD headers/item names - `cperl-invalid' Trailing whitespace - -Note that in several situations the highlighting tries to inform about -possible confusion, such as different colors for function names in -declarations depending on what they (do not) override, or special cases -m// and s/// which do not do what one would expect them to do. - -Help with best setup of these faces for printout requested (for each of -the faces: please specify bold, italic, underline, shadow and box.) - -In regular expressions (except character classes): - `font-lock-string-face' \"Normal\" stuff and non-0-length constructs - `font-lock-constant-face': Delimiters - `font-lock-warning-face' Special-cased m// and s//foo/, - Mismatched closing delimiters, parens - we couldn't match, misplaced quantifiers, - unrecognized escape sequences - `cperl-nonoverridable-face' Modifiers, as gism in m/REx/gism - `font-lock-type-face' POSIX classes inside charclasses, - escape sequences with arguments (\x \23 \p \N) - and others match-a-char escape sequences - `font-lock-keyword-face' Capturing parens, and | - `font-lock-function-name-face' Special symbols: $ ^ . [ ] [^ ] (?{ }) (??{ }) - `font-lock-builtin-face' \"Remaining\" 0-length constructs, executable - parts of a REx, not-capturing parens - `font-lock-variable-name-face' Interpolated constructs, embedded code - `font-lock-comment-face' Embedded comments - -") - - - -;;; Portability stuff: - -(defmacro cperl-define-key (emacs-key definition &optional xemacs-key) - `(define-key cperl-mode-map - ,(if xemacs-key - `(if (featurep 'xemacs) ,xemacs-key ,emacs-key) - emacs-key) - ,definition)) - -(defvar cperl-del-back-ch - (car (append (where-is-internal 'delete-backward-char) - (where-is-internal 'backward-delete-char-untabify))) - "Character generated by key bound to `delete-backward-char'.") - -(and (vectorp cperl-del-back-ch) (= (length cperl-del-back-ch) 1) - (setq cperl-del-back-ch (aref cperl-del-back-ch 0))) - -(defun cperl-mark-active () (mark)) ; Avoid undefined warning -(if (featurep 'xemacs) - (progn - ;; "Active regions" are on: use region only if active - ;; "Active regions" are off: use region unconditionally - (defun cperl-use-region-p () - (if zmacs-regions (mark) t))) - (defun cperl-use-region-p () - (if transient-mark-mode mark-active t)) - (defun cperl-mark-active () mark-active)) - -(defsubst cperl-enable-font-lock () - cperl-can-font-lock) - -(defun cperl-putback-char (c) ; Emacs 19 - (set 'unread-command-events (list c))) ; Avoid undefined warning - -(if (featurep 'xemacs) - (defun cperl-putback-char (c) ; XEmacs >= 19.12 - (setq unread-command-events (list (eval '(character-to-event c)))))) - -(or (fboundp 'uncomment-region) - (defun uncomment-region (beg end) - (interactive "r") - (comment-region beg end -1))) - -(defvar cperl-do-not-fontify - (if (string< emacs-version "19.30") - 'fontified - 'lazy-lock) - "Text property which inhibits refontification.") - -(defsubst cperl-put-do-not-fontify (from to &optional post) - ;; If POST, do not do it with postponed fontification - (if (and post cperl-syntaxify-by-font-lock) - nil - (put-text-property (max (point-min) (1- from)) - to cperl-do-not-fontify t))) - -(defcustom cperl-mode-hook nil - "Hook run by CPerl mode." - :type 'hook - :group 'cperl) - -(defvar cperl-syntax-state nil) -(defvar cperl-syntax-done-to nil) -(defvar cperl-emacs-can-parse (> (length (save-excursion - (parse-partial-sexp (point) (point)))) 9)) - -;; Make customization possible "in reverse" -(defsubst cperl-val (symbol &optional default hairy) - (cond - ((eq (symbol-value symbol) 'null) default) - (cperl-hairy (or hairy t)) - (t (symbol-value symbol)))) - - -(defun cperl-make-indent (column &optional minimum keep) - "Makes indent of the current line the requested amount. -Unless KEEP, removes the old indentation. Works around a bug in ancient -versions of Emacs." - (let ((prop (get-text-property (point) 'syntax-type))) - (or keep - (delete-horizontal-space)) - (indent-to column minimum) - ;; In old versions (e.g., 19.33) `indent-to' would not inherit properties - (and prop - (> (current-column) 0) - (save-excursion - (beginning-of-line) - (or (get-text-property (point) 'syntax-type) - (and (looking-at "\\=[ \t]") - (put-text-property (point) (match-end 0) - 'syntax-type prop))))))) - -;;; Probably it is too late to set these guys already, but it can help later: - -;;;(and cperl-clobber-mode-lists -;;;(setq auto-mode-alist -;;; (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist )) -;;;(and (boundp 'interpreter-mode-alist) -;;; (setq interpreter-mode-alist (append interpreter-mode-alist -;;; '(("miniperl" . perl-mode)))))) -(eval-when-compile - (mapc (lambda (p) - (condition-case nil - (require p) - (error nil))) - '(imenu easymenu etags timer man info)) - (if (fboundp 'ps-extend-face-list) - (defmacro cperl-ps-extend-face-list (arg) - `(ps-extend-face-list ,arg)) - (defmacro cperl-ps-extend-face-list (arg) - `(error "This version of Emacs has no `ps-extend-face-list'"))) - ;; Calling `cperl-enable-font-lock' below doesn't compile on XEmacs, - ;; macros instead of defsubsts don't work on Emacs, so we do the - ;; expansion manually. Any other suggestions? - (require 'cl)) - -(defvar cperl-mode-abbrev-table nil - "Abbrev table in use in CPerl mode buffers.") - -(add-hook 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-"))) - -(defvar cperl-mode-map () "Keymap used in CPerl mode.") - -(if cperl-mode-map nil - (setq cperl-mode-map (make-sparse-keymap)) - (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-t" 'cperl-invert-if-unless) - (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-w" 'cperl-toggle-construct-fix) - (cperl-define-key "\C-c\C-f" 'auto-fill-mode) - (cperl-define-key "\C-c\C-e" 'cperl-toggle-electric) - (cperl-define-key "\C-c\C-b" 'cperl-find-bad-style) - (cperl-define-key "\C-c\C-p" 'cperl-pod-spell) - (cperl-define-key "\C-c\C-d" 'cperl-here-doc-spell) - (cperl-define-key "\C-c\C-n" 'cperl-narrow-to-here-doc) - (cperl-define-key "\C-c\C-v" 'cperl-next-interpolated-REx) - (cperl-define-key "\C-c\C-x" 'cperl-next-interpolated-REx-0) - (cperl-define-key "\C-c\C-y" 'cperl-next-interpolated-REx-1) - (cperl-define-key "\C-c\C-ha" 'cperl-toggle-autohelp) - (cperl-define-key "\C-c\C-hp" 'cperl-perldoc) - (cperl-define-key "\C-c\C-hP" 'cperl-perldoc-at-point) - (cperl-define-key "\e\C-q" 'cperl-indent-exp) ; Usually not bound - (cperl-define-key [?\C-\M-\|] 'cperl-lineup - [(control meta |)]) - ;;(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-c\C-hF" 'cperl-info-on-command - [(control c) (control h) F]) - (if (cperl-val 'cperl-clobber-lisp-bindings) - (progn - (cperl-define-key "\C-hf" - ;;(concat (char-to-string help-char) "f") ; does not work - 'cperl-info-on-command - [(control h) f]) - (cperl-define-key "\C-hv" - ;;(concat (char-to-string help-char) "v") ; does not work - 'cperl-get-help - [(control h) v]) - (cperl-define-key "\C-c\C-hf" - ;;(concat (char-to-string help-char) "f") ; does not work - (key-binding "\C-hf") - [(control c) (control h) f]) - (cperl-define-key "\C-c\C-hv" - ;;(concat (char-to-string help-char) "v") ; does not work - (key-binding "\C-hv") - [(control c) (control h) v])) - (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command - [(control c) (control h) f]) - (cperl-define-key "\C-c\C-hv" - ;;(concat (char-to-string help-char) "v") ; does not work - 'cperl-get-help - [(control c) (control h) v])) - (if (and (featurep 'xemacs) - (<= emacs-minor-version 11) (<= emacs-major-version 19)) - (progn - ;; substitute-key-definition is usefulness-deenhanced... - ;;;;;(cperl-define-key "\M-q" 'cperl-fill-paragraph) - (cperl-define-key "\e;" 'cperl-indent-for-comment) - (cperl-define-key "\e\C-\\" 'cperl-indent-region)) - (or (boundp 'fill-paragraph-function) - (substitute-key-definition - 'fill-paragraph 'cperl-fill-paragraph - cperl-mode-map global-map)) - (substitute-key-definition - 'indent-sexp 'cperl-indent-exp - cperl-mode-map global-map) - (substitute-key-definition - 'indent-region 'cperl-indent-region - cperl-mode-map global-map) - (substitute-key-definition - 'indent-for-comment 'cperl-indent-for-comment - cperl-mode-map global-map))) - -(defvar cperl-menu) -(defvar cperl-lazy-installed) -(defvar cperl-old-style nil) -(condition-case nil - (progn - (require 'easymenu) - (easy-menu-define - cperl-menu cperl-mode-map "Menu for CPerl mode" - '("Perl" - ["Beginning of function" beginning-of-defun t] - ["End of function" end-of-defun t] - ["Mark function" mark-defun t] - ["Indent expression" cperl-indent-exp t] - ["Fill paragraph/comment" fill-paragraph t] - "----" - ["Line up a construction" cperl-lineup (cperl-use-region-p)] - ["Invert if/unless/while etc" cperl-invert-if-unless t] - ("Regexp" - ["Beautify" cperl-beautify-regexp - cperl-use-syntax-table-text-property] - ["Beautify one level deep" (cperl-beautify-regexp 1) - cperl-use-syntax-table-text-property] - ["Beautify a group" cperl-beautify-level - cperl-use-syntax-table-text-property] - ["Beautify a group one level deep" (cperl-beautify-level 1) - cperl-use-syntax-table-text-property] - ["Contract a group" cperl-contract-level - cperl-use-syntax-table-text-property] - ["Contract groups" cperl-contract-levels - cperl-use-syntax-table-text-property] - "----" - ["Find next interpolated" cperl-next-interpolated-REx - (next-single-property-change (point-min) 'REx-interpolated)] - ["Find next interpolated (no //o)" - cperl-next-interpolated-REx-0 - (or (text-property-any (point-min) (point-max) 'REx-interpolated t) - (text-property-any (point-min) (point-max) 'REx-interpolated 1))] - ["Find next interpolated (neither //o nor whole-REx)" - cperl-next-interpolated-REx-1 - (text-property-any (point-min) (point-max) 'REx-interpolated t)]) - ["Insert spaces if needed to fix style" cperl-find-bad-style t] - ["Refresh \"hard\" constructions" cperl-find-pods-heres t] - "----" - ["Indent region" cperl-indent-region (cperl-use-region-p)] - ["Comment region" cperl-comment-region (cperl-use-region-p)] - ["Uncomment region" cperl-uncomment-region (cperl-use-region-p)] - "----" - ["Run" mode-compile (fboundp 'mode-compile)] - ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill) - (get-buffer "*compilation*"))] - ["Next error" next-error (get-buffer "*compilation*")] - ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)] - "----" - ["Debugger" cperl-db t] - "----" - ("Tools" - ["Imenu" imenu (fboundp 'imenu)] - ["Imenu on Perl Info" cperl-imenu-on-info (featurep 'imenu)] - "----" - ["Ispell PODs" cperl-pod-spell - ;; Better not to update syntaxification here: - ;; debugging syntaxificatio can be broken by this??? - (or - (get-text-property (point-min) 'in-pod) - (< (progn - (and cperl-syntaxify-for-menu - (cperl-update-syntaxification (point-max) (point-max))) - (next-single-property-change (point-min) 'in-pod nil (point-max))) - (point-max)))] - ["Ispell HERE-DOCs" cperl-here-doc-spell - (< (progn - (and cperl-syntaxify-for-menu - (cperl-update-syntaxification (point-max) (point-max))) - (next-single-property-change (point-min) 'here-doc-group nil (point-max))) - (point-max))] - ["Narrow to this HERE-DOC" cperl-narrow-to-here-doc - (eq 'here-doc (progn - (and cperl-syntaxify-for-menu - (cperl-update-syntaxification (point) (point))) - (get-text-property (point) 'syntax-type)))] - ["Select this HERE-DOC or POD section" - cperl-select-this-pod-or-here-doc - (memq (progn - (and cperl-syntaxify-for-menu - (cperl-update-syntaxification (point) (point))) - (get-text-property (point) 'syntax-type)) - '(here-doc pod))] - "----" - ["CPerl pretty print (exprmntl)" cperl-ps-print - (fboundp 'ps-extend-face-list)] - "----" - ["Syntaxify region" cperl-find-pods-heres-region - (cperl-use-region-p)] - ["Profile syntaxification" cperl-time-fontification t] - ["Debug errors in delayed fontification" cperl-emulate-lazy-lock t] - ["Debug unwind for syntactic scan" cperl-toggle-set-debug-unwind t] - ["Debug backtrace on syntactic scan (BEWARE!!!)" - (cperl-toggle-set-debug-unwind nil t) t] - "----" - ["Class Hierarchy from TAGS" cperl-tags-hier-init t] - ;;["Update classes" (cperl-tags-hier-init t) tags-table-list] - ("Tags" -;;; ["Create tags for current file" cperl-etags t] -;;; ["Add tags for current file" (cperl-etags t) t] -;;; ["Create tags for Perl files in directory" (cperl-etags nil t) t] -;;; ["Add tags for Perl files in directory" (cperl-etags t t) t] -;;; ["Create tags for Perl files in (sub)directories" -;;; (cperl-etags nil 'recursive) t] -;;; ["Add tags for Perl files in (sub)directories" -;;; (cperl-etags t 'recursive) t]) -;;;; cperl-write-tags (&optional file erase recurse dir inbuffer) - ["Create tags for current file" (cperl-write-tags nil t) t] - ["Add tags for current file" (cperl-write-tags) t] - ["Create tags for Perl files in directory" - (cperl-write-tags nil t nil t) t] - ["Add tags for Perl files in directory" - (cperl-write-tags nil nil nil t) t] - ["Create tags for Perl files in (sub)directories" - (cperl-write-tags nil t t t) t] - ["Add tags for Perl files in (sub)directories" - (cperl-write-tags nil nil t t) t])) - ("Perl docs" - ["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 symbol at point" cperl-get-help t] - ["Perldoc" cperl-perldoc t] - ["Perldoc on word at point" cperl-perldoc-at-point t] - ["View manpage of POD in this file" cperl-build-manpage t] - ["Auto-help on" cperl-lazy-install - (and (fboundp 'run-with-idle-timer) - (not cperl-lazy-installed))] - ["Auto-help off" cperl-lazy-unstall - (and (fboundp 'run-with-idle-timer) - cperl-lazy-installed)]) - ("Toggle..." - ["Auto newline" cperl-toggle-auto-newline t] - ["Electric parens" cperl-toggle-electric t] - ["Electric keywords" cperl-toggle-abbrev t] - ["Fix whitespace on indent" cperl-toggle-construct-fix t] - ["Auto-help on Perl constructs" cperl-toggle-autohelp t] - ["Auto fill" auto-fill-mode t]) - ("Indent styles..." - ["CPerl" (cperl-set-style "CPerl") t] - ["PerlStyle" (cperl-set-style "PerlStyle") t] - ["GNU" (cperl-set-style "GNU") t] - ["C++" (cperl-set-style "C++") t] - ["K&R" (cperl-set-style "K&R") t] - ["BSD" (cperl-set-style "BSD") t] - ["Whitesmith" (cperl-set-style "Whitesmith") t] - ["Memorize Current" (cperl-set-style "Current") t] - ["Memorized" (cperl-set-style-back) cperl-old-style]) - ("Micro-docs" - ["Tips" (describe-variable 'cperl-tips) t] - ["Problems" (describe-variable 'cperl-problems) t] - ["Speed" (describe-variable 'cperl-speed) t] - ["Praise" (describe-variable 'cperl-praise) t] - ["Faces" (describe-variable 'cperl-tips-faces) t] - ["CPerl mode" (describe-function 'cperl-mode) t] - ["CPerl version" - (message "The version of master-file for this CPerl is %s-Emacs" - cperl-version) t])))) - (error nil)) - -(autoload 'c-macro-expand "cmacexp" - "Display the result of expanding all C macros occurring in the region. -The expansion is entirely correct because it uses the C preprocessor." - t) - -;;; These two must be unwound, otherwise take exponential time -(defconst cperl-maybe-white-and-comment-rex "[ \t\n]*\\(#[^\n]*\n[ \t\n]*\\)*" -"Regular expression to match optional whitespace with interpspersed comments. -Should contain exactly one group.") - -;;; This one is tricky to unwind; still very inefficient... -(defconst cperl-white-and-comment-rex "\\([ \t\n]\\|#[^\n]*\n\\)+" -"Regular expression to match whitespace with interpspersed comments. -Should contain exactly one group.") - - -;;; Is incorporated in `cperl-imenu--function-name-regexp-perl' -;;; `cperl-outline-regexp', `defun-prompt-regexp'. -;;; Details of groups in this may be used in several functions; see comments -;;; near mentioned above variable(s)... -;;; sub($$):lvalue{} sub:lvalue{} Both allowed... -(defsubst cperl-after-sub-regexp (named attr) ; 9 groups without attr... - "Match the text after `sub' in a subroutine declaration. -If NAMED is nil, allows anonymous subroutines. Matches up to the first \":\" -of attributes (if present), or end of the name or prototype (whatever is -the last)." - (concat ; Assume n groups before this... - "\\(" ; n+1=name-group - cperl-white-and-comment-rex ; n+2=pre-name - "\\(::[a-zA-Z_0-9:']+\\|[a-zA-Z_'][a-zA-Z_0-9:']*\\)" ; n+3=name - "\\)" ; END n+1=name-group - (if named "" "?") - "\\(" ; n+4=proto-group - cperl-maybe-white-and-comment-rex ; n+5=pre-proto - "\\(([^()]*)\\)" ; n+6=prototype - "\\)?" ; END n+4=proto-group - "\\(" ; n+7=attr-group - cperl-maybe-white-and-comment-rex ; n+8=pre-attr - "\\(" ; n+9=start-attr - ":" - (if attr (concat - "\\(" - cperl-maybe-white-and-comment-rex ; whitespace-comments - "\\(\\sw\\|_\\)+" ; attr-name - ;; attr-arg (1 level of internal parens allowed!) - "\\((\\(\\\\.\\|[^\\\\()]\\|([^\\\\()]*)\\)*)\\)?" - "\\(" ; optional : (XXX allows trailing???) - cperl-maybe-white-and-comment-rex ; whitespace-comments - ":\\)?" - "\\)+") - "[^:]") - "\\)" - "\\)?" ; END n+6=proto-group - )) - -;;; Details of groups in this are used in `cperl-imenu--create-perl-index' -;;; and `cperl-outline-level'. -;;;; Was: 2=sub|package; now 2=package-group, 5=package-name 8=sub-name (+3) -(defvar cperl-imenu--function-name-regexp-perl - (concat - "^\\(" ; 1 = all - "\\([ \t]*package" ; 2 = package-group - "\\(" ; 3 = package-name-group - cperl-white-and-comment-rex ; 4 = pre-package-name - "\\([a-zA-Z_0-9:']+\\)\\)?\\)" ; 5 = package-name - "\\|" - "[ \t]*sub" - (cperl-after-sub-regexp 'named nil) ; 8=name 11=proto 14=attr-start - cperl-maybe-white-and-comment-rex ; 15=pre-block - "\\|" - "=head\\([1-4]\\)[ \t]+" ; 16=level - "\\([^\n]+\\)$" ; 17=text - "\\)")) - -(defvar cperl-outline-regexp - (concat cperl-imenu--function-name-regexp-perl "\\|" "\\`")) - -(defvar cperl-mode-syntax-table nil - "Syntax table in use in CPerl mode buffers.") - -(defvar cperl-string-syntax-table nil - "Syntax table in use in CPerl mode string-like chunks.") - -(defsubst cperl-1- (p) - (max (point-min) (1- p))) - -(defsubst cperl-1+ (p) - (min (point-max) (1+ p))) - -(if cperl-mode-syntax-table - () - (setq cperl-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\\ "\\" cperl-mode-syntax-table) - (modify-syntax-entry ?/ "." cperl-mode-syntax-table) - (modify-syntax-entry ?* "." cperl-mode-syntax-table) - (modify-syntax-entry ?+ "." cperl-mode-syntax-table) - (modify-syntax-entry ?- "." cperl-mode-syntax-table) - (modify-syntax-entry ?= "." cperl-mode-syntax-table) - (modify-syntax-entry ?% "." cperl-mode-syntax-table) - (modify-syntax-entry ?< "." cperl-mode-syntax-table) - (modify-syntax-entry ?> "." cperl-mode-syntax-table) - (modify-syntax-entry ?& "." cperl-mode-syntax-table) - (modify-syntax-entry ?$ "\\" cperl-mode-syntax-table) - (modify-syntax-entry ?\n ">" cperl-mode-syntax-table) - (modify-syntax-entry ?# "<" cperl-mode-syntax-table) - (modify-syntax-entry ?' "\"" cperl-mode-syntax-table) - (modify-syntax-entry ?` "\"" cperl-mode-syntax-table) - (if cperl-under-as-char - (modify-syntax-entry ?_ "w" cperl-mode-syntax-table)) - (modify-syntax-entry ?: "_" cperl-mode-syntax-table) - (modify-syntax-entry ?| "." cperl-mode-syntax-table) - (setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table)) - (modify-syntax-entry ?$ "." cperl-string-syntax-table) - (modify-syntax-entry ?\{ "." cperl-string-syntax-table) - (modify-syntax-entry ?\} "." cperl-string-syntax-table) - (modify-syntax-entry ?# "." cperl-string-syntax-table)) ; (?# comment ) - - - -(defvar cperl-faces-init nil) -;; Fix for msb.el -(defvar cperl-msb-fixed nil) -(defvar cperl-use-major-mode 'cperl-mode) -(defvar cperl-font-lock-multiline-start nil) -(defvar cperl-font-lock-multiline nil) -(defvar cperl-font-locking nil) - -;; NB as it stands the code in cperl-mode assumes this only has one -;; element. If Xemacs 19 support were dropped, this could all be simplified. -(defvar cperl-compilation-error-regexp-alist - ;; This look like a paranoiac regexp: could anybody find a better one? (which WORKS). - '(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]" - 2 3)) - "Alist that specifies how to match errors in perl output.") - -(defvar compilation-error-regexp-alist) - -;;;###autoload -(defun cperl-mode () - "Major mode for editing Perl code. -Expression and list commands understand all C brackets. -Tab indents for Perl code. -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. - -Various characters in Perl almost always come in pairs: {}, (), [], -sometimes <>. When the user types the first, she gets the second as -well, with optional special formatting done on {}. (Disabled by -default.) You can always quote (with \\[quoted-insert]) the left -\"paren\" to avoid the expansion. The processing of < is special, -since most the time you mean \"less\". CPerl mode tries to guess -whether you want to type pair <>, and inserts is if it -appropriate. You can set `cperl-electric-parens-string' to the string that -contains the parenths from the above list you want to be electrical. -Electricity of parenths is controlled by `cperl-electric-parens'. -You may also set `cperl-electric-parens-mark' to have electric parens -look for active mark and \"embrace\" a region if possible.' - -CPerl mode provides expansion of the Perl control constructs: - - if, else, elsif, unless, while, until, continue, do, - for, foreach, formy and foreachmy. - -and POD directives (Disabled by default, see `cperl-electric-keywords'.) - -The user types the keyword immediately followed by a space, which -causes the construct to be expanded, and the point is positioned where -she is most likely to want to be. eg. when the user types a space -following \"if\" the following appears in the buffer: if () { or if () -} { } and the cursor is between the parentheses. The user can then -type some boolean expression within the parens. Having done that, -typing \\[cperl-linefeed] places you - appropriately indented - on a -new line between the braces (if you typed \\[cperl-linefeed] in a POD -directive line, then appropriate number of new lines is inserted). - -If CPerl decides that you want to insert \"English\" style construct like - - bite if angry; - -it will not do any expansion. See also help on variable -`cperl-extra-newline-before-brace'. (Note that one can switch the -help message on expansion by setting `cperl-message-electric-keyword' -to nil.) - -\\[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 -appropriately indented blank line. If you need a usual -`newline-and-indent' behavior, it is on \\[newline-and-indent], -see documentation on `cperl-electric-linefeed'. - -Use \\[cperl-invert-if-unless] to change a construction of the form - - if (A) { B } - -into - - B if A; - -\\{cperl-mode-map} - -Setting the variable `cperl-font-lock' to t switches on font-lock-mode -\(even with older Emacsen), `cperl-electric-lbrace-space' to t switches -on electric space between $ and {, `cperl-electric-parens-string' is -the string that contains parentheses that should be electric in CPerl -\(see also `cperl-electric-parens-mark' and `cperl-electric-parens'), -setting `cperl-electric-keywords' enables electric expansion of -control structures in CPerl. `cperl-electric-linefeed' governs which -one of two linefeed behavior is preferable. You can enable all these -options simultaneously (recommended mode of use) by setting -`cperl-hairy' to t. In this case you can switch separate options off -by setting them to `null'. Note that one may undo the extra -whitespace inserted by semis and braces in `auto-newline'-mode by -consequent \\[cperl-electric-backspace]. - -If your site has perl5 documentation in info format, you can use commands -\\[cperl-info-on-current-command] and \\[cperl-info-on-command] to access it. -These keys run commands `cperl-info-on-current-command' and -`cperl-info-on-command', which one is which is controlled by variable -`cperl-info-on-command-no-prompt' and `cperl-clobber-lisp-bindings' -\(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], and one can run perldoc or -man via menu. - -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' (if the value of `cperl-lazy-help-time' is nil) is 5 -secs idle time . It is also possible to switch this on/off from the -menu, or via \\[cperl-toggle-autohelp]. Requires `run-with-idle-timer'. - -Use \\[cperl-lineup] to vertically lineup some construction - put the -beginning of the region at the start of construction, and make region -span the needed amount of lines. - -Variables `cperl-pod-here-scan', `cperl-pod-here-fontify', -`cperl-pod-face', `cperl-pod-head-face' control processing of POD and -here-docs sections. With capable Emaxen results of scan are used -for indentation too, otherwise they are used for highlighting only. - -Variables controlling indentation style: - `cperl-tab-always-indent' - Non-nil means TAB in CPerl mode should always reindent the current line, - regardless of where in the line point is when the TAB command is used. - `cperl-indent-left-aligned-comments' - Non-nil means that the comment starting in leftmost column should indent. - `cperl-auto-newline' - Non-nil means automatically newline before and after braces, - and after colons and semicolons, inserted in Perl code. The following - \\[cperl-electric-backspace] will remove the inserted whitespace. - Insertion after colons requires both this variable and - `cperl-auto-newline-after-colon' set. - `cperl-auto-newline-after-colon' - Non-nil means automatically newline even after colons. - Subject to `cperl-auto-newline' setting. - `cperl-indent-level' - Indentation of Perl statements within surrounding block. - The surrounding block's indentation is the indentation - of the line on which the open-brace appears. - `cperl-continued-statement-offset' - Extra indentation given to a substatement, such as the - then-clause of an if, or body of a while, or just a statement continuation. - `cperl-continued-brace-offset' - Extra indentation given to a brace that starts a substatement. - This is in addition to `cperl-continued-statement-offset'. - `cperl-brace-offset' - Extra indentation for line if it starts with an open brace. - `cperl-brace-imaginary-offset' - An open brace following other text is treated as if it the line started - this far to the right of the actual line indentation. - `cperl-label-offset' - Extra indentation for line that is a label. - `cperl-min-label-indent' - Minimal indentation for line that is a label. - -Settings for classic indent-styles: K&R BSD=C++ GNU PerlStyle=Whitesmith - `cperl-indent-level' 5 4 2 4 - `cperl-brace-offset' 0 0 0 0 - `cperl-continued-brace-offset' -5 -4 0 0 - `cperl-label-offset' -5 -4 -2 -4 - `cperl-continued-statement-offset' 5 4 2 4 - -CPerl knows several indentation styles, and may bulk set the -corresponding variables. Use \\[cperl-set-style] to do this. Use -\\[cperl-set-style-back] to restore the memorized preexisting values -\(both available from menu). See examples in `cperl-style-examples'. - -Part of the indentation style is how different parts of if/elsif/else -statements are broken into lines; in CPerl, this is reflected on how -templates for these constructs are created (controlled by -`cperl-extra-newline-before-brace'), and how reflow-logic should treat \"continuation\" blocks of else/elsif/continue, controlled by the same variable, -and by `cperl-extra-newline-before-brace-multiline', -`cperl-merge-trailing-else', `cperl-indent-region-fix-constructs'. - -If `cperl-indent-level' is 0, the statement after opening brace in -column 0 is indented on -`cperl-brace-offset'+`cperl-continued-statement-offset'. - -Turning on CPerl mode calls the hooks in the variable `cperl-mode-hook' -with no args. - -DO NOT FORGET to read micro-docs (available from `Perl' menu) -or as help on variables `cperl-tips', `cperl-problems', -`cperl-praise', `cperl-speed'." - (interactive) - (kill-all-local-variables) - (use-local-map cperl-mode-map) - (if (cperl-val 'cperl-electric-linefeed) - (progn - (local-set-key "\C-J" 'cperl-linefeed) - (local-set-key "\C-C\C-J" 'newline-and-indent))) - (if (and - (cperl-val 'cperl-clobber-lisp-bindings) - (cperl-val 'cperl-info-on-command-no-prompt)) - (progn - ;; 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 cperl-use-major-mode) - (setq mode-name "CPerl") - (let ((prev-a-c abbrevs-changed)) - (define-abbrev-table 'cperl-mode-abbrev-table '( - ("if" "if" cperl-electric-keyword 0) - ("elsif" "elsif" cperl-electric-keyword 0) - ("while" "while" cperl-electric-keyword 0) - ("until" "until" cperl-electric-keyword 0) - ("unless" "unless" cperl-electric-keyword 0) - ("else" "else" cperl-electric-else 0) - ("continue" "continue" cperl-electric-else 0) - ("for" "for" cperl-electric-keyword 0) - ("foreach" "foreach" cperl-electric-keyword 0) - ("formy" "formy" cperl-electric-keyword 0) - ("foreachmy" "foreachmy" cperl-electric-keyword 0) - ("do" "do" cperl-electric-keyword 0) - ("=pod" "=pod" cperl-electric-pod 0) - ("=over" "=over" cperl-electric-pod 0) - ("=head1" "=head1" cperl-electric-pod 0) - ("=head2" "=head2" cperl-electric-pod 0) - ("pod" "pod" cperl-electric-pod 0) - ("over" "over" cperl-electric-pod 0) - ("head1" "head1" cperl-electric-pod 0) - ("head2" "head2" cperl-electric-pod 0))) - (setq abbrevs-changed prev-a-c)) - (setq local-abbrev-table cperl-mode-abbrev-table) - (if (cperl-val 'cperl-electric-keywords) - (abbrev-mode 1)) - (set-syntax-table cperl-mode-syntax-table) - ;; Until Emacs is multi-threaded, we do not actually need it local: - (make-local-variable 'cperl-font-lock-multiline-start) - (make-local-variable 'cperl-font-locking) - (make-local-variable 'outline-regexp) - ;; (setq outline-regexp imenu-example--function-name-regexp-perl) - (setq outline-regexp cperl-outline-regexp) - (make-local-variable 'outline-level) - (setq outline-level 'cperl-outline-level) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "^$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (if (featurep 'xemacs) - (progn - (make-local-variable 'paren-backwards-message) - (set 'paren-backwards-message t))) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'cperl-indent-line) - (make-local-variable 'require-final-newline) - (setq require-final-newline mode-require-final-newline) - (make-local-variable 'comment-start) - (setq comment-start "# ") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column cperl-comment-column) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "#+ *") - (make-local-variable 'defun-prompt-regexp) -;;; "[ \t]*sub" -;;; (cperl-after-sub-regexp 'named nil) ; 8=name 11=proto 14=attr-start -;;; cperl-maybe-white-and-comment-rex ; 15=pre-block - (setq defun-prompt-regexp - (concat "^[ \t]*\\(\\(?:sub\\|method\\)" - (cperl-after-sub-regexp 'named 'attr-groups) - "\\|" ; per toke.c - "\\(BEGIN\\|CHECK\\|INIT\\|END\\|AUTOLOAD\\|DESTROY\\)" - "\\)" - cperl-maybe-white-and-comment-rex)) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'cperl-comment-indent) - (and (boundp 'fill-paragraph-function) - (progn - (make-local-variable 'fill-paragraph-function) - (set 'fill-paragraph-function 'cperl-fill-paragraph))) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (make-local-variable 'indent-region-function) - (setq indent-region-function 'cperl-indent-region) - ;;(setq auto-fill-function 'cperl-do-auto-fill) ; Need to switch on and off! - (make-local-variable 'imenu-create-index-function) - (setq imenu-create-index-function - (function cperl-imenu--create-perl-index)) - (make-local-variable 'imenu-sort-function) - (setq imenu-sort-function nil) - (make-local-variable 'vc-rcs-header) - (set 'vc-rcs-header cperl-vc-rcs-header) - (make-local-variable 'vc-sccs-header) - (set 'vc-sccs-header cperl-vc-sccs-header) - ;; This one is obsolete... - (make-local-variable 'vc-header-alist) - (with-no-warnings - (set 'vc-header-alist (or cperl-vc-header-alist ; Avoid warning - `((SCCS ,(car cperl-vc-sccs-header)) - (RCS ,(car cperl-vc-rcs-header))))) - ) - (cond ((boundp 'compilation-error-regexp-alist-alist);; xemacs 20.x - (make-local-variable 'compilation-error-regexp-alist-alist) - (set 'compilation-error-regexp-alist-alist - (cons (cons 'cperl (car cperl-compilation-error-regexp-alist)) - (symbol-value 'compilation-error-regexp-alist-alist))) - (if (fboundp 'compilation-build-compilation-error-regexp-alist) - (let ((f 'compilation-build-compilation-error-regexp-alist)) - (funcall f)) - (make-local-variable 'compilation-error-regexp-alist) - (push 'cperl compilation-error-regexp-alist))) - ((boundp 'compilation-error-regexp-alist);; xmeacs 19.x - (make-local-variable 'compilation-error-regexp-alist) - (set 'compilation-error-regexp-alist - (append cperl-compilation-error-regexp-alist - (symbol-value 'compilation-error-regexp-alist))))) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults - (cond - ((string< emacs-version "19.30") - '(cperl-font-lock-keywords-2 nil nil ((?_ . "w")))) - ((string< emacs-version "19.33") ; Which one to use? - '((cperl-font-lock-keywords - cperl-font-lock-keywords-1 - cperl-font-lock-keywords-2) nil nil ((?_ . "w")))) - (t - '((cperl-load-font-lock-keywords - cperl-load-font-lock-keywords-1 - cperl-load-font-lock-keywords-2) nil nil ((?_ . "w")))))) - (make-local-variable 'cperl-syntax-state) - (setq cperl-syntax-state nil) ; reset syntaxification cache - (if cperl-use-syntax-table-text-property - (progn - (make-local-variable 'parse-sexp-lookup-properties) - ;; Do not introduce variable if not needed, we check it! - (set 'parse-sexp-lookup-properties t) - ;; Fix broken font-lock: - (or (boundp 'font-lock-unfontify-region-function) - (set 'font-lock-unfontify-region-function - 'font-lock-default-unfontify-region)) - (unless (featurep 'xemacs) ; Our: just a plug for wrong font-lock - (make-local-variable 'font-lock-unfontify-region-function) - (set 'font-lock-unfontify-region-function ; not present with old Emacs - 'cperl-font-lock-unfontify-region-function)) - (make-local-variable 'cperl-syntax-done-to) - (setq cperl-syntax-done-to nil) ; reset syntaxification cache - (make-local-variable 'font-lock-syntactic-keywords) - (setq font-lock-syntactic-keywords - (if cperl-syntaxify-by-font-lock - '((cperl-fontify-syntaxically)) - ;; unless font-lock-syntactic-keywords, font-lock (pre-22.1) - ;; used to ignore syntax-table text-properties. (t) is a hack - ;; to make font-lock think that font-lock-syntactic-keywords - ;; are defined. - '(t))))) - (if (boundp 'font-lock-multiline) ; Newer font-lock; use its facilities - (progn - (setq cperl-font-lock-multiline t) ; Not localized... - (set (make-local-variable 'font-lock-multiline) t)) - (make-local-variable 'font-lock-fontify-region-function) - (set 'font-lock-fontify-region-function ; not present with old Emacs - 'cperl-font-lock-fontify-region-function)) - (make-local-variable 'font-lock-fontify-region-function) - (set 'font-lock-fontify-region-function ; not present with old Emacs - 'cperl-font-lock-fontify-region-function) - (make-local-variable 'cperl-old-style) - (if (boundp 'normal-auto-fill-function) ; 19.33 and later - (set (make-local-variable 'normal-auto-fill-function) - 'cperl-do-auto-fill) - (or (fboundp 'cperl-old-auto-fill-mode) - (progn - (fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode)) - (defun auto-fill-mode (&optional arg) - (interactive "P") - (eval '(cperl-old-auto-fill-mode arg)) ; Avoid a warning - (and auto-fill-function (memq major-mode '(perl-mode cperl-mode)) - (setq auto-fill-function 'cperl-do-auto-fill)))))) - (if (cperl-enable-font-lock) - (if (cperl-val 'cperl-font-lock) - (progn (or cperl-faces-init (cperl-init-faces)) - (font-lock-mode 1)))) - (set (make-local-variable 'facemenu-add-face-function) - 'cperl-facemenu-add-face-function) ; XXXX What this guy is for??? - (and (boundp 'msb-menu-cond) - (not cperl-msb-fixed) - (cperl-msb-fix)) - (if (featurep 'easymenu) - (easy-menu-add cperl-menu)) ; A NOP in Emacs. - (run-mode-hooks 'cperl-mode-hook) - (if cperl-hook-after-change - (add-hook 'after-change-functions 'cperl-after-change-function nil t)) - ;; After hooks since fontification will break this - (if cperl-pod-here-scan - (or cperl-syntaxify-by-font-lock - (progn (or cperl-faces-init (cperl-init-faces-weak)) - (cperl-find-pods-heres))))) - -;; Fix for perldb - make default reasonable -(defun cperl-db () - (interactive) - (require 'gud) - (perldb (read-from-minibuffer "Run perldb (like this): " - (if (consp gud-perldb-history) - (car gud-perldb-history) - (concat "perl " ;;(file-name-nondirectory - ;; I have problems - ;; in OS/2 - ;; otherwise - (buffer-file-name))) - nil nil - '(gud-perldb-history . 1)))) - -(defun cperl-msb-fix () - ;; Adds perl files to msb menu, supposes that msb is already loaded - (setq cperl-msb-fixed t) - (let* ((l (length msb-menu-cond)) - (last (nth (1- l) msb-menu-cond)) - (precdr (nthcdr (- l 2) msb-menu-cond)) ; cdr of this is last - (handle (1- (nth 1 last)))) - (setcdr precdr (list - (list - '(memq major-mode '(cperl-mode perl-mode)) - handle - "Perl Files (%d)") - last)))) - -;; This is used by indent-for-comment -;; to decide how much to indent a comment in CPerl code -;; based on its context. Do fallback if comment is found wrong. - -(defvar cperl-wrong-comment) -(defvar cperl-st-cfence '(14)) ; Comment-fence -(defvar cperl-st-sfence '(15)) ; String-fence -(defvar cperl-st-punct '(1)) -(defvar cperl-st-word '(2)) -(defvar cperl-st-bra '(4 . ?\>)) -(defvar cperl-st-ket '(5 . ?\<)) - - -(defun cperl-comment-indent () ; called at point at supposed comment - (let ((p (point)) (c (current-column)) was phony) - (if (and (not cperl-indent-comment-at-column-0) - (looking-at "^#")) - 0 ; Existing comment at bol stays there. - ;; Wrong comment found - (save-excursion - (setq was (cperl-to-comment-or-eol) - phony (eq (get-text-property (point) 'syntax-table) - cperl-st-cfence)) - (if phony - (progn ; Too naive??? - (re-search-forward "#\\|$") ; Hmm, what about embedded #? - (if (eq (preceding-char) ?\#) - (forward-char -1)) - (setq was nil))) - (if (= (point) p) ; Our caller found a correct place - (progn - (skip-chars-backward " \t") - (setq was (current-column)) - (if (eq was 0) - comment-column - (max (1+ was) ; Else indent at comment column - comment-column))) - ;; No, the caller found a random place; we need to edit ourselves - (if was nil - (insert comment-start) - (backward-char (length comment-start))) - (setq cperl-wrong-comment t) - (cperl-make-indent comment-column 1) ; Indent min 1 - c))))) - -;;;(defun cperl-comment-indent-fallback () -;;; "Is called if the standard comment-search procedure fails. -;;;Point is at start of real comment." -;;; (let ((c (current-column)) target cnt prevc) -;;; (if (= c comment-column) nil -;;; (setq cnt (skip-chars-backward "[ \t]")) -;;; (setq target (max (1+ (setq prevc -;;; (current-column))) ; Else indent at comment column -;;; comment-column)) -;;; (if (= c comment-column) nil -;;; (delete-backward-char cnt) -;;; (while (< prevc target) -;;; (insert "\t") -;;; (setq prevc (current-column))) -;;; (if (> prevc target) (progn (delete-char -1) (setq prevc (current-column)))) -;;; (while (< prevc target) -;;; (insert " ") -;;; (setq prevc (current-column))))))) - -(defun cperl-indent-for-comment () - "Substitute for `indent-for-comment' in CPerl." - (interactive) - (let (cperl-wrong-comment) - (indent-for-comment) - (if cperl-wrong-comment ; set by `cperl-comment-indent' - (progn (cperl-to-comment-or-eol) - (forward-char (length comment-start)))))) - -(defun cperl-comment-region (b e arg) - "Comment or uncomment each line in the region in CPerl mode. -See `comment-region'." - (interactive "r\np") - (let ((comment-start "#")) - (comment-region b e arg))) - -(defun cperl-uncomment-region (b e arg) - "Uncomment or comment each line in the region in CPerl mode. -See `comment-region'." - (interactive "r\np") - (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 -place (even in empty line), but not after. If after \")\" and the inserted -char is \"{\", insert extra newline before only if -`cperl-extra-newline-before-brace'." - (interactive "P") - (let (insertpos - (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 - (save-excursion - (setq insertpos (point-marker)) - (goto-char other-end) - (setq last-command-char ?\{) - (cperl-electric-lbrace arg insertpos)) - (forward-char 1)) - ;; Check whether we close something "usual" with `}' - (if (and (eq last-command-char ?\}) - (not - (condition-case nil - (save-excursion - (up-list (- (prefix-numeric-value arg))) - ;;(cperl-after-block-p (point-min)) - (or (cperl-after-expr-p nil "{;)") - ;; after sub, else, continue - (cperl-after-block-p nil 'pre))) - (error nil)))) - ;; Just insert the guy - (self-insert-command (prefix-numeric-value arg)) - (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 - (self-insert-command (prefix-numeric-value arg)) - (cperl-indent-line) - (if cperl-auto-newline - (setq insertpos (1- (point)))) - (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 &optional end) - "Insert character, correct line's indentation, correct quoting by space." - (interactive "P") - (let ((cperl-brace-recursing t) - (cperl-auto-newline cperl-auto-newline) - (other-end (or end - (if (and cperl-electric-parens-mark - (cperl-mark-active) - (> (mark) (point))) - (save-excursion - (goto-char (mark)) - (point-marker)) - nil))) - pos after) - (and (cperl-val 'cperl-electric-lbrace-space) - (eq (preceding-char) ?$) - (save-excursion - (skip-chars-backward "$") - (looking-at "\\(\\$\\$\\)*\\$\\([^\\$]\\|$\\)")) - (insert ?\s)) - ;; Check whether we are in comment - (if (and - (save-excursion - (beginning-of-line) - (not (looking-at "[ \t]*#"))) - (cperl-after-expr-p nil "{;)")) - nil - (setq cperl-auto-newline nil)) - (cperl-electric-brace arg) - (and (cperl-val 'cperl-electric-parens) - (eq last-command-char ?{) - (memq last-command-char - (append cperl-electric-parens-string nil)) - (or (if other-end (goto-char (marker-position other-end))) - t) - (setq last-command-char ?} pos (point)) - (progn (cperl-electric-brace arg t) - (goto-char pos))))) - -(defun cperl-electric-paren (arg) - "Insert an opening parenthesis or a matching pair of parentheses. -See `cperl-electric-parens'." - (interactive "P") - (let ((beg (save-excursion (beginning-of-line) (point))) - (other-end (if (and cperl-electric-parens-mark - (cperl-mark-active) - (> (mark) (point))) - (save-excursion - (goto-char (mark)) - (point-marker)) - nil))) - (if (and (cperl-val 'cperl-electric-parens) - (memq last-command-char - (append cperl-electric-parens-string nil)) - (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)) - ;;(not (save-excursion (search-backward "#" beg t))) - (if (eq last-command-char ?<) - (progn - (and abbrev-mode ; later it is too late, may be after `for' - (expand-abbrev)) - (cperl-after-expr-p nil "{;(,:=")) - 1)) - (progn - (self-insert-command (prefix-numeric-value arg)) - (if other-end (goto-char (marker-position other-end))) - (insert (make-string - (prefix-numeric-value arg) - (cdr (assoc last-command-char '((?{ .?}) - (?[ . ?]) - (?( . ?)) - (?< . ?>)))))) - (forward-char (- (prefix-numeric-value arg)))) - (self-insert-command (prefix-numeric-value arg))))) - -(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. -Affected by `cperl-electric-parens'." - (interactive "P") - (let ((beg (save-excursion (beginning-of-line) (point))) - (other-end (if (and cperl-electric-parens-mark - (cperl-val 'cperl-electric-parens) - (memq last-command-char - (append cperl-electric-parens-string nil)) - (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 - (self-insert-command (prefix-numeric-value arg)) - (setq p (point)) - (if other-end (goto-char other-end)) - (insert (make-string - (prefix-numeric-value arg) - (cdr (assoc last-command-char '((?\} . ?\{) - (?\] . ?\[) - (?\) . ?\() - (?\> . ?\<)))))) - (goto-char (1+ p))) - (self-insert-command (prefix-numeric-value arg))))) - -(defun cperl-electric-keyword () - "Insert a construction appropriate after a keyword. -Help message may be switched off by setting `cperl-message-electric-keyword' -to nil." - (let ((beg (save-excursion (beginning-of-line) (point))) - (dollar (and (eq last-command-char ?$) - (eq this-command 'self-insert-command))) - (delete (and (memq last-command-char '(?\s ?\n ?\t ?\f)) - (memq this-command '(self-insert-command newline)))) - my do) - (and (save-excursion - (condition-case nil - (progn - (backward-sexp 1) - (setq do (looking-at "do\\>"))) - (error nil)) - (cperl-after-expr-p nil "{;:")) - (save-excursion - (not - (re-search-backward - "[#\"'`]\\|\\" - beg t))) - (save-excursion (or (not (re-search-backward "^=" nil t)) - (or - (looking-at "=cut") - (and cperl-use-syntax-table-text-property - (not (eq (get-text-property (point) - 'syntax-type) - 'pod)))))) - (save-excursion (forward-sexp -1) - (not (memq (following-char) (append "$@%&*" nil)))) - (progn - (and (eq (preceding-char) ?y) - (progn ; "foreachmy" - (forward-char -2) - (insert " ") - (forward-char 2) - (setq my t dollar t - delete - (memq this-command '(self-insert-command newline))))) - (and dollar (insert " $")) - (cperl-indent-line) - ;;(insert " () {\n}") - (cond - (cperl-extra-newline-before-brace - (insert (if do "\n" " ()\n")) - (insert "{") - (cperl-indent-line) - (insert "\n") - (cperl-indent-line) - (insert "\n}") - (and do (insert " while ();"))) - (t - (insert (if do " {\n} while ();" " () {\n}")))) - (or (looking-at "[ \t]\\|$") (insert " ")) - (cperl-indent-line) - (if dollar (progn (search-backward "$") - (if my - (forward-char 1) - (delete-char 1))) - (search-backward ")") - (if (eq last-command-char ?\() - (progn ; Avoid "if (())" - (delete-backward-char 1) - (delete-backward-char -1)))) - (if delete - (cperl-putback-char cperl-del-back-ch)) - (if cperl-message-electric-keyword - (message "Precede char by C-q to avoid expansion")))))) - -(defun cperl-ensure-newlines (n &optional pos) - "Make sure there are N newlines after the point." - (or pos (setq pos (point))) - (if (looking-at "\n") - (forward-char 1) - (insert "\n")) - (if (> n 1) - (cperl-ensure-newlines (1- n) pos) - (goto-char pos))) - -(defun cperl-electric-pod () - "Insert a POD chunk appropriate after a =POD directive." - (let ((delete (and (memq last-command-char '(?\s ?\n ?\t ?\f)) - (memq this-command '(self-insert-command newline)))) - head1 notlast name p really-delete over) - (and (save-excursion - (forward-word -1) - (and - (eq (preceding-char) ?=) - (progn - (setq head1 (looking-at "head1\\>[ \t]*$")) - (setq over (and (looking-at "over\\>[ \t]*$") - (not (looking-at "over[ \t]*\n\n\n*=item\\>")))) - (forward-char -1) - (bolp)) - (or - (get-text-property (point) 'in-pod) - (cperl-after-expr-p nil "{;:") - (and (re-search-backward "\\(\\`\n?\\|^\n\\)=\\sw+" (point-min) t) - (not (looking-at "\n*=cut")) - (or (not cperl-use-syntax-table-text-property) - (eq (get-text-property (point) 'syntax-type) 'pod)))))) - (progn - (save-excursion - (setq notlast (re-search-forward "^\n=" nil t))) - (or notlast - (progn - (insert "\n\n=cut") - (cperl-ensure-newlines 2) - (forward-word -2) - (if (and head1 - (not - (save-excursion - (forward-char -1) - (re-search-backward "\\(\\`\n?\\|\n\n\\)=head1\\>" - nil t)))) ; Only one - (progn - (forward-word 1) - (setq name (file-name-sans-extension - (file-name-nondirectory (buffer-file-name))) - p (point)) - (insert " NAME\n\n" name - " - \n\n=head1 SYNOPSIS\n\n\n\n" - "=head1 DESCRIPTION") - (cperl-ensure-newlines 4) - (goto-char p) - (forward-word 2) - (end-of-line) - (setq really-delete t)) - (forward-word 1)))) - (if over - (progn - (setq p (point)) - (insert "\n\n=item \n\n\n\n" - "=back") - (cperl-ensure-newlines 2) - (goto-char p) - (forward-word 1) - (end-of-line) - (setq really-delete t))) - (if (and delete really-delete) - (cperl-putback-char cperl-del-back-ch)))))) - -(defun cperl-electric-else () - "Insert a construction appropriate after a keyword. -Help message may be switched off by setting `cperl-message-electric-keyword' -to nil." - (let ((beg (save-excursion (beginning-of-line) (point)))) - (and (save-excursion - (backward-sexp 1) - (cperl-after-expr-p nil "{;:")) - (save-excursion - (not - (re-search-backward - "[#\"'`]\\|\\" - beg t))) - (save-excursion (or (not (re-search-backward "^=" nil t)) - (looking-at "=cut") - (and cperl-use-syntax-table-text-property - (not (eq (get-text-property (point) - 'syntax-type) - 'pod))))) - (progn - (cperl-indent-line) - ;;(insert " {\n\n}") - (cond - (cperl-extra-newline-before-brace - (insert "\n") - (insert "{") - (cperl-indent-line) - (insert "\n\n}")) - (t - (insert " {\n\n}"))) - (or (looking-at "[ \t]\\|$") (insert " ")) - (cperl-indent-line) - (forward-line -1) - (cperl-indent-line) - (cperl-putback-char cperl-del-back-ch) - (setq this-command 'cperl-electric-else) - (if cperl-message-electric-keyword - (message "Precede char by C-q to avoid expansion")))))) - -(defun cperl-linefeed () - "Go to end of line, open a new line and indent appropriately. -If in POD, insert appropriate lines." - (interactive) - (let ((beg (save-excursion (beginning-of-line) (point))) - (end (save-excursion (end-of-line) (point))) - (pos (point)) start over cut res) - (if (and ; Check if we need to split: - ; i.e., on a boundary and inside "{...}" - (save-excursion (cperl-to-comment-or-eol) - (>= (point) pos)) ; Not in a comment - (or (save-excursion - (skip-chars-backward " \t" beg) - (forward-char -1) - (looking-at "[;{]")) ; After { or ; + spaces - (looking-at "[ \t]*}") ; Before } - (re-search-forward "\\=[ \t]*;" end t)) ; Before spaces + ; - (save-excursion - (and - (eq (car (parse-partial-sexp pos end -1)) -1) - ; Leave the level of parens - (looking-at "[,; \t]*\\($\\|#\\)") ; Comma to allow anon subr - ; Are at end - (cperl-after-block-p (point-min)) - (progn - (backward-sexp 1) - (setq start (point-marker)) - (<= start pos))))) ; Redundant? Are after the - ; start of parens group. - (progn - (skip-chars-backward " \t") - (or (memq (preceding-char) (append ";{" nil)) - (insert ";")) - (insert "\n") - (forward-line -1) - (cperl-indent-line) - (goto-char start) - (or (looking-at "{[ \t]*$") ; If there is a statement - ; before, move it to separate line - (progn - (forward-char 1) - (insert "\n") - (cperl-indent-line))) - (forward-line 1) ; We are on the target line - (cperl-indent-line) - (beginning-of-line) - (or (looking-at "[ \t]*}[,; \t]*$") ; If there is a statement - ; after, move it to separate line - (progn - (end-of-line) - (search-backward "}" beg) - (skip-chars-backward " \t") - (or (memq (preceding-char) (append ";{" nil)) - (insert ";")) - (insert "\n") - (cperl-indent-line) - (forward-line -1))) - (forward-line -1) ; We are on the line before target - (end-of-line) - (newline-and-indent)) - (end-of-line) ; else - no splitting - (cond - ((and (looking-at "\n[ \t]*{$") - (save-excursion - (skip-chars-backward " \t") - (eq (preceding-char) ?\)))) ; Probably if () {} group - ; with an extra newline. - (forward-line 2) - (cperl-indent-line)) - ((save-excursion ; In POD header - (forward-paragraph -1) - ;; (re-search-backward "\\(\\`\n?\\|\n\n\\)=head1\\b") - ;; We are after \n now, so look for the rest - (if (looking-at "\\(\\`\n?\\|\n\\)=\\sw+") - (progn - (setq cut (looking-at "\\(\\`\n?\\|\n\\)=cut\\>")) - (setq over (looking-at "\\(\\`\n?\\|\n\\)=over\\>")) - t))) - (if (and over - (progn - (forward-paragraph -1) - (forward-word 1) - (setq pos (point)) - (setq cut (buffer-substring (point) - (save-excursion - (end-of-line) - (point)))) - (delete-char (- (save-excursion (end-of-line) (point)) - (point))) - (setq res (expand-abbrev)) - (save-excursion - (goto-char pos) - (insert cut)) - res)) - nil - (cperl-ensure-newlines (if cut 2 4)) - (forward-line 2))) - ((get-text-property (point) 'in-pod) ; In POD section - (cperl-ensure-newlines 4) - (forward-line 2)) - ((looking-at "\n[ \t]*$") ; Next line is empty - use it. - (forward-line 1) - (cperl-indent-line)) - (t - (newline-and-indent)))))) - -(defun cperl-electric-semi (arg) - "Insert character and correct line's indentation." - (interactive "P") - (if cperl-auto-newline - (cperl-electric-terminator arg) - (self-insert-command (prefix-numeric-value arg)) - (if cperl-autoindent-on-semi - (cperl-indent-line)))) - -(defun cperl-electric-terminator (arg) - "Insert character and correct line's indentation." - (interactive "P") - (let ((end (point)) - (auto (and cperl-auto-newline - (or (not (eq last-command-char ?:)) - cperl-auto-newline-after-colon))) - insertpos) - (if (and ;;(not arg) - (eolp) - (not (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (or - ;; Ignore in comment lines - (= (following-char) ?#) - ;; Colon is special only after a label - ;; So quickly rule out most other uses of colon - ;; and do no indentation for them. - (and (eq last-command-char ?:) - (save-excursion - (forward-word 1) - (skip-chars-forward " \t") - (and (< (point) end) - (progn (goto-char (- end 1)) - (not (looking-at ":")))))) - (progn - (beginning-of-defun) - (let ((pps (parse-partial-sexp (point) end))) - (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))))) - (progn - (self-insert-command (prefix-numeric-value arg)) - ;;(forward-char -1) - (if auto (setq insertpos (point-marker))) - ;;(forward-char 1) - (cperl-indent-line) - (if auto - (progn - (newline) - (cperl-indent-line))) - (save-excursion - (if insertpos (goto-char (1- (marker-position insertpos))) - (forward-char -1)) - (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-backspace (arg) - "Backspace, or remove the whitespace around the point inserted by an electric -key. Will untabify if `cperl-electric-backspace-untabify' is non-nil." - (interactive "p") - (if (and cperl-auto-newline - (memq last-command '(cperl-electric-semi - cperl-electric-terminator - cperl-electric-lbrace)) - (memq (preceding-char) '(?\s ?\t ?\n))) - (let (p) - (if (eq last-command 'cperl-electric-lbrace) - (skip-chars-forward " \t\n")) - (setq p (point)) - (skip-chars-backward " \t\n") - (delete-region (point) p)) - (and (eq last-command 'cperl-electric-else) - ;; We are removing the whitespace *inside* cperl-electric-else - (setq this-command 'cperl-electric-else-really)) - (if (and cperl-auto-newline - (eq last-command 'cperl-electric-else-really) - (memq (preceding-char) '(?\s ?\t ?\n))) - (let (p) - (skip-chars-forward " \t\n") - (setq p (point)) - (skip-chars-backward " \t\n") - (delete-region (point) p)) - (if cperl-electric-backspace-untabify - (backward-delete-char-untabify arg) - (delete-backward-char arg))))) - -(put 'cperl-electric-backspace 'delete-selection 'supersede) - -(defun cperl-inside-parens-p () ;; NOT USED???? - (condition-case () - (save-excursion - (save-restriction - (narrow-to-region (point) - (progn (beginning-of-defun) (point))) - (goto-char (point-max)) - (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\())) - (error nil))) - -(defun cperl-indent-command (&optional whole-exp) - "Indent current line as Perl code, or in some cases insert a tab character. -If `cperl-tab-always-indent' is non-nil (the default), always indent current -line. Otherwise, indent the current line only if point is at the left margin -or in the line's indentation; otherwise insert a tab. - -A numeric argument, regardless of its value, -means indent rigidly all the lines of the expression starting after point -so that this line becomes properly indented. -The relative indentation among the lines of the expression are preserved." - (interactive "P") - (cperl-update-syntaxification (point) (point)) - (if whole-exp - ;; If arg, always indent this line as Perl - ;; and shift remaining lines of expression the same amount. - (let ((shift-amt (cperl-indent-line)) - beg end) - (save-excursion - (if cperl-tab-always-indent - (beginning-of-line)) - (setq beg (point)) - (forward-sexp 1) - (setq end (point)) - (goto-char beg) - (forward-line 1) - (setq beg (point))) - (if (and shift-amt (> end beg)) - (indent-code-rigidly beg end shift-amt "#"))) - (if (and (not cperl-tab-always-indent) - (save-excursion - (skip-chars-backward " \t") - (not (bolp)))) - (insert-tab) - (cperl-indent-line)))) - -(defun cperl-indent-line (&optional parse-data) - "Indent current line as Perl code. -Return the amount the indentation changed by." - (let ((case-fold-search nil) - (pos (- (point-max) (point))) - indent i beg shift-amt) - (setq indent (cperl-calculate-indent parse-data) - i indent) - (beginning-of-line) - (setq beg (point)) - (cond ((or (eq indent nil) (eq indent t)) - (setq indent (current-indentation) i nil)) - ;;((eq indent t) ; Never? - ;; (setq indent (cperl-calculate-indent-within-comment))) - ;;((looking-at "[ \t]*#") - ;; (setq indent 0)) - (t - (skip-chars-forward " \t") - (if (listp indent) (setq indent (car indent))) - (cond ((and (looking-at "[A-Za-z_][A-Za-z_0-9]*:[^:]") - (not (looking-at "[smy]:\\|tr:"))) - (and (> indent 0) - (setq indent (max cperl-min-label-indent - (+ indent cperl-label-offset))))) - ((= (following-char) ?}) - (setq indent (- indent cperl-indent-level))) - ((memq (following-char) '(?\) ?\])) ; To line up with opening paren. - (setq indent (+ indent cperl-close-paren-offset))) - ((= (following-char) ?{) - (setq indent (+ indent cperl-brace-offset)))))) - (skip-chars-forward " \t") - (setq shift-amt (and i (- indent (current-column)))) - (if (or (not shift-amt) - (zerop shift-amt)) - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - ;;;(delete-region beg (point)) - ;;;(indent-to indent) - (cperl-make-indent indent) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos)))) - shift-amt)) - -(defun cperl-after-label () - ;; Returns true if the point is after label. Does not do save-excursion. - (and (eq (preceding-char) ?:) - (memq (char-syntax (char-after (- (point) 2))) - '(?w ?_)) - (progn - (backward-sexp) - (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:[^:]")))) - -(defun cperl-get-state (&optional parse-start start-state) - ;; returns list (START STATE DEPTH PRESTART), - ;; START is a good place to start parsing, or equal to - ;; PARSE-START if preset, - ;; STATE is what is returned by `parse-partial-sexp'. - ;; DEPTH is true is we are immediately after end of block - ;; which contains START. - ;; PRESTART is the position basing on which START was found. - (save-excursion - (let ((start-point (point)) depth state start prestart) - (if (and parse-start - (<= parse-start start-point)) - (goto-char parse-start) - (beginning-of-defun) - (setq start-state nil)) - (setq prestart (point)) - (if start-state nil - ;; Try to go out, if sub is not on the outermost level - (while (< (point) start-point) - (setq start (point) parse-start start depth nil - state (parse-partial-sexp start start-point -1)) - (if (> (car state) -1) nil - ;; The current line could start like }}}, so the indentation - ;; corresponds to a different level than what we reached - (setq depth t) - (beginning-of-line 2))) ; Go to the next line. - (if start (goto-char start))) ; Not at the start of file - (setq start (point)) - (or state (setq state (parse-partial-sexp start start-point -1 nil start-state))) - (list start state depth prestart)))) - -(defvar cperl-look-for-prop '((pod in-pod) (here-doc-delim here-doc-group))) - -(defun cperl-beginning-of-property (p prop &optional lim) - "Given that P has a property PROP, find where the property starts. -Will not look before LIM." - ;;; XXXX What to do at point-max??? - (or (previous-single-property-change (cperl-1+ p) prop lim) - (point-min)) -;;; (cond ((eq p (point-min)) -;;; p) -;;; ((and lim (<= p lim)) -;;; p) -;;; ((not (get-text-property (1- p) prop)) -;;; p) -;;; (t (or (previous-single-property-change p look-prop lim) -;;; (point-min)))) - ) - -(defun cperl-sniff-for-indent (&optional parse-data) ; was parse-start - ;; Old workhorse for calculation of indentation; the major problem - ;; is that it mixes the sniffer logic to understand what the current line - ;; MEANS with the logic to actually calculate where to indent it. - ;; The latter part should be eventually moved to `cperl-calculate-indent'; - ;; actually, this is mostly done now... - (cperl-update-syntaxification (point) (point)) - (let ((res (get-text-property (point) 'syntax-type))) - (save-excursion - (cond - ((and (memq res '(pod here-doc here-doc-delim format)) - (not (get-text-property (point) 'indentable))) - (vector res)) - ;; before start of POD - whitespace found since do not have 'pod! - ((looking-at "[ \t]*\n=") - (error "Spaces before POD section!")) - ((and (not cperl-indent-left-aligned-comments) - (looking-at "^#")) - [comment-special:at-beginning-of-line]) - ((get-text-property (point) 'in-pod) - [in-pod]) - (t - (beginning-of-line) - (let* ((indent-point (point)) - (char-after-pos (save-excursion - (skip-chars-forward " \t") - (point))) - (char-after (char-after char-after-pos)) - (pre-indent-point (point)) - p prop look-prop is-block delim) - (save-excursion ; Know we are not in POD, find appropriate pos before - (cperl-backward-to-noncomment nil) - (setq p (max (point-min) (1- (point))) - prop (get-text-property p 'syntax-type) - look-prop (or (nth 1 (assoc prop cperl-look-for-prop)) - 'syntax-type)) - (if (memq prop '(pod here-doc format here-doc-delim)) - (progn - (goto-char (cperl-beginning-of-property p look-prop)) - (beginning-of-line) - (setq pre-indent-point (point))))) - (goto-char pre-indent-point) ; Orig line skipping preceeding pod/etc - (let* ((case-fold-search nil) - (s-s (cperl-get-state (car parse-data) (nth 1 parse-data))) - (start (or (nth 2 parse-data) ; last complete sexp terminated - (nth 0 s-s))) ; Good place to start parsing - (state (nth 1 s-s)) - (containing-sexp (car (cdr state))) - old-indent) - (if (and - ;;containing-sexp ;; We are buggy at toplevel :-( - parse-data) - (progn - (setcar parse-data pre-indent-point) - (setcar (cdr parse-data) state) - (or (nth 2 parse-data) - (setcar (cddr parse-data) start)) - ;; Before this point: end of statement - (setq old-indent (nth 3 parse-data)))) - (cond ((get-text-property (point) 'indentable) - ;; indent to "after" the surrounding open - ;; (same offset as `cperl-beautify-regexp-piece'), - ;; skip blanks if we do not close the expression. - (setq delim ; We do not close the expression - (get-text-property - (cperl-1+ char-after-pos) 'indentable) - p (1+ (cperl-beginning-of-property - (point) 'indentable)) - is-block ; misused for: preceeding line in REx - (save-excursion ; Find preceeding line - (cperl-backward-to-noncomment p) - (beginning-of-line) - (if (<= (point) p) - (progn ; get indent from the first line - (goto-char p) - (skip-chars-forward " \t") - (if (memq (char-after (point)) - (append "#\n" nil)) - nil ; Can't use intentation of this line... - (point))) - (skip-chars-forward " \t") - (point))) - prop (parse-partial-sexp p char-after-pos)) - (cond ((not delim) ; End the REx, ignore is-block - (vector 'indentable 'terminator p is-block)) - (is-block ; Indent w.r.t. preceeding line - (vector 'indentable 'cont-line char-after-pos - is-block char-after p)) - (t ; No preceeding line... - (vector 'indentable 'first-line p)))) - ((get-text-property char-after-pos 'REx-part2) - (vector 'REx-part2 (point))) - ((nth 4 state) - [comment]) - ((nth 3 state) - [string]) - ;; XXXX Do we need to special-case this? - ((null containing-sexp) - ;; Line is at top level. May be data or function definition, - ;; or may be function argument declaration. - ;; Indent like the previous top level line - ;; unless that ends in a closeparen without semicolon, - ;; in which case this line is the first argument decl. - (skip-chars-forward " \t") - (cperl-backward-to-noncomment (or old-indent (point-min))) - (setq state - (or (bobp) - (eq (point) old-indent) ; old-indent was at comment - (eq (preceding-char) ?\;) - ;; Had ?\) too - (and (eq (preceding-char) ?\}) - (cperl-after-block-and-statement-beg - (point-min))) ; Was start - too close - (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]*:"))) - (get-text-property (point) 'first-format-line))) - - ;; Look at previous line that's at column 0 - ;; to determine whether we are in top-level decls - ;; or function's arg decls. Set basic-indent accordingly. - ;; Now add a little if this is a continuation line. - (and state - parse-data - (not (eq char-after ?\C-j)) - (setcdr (cddr parse-data) - (list pre-indent-point))) - (vector 'toplevel start char-after state (nth 2 s-s))) - ((not - (or (setq is-block - (and (setq delim (= (char-after containing-sexp) ?{)) - (save-excursion ; Is it a hash? - (goto-char containing-sexp) - (cperl-block-p)))) - cperl-indent-parens-as-block)) - ;; group is an expression, not a block: - ;; indent to just after the surrounding open parens, - ;; skip blanks if we do not close the expression. - (goto-char (1+ containing-sexp)) - (or (memq char-after - (append (if delim "}" ")]}") nil)) - (looking-at "[ \t]*\\(#\\|$\\)") - (skip-chars-forward " \t")) - (setq old-indent (point)) ; delim=is-brace - (vector 'in-parens char-after (point) delim containing-sexp)) - (t - ;; Statement level. Is it a continuation or a new statement? - ;; Find previous non-comment character. - (goto-char pre-indent-point) ; Skip one level of POD/etc - (cperl-backward-to-noncomment containing-sexp) - ;; Back up over label lines, since they don't - ;; affect whether our line is a continuation. - ;; (Had \, too) - (while;;(or (eq (preceding-char) ?\,) - (and (eq (preceding-char) ?:) - (or;;(eq (char-after (- (point) 2)) ?\') ; ???? - (memq (char-syntax (char-after (- (point) 2))) - '(?w ?_)))) - ;;) - ;; This is always FALSE? - (if (eq (preceding-char) ?\,) - ;; Will go to beginning of line, essentially. - ;; Will ignore embedded sexpr XXXX. - (cperl-backward-to-start-of-continued-exp containing-sexp)) - (beginning-of-line) - (cperl-backward-to-noncomment containing-sexp)) - ;; Now we get non-label preceeding the indent point - (if (not (or (eq (1- (point)) containing-sexp) - (memq (preceding-char) - (append (if is-block " ;{" " ,;{") '(nil))) - (and (eq (preceding-char) ?\}) - (cperl-after-block-and-statement-beg - containing-sexp)) - (get-text-property (point) 'first-format-line))) - ;; This line is continuation of preceding line's statement; - ;; indent `cperl-continued-statement-offset' more than the - ;; previous line of the statement. - ;; - ;; There might be a label on this line, just - ;; consider it bad style and ignore it. - (progn - (cperl-backward-to-start-of-continued-exp containing-sexp) - (vector 'continuation (point) char-after is-block delim)) - ;; This line starts a new statement. - ;; Position following last unclosed open brace - (goto-char containing-sexp) - ;; Is line first statement after an open-brace? - (or - ;; If no, find that first statement and indent like - ;; it. If the first statement begins with label, do - ;; not believe when the indentation of the label is too - ;; small. - (save-excursion - (forward-char 1) - (let ((colon-line-end 0)) - (while - (progn (skip-chars-forward " \t\n") - ;; s: foo : bar :x is NOT label - (and (looking-at "#\\|\\([a-zA-Z0-9_$]+\\):[^:]\\|=[a-zA-Z]") - (not (looking-at "[sym]:\\|tr:")))) - ;; Skip over comments and labels following openbrace. - (cond ((= (following-char) ?\#) - (forward-line 1)) - ((= (following-char) ?\=) - (goto-char - (or (next-single-property-change (point) 'in-pod) - (point-max)))) ; do not loop if no syntaxification - ;; label: - (t - (save-excursion (end-of-line) - (setq colon-line-end (point))) - (search-forward ":")))) - ;; We are at beginning of code (NOT label or comment) - ;; First, the following code counts - ;; if it is before the line we want to indent. - (and (< (point) indent-point) - (vector 'have-prev-sibling (point) colon-line-end - containing-sexp)))) - (progn - ;; If no previous statement, - ;; indent it relative to line brace is on. - - ;; For open-braces not the first thing in a line, - ;; add in cperl-brace-imaginary-offset. - - ;; If first thing on a line: ????? - ;; Move back over whitespace before the openbrace. - (setq ; brace first thing on a line - old-indent (progn (skip-chars-backward " \t") (bolp))) - ;; Should we indent w.r.t. earlier than start? - ;; Move to start of control group, possibly on a different line - (or cperl-indent-wrt-brace - (cperl-backward-to-noncomment (point-min))) - ;; If the openbrace is preceded by a parenthesized exp, - ;; move to the beginning of that; - (if (eq (preceding-char) ?\)) - (progn - (forward-sexp -1) - (cperl-backward-to-noncomment (point-min)))) - ;; In the case it starts a subroutine, indent with - ;; respect to `sub', not with respect to the - ;; first thing on the line, say in the case of - ;; anonymous sub in a hash. - (if (and;; Is it a sub in group starting on this line? - (cond ((get-text-property (point) 'attrib-group) - (goto-char (cperl-beginning-of-property - (point) 'attrib-group))) - ((eq (preceding-char) ?b) - (forward-sexp -1) - (looking-at "sub\\>"))) - (setq p (nth 1 ; start of innermost containing list - (parse-partial-sexp - (save-excursion (beginning-of-line) - (point)) - (point))))) - (progn - (goto-char (1+ p)) ; enclosing block on the same line - (skip-chars-forward " \t") - (vector 'code-start-in-block containing-sexp char-after - (and delim (not is-block)) ; is a HASH - old-indent ; brace first thing on a line - t (point) ; have something before... - ) - ;;(current-column) - ) - ;; Get initial indentation of the line we are on. - ;; If line starts with label, calculate label indentation - (vector 'code-start-in-block containing-sexp char-after - (and delim (not is-block)) ; is a HASH - old-indent ; brace first thing on a line - nil (point))))))))))))))) ; nothing interesting before - -(defvar cperl-indent-rules-alist - '((pod nil) ; via `syntax-type' property - (here-doc nil) ; via `syntax-type' property - (here-doc-delim nil) ; via `syntax-type' property - (format nil) ; via `syntax-type' property - (in-pod nil) ; via `in-pod' property - (comment-special:at-beginning-of-line nil) - (string t) - (comment nil)) - "Alist of indentation rules for CPerl mode. -The values mean: - nil: do not indent; - number: add this amount of indentation.") - -(defun cperl-calculate-indent (&optional parse-data) ; was parse-start - "Return appropriate indentation for current line as Perl code. -In usual case returns an integer: the column to indent to. -Returns nil if line starts inside a string, t if in a comment. - -Will not correct the indentation for labels, but will correct it for braces -and closing parentheses and brackets." - ;; This code is still a broken architecture: in some cases we need to - ;; compensate for some modifications which `cperl-indent-line' will add later - (save-excursion - (let ((i (cperl-sniff-for-indent parse-data)) what p) - (cond - ;;((or (null i) (eq i t) (numberp i)) - ;; i) - ((vectorp i) - (setq what (assoc (elt i 0) cperl-indent-rules-alist)) - (cond - (what (cadr what)) ; Load from table - ;; - ;; Indenters for regular expressions with //x and qw() - ;; - ((eq 'REx-part2 (elt i 0)) ;; [self start] start of /REP in s//REP/x - (goto-char (elt i 1)) - (condition-case nil ; Use indentation of the 1st part - (forward-sexp -1)) - (current-column)) - ((eq 'indentable (elt i 0)) ; Indenter for REGEXP qw() etc - (cond ;;; [indentable terminator start-pos is-block] - ((eq 'terminator (elt i 1)) ; Lone terminator of "indentable string" - (goto-char (elt i 2)) ; After opening parens - (1- (current-column))) - ((eq 'first-line (elt i 1)); [indentable first-line start-pos] - (goto-char (elt i 2)) - (+ (or cperl-regexp-indent-step cperl-indent-level) - -1 - (current-column))) - ((eq 'cont-line (elt i 1)); [indentable cont-line pos prev-pos first-char start-pos] - ;; Indent as the level after closing parens - (goto-char (elt i 2)) ; indent line - (skip-chars-forward " \t)") ; Skip closing parens - (setq p (point)) - (goto-char (elt i 3)) ; previous line - (skip-chars-forward " \t)") ; Skip closing parens - ;; Number of parens in between: - (setq p (nth 0 (parse-partial-sexp (point) p)) - what (elt i 4)) ; First char on current line - (goto-char (elt i 3)) ; previous line - (+ (* p (or cperl-regexp-indent-step cperl-indent-level)) - (cond ((eq what ?\) ) - (- cperl-close-paren-offset)) ; compensate - ((eq what ?\| ) - (- (or cperl-regexp-indent-step cperl-indent-level))) - (t 0)) - (if (eq (following-char) ?\| ) - (or cperl-regexp-indent-step cperl-indent-level) - 0) - (current-column))) - (t - (error "Unrecognized value of indent: %s" i)))) - ;; - ;; Indenter for stuff at toplevel - ;; - ((eq 'toplevel (elt i 0)) ;; [toplevel start char-after state immed-after-block] - (+ (save-excursion ; To beg-of-defun, or end of last sexp - (goto-char (elt i 1)) ; start = Good place to start parsing - (- (current-indentation) ; - (if (elt i 4) cperl-indent-level 0))) ; immed-after-block - (if (eq (elt i 2) ?{) cperl-continued-brace-offset 0) ; char-after - ;; Look at previous line that's at column 0 - ;; to determine whether we are in top-level decls - ;; or function's arg decls. Set basic-indent accordingly. - ;; Now add a little if this is a continuation line. - (if (elt i 3) ; state (XXX What is the semantic???) - 0 - cperl-continued-statement-offset))) - ;; - ;; Indenter for stuff in "parentheses" (or brackets, braces-as-hash) - ;; - ((eq 'in-parens (elt i 0)) - ;; in-parens char-after old-indent-point is-brace containing-sexp - - ;; group is an expression, not a block: - ;; indent to just after the surrounding open parens, - ;; skip blanks if we do not close the expression. - (+ (progn - (goto-char (elt i 2)) ; old-indent-point - (current-column)) - (if (and (elt i 3) ; is-brace - (eq (elt i 1) ?\})) ; char-after - ;; Correct indentation of trailing ?\} - (+ cperl-indent-level cperl-close-paren-offset) - 0))) - ;; - ;; Indenter for continuation lines - ;; - ((eq 'continuation (elt i 0)) - ;; [continuation statement-start char-after is-block is-brace] - (goto-char (elt i 1)) ; statement-start - (+ (if (memq (elt i 2) (append "}])" nil)) ; char-after - 0 ; Closing parenth - cperl-continued-statement-offset) - (if (or (elt i 3) ; is-block - (not (elt i 4)) ; is-brace - (not (eq (elt i 2) ?\}))) ; char-after - 0 - ;; Now it is a hash reference - (+ cperl-indent-level cperl-close-paren-offset)) - ;; Labels do not take :: ... - (if (looking-at "\\(\\w\\|_\\)+[ \t]*:") - (if (> (current-indentation) cperl-min-label-indent) - (- (current-indentation) cperl-label-offset) - ;; Do not move `parse-data', this should - ;; be quick anyway (this comment comes - ;; from different location): - (cperl-calculate-indent)) - (current-column)) - (if (eq (elt i 2) ?\{) ; char-after - cperl-continued-brace-offset 0))) - ;; - ;; Indenter for lines in a block which are not leading lines - ;; - ((eq 'have-prev-sibling (elt i 0)) - ;; [have-prev-sibling sibling-beg colon-line-end block-start] - (goto-char (elt i 1)) ; sibling-beg - (if (> (elt i 2) (point)) ; colon-line-end; have label before point - (if (> (current-indentation) - cperl-min-label-indent) - (- (current-indentation) cperl-label-offset) - ;; Do not believe: `max' was involved in calculation of indent - (+ cperl-indent-level - (save-excursion - (goto-char (elt i 3)) ; block-start - (current-indentation)))) - (current-column))) - ;; - ;; Indenter for the first line in a block - ;; - ((eq 'code-start-in-block (elt i 0)) - ;;[code-start-in-block before-brace char-after - ;; is-a-HASH-ref brace-is-first-thing-on-a-line - ;; group-starts-before-start-of-sub start-of-control-group] - (goto-char (elt i 1)) - ;; For open brace in column zero, don't let statement - ;; start there too. If cperl-indent-level=0, - ;; use cperl-brace-offset + cperl-continued-statement-offset instead. - (+ (if (and (bolp) (zerop cperl-indent-level)) - (+ cperl-brace-offset cperl-continued-statement-offset) - cperl-indent-level) - (if (and (elt i 3) ; is-a-HASH-ref - (eq (elt i 2) ?\})) ; char-after: End of a hash reference - (+ cperl-indent-level cperl-close-paren-offset) - 0) - ;; Unless openbrace is the first nonwhite thing on the line, - ;; add the cperl-brace-imaginary-offset. - (if (elt i 4) 0 ; brace-is-first-thing-on-a-line - cperl-brace-imaginary-offset) - (progn - (goto-char (elt i 6)) ; start-of-control-group - (if (elt i 5) ; group-starts-before-start-of-sub - (current-column) - ;; Get initial indentation of the line we are on. - ;; If line starts with label, calculate label indentation - (if (save-excursion - (beginning-of-line) - (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]")) - (if (> (current-indentation) cperl-min-label-indent) - (- (current-indentation) cperl-label-offset) - ;; Do not move `parse-data', this should - ;; be quick anyway: - (cperl-calculate-indent)) - (current-indentation)))))) - (t - (error "Unrecognized value of indent: %s" i)))) - (t - (error "Got strange value of indent: %s" i)))))) - -(defun cperl-calculate-indent-within-comment () - "Return the indentation amount for line, assuming that -the current line is to be regarded as part of a block comment." - (let (end star-start) - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (setq end (point)) - (and (= (following-char) ?#) - (forward-line -1) - (cperl-to-comment-or-eol) - (setq end (point))) - (goto-char end) - (current-column)))) - - -(defun cperl-to-comment-or-eol () - "Go to position before comment on the current line, or to end of line. -Returns true if comment is found. In POD will not move the point." - ;; If the line is inside other syntax groups (qq-style strings, HERE-docs) - ;; then looks for literal # or end-of-line. - (let (state stop-in cpoint (lim (progn (end-of-line) (point))) pr e) - (or cperl-font-locking - (cperl-update-syntaxification lim lim)) - (beginning-of-line) - (if (setq pr (get-text-property (point) 'syntax-type)) - (setq e (next-single-property-change (point) 'syntax-type nil (point-max)))) - (if (or (eq pr 'pod) - (if (or (not e) (> e lim)) ; deep inside a group - (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t))) - (if (eq (preceding-char) ?\#) (progn (backward-char 1) t)) - ;; Else - need to do it the hard way - (and (and e (<= e lim)) - (goto-char e)) - (while (not stop-in) - (setq state (parse-partial-sexp (point) lim nil nil nil t)) - ; stop at comment - ;; If fails (beginning-of-line inside sexp), then contains not-comment - (if (nth 4 state) ; After `#'; - ; (nth 2 state) can be - ; beginning of m,s,qq and so - ; on - (if (nth 2 state) - (progn - (setq cpoint (point)) - (goto-char (nth 2 state)) - (cond - ((looking-at "\\(s\\|tr\\)\\>") - (or (re-search-forward - "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*" - lim 'move) - (setq stop-in t))) - ((looking-at "\\(m\\|q\\([qxwr]\\)?\\)\\>") - (or (re-search-forward - "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#" - lim 'move) - (setq stop-in t))) - (t ; It was fair comment - (setq stop-in t) ; Finish - (goto-char (1- cpoint))))) - (setq stop-in t) ; Finish - (forward-char -1)) - (setq stop-in t))) ; Finish - (nth 4 state)))) - -(defsubst cperl-modify-syntax-type (at how) - (if (< at (point-max)) - (progn - (put-text-property at (1+ at) 'syntax-table how) - (put-text-property at (1+ at) 'rear-nonsticky '(syntax-table))))) - -(defun cperl-protect-defun-start (s e) - ;; C code looks for "^\\s(" to skip comment backward in "hard" situations - (save-excursion - (goto-char s) - (while (re-search-forward "^\\s(" e 'to-end) - (put-text-property (1- (point)) (point) 'syntax-table cperl-st-punct)))) - -(defun cperl-commentify (bb e string &optional noface) - (if cperl-use-syntax-table-text-property - (if (eq noface 'n) ; Only immediate - nil - ;; We suppose that e is _after_ the end of construction, as after eol. - (setq string (if string cperl-st-sfence cperl-st-cfence)) - (if (> bb (- e 2)) - ;; one-char string/comment?! - (cperl-modify-syntax-type bb cperl-st-punct) - (cperl-modify-syntax-type bb string) - (cperl-modify-syntax-type (1- e) string)) - (if (and (eq string cperl-st-sfence) (> (- e 2) bb)) - (put-text-property (1+ bb) (1- e) - 'syntax-table cperl-string-syntax-table)) - (cperl-protect-defun-start bb e)) - ;; Fontify - (or noface - (not cperl-pod-here-fontify) - (put-text-property bb e 'face (if string 'font-lock-string-face - 'font-lock-comment-face))))) - -(defvar cperl-starters '(( ?\( . ?\) ) - ( ?\[ . ?\] ) - ( ?\{ . ?\} ) - ( ?\< . ?\> ))) - -(defun cperl-cached-syntax-table (st) - "Get a syntax table cached in ST, or create and cache into ST a syntax table. -All the entries of the syntax table are \".\", except for a backslash, which -is quoting." - (if (car-safe st) - (car st) - (setcar st (make-syntax-table)) - (setq st (car st)) - (let ((i 0)) - (while (< i 256) - (modify-syntax-entry i "." st) - (setq i (1+ i)))) - (modify-syntax-entry ?\\ "\\" st) - st)) - -(defun cperl-forward-re (lim end is-2arg st-l err-l argument - &optional ostart oend) -"Find the end of a regular expression or a stringish construct (q[] etc). -The point should be before the starting delimiter. - -Goes to LIM if none is found. If IS-2ARG is non-nil, assumes that it -is s/// or tr/// like expression. If END is nil, generates an error -message if needed. If SET-ST is non-nil, will use (or generate) a -cached syntax table in ST-L. If ERR-L is non-nil, will store the -error message in its CAR (unless it already contains some error -message). ARGUMENT should be the name of the construct (used in error -messages). OSTART, OEND may be set in recursive calls when processing -the second argument of 2ARG construct. - -Works *before* syntax recognition is done. In IS-2ARG situation may -modify syntax-type text property if the situation is too hard." - (let (b starter ender st i i2 go-forward reset-st set-st) - (skip-chars-forward " \t") - ;; ender means matching-char matcher. - (setq b (point) - starter (if (eobp) 0 (char-after b)) - ender (cdr (assoc starter cperl-starters))) - ;; What if starter == ?\\ ???? - (setq st (cperl-cached-syntax-table st-l)) - (setq set-st t) - ;; Whether we have an intermediate point - (setq i nil) - ;; Prepare the syntax table: - (if (not ender) ; m/blah/, s/x//, s/x/y/ - (modify-syntax-entry starter "$" st) - (modify-syntax-entry starter (concat "(" (list ender)) st) - (modify-syntax-entry ender (concat ")" (list starter)) st)) - (condition-case bb - (progn - ;; We use `$' syntax class to find matching stuff, but $$ - ;; is recognized the same as $, so we need to check this manually. - (if (and (eq starter (char-after (cperl-1+ b))) - (not ender)) - ;; $ has TeXish matching rules, so $$ equiv $... - (forward-char 2) - (setq reset-st (syntax-table)) - (set-syntax-table st) - (forward-sexp 1) - (if (<= (point) (1+ b)) - (error "Unfinished regular expression")) - (set-syntax-table reset-st) - (setq reset-st nil) - ;; Now the problem is with m;blah;; - (and (not ender) - (eq (preceding-char) - (char-after (- (point) 2))) - (save-excursion - (forward-char -2) - (= 0 (% (skip-chars-backward "\\\\") 2))) - (forward-char -1))) - ;; Now we are after the first part. - (and is-2arg ; Have trailing part - (not ender) - (eq (following-char) starter) ; Empty trailing part - (progn - (or (eq (char-syntax (following-char)) ?.) - ;; Make trailing letter into punctuation - (cperl-modify-syntax-type (point) cperl-st-punct)) - (setq is-2arg nil go-forward t))) ; Ignore the tail - (if is-2arg ; Not number => have second part - (progn - (setq i (point) i2 i) - (if ender - (if (memq (following-char) '(?\s ?\t ?\n ?\f)) - (progn - (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+") - (goto-char (match-end 0)) - (skip-chars-forward " \t\n\f")) - (setq i2 (point)))) - (forward-char -1)) - (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st) - (if ender (modify-syntax-entry ender "." st)) - (setq set-st nil) - (setq ender (cperl-forward-re lim end nil st-l err-l - argument starter ender) - ender (nth 2 ender))))) - (error (goto-char lim) - (setq set-st nil) - (if reset-st - (set-syntax-table reset-st)) - (or end - (message - "End of `%s%s%c ... %c' string/RE not found: %s" - argument - (if ostart (format "%c ... %c" ostart (or oend ostart)) "") - starter (or ender starter) bb) - (or (car err-l) (setcar err-l b))))) - (if set-st - (progn - (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st) - (if ender (modify-syntax-entry ender "." st)))) - ;; i: have 2 args, after end of the first arg - ;; i2: start of the second arg, if any (before delim if `ender'). - ;; ender: the last arg bounded by parens-like chars, the second one of them - ;; starter: the starting delimiter of the first arg - ;; go-forward: has 2 args, and the second part is empty - (list i i2 ender starter go-forward))) - -(defun cperl-forward-group-in-re (&optional st-l) - "Find the end of a group in a REx. -Return the error message (if any). Does not work if delimiter is `)'. -Works before syntax recognition is done." - ;; Works *before* syntax recognition is done - (or st-l (setq st-l (list nil))) ; Avoid overwriting '() - (let (st b reset-st) - (condition-case b - (progn - (setq st (cperl-cached-syntax-table st-l)) - (modify-syntax-entry ?\( "()" st) - (modify-syntax-entry ?\) ")(" st) - (setq reset-st (syntax-table)) - (set-syntax-table st) - (forward-sexp 1)) - (error (message - "cperl-forward-group-in-re: error %s" b))) - ;; now restore the initial state - (if st - (progn - (modify-syntax-entry ?\( "." st) - (modify-syntax-entry ?\) "." st))) - (if reset-st - (set-syntax-table reset-st)) - b)) - - -(defvar font-lock-string-face) -;;(defvar font-lock-reference-face) -(defvar font-lock-constant-face) -(defsubst cperl-postpone-fontification (b e type val &optional now) - ;; Do after syntactic fontification? - (if cperl-syntaxify-by-font-lock - (or now (put-text-property b e 'cperl-postpone (cons type val))) - (put-text-property b e type val))) - -;;; Here is how the global structures (those which cannot be -;;; recognized locally) are marked: -;; a) PODs: -;; Start-to-end is marked `in-pod' ==> t -;; Each non-literal part is marked `syntax-type' ==> `pod' -;; Each literal part is marked `syntax-type' ==> `in-pod' -;; b) HEREs: -;; Start-to-end is marked `here-doc-group' ==> t -;; The body is marked `syntax-type' ==> `here-doc' -;; The delimiter is marked `syntax-type' ==> `here-doc-delim' -;; c) FORMATs: -;; First line (to =) marked `first-format-line' ==> t -;; After-this--to-end is marked `syntax-type' ==> `format' -;; d) 'Q'uoted string: -;; part between markers inclusive is marked `syntax-type' ==> `string' -;; part between `q' and the first marker is marked `syntax-type' ==> `prestring' -;; second part of s///e is marked `syntax-type' ==> `multiline' -;; e) Attributes of subroutines: `attrib-group' ==> t -;; (or 0 if declaration); up to `{' or ';': `syntax-type' => `sub-decl'. -;; f) Multiline my/our declaration lists etc: `syntax-type' => `multiline' - -;;; In addition, some parts of RExes may be marked as `REx-interpolated' -;;; (value: 0 in //o, 1 if "interpolated variable" is whole-REx, t otherwise). - -(defun cperl-unwind-to-safe (before &optional end) - ;; if BEFORE, go to the previous start-of-line on each step of unwinding - (let ((pos (point)) opos) - (while (and pos (progn - (beginning-of-line) - (get-text-property (setq pos (point)) 'syntax-type))) - (setq opos pos - pos (cperl-beginning-of-property pos 'syntax-type)) - (if (eq pos (point-min)) - (setq pos nil)) - (if pos - (if before - (progn - (goto-char (cperl-1- pos)) - (beginning-of-line) - (setq pos (point))) - (goto-char (setq pos (cperl-1- pos)))) - ;; Up to the start - (goto-char (point-min)))) - ;; Skip empty lines - (and (looking-at "\n*=") - (/= 0 (skip-chars-backward "\n")) - (forward-char)) - (setq pos (point)) - (if end - ;; Do the same for end, going small steps - (save-excursion - (while (and end (get-text-property end 'syntax-type)) - (setq pos end - end (next-single-property-change end 'syntax-type nil (point-max))) - (if end (progn (goto-char end) - (or (bolp) (forward-line 1)) - (setq end (point))))) - (or end pos))))) - -;;; These are needed for byte-compile (at least with v19) -(defvar cperl-nonoverridable-face) -(defvar font-lock-variable-name-face) -(defvar font-lock-function-name-face) -(defvar font-lock-keyword-face) -(defvar font-lock-builtin-face) -(defvar font-lock-type-face) -(defvar font-lock-comment-face) -(defvar font-lock-warning-face) - -(defun cperl-find-sub-attrs (&optional st-l b-fname e-fname pos) - "Syntaxically mark (and fontify) attributes of a subroutine. -Should be called with the point before leading colon of an attribute." - ;; Works *before* syntax recognition is done - (or st-l (setq st-l (list nil))) ; Avoid overwriting '() - (let (st b p reset-st after-first (start (point)) start1 end1) - (condition-case b - (while (looking-at - (concat - "\\(" ; 1=optional? colon - ":" cperl-maybe-white-and-comment-rex ; 2=whitespace/comment? - "\\)" - (if after-first "?" "") - ;; No space between name and paren allowed... - "\\(\\sw+\\)" ; 3=name - "\\((\\)?")) ; 4=optional paren - (and (match-beginning 1) - (cperl-postpone-fontification - (match-beginning 0) (cperl-1+ (match-beginning 0)) - 'face font-lock-constant-face)) - (setq start1 (match-beginning 3) end1 (match-end 3)) - (cperl-postpone-fontification start1 end1 - 'face font-lock-constant-face) - (goto-char end1) ; end or before `(' - (if (match-end 4) ; Have attribute arguments... - (progn - (if st nil - (setq st (cperl-cached-syntax-table st-l)) - (modify-syntax-entry ?\( "()" st) - (modify-syntax-entry ?\) ")(" st)) - (setq reset-st (syntax-table) p (point)) - (set-syntax-table st) - (forward-sexp 1) - (set-syntax-table reset-st) - (setq reset-st nil) - (cperl-commentify p (point) t))) ; mark as string - (forward-comment (buffer-size)) - (setq after-first t)) - (error (message - "L%d: attribute `%s': %s" - (count-lines (point-min) (point)) - (and start1 end1 (buffer-substring start1 end1)) b) - (setq start nil))) - (and start - (progn - (put-text-property start (point) - 'attrib-group (if (looking-at "{") t 0)) - (and pos - (< 1 (count-lines (+ 3 pos) (point))) ; end of `sub' - ;; Apparently, we do not need `multiline': faces added now - (put-text-property (+ 3 pos) (cperl-1+ (point)) - 'syntax-type 'sub-decl)) - (and b-fname ; Fontify here: the following condition - (cperl-postpone-fontification ; is too hard to determine by - b-fname e-fname 'face ; a REx, so do it here - (if (looking-at "{") - font-lock-function-name-face - font-lock-variable-name-face))))) - ;; now restore the initial state - (if st - (progn - (modify-syntax-entry ?\( "." st) - (modify-syntax-entry ?\) "." st))) - (if reset-st - (set-syntax-table reset-st)))) - -(defsubst cperl-look-at-leading-count (is-x-REx e) - (if (and - (< (point) e) - (re-search-forward (concat "\\=" (if is-x-REx "[ \t\n]*" "") "[{?+*]") - (1- e) t)) ; return nil on failure, no moving - (if (eq ?\{ (preceding-char)) nil - (cperl-postpone-fontification - (1- (point)) (point) - 'face font-lock-warning-face)))) - -;;; Debugging this may require (setq max-specpdl-size 2000)... -(defun cperl-find-pods-heres (&optional min max non-inter end ignore-max end-of-here-doc) - "Scans the buffer for hard-to-parse Perl constructions. -If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify -the sections using `cperl-pod-head-face', `cperl-pod-face', -`cperl-here-face'." - (interactive) - (or min (setq min (point-min) - cperl-syntax-state nil - cperl-syntax-done-to min)) - (or max (setq max (point-max))) - (let* ((cperl-pod-here-fontify (eval cperl-pod-here-fontify)) go tmpend - face head-face here-face b e bb tag qtag b1 e1 argument i c tail tb - is-REx is-x-REx REx-subgr-start REx-subgr-end was-subgr i2 hairy-RE - (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t) - (modified (buffer-modified-p)) overshoot is-o-REx - (after-change-functions nil) - (cperl-font-locking t) - (use-syntax-state (and cperl-syntax-state - (>= min (car cperl-syntax-state)))) - (state-point (if use-syntax-state - (car cperl-syntax-state) - (point-min))) - (state (if use-syntax-state - (cdr cperl-syntax-state))) - ;; (st-l '(nil)) (err-l '(nil)) ; Would overwrite - propagates from a function call to a function call! - (st-l (list nil)) (err-l (list nil)) - ;; Somehow font-lock may be not loaded yet... - ;; (e.g., when building TAGS via command-line call) - (font-lock-string-face (if (boundp 'font-lock-string-face) - font-lock-string-face - 'font-lock-string-face)) - (my-cperl-delimiters-face (if (boundp 'font-lock-constant-face) - font-lock-constant-face - 'font-lock-constant-face)) - (my-cperl-REx-spec-char-face ; [] ^.$ and wrapper-of ({}) - (if (boundp 'font-lock-function-name-face) - font-lock-function-name-face - 'font-lock-function-name-face)) - (font-lock-variable-name-face ; interpolated vars and ({})-code - (if (boundp 'font-lock-variable-name-face) - font-lock-variable-name-face - 'font-lock-variable-name-face)) - (font-lock-function-name-face ; used in `cperl-find-sub-attrs' - (if (boundp 'font-lock-function-name-face) - font-lock-function-name-face - 'font-lock-function-name-face)) - (font-lock-constant-face ; used in `cperl-find-sub-attrs' - (if (boundp 'font-lock-constant-face) - font-lock-constant-face - 'font-lock-constant-face)) - (my-cperl-REx-0length-face ; 0-length, (?:)etc, non-literal \ - (if (boundp 'font-lock-builtin-face) - font-lock-builtin-face - 'font-lock-builtin-face)) - (font-lock-comment-face - (if (boundp 'font-lock-comment-face) - font-lock-comment-face - 'font-lock-comment-face)) - (font-lock-warning-face - (if (boundp 'font-lock-warning-face) - font-lock-warning-face - 'font-lock-warning-face)) - (my-cperl-REx-ctl-face ; (|) - (if (boundp 'font-lock-keyword-face) - font-lock-keyword-face - 'font-lock-keyword-face)) - (my-cperl-REx-modifiers-face ; //gims - (if (boundp 'cperl-nonoverridable-face) - cperl-nonoverridable-face - 'cperl-nonoverridable-face)) - (my-cperl-REx-length1-face ; length=1 escaped chars, POSIX classes - (if (boundp 'font-lock-type-face) - font-lock-type-face - 'font-lock-type-face)) - (stop-point (if ignore-max - (point-max) - max)) - (search - (concat - "\\(\\`\n?\\|^\n\\)=" ; POD - "\\|" - ;; One extra () before this: - "<<" ; HERE-DOC - "\\(" ; 1 + 1 - ;; First variant "BLAH" or just ``. - "[ \t]*" ; Yes, whitespace is allowed! - "\\([\"'`]\\)" ; 2 + 1 = 3 - "\\([^\"'`\n]*\\)" ; 3 + 1 - "\\3" - "\\|" - ;; Second variant: Identifier or \ID (same as 'ID') or empty - "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1 - ;; Do not have <<= or << 30 or <<30 or << $blah. - ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1 - "\\(\\)" ; To preserve count of pars :-( 6 + 1 - "\\)" - "\\|" - ;; 1+6 extra () before this: - "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" ;FRMAT - (if cperl-use-syntax-table-text-property - (concat - "\\|" - ;; 1+6+2=9 extra () before this: - "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" ; QUOTED CONSTRUCT - "\\|" - ;; 1+6+2+1=10 extra () before this: - "\\([?/<]\\)" ; /blah/ or ?blah? or - "\\|" - ;; 1+6+2+1+1=11 extra () before this - "\\<\\(?:sub\\|method\\)\\>" ; sub with proto/attr - "\\(" - cperl-white-and-comment-rex - "\\(::[a-zA-Z_:'0-9]*\\|[a-zA-Z_'][a-zA-Z_:'0-9]*\\)\\)?" ; name - "\\(" - cperl-maybe-white-and-comment-rex - "\\(([^()]*)\\|:[^:]\\)\\)" ; prototype or attribute start - "\\|" - ;; 1+6+2+1+1+6=17 extra () before this: - "\\$\\(['{]\\)" ; $' or ${foo} - "\\|" - ;; 1+6+2+1+1+6+1=18 extra () before this (old pack'var syntax; - ;; we do not support intervening comments...): - "\\(\\<\\(?:sub\\|method\\)[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'" - ;; 1+6+2+1+1+6+1+1=19 extra () before this: - "\\|" - "__\\(END\\|DATA\\)__" ; __END__ or __DATA__ - ;; 1+6+2+1+1+6+1+1+1=20 extra () before this: - "\\|" - "\\\\\\(['`\"($]\\)") ; BACKWACKED something-hairy - "")))) - (unwind-protect - (progn - (save-excursion - (or non-inter - (message "Scanning for \"hard\" Perl constructions...")) - ;;(message "find: %s --> %s" min max) - (and cperl-pod-here-fontify - ;; We had evals here, do not know why... - (setq face cperl-pod-face - head-face cperl-pod-head-face - here-face cperl-here-face)) - (remove-text-properties min max - '(syntax-type t in-pod t syntax-table t - attrib-group t - REx-interpolated t - cperl-postpone t - syntax-subtype t - rear-nonsticky t - front-sticky t - here-doc-group t - first-format-line t - REx-part2 t - indentable t)) - ;; Need to remove face as well... - (goto-char min) - (and (eq system-type 'emx) - (eq (point) 1) - (let ((case-fold-search t)) - (looking-at "extproc[ \t]")) ; Analogue of #! - (cperl-commentify min - (save-excursion (end-of-line) (point)) - nil)) - (while (and - (< (point) max) - (re-search-forward search max t)) - (setq tmpend nil) ; Valid for most cases - (setq b (match-beginning 0) - state (save-excursion (parse-partial-sexp - state-point b nil nil state)) - state-point b) - (cond - ;; 1+6+2+1+1+6=17 extra () before this: - ;; "\\$\\(['{]\\)" - ((match-beginning 18) ; $' or ${foo} - (if (eq (preceding-char) ?\') ; $' - (progn - (setq b (1- (point)) - state (parse-partial-sexp - state-point (1- b) nil nil state) - state-point (1- b)) - (if (nth 3 state) ; in string - (cperl-modify-syntax-type (1- b) cperl-st-punct)) - (goto-char (1+ b))) - ;; else: ${ - (setq bb (match-beginning 0)) - (cperl-modify-syntax-type bb cperl-st-punct))) - ;; No processing in strings/comments beyond this point: - ((or (nth 3 state) (nth 4 state)) - t) ; Do nothing in comment/string - ((match-beginning 1) ; POD section - ;; "\\(\\`\n?\\|^\n\\)=" - (setq b (match-beginning 0) - state (parse-partial-sexp - state-point b nil nil state) - state-point b) - (if (or (nth 3 state) (nth 4 state) - (looking-at "cut\\>")) - (if (or (nth 3 state) (nth 4 state) ignore-max) - nil ; Doing a chunk only - (message "=cut is not preceded by a POD section") - (or (car err-l) (setcar err-l (point)))) - (beginning-of-line) - - (setq b (point) - bb b - tb (match-beginning 0) - b1 nil) ; error condition - ;; We do not search to max, since we may be called from - ;; some hook of fontification, and max is random - (or (re-search-forward "^\n=cut\\>" stop-point 'toend) - (progn - (goto-char b) - (if (re-search-forward "\n=cut\\>" stop-point 'toend) - (progn - (message "=cut is not preceded by an empty line") - (setq b1 t) - (or (car err-l) (setcar err-l b)))))) - (beginning-of-line 2) ; An empty line after =cut is not POD! - (setq e (point)) - (and (> e max) - (progn - (remove-text-properties - max e '(syntax-type t in-pod t syntax-table t - attrib-group t - REx-interpolated t - cperl-postpone t - syntax-subtype t - here-doc-group t - rear-nonsticky t - front-sticky t - first-format-line t - REx-part2 t - indentable t)) - (setq tmpend tb))) - (put-text-property b e 'in-pod t) - (put-text-property b e 'syntax-type 'in-pod) - (goto-char b) - (while (re-search-forward "\n\n[ \t]" e t) - ;; We start 'pod 1 char earlier to include the preceding line - (beginning-of-line) - (put-text-property (cperl-1- b) (point) 'syntax-type 'pod) - (cperl-put-do-not-fontify b (point) t) - ;; mark the non-literal parts as PODs - (if cperl-pod-here-fontify - (cperl-postpone-fontification b (point) 'face face t)) - (re-search-forward "\n\n[^ \t\f\n]" e 'toend) - (beginning-of-line) - (setq b (point))) - (put-text-property (cperl-1- (point)) e 'syntax-type 'pod) - (cperl-put-do-not-fontify (point) e t) - (if cperl-pod-here-fontify - (progn - ;; mark the non-literal parts as PODs - (cperl-postpone-fontification (point) e 'face face t) - (goto-char bb) - (if (looking-at - "=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$") - ;; mark the headers - (cperl-postpone-fontification - (match-beginning 1) (match-end 1) - 'face head-face)) - (while (re-search-forward - ;; One paragraph - "^\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$" - e 'toend) - ;; mark the headers - (cperl-postpone-fontification - (match-beginning 1) (match-end 1) - 'face head-face)))) - (cperl-commentify bb e nil) - (goto-char e) - (or (eq e (point-max)) - (forward-char -1)))) ; Prepare for immediate POD start. - ;; Here document - ;; We can do many here-per-line; - ;; but multiline quote on the same line as <"))) - (error t))))))) - (error nil))) ; func(< overshoot (point))) - (goto-char overshoot) - (setq overshoot e1)) - (if (> e1 max) - (setq tmpend tb)))) - ;; format - ((match-beginning 8) - ;; 1+6=7 extra () before this: - ;;"^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" - (setq b (point) - name (if (match-beginning 8) ; 7 + 1 - (buffer-substring (match-beginning 8) ; 7 + 1 - (match-end 8)) ; 7 + 1 - "") - tb (match-beginning 0)) - (setq argument nil) - (put-text-property (save-excursion - (beginning-of-line) - (point)) - b 'first-format-line 't) - (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) - ;; Highlight the format line - (cperl-postpone-fontification b1 (point) - 'face font-lock-string-face) - (cperl-commentify b1 (point) nil) - (cperl-put-do-not-fontify b1 (point) t)))) - ;; We do not search to max, since we may be called from - ;; some hook of fontification, and max is random - (re-search-forward "^[.;]$" stop-point 'toend)) - (beginning-of-line) - (if (looking-at "^\\.$") ; ";" is not supported yet - (progn - ;; Highlight the ending delimiter - (cperl-postpone-fontification (point) (+ (point) 2) - 'face font-lock-string-face) - (cperl-commentify (point) (+ (point) 2) nil) - (cperl-put-do-not-fontify (point) (+ (point) 2) t)) - (message "End of format `%s' not found." name) - (or (car err-l) (setcar err-l b))) - (forward-line) - (if (> (point) max) - (setq tmpend tb)) - (put-text-property b (point) 'syntax-type 'format)) - ;; qq-like String or Regexp: - ((or (match-beginning 10) (match-beginning 11)) - ;; 1+6+2=9 extra () before this: - ;; "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" - ;; "\\|" - ;; "\\([?/<]\\)" ; /blah/ or ?blah? or - (setq b1 (if (match-beginning 10) 10 11) - argument (buffer-substring - (match-beginning b1) (match-end b1)) - b (point) ; end of qq etc - i b - c (char-after (match-beginning b1)) - bb (char-after (1- (match-beginning b1))) ; tmp holder - ;; bb == "Not a stringy" - bb (if (eq b1 10) ; user variables/whatever - (and (memq bb (append "$@%*#_:-&>" nil)) ; $#y) - (cond ((eq bb ?-) (eq c ?s)) ; -s file test - ((eq bb ?\:) ; $opt::s - (eq (char-after - (- (match-beginning b1) 2)) - ?\:)) - ((eq bb ?\>) ; $foo->s - (eq (char-after - (- (match-beginning b1) 2)) - ?\-)) - ((eq bb ?\&) - (not (eq (char-after ; &&m/blah/ - (- (match-beginning b1) 2)) - ?\&))) - (t t))) - ;; or <$file> - (and (eq c ?\<) - ;; Do not stringify , <$fh> : - (save-match-data - (looking-at - "\\$?\\([_a-zA-Z:][_a-zA-Z0-9:]*\\)?>")))) - tb (match-beginning 0)) - (goto-char (match-beginning b1)) - (cperl-backward-to-noncomment (point-min)) - (or bb - (if (eq b1 11) ; bare /blah/ or ?blah? or - (setq argument "" - b1 nil - bb ; Not a regexp? - (not - ;; What is below: regexp-p? - (and - (or (memq (preceding-char) - (append (if (memq c '(?\? ?\<)) - ;; $a++ ? 1 : 2 - "~{(=|&*!,;:[" - "~{(=|&+-*!,;:[") nil)) - (and (eq (preceding-char) ?\}) - (cperl-after-block-p (point-min))) - (and (eq (char-syntax (preceding-char)) ?w) - (progn - (forward-sexp -1) -;; After these keywords `/' starts a RE. One should add all the -;; functions/builtins which expect an argument, but ... - (if (eq (preceding-char) ?-) - ;; -d ?foo? is a RE - (looking-at "[a-zA-Z]\\>") - (and - (not (memq (preceding-char) - '(?$ ?@ ?& ?%))) - (looking-at - "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\|say\\)\\>"))))) - (and (eq (preceding-char) ?.) - (eq (char-after (- (point) 2)) ?.)) - (bobp)) - ;; m|blah| ? foo : bar; - (not - (and (eq c ?\?) - cperl-use-syntax-table-text-property - (not (bobp)) - (progn - (forward-char -1) - (looking-at "\\s|")))))) - b (1- b)) - ;; s y tr m - ;; Check for $a -> y - (setq b1 (preceding-char) - go (point)) - (if (and (eq b1 ?>) - (eq (char-after (- go 2)) ?-)) - ;; Not a regexp - (setq bb t)))) - (or bb - (progn - (goto-char b) - (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+") - (goto-char (match-end 0)) - (skip-chars-forward " \t\n\f")) - (cond ((and (eq (following-char) ?\}) - (eq b1 ?\{)) - ;; Check for $a[23]->{ s }, @{s} and *{s::foo} - (goto-char (1- go)) - (skip-chars-backward " \t\n\f") - (if (memq (preceding-char) (append "$@%&*" nil)) - (setq bb t) ; @{y} - (condition-case nil - (forward-sexp -1) - (error nil))) - (if (or bb - (looking-at ; $foo -> {s} - "[$@]\\$*\\([a-zA-Z0-9_:]+\\|[^{]\\)\\([ \t\n]*->\\)?[ \t\n]*{") - (and ; $foo[12] -> {s} - (memq (following-char) '(?\{ ?\[)) - (progn - (forward-sexp 1) - (looking-at "\\([ \t\n]*->\\)?[ \t\n]*{")))) - (setq bb t) - (goto-char b))) - ((and (eq (following-char) ?=) - (eq (char-after (1+ (point))) ?\>)) - ;; Check for { foo => 1, s => 2 } - ;; Apparently s=> is never a substitution... - (setq bb t)) - ((and (eq (following-char) ?:) - (eq b1 ?\{) ; Check for $ { s::bar } - (looking-at "::[a-zA-Z0-9_:]*[ \t\n\f]*}") - (progn - (goto-char (1- go)) - (skip-chars-backward " \t\n\f") - (memq (preceding-char) - (append "$@%&*" nil)))) - (setq bb t)) - ((eobp) - (setq bb t))))) - (if bb - (goto-char i) - ;; Skip whitespace and comments... - (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+") - (goto-char (match-end 0)) - (skip-chars-forward " \t\n\f")) - (if (> (point) b) - (put-text-property b (point) 'syntax-type 'prestring)) - ;; qtag means two-arg matcher, may be reset to - ;; 2 or 3 later if some special quoting is needed. - ;; e1 means matching-char matcher. - (setq b (point) ; before the first delimiter - ;; has 2 args - i2 (string-match "^\\([sy]\\|tr\\)$" argument) - ;; We do not search to max, since we may be called from - ;; some hook of fontification, and max is random - i (cperl-forward-re stop-point end - i2 - st-l err-l argument) - ;; If `go', then it is considered as 1-arg, `b1' is nil - ;; as in s/foo//x; the point is before final "slash" - b1 (nth 1 i) ; start of the second part - tag (nth 2 i) ; ender-char, true if second part - ; is with matching chars [] - go (nth 4 i) ; There is a 1-char part after the end - i (car i) ; intermediate point - e1 (point) ; end - ;; Before end of the second part if non-matching: /// - tail (if (and i (not tag)) - (1- e1)) - e (if i i e1) ; end of the first part - qtag nil ; need to preserve backslashitis - is-x-REx nil is-o-REx nil); REx has //x //o modifiers - ;; If s{} (), then b/b1 are at "{", "(", e1/i after ")", "}" - ;; Commenting \\ is dangerous, what about ( ? - (and i tail - (eq (char-after i) ?\\) - (setq qtag t)) - (and (if go (looking-at ".\\sw*x") - (looking-at "\\sw*x")) ; qr//x - (setq is-x-REx t)) - (and (if go (looking-at ".\\sw*o") - (looking-at "\\sw*o")) ; //o - (setq is-o-REx t)) - (if (null i) - ;; Considered as 1arg form - (progn - (cperl-commentify b (point) t) - (put-text-property b (point) 'syntax-type 'string) - (if (or is-x-REx - ;; ignore other text properties: - (string-match "^qw$" argument)) - (put-text-property b (point) 'indentable t)) - (and go - (setq e1 (cperl-1+ e1)) - (or (eobp) - (forward-char 1)))) - (cperl-commentify b i t) - (if (looking-at "\\sw*e") ; s///e - (progn - ;; Cache the syntax info... - (setq cperl-syntax-state (cons state-point state)) - (and - ;; silent: - (car (cperl-find-pods-heres b1 (1- (point)) t end)) - ;; Error - (goto-char (1+ max))) - (if (and tag (eq (preceding-char) ?\>)) - (progn - (cperl-modify-syntax-type (1- (point)) cperl-st-ket) - (cperl-modify-syntax-type i cperl-st-bra))) - (put-text-property b i 'syntax-type 'string) - (put-text-property i (point) 'syntax-type 'multiline) - (if is-x-REx - (put-text-property b i 'indentable t))) - (cperl-commentify b1 (point) t) - (put-text-property b (point) 'syntax-type 'string) - (if is-x-REx - (put-text-property b i 'indentable t)) - (if qtag - (cperl-modify-syntax-type (1+ i) cperl-st-punct)) - (setq tail nil))) - ;; Now: tail: if the second part is non-matching without ///e - (if (eq (char-syntax (following-char)) ?w) - (progn - (forward-word 1) ; skip modifiers s///s - (if tail (cperl-commentify tail (point) t)) - (cperl-postpone-fontification - e1 (point) 'face my-cperl-REx-modifiers-face))) - ;; Check whether it is m// which means "previous match" - ;; and highlight differently - (setq is-REx - (and (string-match "^\\([sm]?\\|qr\\)$" argument) - (or (not (= (length argument) 0)) - (not (eq c ?\<))))) - (if (and is-REx - (eq e (+ 2 b)) - ;; split // *is* using zero-pattern - (save-excursion - (condition-case nil - (progn - (goto-char tb) - (forward-sexp -1) - (not (looking-at "split\\>"))) - (error t)))) - (cperl-postpone-fontification - b e 'face font-lock-warning-face) - (if (or i2 ; Has 2 args - (and cperl-fontify-m-as-s - (or - (string-match "^\\(m\\|qr\\)$" argument) - (and (eq 0 (length argument)) - (not (eq ?\< (char-after b))))))) - (progn - (cperl-postpone-fontification - b (cperl-1+ b) 'face my-cperl-delimiters-face) - (cperl-postpone-fontification - (1- e) e 'face my-cperl-delimiters-face))) - (if (and is-REx cperl-regexp-scan) - ;; Process RExen: embedded comments, charclasses and ] -;;;/\3333\xFg\x{FFF}a\ppp\PPP\qqq\C\99f(?{ foo })(??{ foo })/; -;;;/a\.b[^a[:ff:]b]x$ab->$[|$,$ab->[cd]->[ef]|$ab[xy].|^${a,b}{c,d}/; -;;;/(?<=foo)(?" "\\)?" - "\\[[^][]*\\]" - "\\|" - "{[^{}]*}" - "\\)*" - ;; XXXX: what if u is delim? - "\\|" - "[)^|$.*?+]" - "\\|" - "{[0-9]+}" - "\\|" - "{[0-9]+,[0-9]*}" - "\\|" - "\\\\[luLUEQbBAzZG]" - "\\|" - "(" ; Group opener - "\\(" ; 10 group opener follower - "\\?\\((\\?\\)" ; 11: in (?(?=C)A|B) - "\\|" - "\\?[:=!>?{]" ; "?" something - "\\|" - "\\?[-imsx]+[:)]" ; (?i) (?-s:.) - "\\|" - "\\?([0-9]+)" ; (?(1)foo|bar) - "\\|" - "\\?<[=!]" - ;;;"\\|" - ;;; "\\?" - "\\)?" - "\\)" - "\\|" - "\\\\\\(.\\)" ; 12=\SYMBOL - )) - (while - (and (< (point) (1- e)) - (re-search-forward hairy-RE (1- e) 'to-end)) - (goto-char (match-beginning 0)) - (setq REx-subgr-start (point) - was-subgr (following-char)) - (cond - ((match-beginning 6) ; 0-length builtins, groups - (goto-char (match-end 0)) - (if (match-beginning 11) - (goto-char (match-beginning 11))) - (if (>= (point) e) - (goto-char (1- e))) - (cperl-postpone-fontification - (match-beginning 0) (point) - 'face - (cond - ((eq was-subgr ?\) ) - (condition-case nil - (save-excursion - (forward-sexp -1) - (if (> (point) b) - (if (if (eq (char-after b) ?? ) - (looking-at "(\\\\\\?") - (eq (char-after (1+ (point))) ?\?)) - my-cperl-REx-0length-face - my-cperl-REx-ctl-face) - font-lock-warning-face)) - (error font-lock-warning-face))) - ((eq was-subgr ?\| ) - my-cperl-REx-ctl-face) - ((eq was-subgr ?\$ ) - (if (> (point) (1+ REx-subgr-start)) - (progn - (put-text-property - (match-beginning 0) (point) - 'REx-interpolated - (if is-o-REx 0 - (if (and (eq (match-beginning 0) - (1+ b)) - (eq (point) - (1- e))) 1 t))) - font-lock-variable-name-face) - my-cperl-REx-spec-char-face)) - ((memq was-subgr (append "^." nil) ) - my-cperl-REx-spec-char-face) - ((eq was-subgr ?\( ) - (if (not (match-beginning 10)) - my-cperl-REx-ctl-face - my-cperl-REx-0length-face)) - (t my-cperl-REx-0length-face))) - (if (and (memq was-subgr (append "(|" nil)) - (not (string-match "(\\?[-imsx]+)" - (match-string 0)))) - (cperl-look-at-leading-count is-x-REx e)) - (setq was-subgr nil)) ; We do stuff here - ((match-beginning 12) ; \SYMBOL - (forward-char 2) - (if (>= (point) e) - (goto-char (1- e)) - ;; How many chars to not highlight: - ;; 0-len special-alnums in other branch => - ;; Generic: \non-alnum (1), \alnum (1+face) - ;; Is-delim: \non-alnum (1/spec-2) alnum-1 (=what hai) - (setq REx-subgr-start (point) - qtag (preceding-char)) - (cperl-postpone-fontification - (- (point) 2) (- (point) 1) 'face - (if (memq qtag - (append "ghijkmoqvFHIJKMORTVY" nil)) - font-lock-warning-face - my-cperl-REx-0length-face)) - (if (and (eq (char-after b) qtag) - (memq qtag (append ".])^$|*?+" nil))) - (progn - (if (and cperl-use-syntax-table-text-property - (eq qtag ?\) )) - (put-text-property - REx-subgr-start (1- (point)) - 'syntax-table cperl-st-punct)) - (cperl-postpone-fontification - (1- (point)) (point) 'face - ; \] can't appear below - (if (memq qtag (append ".]^$" nil)) - 'my-cperl-REx-spec-char-face - (if (memq qtag (append "*?+" nil)) - 'my-cperl-REx-0length-face - 'my-cperl-REx-ctl-face))))) ; )| - ;; Test for arguments: - (cond - ;; This is not pretty: the 5.8.7 logic: - ;; \0numx -> octal (up to total 3 dig) - ;; \DIGIT -> backref unless \0 - ;; \DIGITs -> backref if legal - ;; otherwise up to 3 -> octal - ;; Do not try to distinguish, we guess - ((or (and (memq qtag (append "01234567" nil)) - (re-search-forward - "\\=[01234567]?[01234567]?" - (1- e) 'to-end)) - (and (memq qtag (append "89" nil)) - (re-search-forward - "\\=[0123456789]*" (1- e) 'to-end)) - (and (eq qtag ?x) - (re-search-forward - "\\=[0-9a-fA-F][0-9a-fA-F]?\\|\\={[0-9a-fA-F]+}" - (1- e) 'to-end)) - (and (memq qtag (append "pPN" nil)) - (re-search-forward "\\={[^{}]+}\\|." - (1- e) 'to-end)) - (eq (char-syntax qtag) ?w)) - (cperl-postpone-fontification - (1- REx-subgr-start) (point) - 'face my-cperl-REx-length1-face)))) - (setq was-subgr nil)) ; We do stuff here - ((match-beginning 3) ; [charclass] - (forward-char 1) - (if (eq (char-after b) ?^ ) - (and (eq (following-char) ?\\ ) - (eq (char-after (cperl-1+ (point))) - ?^ ) - (forward-char 2)) - (and (eq (following-char) ?^ ) - (forward-char 1))) - (setq argument b ; continue? - tag nil ; list of POSIX classes - qtag (point)) - (if (eq (char-after b) ?\] ) - (and (eq (following-char) ?\\ ) - (eq (char-after (cperl-1+ (point))) - ?\] ) - (setq qtag (1+ qtag)) - (forward-char 2)) - (and (eq (following-char) ?\] ) - (forward-char 1))) - ;; Apparently, I can't put \] into a charclass - ;; in m]]: m][\\\]\]] produces [\\]] -;;; POSIX? [:word:] [:^word:] only inside [] -;;; "\\=\\(\\\\.\\|[^][\\\\]\\|\\[:\\^?\sw+:]\\|\\[[^:]\\)*]") - (while - (and argument - (re-search-forward - (if (eq (char-after b) ?\] ) - "\\=\\(\\\\[^]]\\|[^]\\\\]\\)*\\\\]" - "\\=\\(\\\\.\\|[^]\\\\]\\)*]") - (1- e) 'toend)) - ;; Is this ] an end of POSIX class? - (if (save-excursion - (and - (search-backward "[" argument t) - (< REx-subgr-start (point)) - (not - (and ; Should work with delim = \ - (eq (preceding-char) ?\\ ) - (= (% (skip-chars-backward - "\\\\") 2) 0))) - (looking-at - (cond - ((eq (char-after b) ?\] ) - "\\\\*\\[:\\^?\\sw+:\\\\\\]") - ((eq (char-after b) ?\: ) - "\\\\*\\[\\\\:\\^?\\sw+\\\\:]") - ((eq (char-after b) ?^ ) - "\\\\*\\[:\\(\\\\\\^\\)?\\sw+:\]") - ((eq (char-syntax (char-after b)) - ?w) - (concat - "\\\\*\\[:\\(\\\\\\^\\)?\\(\\\\" - (char-to-string (char-after b)) - "\\|\\sw\\)+:\]")) - (t "\\\\*\\[:\\^?\\sw*:]"))) - (setq argument (point)))) - (setq tag (cons (cons argument (point)) - tag) - argument (point)) ; continue - (setq argument nil))) - (and argument - (message "Couldn't find end of charclass in a REx, pos=%s" - REx-subgr-start)) - (if (and cperl-use-syntax-table-text-property - (> (- (point) 2) REx-subgr-start)) - (put-text-property - (1+ REx-subgr-start) (1- (point)) - 'syntax-table cperl-st-punct)) - (cperl-postpone-fontification - REx-subgr-start qtag - 'face my-cperl-REx-spec-char-face) - (cperl-postpone-fontification - (1- (point)) (point) 'face - my-cperl-REx-spec-char-face) - (if (eq (char-after b) ?\] ) - (cperl-postpone-fontification - (- (point) 2) (1- (point)) - 'face my-cperl-REx-0length-face)) - (while tag - (cperl-postpone-fontification - (car (car tag)) (cdr (car tag)) - 'face my-cperl-REx-length1-face) - (setq tag (cdr tag))) - (setq was-subgr nil)) ; did facing already - ;; Now rare stuff: - ((and (match-beginning 2) ; #-comment - (/= (match-beginning 2) (match-end 2))) - (beginning-of-line 2) - (if (> (point) e) - (goto-char (1- e)))) - ((match-beginning 4) ; character "]" - (setq was-subgr nil) ; We do stuff here - (goto-char (match-end 0)) - (if cperl-use-syntax-table-text-property - (put-text-property - (1- (point)) (point) - 'syntax-table cperl-st-punct)) - (cperl-postpone-fontification - (1- (point)) (point) - 'face font-lock-warning-face)) - ((match-beginning 5) ; before (?{}) (??{}) - (setq tag (match-end 0)) - (if (or (setq qtag - (cperl-forward-group-in-re st-l)) - (and (>= (point) e) - (setq qtag "no matching `)' found")) - (and (not (eq (char-after (- (point) 2)) - ?\} )) - (setq qtag "Can't find })"))) - (progn - (goto-char (1- e)) - (message "%s" qtag)) - (cperl-postpone-fontification - (1- tag) (1- (point)) - 'face font-lock-variable-name-face) - (cperl-postpone-fontification - REx-subgr-start (1- tag) - 'face my-cperl-REx-spec-char-face) - (cperl-postpone-fontification - (1- (point)) (point) - 'face my-cperl-REx-spec-char-face) - (if cperl-use-syntax-table-text-property - (progn - (put-text-property - (- (point) 2) (1- (point)) - 'syntax-table cperl-st-cfence) - (put-text-property - (+ REx-subgr-start 2) - (+ REx-subgr-start 3) - 'syntax-table cperl-st-cfence)))) - (setq was-subgr nil)) - (t ; (?#)-comment - ;; Inside "(" and "\" arn't special in any way - ;; Works also if the outside delimiters are (). - (or;;(if (eq (char-after b) ?\) ) - ;;(re-search-forward - ;; "[^\\\\]\\(\\\\\\\\\\)*\\\\)" - ;; (1- e) 'toend) - (search-forward ")" (1- e) 'toend) - ;;) - (message - "Couldn't find end of (?#...)-comment in a REx, pos=%s" - REx-subgr-start)))) - (if (>= (point) e) - (goto-char (1- e))) - (cond - (was-subgr - (setq REx-subgr-end (point)) - (cperl-commentify - REx-subgr-start REx-subgr-end nil) - (cperl-postpone-fontification - REx-subgr-start REx-subgr-end - 'face font-lock-comment-face)))))) - (if (and is-REx is-x-REx) - (put-text-property (1+ b) (1- e) - 'syntax-subtype 'x-REx))) - (if (and i2 e1 b1 (> e1 b1)) - (progn ; No errors finding the second part... - (cperl-postpone-fontification - (1- e1) e1 'face my-cperl-delimiters-face) - (if (and (not (eobp)) - (assoc (char-after b) cperl-starters)) - (progn - (cperl-postpone-fontification - b1 (1+ b1) 'face my-cperl-delimiters-face) - (put-text-property b1 (1+ b1) - 'REx-part2 t))))) - (if (> (point) max) - (setq tmpend tb)))) - ((match-beginning 17) ; sub with prototype or attribute - ;; 1+6+2+1+1=11 extra () before this (sub with proto/attr): - ;;"\\\\(" ;12 - ;; cperl-white-and-comment-rex ;13 - ;; "\\([a-zA-Z_:'0-9]+\\)\\)?" ; name ;14 - ;;"\\(" cperl-maybe-white-and-comment-rex ;15,16 - ;; "\\(([^()]*)\\|:[^:]\\)\\)" ; 17:proto or attribute start - (setq b1 (match-beginning 14) e1 (match-end 14)) - (if (memq (char-after (1- b)) - '(?\$ ?\@ ?\% ?\& ?\*)) - nil - (goto-char b) - (if (eq (char-after (match-beginning 17)) ?\( ) - (progn - (cperl-commentify ; Prototypes; mark as string - (match-beginning 17) (match-end 17) t) - (goto-char (match-end 0)) - ;; Now look for attributes after prototype: - (forward-comment (buffer-size)) - (and (looking-at ":[^:]") - (cperl-find-sub-attrs st-l b1 e1 b))) - ;; treat attributes without prototype - (goto-char (match-beginning 17)) - (cperl-find-sub-attrs st-l b1 e1 b)))) - ;; 1+6+2+1+1+6+1=18 extra () before this: - ;; "\\(\\ (point) stop-point) - (progn - (if end - (message "Garbage after __END__/__DATA__ ignored") - (message "Unbalanced syntax found while scanning") - (or (car err-l) (setcar err-l b))) - (goto-char stop-point)))) - (setq cperl-syntax-state (cons state-point state) - ;; Do not mark syntax as done past tmpend??? - cperl-syntax-done-to (or tmpend (max (point) max))) - ;;(message "state-at=%s, done-to=%s" state-point cperl-syntax-done-to) - ) - (if (car err-l) (goto-char (car err-l)) - (or non-inter - (message "Scanning for \"hard\" Perl constructions... done")))) - (and (buffer-modified-p) - (not modified) - (set-buffer-modified-p nil)) - ;; I do not understand what this is doing here. It breaks font-locking - ;; because it resets the syntax-table from font-lock-syntax-table to - ;; cperl-mode-syntax-table. - ;; (set-syntax-table cperl-mode-syntax-table) - ) - (list (car err-l) overshoot))) - -(defun cperl-find-pods-heres-region (min max) - (interactive "r") - (cperl-find-pods-heres min max)) - -(defun cperl-backward-to-noncomment (lim) - ;; Stops at lim or after non-whitespace that is not in comment - ;; XXXX Wrongly understands end-of-multiline strings with # as comment - (let (stop p pr) - (while (and (not stop) (> (point) (or lim (point-min)))) - (skip-chars-backward " \t\n\f" lim) - (setq p (point)) - (beginning-of-line) - (if (memq (setq pr (get-text-property (point) 'syntax-type)) - '(pod here-doc here-doc-delim)) - (progn - (cperl-unwind-to-safe nil) - (setq pr (get-text-property (point) 'syntax-type)))) - (or (and (looking-at "^[ \t]*\\(#\\|$\\)") - (not (memq pr '(string prestring)))) - (progn (cperl-to-comment-or-eol) (bolp)) - (progn - (skip-chars-backward " \t") - (if (< p (point)) (goto-char p)) - (setq stop t)))))) - -;; Used only in `cperl-calculate-indent'... -(defun cperl-block-p () ; Do not C-M-q ! One string contains ";" ! - ;; Positions is before ?\{. Checks whether it starts a block. - ;; No save-excursion! This is more a distinguisher of a block/hash ref... - (cperl-backward-to-noncomment (point-min)) - (or (memq (preceding-char) (append ";){}$@&%\C-@" nil)) ; Or label! \C-@ at bobp - ; Label may be mixed up with `$blah :' - (save-excursion (cperl-after-label)) - (get-text-property (cperl-1- (point)) 'attrib-group) - (and (memq (char-syntax (preceding-char)) '(?w ?_)) - (progn - (backward-sexp) - ;; sub {BLK}, print {BLK} $data, but NOT `bless', `return', `tr' - (or (and (looking-at "[a-zA-Z0-9_:]+[ \t\n\f]*[{#]") ; Method call syntax - (not (looking-at "\\(bless\\|return\\|q[wqrx]?\\|tr\\|[smy]\\)\\>"))) - ;; sub bless::foo {} - (progn - (cperl-backward-to-noncomment (point-min)) - (and (eq (preceding-char) ?b) - (progn - (forward-sexp -1) - (looking-at "sub[ \t\n\f#]"))))))))) - -;;; What is the difference of (cperl-after-block-p lim t) and (cperl-block-p)? -;;; No save-excursion; condition-case ... In (cperl-block-p) the block -;;; may be a part of an in-statement construct, such as -;;; ${something()}, print {FH} $data. -;;; Moreover, one takes positive approach (looks for else,grep etc) -;;; another negative (looks for bless,tr etc) -(defun cperl-after-block-p (lim &optional pre-block) - "Return true if the preceeding } (if PRE-BLOCK, following {) delimits a block. -Would not look before LIM. Assumes that LIM is a good place to begin a -statement. The kind of block we treat here is one after which a new -statement would start; thus the block in ${func()} does not count." - (save-excursion - (condition-case nil - (progn - (or pre-block (forward-sexp -1)) - (cperl-backward-to-noncomment lim) - (or (eq (point) lim) - ;; if () {} // sub f () {} // sub f :a(') {} - (eq (preceding-char) ?\) ) - ;; label: {} - (save-excursion (cperl-after-label)) - ;; sub :attr {} - (get-text-property (cperl-1- (point)) 'attrib-group) - (if (memq (char-syntax (preceding-char)) '(?w ?_)) ; else {} - (save-excursion - (forward-sexp -1) - ;; else {} but not else::func {} - (or (and (looking-at "\\(else\\|continue\\|grep\\|map\\|BEGIN\\|END\\|UNITCHECK\\|CHECK\\|INIT\\)\\>") - (not (looking-at "\\(\\sw\\|_\\)+::"))) - ;; sub f {} - (progn - (cperl-backward-to-noncomment lim) - (and (eq (preceding-char) ?b) - (progn - (forward-sexp -1) - (looking-at "sub[ \t\n\f#]")))))) - ;; What preceeds is not word... XXXX Last statement in sub??? - (cperl-after-expr-p lim)))) - (error nil)))) - -(defun cperl-after-expr-p (&optional lim chars test) - "Return true if the position is good for start of expression. -TEST is the expression to evaluate at the found position. If absent, -CHARS is a string that contains good characters to have before us (however, -`}' is treated \"smartly\" if it is not in the list)." - (let ((lim (or lim (point-min))) - stop p pr) - (cperl-update-syntaxification (point) (point)) - (save-excursion - (while (and (not stop) (> (point) lim)) - (skip-chars-backward " \t\n\f" lim) - (setq p (point)) - (beginning-of-line) - ;;(memq (setq pr (get-text-property (point) 'syntax-type)) - ;; '(pod here-doc here-doc-delim)) - (if (get-text-property (point) 'here-doc-group) - (progn - (goto-char - (cperl-beginning-of-property (point) 'here-doc-group)) - (beginning-of-line 0))) - (if (get-text-property (point) 'in-pod) - (progn - (goto-char - (cperl-beginning-of-property (point) 'in-pod)) - (beginning-of-line 0))) - (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip - ;; Else: last iteration, or a label - (cperl-to-comment-or-eol) ; Will not move past "." after a format - (skip-chars-backward " \t") - (if (< p (point)) (goto-char p)) - (setq p (point)) - (if (and (eq (preceding-char) ?:) - (progn - (forward-char -1) - (skip-chars-backward " \t\n\f" lim) - (memq (char-syntax (preceding-char)) '(?w ?_)))) - (forward-sexp -1) ; Possibly label. Skip it - (goto-char p) - (setq stop t)))) - (or (bobp) ; ???? Needed - (eq (point) lim) - (looking-at "[ \t]*__\\(END\\|DATA\\)__") ; After this anything goes - (progn - (if test (eval test) - (or (memq (preceding-char) (append (or chars "{;") nil)) - (and (eq (preceding-char) ?\}) - (cperl-after-block-p lim)) - (and (eq (following-char) ?.) ; in format: see comment above - (eq (get-text-property (point) 'syntax-type) - 'format))))))))) - -(defun cperl-backward-to-start-of-expr (&optional lim) - (condition-case nil - (progn - (while (and (or (not lim) - (> (point) lim)) - (not (cperl-after-expr-p lim))) - (forward-sexp -1) - ;; May be after $, @, $# etc of a variable - (skip-chars-backward "$@%#"))) - (error nil))) - -(defun cperl-at-end-of-expr (&optional lim) - ;; Since the SEXP approach below is very fragile, do some overengineering - (or (looking-at (concat cperl-maybe-white-and-comment-rex "[;}]")) - (condition-case nil - (save-excursion - ;; If nothing interesting after, does as (forward-sexp -1); - ;; otherwise fails, or ends at a start of following sexp. - ;; XXXX PROBLEMS: if what follows (after ";") @FOO, or ${bar} - ;; may be stuck after @ or $; just put some stupid workaround now: - (let ((p (point))) - (forward-sexp 1) - (forward-sexp -1) - (while (memq (preceding-char) (append "%&@$*" nil)) - (forward-char -1)) - (or (< (point) p) - (cperl-after-expr-p lim)))) - (error t)))) - -(defun cperl-forward-to-end-of-expr (&optional lim) - (let ((p (point)))) - (condition-case nil - (progn - (while (and (< (point) (or lim (point-max))) - (not (cperl-at-end-of-expr))) - (forward-sexp 1))) - (error nil))) - -(defun cperl-backward-to-start-of-continued-exp (lim) - (if (memq (preceding-char) (append ")]}\"'`" nil)) - (forward-sexp -1)) - (beginning-of-line) - (if (<= (point) lim) - (goto-char (1+ lim))) - (skip-chars-forward " \t")) - -(defun cperl-after-block-and-statement-beg (lim) - ;; We assume that we are after ?\} - (and - (cperl-after-block-p lim) - (save-excursion - (forward-sexp -1) - (cperl-backward-to-noncomment (point-min)) - (or (bobp) - (eq (point) lim) - (not (= (char-syntax (preceding-char)) ?w)) - (progn - (forward-sexp -1) - (not - (looking-at - "\\(map\\|grep\\|say\\|printf?\\|system\\|exec\\|tr\\|s\\)\\>"))))))) - - -(defun cperl-indent-exp () - "Simple variant of indentation of continued-sexp. - -Will not indent comment if it starts at `comment-indent' or looks like -continuation of the comment on the previous line. - -If `cperl-indent-region-fix-constructs', will improve spacing on -conditional/loop constructs." - (interactive) - (save-excursion - (let ((tmp-end (progn (end-of-line) (point))) top done) - (save-excursion - (beginning-of-line) - (while (null done) - (setq top (point)) - ;; Plan A: if line has an unfinished paren-group, go to end-of-group - (while (= -1 (nth 0 (parse-partial-sexp (point) tmp-end -1))) - (setq top (point))) ; Get the outermost parenths in line - (goto-char top) - (while (< (point) tmp-end) - (parse-partial-sexp (point) tmp-end nil t) ; To start-sexp or eol - (or (eolp) (forward-sexp 1))) - (if (> (point) tmp-end) ; Yes, there an unfinished block - nil - (if (eq ?\) (preceding-char)) - (progn ;; Plan B: find by REGEXP block followup this line - (setq top (point)) - (condition-case nil - (progn - (forward-sexp -2) - (if (eq (following-char) ?$ ) ; for my $var (list) - (progn - (forward-sexp -1) - (if (looking-at "\\(state\\|my\\|local\\|our\\)\\>") - (forward-sexp -1)))) - (if (looking-at - (concat "\\(\\elsif\\|if\\|unless\\|while\\|until" - "\\|for\\(each\\)?\\>\\(\\(" - cperl-maybe-white-and-comment-rex - "\\(state\\|my\\|local\\|our\\)\\)?" - cperl-maybe-white-and-comment-rex - "\\$[_a-zA-Z0-9]+\\)?\\)\\>")) - (progn - (goto-char top) - (forward-sexp 1) - (setq top (point))))) - (error (setq done t))) - (goto-char top)) - (if (looking-at ; Try Plan C: continuation block - (concat cperl-maybe-white-and-comment-rex - "\\<\\(else\\|elsif\|continue\\)\\>")) - (progn - (goto-char (match-end 0)) - (save-excursion - (end-of-line) - (setq tmp-end (point)))) - (setq done t)))) - (save-excursion - (end-of-line) - (setq tmp-end (point)))) - (goto-char tmp-end) - (setq tmp-end (point-marker))) - (if cperl-indent-region-fix-constructs - (cperl-fix-line-spacing tmp-end)) - (cperl-indent-region (point) tmp-end)))) - -(defun cperl-fix-line-spacing (&optional end parse-data) - "Improve whitespace in a conditional/loop construct. -Returns some position at the last line." - (interactive) - (or end - (setq end (point-max))) - (let ((ee (save-excursion (end-of-line) (point))) - (cperl-indent-region-fix-constructs - (or cperl-indent-region-fix-constructs 1)) - p pp ml have-brace ret) - (save-excursion - (beginning-of-line) - (setq ret (point)) - ;; }? continue - ;; blah; } - (if (not - (or (looking-at "[ \t]*\\(els\\(e\\|if\\)\\|continue\\|if\\|while\\|for\\(each\\)?\\|until\\)") - (setq have-brace (save-excursion (search-forward "}" ee t))))) - nil ; Do not need to do anything - ;; Looking at: - ;; } - ;; else - (if cperl-merge-trailing-else - (if (looking-at - "[ \t]*}[ \t]*\n[ \t\n]*\\(els\\(e\\|if\\)\\|continue\\)\\>") - (progn - (search-forward "}") - (setq p (point)) - (skip-chars-forward " \t\n") - (delete-region p (point)) - (insert (make-string cperl-indent-region-fix-constructs ?\s)) - (beginning-of-line))) - (if (looking-at "[ \t]*}[ \t]*\\(els\\(e\\|if\\)\\|continue\\)\\>") - (save-excursion - (search-forward "}") - (delete-horizontal-space) - (insert "\n") - (setq ret (point)) - (if (cperl-indent-line parse-data) - (progn - (cperl-fix-line-spacing end parse-data) - (setq ret (point))))))) - ;; Looking at: - ;; } else - (if (looking-at "[ \t]*}\\(\t*\\|[ \t][ \t]+\\)\\<\\(els\\(e\\|if\\)\\|continue\\)\\>") - (progn - (search-forward "}") - (delete-horizontal-space) - (insert (make-string cperl-indent-region-fix-constructs ?\s)) - (beginning-of-line))) - ;; Looking at: - ;; else { - (if (looking-at - "[ \t]*}?[ \t]*\\<\\(\\els\\(e\\|if\\)\\|continue\\|unless\\|if\\|while\\|for\\(each\\)?\\|until\\)\\>\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]") - (progn - (forward-word 1) - (delete-horizontal-space) - (insert (make-string cperl-indent-region-fix-constructs ?\s)) - (beginning-of-line))) - ;; Looking at: - ;; foreach my $var - (if (looking-at - "[ \t]*\\\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{") - (progn - (setq ml (match-beginning 8)) ; "(" or "{" after control word - (re-search-forward "[({]") - (forward-char -1) - (setq p (point)) - (if (eq (following-char) ?\( ) - (progn - (forward-sexp 1) - (setq pp (point))) ; past parenth-group - ;; after `else' or nothing - (if ml ; after `else' - (skip-chars-backward " \t\n") - (beginning-of-line)) - (setq pp nil)) - ;; Now after the sexp before the brace - ;; Multiline expr should be special - (setq ml (and pp (save-excursion (goto-char p) - (search-forward "\n" pp t)))) - (if (and (or (not pp) (< pp end)) ; Do not go too far... - (looking-at "[ \t\n]*{")) - (progn - (cond - ((bolp) ; Were before `{', no if/else/etc - nil) - ((looking-at "\\(\t*\\| [ \t]+\\){") ; Not exactly 1 SPACE - (delete-horizontal-space) - (if (if ml - cperl-extra-newline-before-brace-multiline - cperl-extra-newline-before-brace) - (progn - (delete-horizontal-space) - (insert "\n") - (setq ret (point)) - (if (cperl-indent-line parse-data) - (progn - (cperl-fix-line-spacing end parse-data) - (setq ret (point))))) - (insert - (make-string cperl-indent-region-fix-constructs ?\s)))) - ((and (looking-at "[ \t]*\n") - (not (if ml - cperl-extra-newline-before-brace-multiline - cperl-extra-newline-before-brace))) - (setq pp (point)) - (skip-chars-forward " \t\n") - (delete-region pp (point)) - (insert - (make-string cperl-indent-region-fix-constructs ?\ ))) - ((and (looking-at "[\t ]*{") - (if ml cperl-extra-newline-before-brace-multiline - cperl-extra-newline-before-brace)) - (delete-horizontal-space) - (insert "\n") - (setq ret (point)) - (if (cperl-indent-line parse-data) - (progn - (cperl-fix-line-spacing end parse-data) - (setq ret (point)))))) - ;; Now we are before `{' - (if (looking-at "[ \t\n]*{[ \t]*[^ \t\n#]") - (progn - (skip-chars-forward " \t\n") - (setq pp (point)) - (forward-sexp 1) - (setq p (point)) - (goto-char pp) - (setq ml (search-forward "\n" p t)) - (if (or cperl-break-one-line-blocks-when-indent ml) - ;; not good: multi-line BLOCK - (progn - (goto-char (1+ pp)) - (delete-horizontal-space) - (insert "\n") - (setq ret (point)) - (if (cperl-indent-line parse-data) - (setq ret (cperl-fix-line-spacing end parse-data))))))))))) - (beginning-of-line) - (setq p (point) pp (save-excursion (end-of-line) (point))) ; May be different from ee. - ;; Now check whether there is a hanging `}' - ;; Looking at: - ;; } blah - (if (and - cperl-fix-hanging-brace-when-indent - have-brace - (not (looking-at "[ \t]*}[ \t]*\\(\\<\\(els\\(if\\|e\\)\\|continue\\|while\\|until\\)\\>\\|$\\|#\\)")) - (condition-case nil - (progn - (up-list 1) - (if (and (<= (point) pp) - (eq (preceding-char) ?\} ) - (cperl-after-block-and-statement-beg (point-min))) - t - (goto-char p) - nil)) - (error nil))) - (progn - (forward-char -1) - (skip-chars-backward " \t") - (if (bolp) - ;; `}' was the first thing on the line, insert NL *after* it. - (progn - (cperl-indent-line parse-data) - (search-forward "}") - (delete-horizontal-space) - (insert "\n")) - (delete-horizontal-space) - (or (eq (preceding-char) ?\;) - (bolp) - (and (eq (preceding-char) ?\} ) - (cperl-after-block-p (point-min))) - (insert ";")) - (insert "\n") - (setq ret (point))) - (if (cperl-indent-line parse-data) - (setq ret (cperl-fix-line-spacing end parse-data))) - (beginning-of-line))))) - ret)) - -(defvar cperl-update-start) ; Do not need to make them local -(defvar cperl-update-end) -(defun cperl-delay-update-hook (beg end old-len) - (setq cperl-update-start (min beg (or cperl-update-start (point-max)))) - (setq cperl-update-end (max end (or cperl-update-end (point-min))))) - -(defun cperl-indent-region (start end) - "Simple variant of indentation of region in CPerl mode. -Should be slow. Will not indent comment if it starts at `comment-indent' -or looks like continuation of the comment on the previous line. -Indents all the lines whose first character is between START and END -inclusive. - -If `cperl-indent-region-fix-constructs', will improve spacing on -conditional/loop constructs." - (interactive "r") - (cperl-update-syntaxification end end) - (save-excursion - (let (cperl-update-start cperl-update-end (h-a-c after-change-functions)) - (let ((indent-info (if cperl-emacs-can-parse - (list nil nil nil) ; Cannot use '(), since will modify - nil)) - (pm 0) - after-change-functions ; Speed it up! - st comm old-comm-indent new-comm-indent p pp i empty) - (if h-a-c (add-hook 'after-change-functions 'cperl-delay-update-hook)) - (goto-char start) - (setq old-comm-indent (and (cperl-to-comment-or-eol) - (current-column)) - new-comm-indent old-comm-indent) - (goto-char start) - (setq end (set-marker (make-marker) end)) ; indentation changes pos - (or (bolp) (beginning-of-line 2)) - (while (and (<= (point) end) (not (eobp))) ; bol to check start - (setq st (point)) - (if (or - (setq empty (looking-at "[ \t]*\n")) - (and (setq comm (looking-at "[ \t]*#")) - (or (eq (current-indentation) (or old-comm-indent - comment-column)) - (setq old-comm-indent nil)))) - (if (and old-comm-indent - (not empty) - (= (current-indentation) old-comm-indent) - (not (eq (get-text-property (point) 'syntax-type) 'pod)) - (not (eq (get-text-property (point) 'syntax-table) - cperl-st-cfence))) - (let ((comment-column new-comm-indent)) - (indent-for-comment))) - (progn - (setq i (cperl-indent-line indent-info)) - (or comm - (not i) - (progn - (if cperl-indent-region-fix-constructs - (goto-char (cperl-fix-line-spacing end indent-info))) - (if (setq old-comm-indent - (and (cperl-to-comment-or-eol) - (not (memq (get-text-property (point) - 'syntax-type) - '(pod here-doc))) - (not (eq (get-text-property (point) - 'syntax-table) - cperl-st-cfence)) - (current-column))) - (progn (indent-for-comment) - (skip-chars-backward " \t") - (skip-chars-backward "#") - (setq new-comm-indent (current-column)))))))) - (beginning-of-line 2))) - ;; Now run the update hooks - (and after-change-functions - cperl-update-end - (save-excursion - (goto-char cperl-update-end) - (insert " ") - (delete-char -1) - (goto-char cperl-update-start) - (insert " ") - (delete-char -1)))))) - -;; Stolen from lisp-mode with a lot of improvements - -(defun cperl-fill-paragraph (&optional justify iteration) - "Like `fill-paragraph', but handle CPerl comments. -If any of the current line is a comment, fill the comment or the -block of it that point is in, preserving the comment's initial -indentation and initial hashes. Behaves usually outside of comment." - ;; (interactive "P") ; Only works when called from fill-paragraph. -stef - (let (;; Non-nil if the current line contains a comment. - has-comment - fill-paragraph-function ; do not recurse - ;; If has-comment, the appropriate fill-prefix for the comment. - comment-fill-prefix - ;; Line that contains code and comment (or nil) - start - c spaces len dc (comment-column comment-column)) - ;; Figure out what kind of comment we are looking at. - (save-excursion - (beginning-of-line) - (cond - - ;; A line with nothing but a comment on it? - ((looking-at "[ \t]*#[# \t]*") - (setq has-comment t - comment-fill-prefix (buffer-substring (match-beginning 0) - (match-end 0)))) - - ;; A line with some code, followed by a comment? Remember that the - ;; semi which starts the comment shouldn't be part of a string or - ;; character. - ((cperl-to-comment-or-eol) - (setq has-comment t) - (looking-at "#+[ \t]*") - (setq start (point) c (current-column) - comment-fill-prefix - (concat (make-string (current-column) ?\s) - (buffer-substring (match-beginning 0) (match-end 0))) - spaces (progn (skip-chars-backward " \t") - (buffer-substring (point) start)) - dc (- c (current-column)) len (- start (point)) - start (point-marker)) - (delete-char len) - (insert (make-string dc ?-))))) ; Placeholder (to avoid splitting???) - (if (not has-comment) - (fill-paragraph justify) ; Do the usual thing outside of comment - ;; Narrow to include only the comment, and then fill the region. - (save-restriction - (narrow-to-region - ;; Find the first line we should include in the region to fill. - (if start (progn (beginning-of-line) (point)) - (save-excursion - (while (and (zerop (forward-line -1)) - (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]"))) - ;; We may have gone to far. Go forward again. - (or (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]") - (forward-line 1)) - (point))) - ;; Find the beginning of the first line past the region to fill. - (save-excursion - (while (progn (forward-line 1) - (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]"))) - (point))) - ;; Remove existing hashes - (save-excursion - (goto-char (point-min)) - (while (progn (forward-line 1) (< (point) (point-max))) - (skip-chars-forward " \t") - (if (looking-at "#+") - (progn - (if (and (eq (point) (match-beginning 0)) - (not (eq (point) (match-end 0)))) nil - (error - "Bug in Emacs: `looking-at' in `narrow-to-region': match-data is garbage")) - (delete-char (- (match-end 0) (match-beginning 0))))))) - - ;; Lines with only hashes on them can be paragraph boundaries. - (let ((paragraph-start (concat paragraph-start "\\|^[ \t#]*$")) - (paragraph-separate (concat paragraph-start "\\|^[ \t#]*$")) - (fill-prefix comment-fill-prefix)) - (fill-paragraph justify))) - (if (and start) - (progn - (goto-char start) - (if (> dc 0) - (progn (delete-char dc) (insert spaces))) - (if (or (= (current-column) c) iteration) nil - (setq comment-column c) - (indent-for-comment) - ;; Repeat once more, flagging as iteration - (cperl-fill-paragraph justify t)))))) - t) - -(defun cperl-do-auto-fill () - ;; Break out if the line is short enough - (if (> (save-excursion - (end-of-line) - (current-column)) - fill-column) - (let ((c (save-excursion (beginning-of-line) - (cperl-to-comment-or-eol) (point))) - (s (memq (following-char) '(?\s ?\t))) marker) - (if (>= c (point)) - ;; Don't break line inside code: only inside comment. - nil - (setq marker (point-marker)) - (fill-paragraph nil) - (goto-char marker) - ;; Is not enough, sometimes marker is a start of line - (if (bolp) (progn (re-search-forward "#+[ \t]*") - (goto-char (match-end 0)))) - ;; Following space could have gone: - (if (or (not s) (memq (following-char) '(?\s ?\t))) nil - (insert " ") - (backward-char 1)) - ;; Previous space could have gone: - (or (memq (preceding-char) '(?\s ?\t)) (insert " ")))))) - -(defun cperl-imenu-addback (lst &optional isback name) - ;; We suppose that the lst is a DAG, unless the first element only - ;; loops back, and ISBACK is set. Thus this function cannot be - ;; applied twice without ISBACK set. - (cond ((not cperl-imenu-addback) lst) - (t - (or name - (setq name "+++BACK+++")) - (mapc (lambda (elt) - (if (and (listp elt) (listp (cdr elt))) - (progn - ;; In the other order it goes up - ;; one level only ;-( - (setcdr elt (cons (cons name lst) - (cdr elt))) - (cperl-imenu-addback (cdr elt) t name)))) - (if isback (cdr lst) lst)) - lst))) - -(defun cperl-imenu--create-perl-index (&optional regexp) - (require 'imenu) ; May be called from TAGS creator - (let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '()) - (index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function)) - (index-meth-alist '()) meth - packages ends-ranges p marker is-proto - (prev-pos 0) is-pack index index1 name (end-range 0) package) - (goto-char (point-min)) - (cperl-update-syntaxification (point-max) (point-max)) - ;; Search for the function - (progn ;;save-match-data - (while (re-search-forward - (or regexp cperl-imenu--function-name-regexp-perl) - nil t) - ;; 2=package-group, 5=package-name 8=sub-name - (cond - ((and ; Skip some noise if building tags - (match-beginning 5) ; package name - ;;(eq (char-after (match-beginning 2)) ?p) ; package - (not (save-match-data - (looking-at "[ \t\n]*;")))) ; Plain text word 'package' - nil) - ((and - (or (match-beginning 2) - (match-beginning 8)) ; package or sub - ;; Skip if quoted (will not skip multi-line ''-strings :-(): - (null (get-text-property (match-beginning 1) 'syntax-table)) - (null (get-text-property (match-beginning 1) 'syntax-type)) - (null (get-text-property (match-beginning 1) 'in-pod))) - (setq is-pack (match-beginning 2)) - ;; (if (looking-at "([^()]*)[ \t\n\f]*") - ;; (goto-char (match-end 0))) ; Messes what follows - (setq meth nil - p (point)) - (while (and ends-ranges (>= p (car ends-ranges))) - ;; delete obsolete entries - (setq ends-ranges (cdr ends-ranges) packages (cdr packages))) - (setq package (or (car packages) "") - end-range (or (car ends-ranges) 0)) - (if is-pack ; doing "package" - (progn - (if (match-beginning 5) ; named package - (setq name (buffer-substring (match-beginning 5) - (match-end 5)) - name (progn - (set-text-properties 0 (length name) nil name) - name) - package (concat name "::") - name (concat "package " name)) - ;; Support nameless packages - (setq name "package;" package "")) - (setq end-range - (save-excursion - (parse-partial-sexp (point) (point-max) -1) (point)) - ends-ranges (cons end-range ends-ranges) - packages (cons package packages))) - (setq is-proto - (or (eq (following-char) ?\;) - (eq 0 (get-text-property (point) 'attrib-group))))) - ;; Skip this function name if it is a prototype declaration. - (if (and is-proto (not is-pack)) nil - (or is-pack - (setq name - (buffer-substring (match-beginning 8) (match-end 8))) - (set-text-properties 0 (length name) nil name)) - (setq marker (make-marker)) - (set-marker marker (match-end (if is-pack 2 8))) - (cond (is-pack nil) - ((string-match "[:']" name) - (setq meth t)) - ((> p end-range) nil) - (t - (setq name (concat package name) meth t))) - (setq index (cons name marker)) - (if is-pack - (push index index-pack-alist) - (push index index-alist)) - (if meth (push index index-meth-alist)) - (push index index-unsorted-alist))) - ((match-beginning 16) ; POD section - (setq name (buffer-substring (match-beginning 17) (match-end 17)) - marker (make-marker)) - (set-marker marker (match-beginning 17)) - (set-text-properties 0 (length name) nil name) - (setq name (concat (make-string - (* 3 (- (char-after (match-beginning 16)) ?1)) - ?\ ) - name) - index (cons name marker)) - (setq index1 (cons (concat "=" name) (cdr index))) - (push index index-pod-alist) - (push index1 index-unsorted-alist))))) - (setq index-alist - (if (default-value 'imenu-sort-function) - (sort index-alist (default-value 'imenu-sort-function)) - (nreverse index-alist))) - (and index-pod-alist - (push (cons "+POD headers+..." - (nreverse index-pod-alist)) - index-alist)) - (and (or index-pack-alist index-meth-alist) - (let ((lst index-pack-alist) hier-list pack elt group name) - ;; Remove "package ", reverse and uniquify. - (while lst - (setq elt (car lst) lst (cdr lst) name (substring (car elt) 8)) - (if (assoc name hier-list) nil - (setq hier-list (cons (cons name (cdr elt)) hier-list)))) - (setq lst index-meth-alist) - (while lst - (setq elt (car lst) lst (cdr lst)) - (cond ((string-match "\\(::\\|'\\)[_a-zA-Z0-9]+$" (car elt)) - (setq pack (substring (car elt) 0 (match-beginning 0))) - (if (setq group (assoc pack hier-list)) - (if (listp (cdr group)) - ;; Have some functions already - (setcdr group - (cons (cons (substring - (car elt) - (+ 2 (match-beginning 0))) - (cdr elt)) - (cdr group))) - (setcdr group (list (cons (substring - (car elt) - (+ 2 (match-beginning 0))) - (cdr elt))))) - (setq hier-list - (cons (cons pack - (list (cons (substring - (car elt) - (+ 2 (match-beginning 0))) - (cdr elt)))) - hier-list)))))) - (push (cons "+Hierarchy+..." - hier-list) - index-alist))) - (and index-pack-alist - (push (cons "+Packages+..." - (nreverse index-pack-alist)) - index-alist)) - (and (or index-pack-alist index-pod-alist - (default-value 'imenu-sort-function)) - index-unsorted-alist - (push (cons "+Unsorted List+..." - (nreverse index-unsorted-alist)) - index-alist)) - (cperl-imenu-addback index-alist))) - - -;; Suggested by Mark A. Hershberger -(defun cperl-outline-level () - (looking-at outline-regexp) - (cond ((not (match-beginning 1)) 0) ; beginning-of-file -;;;; 2=package-group, 5=package-name 8=sub-name 16=head-level - ((match-beginning 2) 0) ; package - ((match-beginning 8) 1) ; sub - ((match-beginning 16) - (- (char-after (match-beginning 16)) ?0)) ; headN ==> N - (t 5))) ; should not happen - - -(defun cperl-windowed-init () - "Initialization under windowed version." - (cond ((featurep 'ps-print) - (or cperl-faces-init - (progn - (and (boundp 'font-lock-multiline) - (setq cperl-font-lock-multiline t)) - (cperl-init-faces)))) - ((not cperl-faces-init) - (add-hook 'font-lock-mode-hook - (function - (lambda () - (if (memq major-mode '(perl-mode cperl-mode)) - (progn - (or cperl-faces-init (cperl-init-faces))))))) - (if (fboundp 'eval-after-load) - (eval-after-load - "ps-print" - '(or cperl-faces-init (cperl-init-faces))))))) - -(defvar cperl-font-lock-keywords-1 nil - "Additional expressions to highlight in Perl mode. Minimal set.") -(defvar cperl-font-lock-keywords nil - "Additional expressions to highlight in Perl mode. Default set.") -(defvar cperl-font-lock-keywords-2 nil - "Additional expressions to highlight in Perl mode. Maximal set") - -(defun cperl-load-font-lock-keywords () - (or cperl-faces-init (cperl-init-faces)) - cperl-font-lock-keywords) - -(defun cperl-load-font-lock-keywords-1 () - (or cperl-faces-init (cperl-init-faces)) - cperl-font-lock-keywords-1) - -(defun cperl-load-font-lock-keywords-2 () - (or cperl-faces-init (cperl-init-faces)) - cperl-font-lock-keywords-2) - -(defun cperl-init-faces-weak () - ;; Allow `cperl-find-pods-heres' to run. - (or (boundp 'font-lock-constant-face) - (cperl-force-face font-lock-constant-face - "Face for constant and label names")) - (or (boundp 'font-lock-warning-face) - (cperl-force-face font-lock-warning-face - "Face for things which should stand out")) - ;;(setq font-lock-constant-face 'font-lock-constant-face) - ) - -(defun cperl-init-faces () - (condition-case errs - (progn - (require 'font-lock) - (and (fboundp 'font-lock-fontify-anchored-keywords) - (featurep 'font-lock-extra) - (message "You have an obsolete package `font-lock-extra'. Install `choose-color'.")) - (let (t-font-lock-keywords t-font-lock-keywords-1 font-lock-anchored) - (if (fboundp 'font-lock-fontify-anchored-keywords) - (setq font-lock-anchored t)) - (setq - t-font-lock-keywords - (list - `("[ \t]+$" 0 ',cperl-invalid-face t) - (cons - (concat - "\\(^\\|[^$@%&\\]\\)\\<\\(" - (mapconcat - 'identity - '("if" "until" "while" "elsif" "else" - "given" "when" "default" "break" - "unless" "for" - "foreach" "continue" "exit" "die" "last" "goto" "next" - "redo" "return" "local" "exec" "sub" "method" "do" "dump" - "use" "our" - "require" "package" "eval" "my" "state" - "BEGIN" "END" "CHECK" "INIT" "UNITCHECK") - "\\|") ; Flow control - "\\)\\>") 2) ; was "\\)[ \n\t;():,\|&]" - ; In what follows we use `type' style - ; 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" "lock" "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" "sysopen" "sysread" "system" "syswrite" "tell" - ;; "telldir" "time" "times" "truncate" "uc" "ucfirst" - ;; "umask" "unlink" "unpack" "utime" "values" "vec" - ;; "wait" "waitpid" "wantarray" "warn" "write" "x" "xor" - "a\\(bs\\|ccept\\|tan2\\|larm\\|nd\\)\\|" - "b\\(in\\(d\\|mode\\)\\|less\\)\\|" - "c\\(h\\(r\\(\\|oot\\)\\|dir\\|mod\\|own\\)\\|aller\\|rypt\\|" - "lose\\(\\|dir\\)\\|mp\\|o\\(s\\|n\\(tinue\\|nect\\)\\)\\)\\|" - "CORE\\|d\\(ie\\|bm\\(close\\|open\\)\\|ump\\)\\|" - "e\\(x\\(p\\|it\\|ec\\)\\|q\\|nd\\(p\\(rotoent\\|went\\)\\|" - "hostent\\|servent\\|netent\\|grent\\)\\|of\\)\\|" - "f\\(ileno\\|cntl\\|lock\\|or\\(k\\|mline\\)\\)\\|" - "g\\(t\\|lob\\|mtime\\|e\\(\\|t\\(p\\(pid\\|r\\(iority\\|" - "oto\\(byn\\(ame\\|umber\\)\\|ent\\)\\)\\|eername\\|w" - "\\(uid\\|ent\\|nam\\)\\|grp\\)\\|host\\(by\\(addr\\|name\\)\\|" - "ent\\)\\|s\\(erv\\(by\\(port\\|name\\)\\|ent\\)\\|" - "ock\\(name\\|opt\\)\\)\\|c\\|login\\|net\\(by\\(addr\\|name\\)\\|" - "ent\\)\\|gr\\(ent\\|nam\\|gid\\)\\)\\)\\)\\|" - "hex\\|i\\(n\\(t\\|dex\\)\\|octl\\)\\|join\\|kill\\|" - "l\\(i\\(sten\\|nk\\)\\|stat\\|c\\(\\|first\\)\\|t\\|e" - "\\(\\|ngth\\)\\|o\\(c\\(altime\\|k\\)\\|g\\)\\)\\|m\\(sg\\(rcv\\|snd\\|" - "ctl\\|get\\)\\|kdir\\)\\|n\\(e\\|ot\\)\\|o\\(pen\\(\\|dir\\)\\|" - "r\\(\\|d\\)\\|ct\\)\\|p\\(ipe\\|ack\\)\\|quotemeta\\|" - "r\\(index\\|and\\|mdir\\|e\\(quire\\|ad\\(pipe\\|\\|lin" - "\\(k\\|e\\)\\|dir\\)\\|set\\|cv\\|verse\\|f\\|winddir\\|name" - "\\)\\)\\|s\\(printf\\|qrt\\|rand\\|tat\\|ubstr\\|e\\(t\\(p\\(r" - "\\(iority\\|otoent\\)\\|went\\|grp\\)\\|hostent\\|s\\(ervent\\|" - "ockopt\\)\\|netent\\|grent\\)\\|ek\\(\\|dir\\)\\|lect\\|" - "m\\(ctl\\|op\\|get\\)\\|nd\\)\\|h\\(utdown\\|m\\(read\\|ctl\\|" - "write\\|get\\)\\)\\|y\\(s\\(read\\|call\\|open\\|tem\\|write\\)\\|" - "mlink\\)\\|in\\|leep\\|ocket\\(pair\\|\\)\\)\\|t\\(runcate\\|" - "ell\\(\\|dir\\)\\|ime\\(\\|s\\)\\)\\|u\\(c\\(\\|first\\)\\|" - "time\\|mask\\|n\\(pack\\|link\\)\\)\\|v\\(alues\\|ec\\)\\|" - "w\\(a\\(rn\\|it\\(pid\\|\\)\\|ntarray\\)\\|rite\\)\\|" - "x\\(\\|or\\)\\|__\\(FILE__\\|LINE__\\|PACKAGE__\\)" - "\\)\\>") 2 'font-lock-type-face) - ;; In what follows we use `other' style - ;; for nonoverwritable builtins - ;; Somehow 's', 'm' are not auto-generated??? - (list - (concat - "\\(^\\|[^$@%&\\]\\)\\<\\(" - ;; "AUTOLOAD" "BEGIN" "CHECK" "DESTROY" "END" "INIT" "UNITCHECK" "__END__" "chomp" - ;; "break" "chop" "default" "defined" "delete" "do" "each" "else" "elsif" - ;; "eval" "exists" "for" "foreach" "format" "given" "goto" - ;; "grep" "if" "keys" "last" "local" "map" "my" "next" - ;; "no" "our" "package" "pop" "pos" "print" "printf" "push" - ;; "q" "qq" "qw" "qx" "redo" "return" "say" "scalar" "shift" - ;; "sort" "splice" "split" "state" "study" "sub" "tie" "tr" - ;; "undef" "unless" "unshift" "untie" "until" "use" - ;; "when" "while" "y" - "AUTOLOAD\\|BEGIN\\|\\(UNIT\\)?CHECK\\|break\\|cho\\(p\\|mp\\)\\|d\\(e\\(f\\(ault|ined\\)\\|lete\\)\\|" - "o\\)\\|DESTROY\\|e\\(ach\\|val\\|xists\\|ls\\(e\\|if\\)\\)\\|" - "END\\|for\\(\\|each\\|mat\\)\\|g\\(iven\\|rep\\|oto\\)\\|INIT\\|if\\|keys\\|" - "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|our\\|" - "p\\(ackage\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|" - "q\\(\\|q\\|w\\|x\\|r\\)\\|re\\(turn\\|do\\)\\|s\\(ay\\|pli\\(ce\\|t\\)\\|" - "calar\\|t\\(ate\\|udy\\)\\|ub\\|hift\\|ort\\)\\|t\\(r\\|ie\\)\\|" - "u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|" - "wh\\(en\\|ile\\)\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually - "\\|[sm]" ; Added manually - "\\)\\>") 2 'cperl-nonoverridable-face) - ;; (mapconcat 'identity - ;; '("#endif" "#else" "#ifdef" "#ifndef" "#if" - ;; "#include" "#define" "#undef") - ;; "\\|") - '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0 - font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]" - ;; This highlights declarations and definitions differenty. - ;; We do not try to highlight in the case of attributes: - ;; it is already done by `cperl-find-pods-heres' - (list (concat "\\<\\(?:sub\\|method\\)" - cperl-white-and-comment-rex ; whitespace/comments - "\\([^ \n\t{;()]+\\)" ; 2=name (assume non-anonymous) - "\\(" - cperl-maybe-white-and-comment-rex ;whitespace/comments? - "([^()]*)\\)?" ; prototype - cperl-maybe-white-and-comment-rex ; whitespace/comments? - "[{;]") - 2 (if cperl-font-lock-multiline - '(if (eq (char-after (cperl-1- (match-end 0))) ?\{ ) - 'font-lock-function-name-face - 'font-lock-variable-name-face) - ;; need to manually set 'multiline' for older font-locks - '(progn - (if (< 1 (count-lines (match-beginning 0) - (match-end 0))) - (put-text-property - (+ 3 (match-beginning 0)) (match-end 0) - 'syntax-type 'multiline)) - (if (eq (char-after (cperl-1- (match-end 0))) ?\{ ) - 'font-lock-function-name-face - 'font-lock-variable-name-face)))) - '("\\<\\(package\\|require\\|use\\|import\\|no\\|bootstrap\\)[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t;]" ; require A if B; - 2 font-lock-function-name-face) - '("^[ \t]*format[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t]*=[ \t]*$" - 1 font-lock-function-name-face) - (cond ((featurep 'font-lock-extra) - '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" - (2 font-lock-string-face t) - (0 '(restart 2 t)))) ; To highlight $a{bc}{ef} - (font-lock-anchored - '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" - (2 font-lock-string-face t) - ("\\=[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" - nil nil - (1 font-lock-string-face t)))) - (t '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" - 2 font-lock-string-face t))) - '("[\[ \t{,(]\\(-?[a-zA-Z0-9_:]+\\)[ \t]*=>" 1 - font-lock-string-face t) - '("^[ \t]*\\([a-zA-Z0-9_]+[ \t]*:\\)[ \t]*\\($\\|{\\|\\<\\(until\\|while\\|for\\(each\\)?\\|do\\)\\>\\)" 1 - font-lock-constant-face) ; labels - '("\\<\\(continue\\|next\\|last\\|redo\\|break\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets - 2 font-lock-constant-face) - ;; Uncomment to get perl-mode-like vars - ;;; '("[$*]{?\\(\\sw+\\)" 1 font-lock-variable-name-face) - ;;; '("\\([@%]\\|\\$#\\)\\(\\sw+\\)" - ;;; (2 (cons font-lock-variable-name-face '(underline)))) - (cond ((featurep 'font-lock-extra) - '("^[ \t]*\\(state\\|my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" - (3 font-lock-variable-name-face) - (4 '(another 4 nil - ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" - (1 font-lock-variable-name-face) - (2 '(restart 2 nil) nil t))) - nil t))) ; local variables, multiple - (font-lock-anchored - ;; 1=my_etc, 2=white? 3=(+white? 4=white? 5=var - `(,(concat "\\<\\(state\\|my\\|local\\|our\\)" - cperl-maybe-white-and-comment-rex - "\\((" - cperl-maybe-white-and-comment-rex - "\\)?\\([$@%*]\\([a-zA-Z0-9_:]+\\|[^a-zA-Z0-9_]\\)\\)") - (5 ,(if cperl-font-lock-multiline - 'font-lock-variable-name-face - '(progn (setq cperl-font-lock-multiline-start - (match-beginning 0)) - 'font-lock-variable-name-face))) - (,(concat "\\=" - cperl-maybe-white-and-comment-rex - "," - cperl-maybe-white-and-comment-rex - "\\([$@%*]\\([a-zA-Z0-9_:]+\\|[^a-zA-Z0-9_]\\)\\)") - ;; Bug in font-lock: limit is used not only to limit - ;; searches, but to set the "extend window for - ;; facification" property. Thus we need to minimize. - ,(if cperl-font-lock-multiline - '(if (match-beginning 3) - (save-excursion - (goto-char (match-beginning 3)) - (condition-case nil - (forward-sexp 1) - (error - (condition-case nil - (forward-char 200) - (error nil)))) ; typeahead - (1- (point))) ; report limit - (forward-char -2)) ; disable continued expr - '(if (match-beginning 3) - (point-max) ; No limit for continuation - (forward-char -2))) ; disable continued expr - ,(if cperl-font-lock-multiline - nil - '(progn ; Do at end - ;; "my" may be already fontified (POD), - ;; so cperl-font-lock-multiline-start is nil - (if (or (not cperl-font-lock-multiline-start) - (> 2 (count-lines - cperl-font-lock-multiline-start - (point)))) - nil - (put-text-property - (1+ cperl-font-lock-multiline-start) (point) - 'syntax-type 'multiline)) - (setq cperl-font-lock-multiline-start nil))) - (3 font-lock-variable-name-face)))) - (t '("^[ \t{}]*\\(state\\|my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" - 3 font-lock-variable-name-face))) - '("\\= 19.12 - ;; ((fboundp 'valid-color-name-p) 'valid-color-name-p) - ;; ;; XEmacs 19.11 - ;; (t 'x-valid-color-name-p)))) - (cperl-force-face font-lock-constant-face - "Face for constant and label names") - (cperl-force-face font-lock-variable-name-face - "Face for variable names") - (cperl-force-face font-lock-type-face - "Face for data types") - (cperl-force-face cperl-nonoverridable-face - "Face for data types from another group") - (cperl-force-face font-lock-warning-face - "Face for things which should stand out") - (cperl-force-face font-lock-comment-face - "Face for comments") - (cperl-force-face font-lock-function-name-face - "Face for function names") - (cperl-force-face cperl-hash-face - "Face for hashes") - (cperl-force-face cperl-array-face - "Face for arrays") - ;;(defvar font-lock-constant-face 'font-lock-constant-face) - ;;(defvar font-lock-variable-name-face 'font-lock-variable-name-face) - ;;(or (boundp 'font-lock-type-face) - ;; (defconst font-lock-type-face - ;; 'font-lock-type-face - ;; "Face to use for data types.")) - ;;(or (boundp 'cperl-nonoverridable-face) - ;; (defconst cperl-nonoverridable-face - ;; 'cperl-nonoverridable-face - ;; "Face to use for data types from another group.")) - ;;(if (not (featurep 'xemacs)) nil - ;; (or (boundp 'font-lock-comment-face) - ;; (defconst font-lock-comment-face - ;; 'font-lock-comment-face - ;; "Face to use for comments.")) - ;; (or (boundp 'font-lock-keyword-face) - ;; (defconst font-lock-keyword-face - ;; 'font-lock-keyword-face - ;; "Face to use for keywords.")) - ;; (or (boundp 'font-lock-function-name-face) - ;; (defconst font-lock-function-name-face - ;; 'font-lock-function-name-face - ;; "Face to use for function names."))) - (if (and - (not (cperl-is-face 'cperl-array-face)) - (cperl-is-face 'font-lock-emphasized-face)) - (copy-face 'font-lock-emphasized-face 'cperl-array-face)) - (if (and - (not (cperl-is-face 'cperl-hash-face)) - (cperl-is-face 'font-lock-other-emphasized-face)) - (copy-face 'font-lock-other-emphasized-face 'cperl-hash-face)) - (if (and - (not (cperl-is-face 'cperl-nonoverridable-face)) - (cperl-is-face 'font-lock-other-type-face)) - (copy-face 'font-lock-other-type-face 'cperl-nonoverridable-face)) - ;;(or (boundp 'cperl-hash-face) - ;; (defconst cperl-hash-face - ;; 'cperl-hash-face - ;; "Face to use for hashes.")) - ;;(or (boundp 'cperl-array-face) - ;; (defconst cperl-array-face - ;; 'cperl-array-face - ;; "Face to use for arrays.")) - ;; Here we try to guess background - (let ((background - (if (boundp 'font-lock-background-mode) - font-lock-background-mode - 'light)) - (face-list (and (fboundp 'face-list) (face-list)))) -;;;; (fset 'cperl-is-face -;;;; (cond ((fboundp 'find-face) -;;;; (symbol-function 'find-face)) -;;;; (face-list -;;;; (function (lambda (face) (member face face-list)))) -;;;; (t -;;;; (function (lambda (face) (boundp face)))))) - (defvar cperl-guessed-background - (if (and (boundp 'font-lock-display-type) - (eq font-lock-display-type 'grayscale)) - 'gray - background) - "Background as guessed by CPerl mode") - (and (not (cperl-is-face 'font-lock-constant-face)) - (cperl-is-face 'font-lock-reference-face) - (copy-face 'font-lock-reference-face 'font-lock-constant-face)) - (if (cperl-is-face 'font-lock-type-face) nil - (copy-face 'default 'font-lock-type-face) - (cond - ((eq background 'light) - (set-face-foreground 'font-lock-type-face - (if (x-color-defined-p "seagreen") - "seagreen" - "sea green"))) - ((eq background 'dark) - (set-face-foreground 'font-lock-type-face - (if (x-color-defined-p "os2pink") - "os2pink" - "pink"))) - (t - (set-face-background 'font-lock-type-face "gray90")))) - (if (cperl-is-face 'cperl-nonoverridable-face) - nil - (copy-face 'font-lock-type-face 'cperl-nonoverridable-face) - (cond - ((eq background 'light) - (set-face-foreground 'cperl-nonoverridable-face - (if (x-color-defined-p "chartreuse3") - "chartreuse3" - "chartreuse"))) - ((eq background 'dark) - (set-face-foreground 'cperl-nonoverridable-face - (if (x-color-defined-p "orchid1") - "orchid1" - "orange"))))) -;;; (if (cperl-is-face 'font-lock-other-emphasized-face) nil -;;; (copy-face 'bold-italic 'font-lock-other-emphasized-face) -;;; (cond -;;; ((eq background 'light) -;;; (set-face-background 'font-lock-other-emphasized-face -;;; (if (x-color-defined-p "lightyellow2") -;;; "lightyellow2" -;;; (if (x-color-defined-p "lightyellow") -;;; "lightyellow" -;;; "light yellow")))) -;;; ((eq background 'dark) -;;; (set-face-background 'font-lock-other-emphasized-face -;;; (if (x-color-defined-p "navy") -;;; "navy" -;;; (if (x-color-defined-p "darkgreen") -;;; "darkgreen" -;;; "dark green")))) -;;; (t (set-face-background 'font-lock-other-emphasized-face "gray90")))) -;;; (if (cperl-is-face 'font-lock-emphasized-face) nil -;;; (copy-face 'bold 'font-lock-emphasized-face) -;;; (cond -;;; ((eq background 'light) -;;; (set-face-background 'font-lock-emphasized-face -;;; (if (x-color-defined-p "lightyellow2") -;;; "lightyellow2" -;;; "lightyellow"))) -;;; ((eq background 'dark) -;;; (set-face-background 'font-lock-emphasized-face -;;; (if (x-color-defined-p "navy") -;;; "navy" -;;; (if (x-color-defined-p "darkgreen") -;;; "darkgreen" -;;; "dark green")))) -;;; (t (set-face-background 'font-lock-emphasized-face "gray90")))) - (if (cperl-is-face 'font-lock-variable-name-face) nil - (copy-face 'italic 'font-lock-variable-name-face)) - (if (cperl-is-face 'font-lock-constant-face) nil - (copy-face 'italic 'font-lock-constant-face)))) - (setq cperl-faces-init t)) - (error (message "cperl-init-faces (ignored): %s" errs)))) - - -(defun cperl-ps-print-init () - "Initialization of `ps-print' components for faces used in CPerl." - (eval-after-load "ps-print" - '(setq ps-bold-faces - ;; font-lock-variable-name-face - ;; font-lock-constant-face - (append '(cperl-array-face cperl-hash-face) - ps-bold-faces) - ps-italic-faces - ;; font-lock-constant-face - (append '(cperl-nonoverridable-face cperl-hash-face) - ps-italic-faces) - ps-underlined-faces - ;; font-lock-type-face - (append '(cperl-array-face cperl-hash-face underline cperl-nonoverridable-face) - ps-underlined-faces)))) - -(defvar ps-print-face-extension-alist) - -(defun cperl-ps-print (&optional file) - "Pretty-print in CPerl style. -If optional argument FILE is an empty string, prints to printer, otherwise -to the file FILE. If FILE is nil, prompts for a file name. - -Style of printout regulated by the variable `cperl-ps-print-face-properties'." - (interactive) - (or file - (setq file (read-from-minibuffer - "Print to file (if empty - to printer): " - (concat (buffer-file-name) ".ps") - nil nil 'file-name-history))) - (or (> (length file) 0) - (setq file nil)) - (require 'ps-print) ; To get ps-print-face-extension-alist - (let ((ps-print-color-p t) - (ps-print-face-extension-alist ps-print-face-extension-alist)) - (cperl-ps-extend-face-list cperl-ps-print-face-properties) - (ps-print-buffer-with-faces file))) - -;;; (defun cperl-ps-print-init () -;;; "Initialization of `ps-print' components for faces used in CPerl." -;;; ;; Guard against old versions -;;; (defvar ps-underlined-faces nil) -;;; (defvar ps-bold-faces nil) -;;; (defvar ps-italic-faces nil) -;;; (setq ps-bold-faces -;;; (append '(font-lock-emphasized-face -;;; cperl-array-face -;;; font-lock-keyword-face -;;; font-lock-variable-name-face -;;; font-lock-constant-face -;;; font-lock-reference-face -;;; font-lock-other-emphasized-face -;;; cperl-hash-face) -;;; ps-bold-faces)) -;;; (setq ps-italic-faces -;;; (append '(cperl-nonoverridable-face -;;; font-lock-constant-face -;;; font-lock-reference-face -;;; font-lock-other-emphasized-face -;;; cperl-hash-face) -;;; ps-italic-faces)) -;;; (setq ps-underlined-faces -;;; (append '(font-lock-emphasized-face -;;; cperl-array-face -;;; font-lock-other-emphasized-face -;;; cperl-hash-face -;;; cperl-nonoverridable-face font-lock-type-face) -;;; ps-underlined-faces)) -;;; (cons 'font-lock-type-face ps-underlined-faces)) - - -(if (cperl-enable-font-lock) (cperl-windowed-init)) - -(defconst cperl-styles-entries - '(cperl-indent-level cperl-brace-offset cperl-continued-brace-offset - cperl-label-offset cperl-extra-newline-before-brace - cperl-extra-newline-before-brace-multiline - cperl-merge-trailing-else - cperl-continued-statement-offset)) - -(defconst cperl-style-examples -"##### Numbers etc are: cperl-indent-level cperl-brace-offset -##### cperl-continued-brace-offset cperl-label-offset -##### cperl-continued-statement-offset -##### cperl-merge-trailing-else cperl-extra-newline-before-brace - -########### (Do not forget cperl-extra-newline-before-brace-multiline) - -### CPerl (=GNU - extra-newline-before-brace + merge-trailing-else) 2/0/0/-2/2/t/nil -if (foo) { - bar - baz; - label: - { - boon; - } -} else { - stop; -} - -### PerlStyle (=CPerl with 4 as indent) 4/0/0/-4/4/t/nil -if (foo) { - bar - baz; - label: - { - boon; - } -} else { - stop; -} - -### GNU 2/0/0/-2/2/nil/t -if (foo) - { - bar - baz; - label: - { - boon; - } - } -else - { - stop; - } - -### C++ (=PerlStyle with braces aligned with control words) 4/0/-4/-4/4/nil/t -if (foo) -{ - bar - baz; - label: - { - boon; - } -} -else -{ - stop; -} - -### BSD (=C++, but will not change preexisting merge-trailing-else -### and extra-newline-before-brace ) 4/0/-4/-4/4 -if (foo) -{ - bar - baz; - label: - { - boon; - } -} -else -{ - stop; -} - -### K&R (=C++ with indent 5 - merge-trailing-else, but will not -### change preexisting extra-newline-before-brace) 5/0/-5/-5/5/nil -if (foo) -{ - bar - baz; - label: - { - boon; - } -} -else -{ - stop; -} - -### Whitesmith (=PerlStyle, but will not change preexisting -### extra-newline-before-brace and merge-trailing-else) 4/0/0/-4/4 -if (foo) - { - bar - baz; - label: - { - boon; - } - } -else - { - stop; - } -" -"Examples of if/else with different indent styles (with v4.23).") - -(defconst cperl-style-alist - '(("CPerl" ;; =GNU - extra-newline-before-brace + cperl-merge-trailing-else - (cperl-indent-level . 2) - (cperl-brace-offset . 0) - (cperl-continued-brace-offset . 0) - (cperl-label-offset . -2) - (cperl-continued-statement-offset . 2) - (cperl-extra-newline-before-brace . nil) - (cperl-extra-newline-before-brace-multiline . nil) - (cperl-merge-trailing-else . t)) - - ("PerlStyle" ; CPerl with 4 as indent - (cperl-indent-level . 4) - (cperl-brace-offset . 0) - (cperl-continued-brace-offset . 0) - (cperl-label-offset . -4) - (cperl-continued-statement-offset . 4) - (cperl-extra-newline-before-brace . nil) - (cperl-extra-newline-before-brace-multiline . nil) - (cperl-merge-trailing-else . t)) - - ("GNU" - (cperl-indent-level . 2) - (cperl-brace-offset . 0) - (cperl-continued-brace-offset . 0) - (cperl-label-offset . -2) - (cperl-continued-statement-offset . 2) - (cperl-extra-newline-before-brace . t) - (cperl-extra-newline-before-brace-multiline . t) - (cperl-merge-trailing-else . nil)) - - ("K&R" - (cperl-indent-level . 5) - (cperl-brace-offset . 0) - (cperl-continued-brace-offset . -5) - (cperl-label-offset . -5) - (cperl-continued-statement-offset . 5) - ;;(cperl-extra-newline-before-brace . nil) ; ??? - ;;(cperl-extra-newline-before-brace-multiline . nil) - (cperl-merge-trailing-else . nil)) - - ("BSD" - (cperl-indent-level . 4) - (cperl-brace-offset . 0) - (cperl-continued-brace-offset . -4) - (cperl-label-offset . -4) - (cperl-continued-statement-offset . 4) - ;;(cperl-extra-newline-before-brace . nil) ; ??? - ;;(cperl-extra-newline-before-brace-multiline . nil) - ;;(cperl-merge-trailing-else . nil) ; ??? - ) - - ("C++" - (cperl-indent-level . 4) - (cperl-brace-offset . 0) - (cperl-continued-brace-offset . -4) - (cperl-label-offset . -4) - (cperl-continued-statement-offset . 4) - (cperl-extra-newline-before-brace . t) - (cperl-extra-newline-before-brace-multiline . t) - (cperl-merge-trailing-else . nil)) - - ("Whitesmith" - (cperl-indent-level . 4) - (cperl-brace-offset . 0) - (cperl-continued-brace-offset . 0) - (cperl-label-offset . -4) - (cperl-continued-statement-offset . 4) - ;;(cperl-extra-newline-before-brace . nil) ; ??? - ;;(cperl-extra-newline-before-brace-multiline . nil) - ;;(cperl-merge-trailing-else . nil) ; ??? - ) - ("Current")) - "List of variables to set to get a particular indentation style. -Should be used via `cperl-set-style' or via Perl menu. - -See examples in `cperl-style-examples'.") - -(defun cperl-set-style (style) - "Set CPerl mode variables to use one of several different indentation styles. -The arguments are a string representing the desired style. -The list of styles is in `cperl-style-alist', available styles -are CPerl, PerlStyle, GNU, K&R, BSD, C++ and Whitesmith. - -The current value of style is memorized (unless there is a memorized -data already), may be restored by `cperl-set-style-back'. - -Chosing \"Current\" style will not change style, so this may be used for -side-effect of memorizing only. Examples in `cperl-style-examples'." - (interactive - (let ((list (mapcar (function (lambda (elt) (list (car elt)))) - cperl-style-alist))) - (list (completing-read "Enter style: " list nil 'insist)))) - (or cperl-old-style - (setq cperl-old-style - (mapcar (function - (lambda (name) - (cons name (eval name)))) - cperl-styles-entries))) - (let ((style (cdr (assoc style cperl-style-alist))) setting str sym) - (while style - (setq setting (car style) style (cdr style)) - (set (car setting) (cdr setting))))) - -(defun cperl-set-style-back () - "Restore a style memorized by `cperl-set-style'." - (interactive) - (or cperl-old-style (error "The style was not changed")) - (let (setting) - (while cperl-old-style - (setq setting (car cperl-old-style) - cperl-old-style (cdr cperl-old-style)) - (set (car setting) (cdr setting))))) - -(defun cperl-check-syntax () - (interactive) - (require 'mode-compile) - (let ((perl-dbg-flags (concat cperl-extra-perl-args " -wc"))) - (eval '(mode-compile)))) ; Avoid a warning - -(defun cperl-info-buffer (type) - ;; Returns buffer with documentation. Creates if missing. - ;; If TYPE, this vars buffer. - ;; Special care is taken to not stomp over an existing info buffer - (let* ((bname (if type "*info-perl-var*" "*info-perl*")) - (info (get-buffer bname)) - (oldbuf (get-buffer "*info*"))) - (if info info - (save-window-excursion - ;; Get Info running - (require 'info) - (cond (oldbuf - (set-buffer oldbuf) - (rename-buffer "*info-perl-tmp*"))) - (save-window-excursion - (info)) - (Info-find-node cperl-info-page (if type "perlvar" "perlfunc")) - (set-buffer "*info*") - (rename-buffer bname) - (cond (oldbuf - (set-buffer "*info-perl-tmp*") - (rename-buffer "*info*") - (set-buffer bname))) - (make-local-variable 'window-min-height) - (setq window-min-height 2) - (current-buffer))))) - -(defun cperl-word-at-point (&optional p) - "Return the word at point or at P." - (save-excursion - (if p (goto-char p)) - (or (cperl-word-at-point-hard) - (progn - (require 'etags) - (funcall (or (and (boundp 'find-tag-default-function) - find-tag-default-function) - (get major-mode 'find-tag-default-function) - ;; XEmacs 19.12 has `find-tag-default-hook'; it is - ;; automatically used within `find-tag-default': - 'find-tag-default)))))) - -(defun cperl-info-on-command (command) - "Show documentation for Perl command COMMAND in other window. -If perl-info buffer is shown in some frame, uses this frame. -Customized by setting variables `cperl-shrink-wrap-info-frame', -`cperl-max-help-size'." - (interactive - (let* ((default (cperl-word-at-point)) - (read (read-string - (format "Find doc for Perl function (default %s): " - default)))) - (list (if (equal read "") - default - read)))) - - (let ((buffer (current-buffer)) - (cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///" - pos isvar height iniheight frheight buf win fr1 fr2 iniwin not-loner - max-height char-height buf-list) - (if (string-match "^-[a-zA-Z]$" command) - (setq cmd-desc "^-X[ \t\n]")) - (setq isvar (string-match "^[$@%]" command) - buf (cperl-info-buffer isvar) - iniwin (selected-window) - fr1 (window-frame iniwin)) - (set-buffer buf) - (goto-char (point-min)) - (or isvar - (progn (re-search-forward "^-X[ \t\n]") - (forward-line -1))) - (if (re-search-forward cmd-desc nil t) - (progn - ;; Go back to beginning of the group (ex, for qq) - (if (re-search-backward "^[ \t\n\f]") - (forward-line 1)) - (beginning-of-line) - ;; Get some of - (setq pos (point) - buf-list (list buf "*info-perl-var*" "*info-perl*")) - (while (and (not win) buf-list) - (setq win (get-buffer-window (car buf-list) t)) - (setq buf-list (cdr buf-list))) - (or (not win) - (eq (window-buffer win) buf) - (set-window-buffer win buf)) - (and win (setq fr2 (window-frame win))) - (if (or (not fr2) (eq fr1 fr2)) - (pop-to-buffer buf) - (special-display-popup-frame buf) ; Make it visible - (select-window win)) - (goto-char pos) ; Needed (?!). - ;; Resize - (setq iniheight (window-height) - frheight (frame-height) - not-loner (< iniheight (1- frheight))) ; Are not alone - (cond ((if not-loner cperl-max-help-size - cperl-shrink-wrap-info-frame) - (setq height - (+ 2 - (count-lines - pos - (save-excursion - (if (re-search-forward - "^[ \t][^\n]*\n+\\([^ \t\n\f]\\|\\'\\)" nil t) - (match-beginning 0) (point-max))))) - max-height - (if not-loner - (/ (* (- frheight 3) cperl-max-help-size) 100) - (setq char-height (frame-char-height)) - ;; Non-functioning under OS/2: - (if (eq char-height 1) (setq char-height 18)) - ;; Title, menubar, + 2 for slack - (- (/ (x-display-pixel-height) char-height) 4))) - (if (> height max-height) (setq height max-height)) - ;;(message "was %s doing %s" iniheight height) - (if not-loner - (enlarge-window (- height iniheight)) - (set-frame-height (window-frame win) (1+ height))))) - (set-window-start (selected-window) pos)) - (message "No entry for %s found." command)) - ;;(pop-to-buffer buffer) - (select-window iniwin))) - -(defun cperl-info-on-current-command () - "Show documentation for Perl command at point in other window." - (interactive) - (cperl-info-on-command (cperl-word-at-point))) - -(defun cperl-imenu-info-imenu-search () - (if (looking-at "^-X[ \t\n]") nil - (re-search-backward - "^\n\\([-a-zA-Z_]+\\)[ \t\n]") - (forward-line 1))) - -(defun cperl-imenu-info-imenu-name () - (buffer-substring - (match-beginning 1) (match-end 1))) - -(defun cperl-imenu-on-info () - "Shows imenu for Perl Info Buffer. -Opens Perl Info buffer if needed." - (interactive) - (let* ((buffer (current-buffer)) - imenu-create-index-function - imenu-prev-index-position-function - imenu-extract-index-name-function - (index-item (save-restriction - (save-window-excursion - (set-buffer (cperl-info-buffer nil)) - (setq imenu-create-index-function - 'imenu-default-create-index-function - imenu-prev-index-position-function - 'cperl-imenu-info-imenu-search - imenu-extract-index-name-function - 'cperl-imenu-info-imenu-name) - (imenu-choose-buffer-index))))) - (and index-item - (progn - (push-mark) - (pop-to-buffer "*info-perl*") - (cond - ((markerp (cdr index-item)) - (goto-char (marker-position (cdr index-item)))) - (t - (goto-char (cdr index-item)))) - (set-window-start (selected-window) (point)) - (pop-to-buffer buffer))))) - -(defun cperl-lineup (beg end &optional step minshift) - "Lineup construction in a region. -Beginning of region should be at the start of a construction. -All first 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. -STEP is the tabwidth to position constructions. -If STEP is nil, `cperl-lineup-step' will be used -\(or `cperl-indent-level', if `cperl-lineup-step' is nil). -Will not move the position at the start to the left." - (interactive "r") - (let (search col tcol seen b) - (save-excursion - (goto-char end) - (end-of-line) - (setq end (point-marker)) - (goto-char beg) - (skip-chars-forward " \t\f") - (setq beg (point-marker)) - (indent-region beg end nil) - (goto-char beg) - (setq col (current-column)) - (if (looking-at "[a-zA-Z0-9_]") - (if (looking-at "\\<[a-zA-Z0-9_]+\\>") - (setq search - (concat "\\<" - (regexp-quote - (buffer-substring (match-beginning 0) - (match-end 0))) "\\>")) - (error "Cannot line up in a middle of the word")) - (if (looking-at "$") - (error "Cannot line up end of line")) - (setq search (regexp-quote (char-to-string (following-char))))) - (setq step (or step cperl-lineup-step cperl-indent-level)) - (or minshift (setq minshift 1)) - (while (progn - (beginning-of-line 2) - (and (< (point) end) - (re-search-forward search end t) - (goto-char (match-beginning 0)))) - (setq tcol (current-column) seen t) - (if (> tcol col) (setq col tcol))) - (or seen - (error "The construction to line up occurred only once")) - (goto-char beg) - (setq col (+ col minshift)) - (if (/= (% col step) 0) (setq step (* step (1+ (/ col step))))) - (while - (progn - (cperl-make-indent col) - (beginning-of-line 2) - (and (< (point) end) - (re-search-forward search end t) - (goto-char (match-beginning 0)))))))) ; No body - -(defun cperl-etags (&optional add all files) ;; NOT USED??? - "Run etags with appropriate options for Perl files. -If optional argument ALL is `recursive', will process Perl files -in subdirectories too." - (interactive) - (let ((cmd "etags") - (args '("-l" "none" "-r" - ;; 1=fullname 2=package? 3=name 4=proto? 5=attrs? (VERY APPROX!) - "/\\; - exec @ARGV;" - cmd) args) - cmd "perl")) - (t - (setq args (append args files)))) - (setq res (apply 'call-process cmd nil nil nil args)) - (or (eq res 0) - (message "etags returned \"%s\"" res)))) - -(defun cperl-toggle-auto-newline () - "Toggle the state of `cperl-auto-newline'." - (interactive) - (setq cperl-auto-newline (not cperl-auto-newline)) - (message "Newlines will %sbe auto-inserted now." - (if cperl-auto-newline "" "not "))) - -(defun cperl-toggle-abbrev () - "Toggle the state of automatic keyword expansion in CPerl mode." - (interactive) - (abbrev-mode (if abbrev-mode 0 1)) - (message "Perl control structure will %sbe auto-inserted now." - (if abbrev-mode "" "not "))) - - -(defun cperl-toggle-electric () - "Toggle the state of parentheses doubling in CPerl mode." - (interactive) - (setq cperl-electric-parens (if (cperl-val 'cperl-electric-parens) 'null t)) - (message "Parentheses will %sbe auto-doubled now." - (if (cperl-val 'cperl-electric-parens) "" "not "))) - -(defun cperl-toggle-autohelp () - "Toggle the state of Auto-Help on Perl constructs (put in the message area). -Delay of auto-help controlled by `cperl-lazy-help-time'." - (interactive) - (if (fboundp 'run-with-idle-timer) - (progn - (if cperl-lazy-installed - (cperl-lazy-unstall) - (cperl-lazy-install)) - (message "Perl help messages will %sbe automatically shown now." - (if cperl-lazy-installed "" "not "))) - (message "Cannot automatically show Perl help messages - run-with-idle-timer missing."))) - -(defun cperl-toggle-construct-fix () - "Toggle whether `indent-region'/`indent-sexp' fix whitespace too." - (interactive) - (setq cperl-indent-region-fix-constructs - (if cperl-indent-region-fix-constructs - nil - 1)) - (message "indent-region/indent-sexp will %sbe automatically fix whitespace." - (if cperl-indent-region-fix-constructs "" "not "))) - -(defun cperl-toggle-set-debug-unwind (arg &optional backtrace) - "Toggle (or, with numeric argument, set) debugging state of syntaxification. -Nonpositive numeric argument disables debugging messages. The message -summarizes which regions it was decided to rescan for syntactic constructs. - -The message looks like this: - - Syxify req=123..138 actual=101..146 done-to: 112=>146 statepos: 73=>117 - -Numbers are character positions in the buffer. REQ provides the range to -rescan requested by `font-lock'. ACTUAL is the range actually resyntaxified; -for correct operation it should start and end outside any special syntactic -construct. DONE-TO and STATEPOS indicate changes to internal caches maintained -by CPerl." - (interactive "P") - (or arg - (setq arg (if (eq cperl-syntaxify-by-font-lock - (if backtrace 'backtrace 'message)) 0 1))) - (setq arg (if (> arg 0) (if backtrace 'backtrace 'message) t)) - (setq cperl-syntaxify-by-font-lock arg) - (message "Debugging messages of syntax unwind %sabled." - (if (eq arg t) "dis" "en"))) - -;;;; Tags file creation. - -(defvar cperl-tmp-buffer " *cperl-tmp*") - -(defun cperl-setup-tmp-buf () - (set-buffer (get-buffer-create cperl-tmp-buffer)) - (set-syntax-table cperl-mode-syntax-table) - (buffer-disable-undo) - (auto-fill-mode 0) - (if cperl-use-syntax-table-text-property-for-tags - (progn - (make-local-variable 'parse-sexp-lookup-properties) - ;; Do not introduce variable if not needed, we check it! - (set 'parse-sexp-lookup-properties t)))) - -(defun cperl-xsub-scan () - (require 'imenu) - (let ((index-alist '()) - (prev-pos 0) index index1 name package prefix) - (goto-char (point-min)) - ;; Search for the function - (progn ;;save-match-data - (while (re-search-forward - "^\\([ \t]*MODULE\\>[^\n]*\\\\|\\([a-zA-Z_][a-zA-Z_0-9]*\\)(\\|[ \t]*BOOT:\\)" - nil t) - (cond - ((match-beginning 2) ; SECTION - (setq package (buffer-substring (match-beginning 2) (match-end 2))) - (goto-char (match-beginning 0)) - (skip-chars-forward " \t") - (forward-char 1) - (if (looking-at "[^\n]*\\") - (setq prefix (buffer-substring (match-beginning 1) (match-end 1))) - (setq prefix nil))) - ((not package) nil) ; C language section - ((match-beginning 3) ; XSUB - (goto-char (1+ (match-beginning 3))) - (setq index (imenu-example--name-and-position)) - (setq name (buffer-substring (match-beginning 3) (match-end 3))) - (if (and prefix (string-match (concat "^" prefix) name)) - (setq name (substring name (length prefix)))) - (cond ((string-match "::" name) nil) - (t - (setq index1 (cons (concat package "::" name) (cdr index))) - (push index1 index-alist))) - (setcar index name) - (push index index-alist)) - (t ; BOOT: section - ;; (beginning-of-line) - (setq index (imenu-example--name-and-position)) - (setcar index (concat package "::BOOT:")) - (push index index-alist))))) - index-alist)) - -(defvar cperl-unreadable-ok nil) - -(defun cperl-find-tags (ifile xs topdir) - (let ((b (get-buffer cperl-tmp-buffer)) ind lst elt pos ret rel - (cperl-pod-here-fontify nil) f file) - (save-excursion - (if b (set-buffer b) - (cperl-setup-tmp-buf)) - (erase-buffer) - (condition-case err - (setq file (car (insert-file-contents ifile))) - (error (if cperl-unreadable-ok nil - (if (y-or-n-p - (format "File %s unreadable. Continue? " ifile)) - (setq cperl-unreadable-ok t) - (error "Aborting: unreadable file %s" ifile))))) - (if (not file) - (message "Unreadable file %s" ifile) - (message "Scanning file %s ..." file) - (if (and cperl-use-syntax-table-text-property-for-tags - (not xs)) - (condition-case err ; after __END__ may have garbage - (cperl-find-pods-heres nil nil noninteractive) - (error (message "While scanning for syntax: %s" err)))) - (if xs - (setq lst (cperl-xsub-scan)) - (setq ind (cperl-imenu--create-perl-index)) - (setq lst (cdr (assoc "+Unsorted List+..." ind)))) - (setq lst - (mapcar - (function - (lambda (elt) - (cond ((string-match "^[_a-zA-Z]" (car elt)) - (goto-char (cdr elt)) - (beginning-of-line) ; pos should be of the start of the line - (list (car elt) - (point) - (1+ (count-lines 1 (point))) ; 1+ since at beg-o-l - (buffer-substring (progn - (goto-char (cdr elt)) - ;; After name now... - (or (eolp) (forward-char 1)) - (point)) - (progn - (beginning-of-line) - (point)))))))) - lst)) - (erase-buffer) - (while lst - (setq elt (car lst) lst (cdr lst)) - (if elt - (progn - (insert (elt elt 3) - 127 - (if (string-match "^package " (car elt)) - (substring (car elt) 8) - (car elt) ) - 1 - (number-to-string (elt elt 2)) ; Line - "," - (number-to-string (1- (elt elt 1))) ; Char pos 0-based - "\n") - (if (and (string-match "^[_a-zA-Z]+::" (car elt)) - (string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]" - (elt elt 3))) - ;; Need to insert the name without package as well - (setq lst (cons (cons (substring (elt elt 3) - (match-beginning 1) - (match-end 1)) - (cdr elt)) - lst)))))) - (setq pos (point)) - (goto-char 1) - (setq rel file) - ;; On case-preserving filesystems (EMX on OS/2) case might be encoded in properties - (set-text-properties 0 (length rel) nil rel) - (and (equal topdir (substring rel 0 (length topdir))) - (setq rel (substring file (length topdir)))) - (insert "\f\n" rel "," (number-to-string (1- pos)) "\n") - (setq ret (buffer-substring 1 (point-max))) - (erase-buffer) - (or noninteractive - (message "Scanning file %s finished" file)) - ret)))) - -(defun cperl-add-tags-recurse-noxs () - "Add to TAGS data for \"pure\" Perl files in the current directory and kids. -Use as - emacs -batch -q -no-site-file -l emacs/cperl-mode.el \ - -f cperl-add-tags-recurse-noxs -" - (cperl-write-tags nil nil t t nil t)) - -(defun cperl-add-tags-recurse-noxs-fullpath () - "Add to TAGS data for \"pure\" Perl in the current directory and kids. -Writes down fullpath, so TAGS is relocatable (but if the build directory -is relocated, the file TAGS inside it breaks). Use as - emacs -batch -q -no-site-file -l emacs/cperl-mode.el \ - -f cperl-add-tags-recurse-noxs-fullpath -" - (cperl-write-tags nil nil t t nil t "")) - -(defun cperl-add-tags-recurse () - "Add to TAGS file data for Perl files in the current directory and kids. -Use as - emacs -batch -q -no-site-file -l emacs/cperl-mode.el \ - -f cperl-add-tags-recurse -" - (cperl-write-tags nil nil t t)) - -(defun cperl-write-tags (&optional file erase recurse dir inbuffer noxs topdir) - ;; If INBUFFER, do not select buffer, and do not save - ;; If ERASE is `ignore', do not erase, and do not try to delete old info. - (require 'etags) - (if file nil - (setq file (if dir default-directory (buffer-file-name))) - (if (and (not dir) (buffer-modified-p)) (error "Save buffer first!"))) - (or topdir - (setq topdir default-directory)) - (let ((tags-file-name "TAGS") - (case-fold-search (eq system-type 'emx)) - xs rel tm) - (save-excursion - (cond (inbuffer nil) ; Already there - ((file-exists-p tags-file-name) - (if (featurep 'xemacs) - (visit-tags-table-buffer) - (visit-tags-table-buffer tags-file-name))) - (t (set-buffer (find-file-noselect tags-file-name)))) - (cond - (dir - (cond ((eq erase 'ignore)) - (erase - (erase-buffer) - (setq erase 'ignore))) - (let ((files - (condition-case err - (directory-files file t - (if recurse nil cperl-scan-files-regexp) - t) - (error - (if cperl-unreadable-ok nil - (if (y-or-n-p - (format "Directory %s unreadable. Continue? " file)) - (setq cperl-unreadable-ok t - tm nil) ; Return empty list - (error "Aborting: unreadable directory %s" file))))))) - (mapc (function - (lambda (file) - (cond - ((string-match cperl-noscan-files-regexp file) - nil) - ((not (file-directory-p file)) - (if (string-match cperl-scan-files-regexp file) - (cperl-write-tags file erase recurse nil t noxs topdir))) - ((not recurse) nil) - (t (cperl-write-tags file erase recurse t t noxs topdir))))) - files))) - (t - (setq xs (string-match "\\.xs$" file)) - (if (not (and xs noxs)) - (progn - (cond ((eq erase 'ignore) (goto-char (point-max))) - (erase (erase-buffer)) - (t - (goto-char 1) - (setq rel file) - ;; On case-preserving filesystems (EMX on OS/2) case might be encoded in properties - (set-text-properties 0 (length rel) nil rel) - (and (equal topdir (substring rel 0 (length topdir))) - (setq rel (substring file (length topdir)))) - (if (search-forward (concat "\f\n" rel ",") nil t) - (progn - (search-backward "\f\n") - (delete-region (point) - (save-excursion - (forward-char 1) - (if (search-forward "\f\n" - nil 'toend) - (- (point) 2) - (point-max))))) - (goto-char (point-max))))) - (insert (cperl-find-tags file xs topdir)))))) - (if inbuffer nil ; Delegate to the caller - (save-buffer 0) ; No backup - (if (fboundp 'initialize-new-tags-table) ; Do we need something special in XEmacs? - (initialize-new-tags-table)))))) - -(defvar cperl-tags-hier-regexp-list - (concat - "^\\(" - "\\(package\\)\\>" - "\\|" - "sub\\>[^\n]+::" - "\\|" - "[a-zA-Z_][a-zA-Z_0-9:]*(\C-?[^\n]+::" ; XSUB? - "\\|" - "[ \t]*BOOT:\C-?[^\n]+::" ; BOOT section - "\\)")) - -(defvar cperl-hierarchy '(() ()) - "Global hierarchy of classes.") - -(defun cperl-tags-hier-fill () - ;; Suppose we are in a tag table cooked by cperl. - (goto-char 1) - (let (type pack name pos line chunk ord cons1 file str info fileind) - (while (re-search-forward cperl-tags-hier-regexp-list nil t) - (setq pos (match-beginning 0) - pack (match-beginning 2)) - (beginning-of-line) - (if (looking-at (concat - "\\([^\n]+\\)" - "\C-?" - "\\([^\n]+\\)" - "\C-a" - "\\([0-9]+\\)" - "," - "\\([0-9]+\\)")) - (progn - (setq ;;str (buffer-substring (match-beginning 1) (match-end 1)) - name (buffer-substring (match-beginning 2) (match-end 2)) - ;;pos (buffer-substring (match-beginning 3) (match-end 3)) - line (buffer-substring (match-beginning 3) (match-end 3)) - ord (if pack 1 0) - file (file-of-tag) - fileind (format "%s:%s" file line) - ;; Moves to beginning of the next line: - info (cperl-etags-snarf-tag file line)) - ;; Move back - (forward-char -1) - ;; Make new member of hierarchy name ==> file ==> pos if needed - (if (setq cons1 (assoc name (nth ord cperl-hierarchy))) - ;; Name known - (setcdr cons1 (cons (cons fileind (vector file info)) - (cdr cons1))) - ;; First occurrence of the name, start alist - (setq cons1 (cons name (list (cons fileind (vector file info))))) - (if pack - (setcar (cdr cperl-hierarchy) - (cons cons1 (nth 1 cperl-hierarchy))) - (setcar cperl-hierarchy - (cons cons1 (car cperl-hierarchy))))))) - (end-of-line)))) - -(defun cperl-tags-hier-init (&optional update) - "Show hierarchical menu of classes and methods. -Finds info about classes by a scan of loaded TAGS files. -Supposes that the TAGS files contain fully qualified function names. -One may build such TAGS files from CPerl mode menu." - (interactive) - (require 'etags) - (require 'imenu) - (if (or update (null (nth 2 cperl-hierarchy))) - (let ((remover (function (lambda (elt) ; (name (file1...) (file2..)) - (or (nthcdr 2 elt) - ;; Only in one file - (setcdr elt (cdr (nth 1 elt))))))) - pack name cons1 to l1 l2 l3 l4 b) - ;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later! - (setq cperl-hierarchy (list l1 l2 l3)) - (if (featurep 'xemacs) ; Not checked - (progn - (or tags-file-name - ;; Does this work in XEmacs? - (call-interactively 'visit-tags-table)) - (message "Updating list of classes...") - (set-buffer (get-file-buffer tags-file-name)) - (cperl-tags-hier-fill)) - (or tags-table-list - (call-interactively 'visit-tags-table)) - (mapc - (function - (lambda (tagsfile) - (message "Updating list of classes... %s" tagsfile) - (set-buffer (get-file-buffer tagsfile)) - (cperl-tags-hier-fill))) - tags-table-list) - (message "Updating list of classes... postprocessing...")) - (mapc remover (car cperl-hierarchy)) - (mapc remover (nth 1 cperl-hierarchy)) - (setq to (list nil (cons "Packages: " (nth 1 cperl-hierarchy)) - (cons "Methods: " (car cperl-hierarchy)))) - (cperl-tags-treeify to 1) - (setcar (nthcdr 2 cperl-hierarchy) - (cperl-menu-to-keymap (cons '("+++UPDATE+++" . -999) (cdr to)))) - (message "Updating list of classes: done, requesting display...") - ;;(cperl-imenu-addback (nth 2 cperl-hierarchy)) - )) - (or (nth 2 cperl-hierarchy) - (error "No items found")) - (setq update -;;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy)) - (if (if (fboundp 'display-popup-menus-p) - (let ((f 'display-popup-menus-p)) - (funcall f)) - window-system) - (x-popup-menu t (nth 2 cperl-hierarchy)) - (require 'tmm) - (tmm-prompt (nth 2 cperl-hierarchy)))) - (if (and update (listp update)) - (progn (while (cdr update) (setq update (cdr update))) - (setq update (car update)))) ; Get the last from the list - (if (vectorp update) - (progn - (find-file (elt update 0)) - (cperl-etags-goto-tag-location (elt update 1)))) - (if (eq update -999) (cperl-tags-hier-init t))) - -(defun cperl-tags-treeify (to level) - ;; cadr of `to' is read-write. On start it is a cons - (let* ((regexp (concat "^\\(" (mapconcat - 'identity - (make-list level "[_a-zA-Z0-9]+") - "::") - "\\)\\(::\\)?")) - (packages (cdr (nth 1 to))) - (methods (cdr (nth 2 to))) - l1 head tail cons1 cons2 ord writeto packs recurse - root-packages root-functions ms many_ms same_name ps - (move-deeper - (function - (lambda (elt) - (cond ((and (string-match regexp (car elt)) - (or (eq ord 1) (match-end 2))) - (setq head (substring (car elt) 0 (match-end 1)) - tail (if (match-end 2) (substring (car elt) - (match-end 2))) - recurse t) - (if (setq cons1 (assoc head writeto)) nil - ;; Need to init new head - (setcdr writeto (cons (list head (list "Packages: ") - (list "Methods: ")) - (cdr writeto))) - (setq cons1 (nth 1 writeto))) - (setq cons2 (nth ord cons1)) ; Either packs or meths - (setcdr cons2 (cons elt (cdr cons2)))) - ((eq ord 2) - (setq root-functions (cons elt root-functions))) - (t - (setq root-packages (cons elt root-packages)))))))) - (setcdr to l1) ; Init to dynamic space - (setq writeto to) - (setq ord 1) - (mapc move-deeper packages) - (setq ord 2) - (mapc move-deeper methods) - (if recurse - (mapc (function (lambda (elt) - (cperl-tags-treeify elt (1+ level)))) - (cdr to))) - ;;Now clean up leaders with one child only - (mapc (function (lambda (elt) - (if (not (and (listp (cdr elt)) - (eq (length elt) 2))) nil - (setcar elt (car (nth 1 elt))) - (setcdr elt (cdr (nth 1 elt)))))) - (cdr to)) - ;; Sort the roots of subtrees - (if (default-value 'imenu-sort-function) - (setcdr to - (sort (cdr to) (default-value 'imenu-sort-function)))) - ;; Now add back functions removed from display - (mapc (function (lambda (elt) - (setcdr to (cons elt (cdr to))))) - (if (default-value 'imenu-sort-function) - (nreverse - (sort root-functions (default-value 'imenu-sort-function))) - root-functions)) - ;; Now add back packages removed from display - (mapc (function (lambda (elt) - (setcdr to (cons (cons (concat "package " (car elt)) - (cdr elt)) - (cdr to))))) - (if (default-value 'imenu-sort-function) - (nreverse - (sort root-packages (default-value 'imenu-sort-function))) - root-packages)))) - -;;;(x-popup-menu t -;;; '(keymap "Name1" -;;; ("Ret1" "aa") -;;; ("Head1" "ab" -;;; keymap "Name2" -;;; ("Tail1" "x") ("Tail2" "y")))) - -(defun cperl-list-fold (list name limit) - (let (list1 list2 elt1 (num 0)) - (if (<= (length list) limit) list - (setq list1 nil list2 nil) - (while list - (setq num (1+ num) - elt1 (car list) - list (cdr list)) - (if (<= num imenu-max-items) - (setq list2 (cons elt1 list2)) - (setq list1 (cons (cons name - (nreverse list2)) - list1) - list2 (list elt1) - num 1))) - (nreverse (cons (cons name - (nreverse list2)) - list1))))) - -(defun cperl-menu-to-keymap (menu &optional name) - (let (list) - (cons 'keymap - (mapcar - (function - (lambda (elt) - (cond ((listp (cdr elt)) - (setq list (cperl-list-fold - (cdr elt) (car elt) imenu-max-items)) - (cons nil - (cons (car elt) - (cperl-menu-to-keymap list)))) - (t - (list (cdr elt) (car elt) t))))) ; t is needed in 19.34 - (cperl-list-fold menu "Root" imenu-max-items))))) - - -(defvar cperl-bad-style-regexp - (mapconcat 'identity - '("[^-\n\t <>=+!.&|(*/'`\"#^][-=+<>!|&^]" ; char sign - "[-<>=+^&|]+[^- \t\n=+<>~]") ; sign+ char - "\\|") - "Finds places such that insertion of a whitespace may help a lot.") - -(defvar cperl-not-bad-style-regexp - (mapconcat - 'identity - '("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++ - "[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used. - "&[(a-zA-Z0-9_$]" ; &subroutine &(var->field) - "<\\$?\\sw+\\(\\.\\(\\sw\\|_\\)+\\)?>" ; - "-[a-zA-Z][ \t]+[_$\"'`a-zA-Z]" ; -f file, -t STDIN - "-[0-9]" ; -5 - "\\+\\+" ; ++var - "--" ; --var - ".->" ; a->b - "->" ; a SPACE ->b - "\\[-" ; a[-1] - "\\\\[&$@*\\\\]" ; \&func - "^=" ; =head - "\\$." ; $| - "<<[a-zA-Z_'\"`]" ; <" ; C - "-[a-zA-Z_0-9]+[ \t]*=>" ; -option => value - ;; Unaddressed trouble spots: = -abc, f(56, -abc) --- specialcased below - ;;"[*/+-|&<.]+=" - ) - "\\|") - "If matches at the start of match found by `my-bad-c-style-regexp', -insertion of a whitespace will not help.") - -(defvar found-bad) - -(defun cperl-find-bad-style () - "Find places in the buffer where insertion of a whitespace may help. -Prompts user for insertion of spaces. -Currently it is tuned to C and Perl syntax." - (interactive) - (let (found-bad (p (point))) - (setq last-nonmenu-event 13) ; To disable popup - (goto-char (point-min)) - (map-y-or-n-p "Insert space here? " - (lambda (arg) (insert " ")) - 'cperl-next-bad-style - '("location" "locations" "insert a space into") - '((?\C-r (lambda (arg) - (let ((buffer-quit-function - 'exit-recursive-edit)) - (message "Exit with Esc Esc") - (recursive-edit) - t)) ; Consider acted upon - "edit, exit with Esc Esc") - (?e (lambda (arg) - (let ((buffer-quit-function - 'exit-recursive-edit)) - (message "Exit with Esc Esc") - (recursive-edit) - t)) ; Consider acted upon - "edit, exit with Esc Esc")) - t) - (if found-bad (goto-char found-bad) - (goto-char p) - (message "No appropriate place found")))) - -(defun cperl-next-bad-style () - (let (p (not-found t) (point (point)) found) - (while (and not-found - (re-search-forward cperl-bad-style-regexp nil 'to-end)) - (setq p (point)) - (goto-char (match-beginning 0)) - (if (or - (looking-at cperl-not-bad-style-regexp) - ;; Check for a < -b and friends - (and (eq (following-char) ?\-) - (save-excursion - (skip-chars-backward " \t\n") - (memq (preceding-char) '(?\= ?\> ?\< ?\, ?\( ?\[ ?\{)))) - ;; Now check for syntax type - (save-match-data - (setq found (point)) - (beginning-of-defun) - (let ((pps (parse-partial-sexp (point) found))) - (or (nth 3 pps) (nth 4 pps) (nth 5 pps))))) - (goto-char (match-end 0)) - (goto-char (1- p)) - (setq not-found nil - found-bad found))) - (not not-found))) - - -;;; Getting help -(defvar cperl-have-help-regexp - ;;(concat "\\(" - (mapconcat - 'identity - '("[$@%*&][0-9a-zA-Z_:]+\\([ \t]*[[{]\\)?" ; Usual variable - "[$@]\\^[a-zA-Z]" ; Special variable - "[$@][^ \n\t]" ; Special variable - "-[a-zA-Z]" ; File test - "\\\\[a-zA-Z0]" ; Special chars - "^=[a-z][a-zA-Z0-9_]*" ; POD sections - "[-!&*+,-./<=>?\\\\^|~]+" ; 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) -(defvar cperl-help-from-timer nil) - -(defun cperl-word-at-point-hard () - ;; Does not 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)) - ((and (eq (preceding-char) ?\=) - (eq (current-column) 1)) - (forward-char -1))) ; =head1 - (if (and (eq (preceding-char) ?\<) - (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; - (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_:]+>")))) ; - (search-backward "<")))) - ((and (eq (following-char) ?\$) - (eq (preceding-char) ?\<) - (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <$fh> - (forward-char -1))) - (if (looking-at cperl-have-help-regexp) - (buffer-substring (match-beginning 0) (match-end 0)))) - -(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-match-data ; May be called "inside" query-replace - (save-excursion - (let ((word (cperl-word-at-point-hard))) - (if word - (if (and cperl-help-from-timer ; Bail out if not in mainland - (not (string-match "^#!\\|\\\\\\|^=" word)) ; Show help even in comments/strings. - (or (memq (get-text-property (point) 'face) - '(font-lock-comment-face font-lock-string-face)) - (memq (get-text-property (point) 'syntax-type) - '(pod here-doc format)))) - nil - (cperl-describe-perl-symbol word)) - (if cperl-message-on-help-error - (message "Nothing found for %s..." - (buffer-substring (point) (min (+ 5 (point)) (point-max)))))))))) - -;;; 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." - (let ((enable-recursive-minibuffers t) - args-file regexp) - (cond - ((string-match "^[&*][a-zA-Z_]" val) - (setq val (concat (substring val 0 1) "NAME"))) - ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*\\[" val) - (setq val (concat "@" (substring val 1 (match-end 1))))) - ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*{" val) - (setq val (concat "%" (substring val 1 (match-end 1))))) - ((and (string= val "x") (string-match "^x=" val)) - (setq val "x=")) - ((string-match "^\\$[\C-a-\C-z]" val) - (setq val (concat "$^" (char-to-string (+ ?A -1 (aref val 1)))))) - ((string-match "^CORE::" val) - (setq val "CORE::")) - ((string-match "^SUPER::" val) - (setq val "SUPER::")) - ((and (string= "<" val) (string-match "^<\\$?[a-zA-Z0-9_:]+>" val)) - (setq val ""))) - (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 'please-ignore-this-line - ;; Perl4 version was written by Johan Vromans (jvromans@squirrel.nl) - "# based on '@(#)@ perl-descr.el 1.9 - describe-perl-symbol' [Perl 5] -... Range (list context); flip/flop [no flop when flip] (scalar context). -! ... 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. Default is %.15g or close. -$$ Process number of this script. Changes in the fork()ed child process. -$% 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 Name of the file containing the current perl script (read/write). -$: String may be broken after these characters to fill ^-lines in a format. -$; Subscript separator for multi-dim array emulation. Default \"\\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. -$^M A buffer for emergency memory allocation when running out of memory. -$^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. -$| Auto-flush after write/print on current output channel? Default 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 Glob: all objects refered by NAME. *NAM1 = *NAM2 aliases NAM1 to NAM2. -&NAME(arg0, ...) Subroutine call. Arguments go to @_. -... + ... Addition. +EXPR Makes EXPR into scalar context. -++ Auto-increment (magical on strings). ++EXPR EXPR++ -... += ... Addition assignment. -, Comma operator. -... - ... Subtraction. --- Auto-decrement (NOT magical on strings). --EXPR EXPR-- -... -= ... 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. -.. Range (list context); flip/flop (scalar context) operator. -.= Concatenate assignment strings -... / ... Division. /PATTERN/ioxsmg Pattern match -... /= ... Division assignment. -/PATTERN/ioxsmg Pattern match. -... < ... Numeric less than. Glob. See , <> as well. - Reads line from filehandle NAME (a bareword or dollar-bareword). - Glob (Unless pattern is bareword/dollar-bareword - see ). -<> 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 -... ~~ .. Smart match -... > ... Numeric greater than. -... >= ... Numeric greater than or equal to. -... >> ... Bitwise shift right. -... >>= ... Bitwise shift right assignment. -... ? ... : ... Condition=if-then-else operator. ?PAT? One-time pattern match. -?PATTERN? One-time 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; result of split() unless in list context. -\\ Creates reference to what follows, like \\$var, or quotes non-\\w in strings. -\\0 Octal char, e.g. \\033. -\\E Case modification terminator. See \\Q, \\L, and \\U. -\\L Lowercase until \\E . See also \\l, lc. -\\U Upcase until \\E . See also \\u, uc. -\\Q Quote metacharacters until \\E . See also quotemeta. -\\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 the next character. See also \\L and \\u, lcfirst. -\\n Newline character (octal 012 on most systems). -\\r Return character (octal 015 on most systems). -\\t Tab character (octal 011). -\\u Upcase the next character. See also \\U and \\l, ucfirst. -\\x Hex character, e.g. \\x1b. -... ^ ... Bitwise exclusive or. -__END__ Ends program source. -__DATA__ Ends program source. -__FILE__ Current (source) filename. -__LINE__ Current line in current source. -__PACKAGE__ Current package. -ARGV Default multi-file input filehandle. is a synonym for <>. -ARGVOUT Output filehandle with -i flag. -BEGIN { ... } Immediately executed (during compilation) piece of code. -END { ... } Pseudo-subroutine executed after the script finishes. -CHECK { ... } Pseudo-subroutine executed after the script is compiled. -UNITCHECK { ... } -INIT { ... } Pseudo-subroutine executed before the script starts running. -DATA Input filehandle for what follows after __END__ or __DATA__. -accept(NEWSOCKET,GENERICSOCKET) -alarm(SECONDS) -atan2(X,Y) -bind(SOCKET,NAME) -binmode(FILEHANDLE) -break Break out of a given/when statement -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(%HASH) -dbmopen(%HASH,DBNAME,MODE) -default { ... } default case for given/when block -defined(EXPR) -delete($HASH{KEY}) -die(LIST) -do { ... }|SUBR while|until EXPR executes at least once -do(EXPR|SUBR([LIST])) (with while|until executes at least once) -dump LABEL -each(%HASH) -endgrent -endhostent -endnetent -endprotoent -endpwent -endservent -eof[([FILEHANDLE])] -... eq ... String equality. -eval(EXPR) or eval { BLOCK } -exec([TRUENAME] ARGV0, ARGVs) or exec(SHELL_COMMAND_LINE) -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) -given (EXPR) { [ when (EXPR) { ... } ]+ [ default { ... } ]? } -gmtime(EXPR) -goto LABEL -... 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(%HASH) -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). -our VAR or our (VAR1,...) Lexically enable a global variable ($V, @A, or %H). -... ne ... String inequality. -next [LABEL] -oct(EXPR) -open(FILEHANDLE[,EXPR]) -opendir(DIRHANDLE,EXPR) -ord(EXPR) ASCII value of the first char of the string. -pack(TEMPLATE,LIST) -package NAME Introduces package context. -pipe(READHANDLE,WRITEHANDLE) Create a pair of filehandles on ends of a pipe. -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 -say [FILEHANDLE] [(LIST)] -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) -state VAR or state (VAR1,...) Introduces a static lexical variable -study[(SCALAR)] -sub [NAME [(format)]] { BODY } sub NAME [(format)]; sub [(format)] {...} -substr(EXPR,OFFSET[,LEN]) -symlink(OLDFILE,NEWFILE) -syscall(LIST) -sysread(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) -system([TRUENAME] ARGV0 [,ARGV]) or system(SHELL_COMMAND_LINE) -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) { ... } EXPR until EXPR -utime(LIST) -values(%HASH) -vec(EXPR,OFFSET,BITS) -wait -waitpid(PID,FLAGS) -wantarray Returns true if the sub/eval is called in list context. -warn(LIST) -while (EXPR) { ... } EXPR while EXPR -write[(EXPR|FILEHANDLE)] -... x ... Repeat string or array. -x= ... Repetition assignment. -y/SEARCHLIST/REPLACEMENTLIST/ -... | ... Bitwise or. -... || ... Logical or. -... // ... Defined-or. -~ ... Unary bitwise complement. -#! OS interpreter indicator. If contains `perl', used for options, and -x. -AUTOLOAD {...} Shorthand for `sub AUTOLOAD {...}'. -CORE:: Prefix to access builtin function if imported sub obscures it. -SUPER:: Prefix to lookup for a method in @ISA classes. -DESTROY Shorthand for `sub DESTROY {...}'. -... EQ ... Obsolete synonym of `eq'. -... GE ... Obsolete synonym of `ge'. -... GT ... Obsolete synonym of `gt'. -... LE ... Obsolete synonym of `le'. -... LT ... Obsolete synonym of `lt'. -... NE ... Obsolete synonym of `ne'. -abs [ EXPR ] absolute value -... and ... Low-precedence synonym for &&. -bless REFERENCE [, PACKAGE] Makes reference into an object of a package. -chomp [LIST] Strips $/ off LIST/$_. Returns count. Special if $/ eq ''! -chr Converts a number to char with the same ordinal. -else Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. -elsif Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. -exists $HASH{KEY} True if the key exists. -format [NAME] = Start of output format. Ended by a single dot (.) on a line. -formline PICTURE, LIST Backdoor into \"format\" processing. -glob EXPR Synonym of . -lc [ EXPR ] Returns lowercased EXPR. -lcfirst [ EXPR ] Returns EXPR with lower-cased first letter. -grep EXPR,LIST or grep {BLOCK} LIST Filters LIST via EXPR/BLOCK. -map EXPR, LIST or map {BLOCK} LIST Applies EXPR/BLOCK to elts of LIST. -no PACKAGE [SYMBOL1, ...] Partial reverse for `use'. Runs `unimport' method. -not ... Low-precedence synonym for ! - negation. -... or ... Low-precedence synonym for ||. -pos STRING Set/Get end-position of the last match over this string, see \\G. -quotemeta [ EXPR ] Quote regexp metacharacters. -qw/WORD1 .../ Synonym of split('', 'WORD1 ...') -readline FH Synonym of . -readpipe CMD Synonym of `CMD`. -ref [ EXPR ] Type of EXPR when dereferenced. -sysopen FH, FILENAME, MODE [, PERM] (MODE is numeric, see Fcntl.) -tie VAR, PACKAGE, LIST Hide an object behind a simple Perl variable. -tied Returns internal object for a tied data. -uc [ EXPR ] Returns upcased EXPR. -ucfirst [ EXPR ] Returns EXPR with upcased first letter. -untie VAR Unlink an object from a simple Perl variable. -use PACKAGE [SYMBOL1, ...] Compile-time `require' with consequent `import'. -... xor ... Low-precedence synonym for exclusive or. -prototype \\&SUB Returns prototype of the function given a reference. -=head1 Top-level heading. -=head2 Second-level heading. -=head3 Third-level heading (is there such?). -=over [ NUMBER ] Start list. -=item [ TITLE ] Start new item in the list. -=back End list. -=cut Switch from POD to Perl. -=pod Switch from Perl to POD. -") - -(defun cperl-switch-to-doc-buffer (&optional interactive) - "Go to the perl documentation buffer and insert the documentation." - (interactive "p") - (let ((buf (get-buffer-create cperl-doc-buffer))) - (if interactive - (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))))) - -(defun cperl-beautify-regexp-piece (b e embed level) - ;; b is before the starting delimiter, e before the ending - ;; e should be a marker, may be changed, but remains "correct". - ;; EMBED is nil if we process the whole REx. - ;; The REx is guaranteed to have //x - ;; LEVEL shows how many levels deep to go - ;; position at enter and at leave is not defined - (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline code pos) - (if (not embed) - (goto-char (1+ b)) - (goto-char b) - (cond ((looking-at "(\\?\\\\#") ; (?#) wrongly commented when //x-ing - (forward-char 2) - (delete-char 1) - (forward-char 1)) - ((looking-at "(\\?[^a-zA-Z]") - (forward-char 3)) - ((looking-at "(\\?") ; (?i) - (forward-char 2)) - (t - (forward-char 1)))) - (setq c (if embed (current-indentation) (1- (current-column))) - c1 (+ c (or cperl-regexp-indent-step cperl-indent-level))) - (or (looking-at "[ \t]*[\n#]") - (progn - (insert "\n"))) - (goto-char e) - (beginning-of-line) - (if (re-search-forward "[^ \t]" e t) - (progn ; Something before the ending delimiter - (goto-char e) - (delete-horizontal-space) - (insert "\n") - (cperl-make-indent c) - (set-marker e (point)))) - (goto-char b) - (end-of-line 2) - (while (< (point) (marker-position e)) - (beginning-of-line) - (setq s (point) - inline t) - (skip-chars-forward " \t") - (delete-region s (point)) - (cperl-make-indent c1) - (while (and - inline - (looking-at - (concat "\\([a-zA-Z0-9]+[^*+{?]\\)" ; 1 word - "\\|" ; Embedded variable - "\\$\\([a-zA-Z0-9_]+\\([[{]\\)?\\|[^\n \t)|]\\)" ; 2 3 - "\\|" ; $ ^ - "[$^]" - "\\|" ; simple-code simple-code*? - "\\(\\\\.\\|[^][()#|*+?\n]\\)\\([*+{?]\\??\\)?" ; 4 5 - "\\|" ; Class - "\\(\\[\\)" ; 6 - "\\|" ; Grouping - "\\((\\(\\?\\)?\\)" ; 7 8 - "\\|" ; | - "\\(|\\)"))) ; 9 - (goto-char (match-end 0)) - (setq spaces t) - (cond ((match-beginning 1) ; Alphanum word + junk - (forward-char -1)) - ((or (match-beginning 3) ; $ab[12] - (and (match-beginning 5) ; X* X+ X{2,3} - (eq (preceding-char) ?\{))) - (forward-char -1) - (forward-sexp 1)) - ((and ; [], already syntaxified - (match-beginning 6) - cperl-regexp-scan - cperl-use-syntax-table-text-property) - (forward-char -1) - (forward-sexp 1) - (or (eq (preceding-char) ?\]) - (error "[]-group not terminated")) - (re-search-forward - "\\=\\([*+?]\\|{[0-9]+\\(,[0-9]*\\)?}\\)\\??" e t)) - ((match-beginning 6) ; [] - (setq tmp (point)) - (if (looking-at "\\^?\\]") - (goto-char (match-end 0))) - ;; XXXX POSIX classes?! - (while (and (not pos) - (re-search-forward "\\[:\\|\\]" e t)) - (if (eq (preceding-char) ?:) - (or (re-search-forward ":\\]" e t) - (error "[:POSIX:]-group in []-group not terminated")) - (setq pos t))) - (or (eq (preceding-char) ?\]) - (error "[]-group not terminated")) - (re-search-forward - "\\=\\([*+?]\\|{[0-9]+\\(,[0-9]*\\)?}\\)\\??" e t)) - ((match-beginning 7) ; () - (goto-char (match-beginning 0)) - (setq pos (current-column)) - (or (eq pos c1) - (progn - (delete-horizontal-space) - (insert "\n") - (cperl-make-indent c1))) - (setq tmp (point)) - (forward-sexp 1) - ;; (or (forward-sexp 1) - ;; (progn - ;; (goto-char tmp) - ;; (error "()-group not terminated"))) - (set-marker m (1- (point))) - (set-marker m1 (point)) - (if (= level 1) - (if (progn ; indent rigidly if multiline - ;; In fact does not make a lot of sense, since - ;; the starting position can be already lost due - ;; to insertion of "\n" and " " - (goto-char tmp) - (search-forward "\n" m1 t)) - (indent-rigidly (point) m1 (- c1 pos))) - (setq level (1- level)) - (cond - ((not (match-beginning 8)) - (cperl-beautify-regexp-piece tmp m t level)) - ((eq (char-after (+ 2 tmp)) ?\{) ; Code - t) - ((eq (char-after (+ 2 tmp)) ?\() ; Conditional - (goto-char (+ 2 tmp)) - (forward-sexp 1) - (cperl-beautify-regexp-piece (point) m t level)) - ((eq (char-after (+ 2 tmp)) ?<) ; Lookbehind - (goto-char (+ 3 tmp)) - (cperl-beautify-regexp-piece (point) m t level)) - (t - (cperl-beautify-regexp-piece tmp m t level)))) - (goto-char m1) - (cond ((looking-at "[*+?]\\??") - (goto-char (match-end 0))) - ((eq (following-char) ?\{) - (forward-sexp 1) - (if (eq (following-char) ?\?) - (forward-char)))) - (skip-chars-forward " \t") - (setq spaces nil) - (if (looking-at "[#\n]") - (progn - (or (eolp) (indent-for-comment)) - (beginning-of-line 2)) - (delete-horizontal-space) - (insert "\n")) - (end-of-line) - (setq inline nil)) - ((match-beginning 9) ; | - (forward-char -1) - (setq tmp (point)) - (beginning-of-line) - (if (re-search-forward "[^ \t]" tmp t) - (progn - (goto-char tmp) - (delete-horizontal-space) - (insert "\n")) - ;; first at line - (delete-region (point) tmp)) - (cperl-make-indent c) - (forward-char 1) - (skip-chars-forward " \t") - (setq spaces nil) - (if (looking-at "[#\n]") - (beginning-of-line 2) - (delete-horizontal-space) - (insert "\n")) - (end-of-line) - (setq inline nil))) - (or (looking-at "[ \t\n]") - (not spaces) - (insert " ")) - (skip-chars-forward " \t")) - (or (looking-at "[#\n]") - (error "Unknown code `%s' in a regexp" - (buffer-substring (point) (1+ (point))))) - (and inline (end-of-line 2))) - ;; Special-case the last line of group - (if (and (>= (point) (marker-position e)) - (/= (current-indentation) c)) - (progn - (beginning-of-line) - (cperl-make-indent c))))) - -(defun cperl-make-regexp-x () - ;; Returns position of the start - ;; XXX this is called too often! Need to cache the result! - (save-excursion - (or cperl-use-syntax-table-text-property - (error "I need to have a regexp marked!")) - ;; Find the start - (if (looking-at "\\s|") - nil ; good already - (if (looking-at "\\([smy]\\|qr\\)\\s|") - (forward-char 1) - (re-search-backward "\\s|"))) ; Assume it is scanned already. - ;;(forward-char 1) - (let ((b (point)) (e (make-marker)) have-x delim (c (current-column)) - (sub-p (eq (preceding-char) ?s)) s) - (forward-sexp 1) - (set-marker e (1- (point))) - (setq delim (preceding-char)) - (if (and sub-p (eq delim (char-after (- (point) 2)))) - (error "Possible s/blah// - do not know how to deal with")) - (if sub-p (forward-sexp 1)) - (if (looking-at "\\sw*x") - (setq have-x t) - (insert "x")) - ;; Protect fragile " ", "#" - (if have-x nil - (goto-char (1+ b)) - (while (re-search-forward "\\(\\=\\|[^\\\\]\\)\\(\\\\\\\\\\)*[ \t\n#]" e t) ; Need to include (?#) too? - (forward-char -1) - (insert "\\") - (forward-char 1))) - b))) - -(defun cperl-beautify-regexp (&optional deep) - "Do it. (Experimental, may change semantics, recheck the result.) -We suppose that the regexp is scanned already." - (interactive "P") - (setq deep (if deep (prefix-numeric-value deep) -1)) - (save-excursion - (goto-char (cperl-make-regexp-x)) - (let ((b (point)) (e (make-marker))) - (forward-sexp 1) - (set-marker e (1- (point))) - (cperl-beautify-regexp-piece b e nil deep)))) - -(defun cperl-regext-to-level-start () - "Goto start of an enclosing group in regexp. -We suppose that the regexp is scanned already." - (interactive) - (let ((limit (cperl-make-regexp-x)) done) - (while (not done) - (or (eq (following-char) ?\() - (search-backward "(" (1+ limit) t) - (error "Cannot find `(' which starts a group")) - (setq done - (save-excursion - (skip-chars-backward "\\") - (looking-at "\\(\\\\\\\\\\)*("))) - (or done (forward-char -1))))) - -(defun cperl-contract-level () - "Find an enclosing group in regexp and contract it. -\(Experimental, may change semantics, recheck the result.) -We suppose that the regexp is scanned already." - (interactive) - ;; (save-excursion ; Can't, breaks `cperl-contract-levels' - (cperl-regext-to-level-start) - (let ((b (point)) (e (make-marker)) c) - (forward-sexp 1) - (set-marker e (1- (point))) - (goto-char b) - (while (re-search-forward "\\(#\\)\\|\n" e 'to-end) - (cond - ((match-beginning 1) ; #-comment - (or c (setq c (current-indentation))) - (beginning-of-line 2) ; Skip - (cperl-make-indent c)) - (t - (delete-char -1) - (just-one-space)))))) - -(defun cperl-contract-levels () - "Find an enclosing group in regexp and contract all the kids. -\(Experimental, may change semantics, recheck the result.) -We suppose that the regexp is scanned already." - (interactive) - (save-excursion - (condition-case nil - (cperl-regext-to-level-start) - (error ; We are outside outermost group - (goto-char (cperl-make-regexp-x)))) - (let ((b (point)) (e (make-marker)) s c) - (forward-sexp 1) - (set-marker e (1- (point))) - (goto-char (1+ b)) - (while (re-search-forward "\\(\\\\\\\\\\)\\|(" e t) - (cond - ((match-beginning 1) ; Skip - nil) - (t ; Group - (cperl-contract-level))))))) - -(defun cperl-beautify-level (&optional deep) - "Find an enclosing group in regexp and beautify it. -\(Experimental, may change semantics, recheck the result.) -We suppose that the regexp is scanned already." - (interactive "P") - (setq deep (if deep (prefix-numeric-value deep) -1)) - (save-excursion - (cperl-regext-to-level-start) - (let ((b (point)) (e (make-marker))) - (forward-sexp 1) - (set-marker e (1- (point))) - (cperl-beautify-regexp-piece b e nil deep)))) - -(defun cperl-invert-if-unless-modifiers () - "Change `B if A;' into `if (A) {B}' etc if possible. -\(Unfinished.)" - (interactive) ; - (let (A B pre-B post-B pre-if post-if pre-A post-A if-string - (w-rex "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>")) - (and (= (char-syntax (preceding-char)) ?w) - (forward-sexp -1)) - (setq pre-if (point)) - (cperl-backward-to-start-of-expr) - (setq pre-B (point)) - (forward-sexp 1) ; otherwise forward-to-end-of-expr is NOP - (cperl-forward-to-end-of-expr) - (setq post-A (point)) - (goto-char pre-if) - (or (looking-at w-rex) - ;; Find the position - (progn (goto-char post-A) - (while (and - (not (looking-at w-rex)) - (> (point) pre-B)) - (forward-sexp -1)) - (setq pre-if (point)))) - (or (looking-at w-rex) - (error "Can't find `if', `unless', `while', `until', `for' or `foreach'")) - ;; 1 B 2 ... 3 B-com ... 4 if 5 ... if-com 6 ... 7 A 8 - (setq if-string (buffer-substring (match-beginning 0) (match-end 0))) - ;; First, simple part: find code boundaries - (forward-sexp 1) - (setq post-if (point)) - (forward-sexp -2) - (forward-sexp 1) - (setq post-B (point)) - (cperl-backward-to-start-of-expr) - (setq pre-B (point)) - (setq B (buffer-substring pre-B post-B)) - (goto-char pre-if) - (forward-sexp 2) - (forward-sexp -1) - ;; May be after $, @, $# etc of a variable - (skip-chars-backward "$@%#") - (setq pre-A (point)) - (cperl-forward-to-end-of-expr) - (setq post-A (point)) - (setq A (buffer-substring pre-A post-A)) - ;; Now modify (from end, to not break the stuff) - (skip-chars-forward " \t;") - (delete-region pre-A (point)) ; we move to pre-A - (insert "\n" B ";\n}") - (and (looking-at "[ \t]*#") (cperl-indent-for-comment)) - (delete-region pre-if post-if) - (delete-region pre-B post-B) - (goto-char pre-B) - (insert if-string " (" A ") {") - (setq post-B (point)) - (if (looking-at "[ \t]+$") - (delete-horizontal-space) - (if (looking-at "[ \t]*#") - (cperl-indent-for-comment) - (just-one-space))) - (forward-line 1) - (if (looking-at "[ \t]*$") - (progn ; delete line - (delete-horizontal-space) - (delete-region (point) (1+ (point))))) - (cperl-indent-line) - (goto-char (1- post-B)) - (forward-sexp 1) - (cperl-indent-line) - (goto-char pre-B))) - -(defun cperl-invert-if-unless () - "Change `if (A) {B}' into `B if A;' etc (or visa versa) if possible. -If the cursor is not on the leading keyword of the BLOCK flavor of -construct, will assume it is the STATEMENT flavor, so will try to find -the appropriate statement modifier." - (interactive) - (and (= (char-syntax (preceding-char)) ?w) - (forward-sexp -1)) - (if (looking-at "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>") - (let ((pre-if (point)) - pre-A post-A pre-B post-B A B state p end-B-code is-block B-comment - (if-string (buffer-substring (match-beginning 0) (match-end 0)))) - (forward-sexp 2) - (setq post-A (point)) - (forward-sexp -1) - (setq pre-A (point)) - (setq is-block (and (eq (following-char) ?\( ) - (save-excursion - (condition-case nil - (progn - (forward-sexp 2) - (forward-sexp -1) - (eq (following-char) ?\{ )) - (error nil))))) - (if is-block - (progn - (goto-char post-A) - (forward-sexp 1) - (setq post-B (point)) - (forward-sexp -1) - (setq pre-B (point)) - (if (and (eq (following-char) ?\{ ) - (progn - (cperl-backward-to-noncomment post-A) - (eq (preceding-char) ?\) ))) - (if (condition-case nil - (progn - (goto-char post-B) - (forward-sexp 1) - (forward-sexp -1) - (looking-at "\\")) - (error nil)) - (error - "`%s' (EXPR) {BLOCK} with `else'/`elsif'" if-string) - (goto-char (1- post-B)) - (cperl-backward-to-noncomment pre-B) - (if (eq (preceding-char) ?\;) - (forward-char -1)) - (setq end-B-code (point)) - (goto-char pre-B) - (while (re-search-forward "\\<\\(for\\|foreach\\|if\\|unless\\|while\\|until\\)\\>\\|;" end-B-code t) - (setq p (match-beginning 0) - A (buffer-substring p (match-end 0)) - state (parse-partial-sexp pre-B p)) - (or (nth 3 state) - (nth 4 state) - (nth 5 state) - (error "`%s' inside `%s' BLOCK" A if-string)) - (goto-char (match-end 0))) - ;; Finally got it - (goto-char (1+ pre-B)) - (skip-chars-forward " \t\n") - (setq B (buffer-substring (point) end-B-code)) - (goto-char end-B-code) - (or (looking-at ";?[ \t\n]*}") - (progn - (skip-chars-forward "; \t\n") - (setq B-comment - (buffer-substring (point) (1- post-B))))) - (and (equal B "") - (setq B "1")) - (goto-char (1- post-A)) - (cperl-backward-to-noncomment pre-A) - (or (looking-at "[ \t\n]*)") - (goto-char (1- post-A))) - (setq p (point)) - (goto-char (1+ pre-A)) - (skip-chars-forward " \t\n") - (setq A (buffer-substring (point) p)) - (delete-region pre-B post-B) - (delete-region pre-A post-A) - (goto-char pre-if) - (insert B " ") - (and B-comment (insert B-comment " ")) - (just-one-space) - (forward-word 1) - (setq pre-A (point)) - (insert " " A ";") - (delete-horizontal-space) - (setq post-B (point)) - (if (looking-at "#") - (indent-for-comment)) - (goto-char post-B) - (forward-char -1) - (delete-horizontal-space) - (goto-char pre-A) - (just-one-space) - (goto-char pre-if) - (setq pre-A (set-marker (make-marker) pre-A)) - (while (<= (point) (marker-position pre-A)) - (cperl-indent-line) - (forward-line 1)) - (goto-char (marker-position pre-A)) - (if B-comment - (progn - (forward-line -1) - (indent-for-comment) - (goto-char (marker-position pre-A))))) - (error "`%s' (EXPR) not with an {BLOCK}" if-string))) - ;; (error "`%s' not with an (EXPR)" if-string) - (forward-sexp -1) - (cperl-invert-if-unless-modifiers))) - ;;(error "Not at `if', `unless', `while', `until', `for' or `foreach'") - (cperl-invert-if-unless-modifiers))) - -;;; By Anthony Foiani -;;; Getting help on modules in C-h f ? -;;; This is a modified version of `man'. -;;; Need to teach it how to lookup functions -;;;###autoload -(defun cperl-perldoc (word) - "Run `perldoc' on WORD." - (interactive - (list (let* ((default-entry (cperl-word-at-point)) - (input (read-string - (format "perldoc entry%s: " - (if (string= default-entry "") - "" - (format " (default %s)" default-entry)))))) - (if (string= input "") - (if (string= default-entry "") - (error "No perldoc args given") - default-entry) - input)))) - (require 'man) - (let* ((case-fold-search nil) - (is-func (and - (string-match "^[a-z]+$" word) - (string-match (concat "^" word "\\>") - (documentation-property - 'cperl-short-docs - 'variable-documentation)))) - (manual-program (if is-func "perldoc -f" "perldoc"))) - (cond - ((featurep 'xemacs) - (let ((Manual-program "perldoc") - (Manual-switches (if is-func (list "-f")))) - (manual-entry word))) - (t - (Man-getpage-in-background word))))) - -;;;###autoload -(defun cperl-perldoc-at-point () - "Run a `perldoc' on the word around point." - (interactive) - (cperl-perldoc (cperl-word-at-point))) - -(defcustom pod2man-program "pod2man" - "*File name for `pod2man'." - :type 'file - :group 'cperl) - -;;; By Nick Roberts (with changes) -(defun cperl-pod-to-manpage () - "Create a virtual manpage in Emacs from the Perl Online Documentation." - (interactive) - (require 'man) - (let* ((pod2man-args (concat buffer-file-name " | nroff -man ")) - (bufname (concat "Man " buffer-file-name)) - (buffer (generate-new-buffer bufname))) - (save-excursion - (set-buffer buffer) - (let ((process-environment (copy-sequence process-environment))) - ;; Prevent any attempt to use display terminal fanciness. - (setenv "TERM" "dumb") - (set-process-sentinel - (start-process pod2man-program buffer "sh" "-c" - (format (cperl-pod2man-build-command) pod2man-args)) - 'Man-bgproc-sentinel))))) - -;;; Updated version by him too -(defun cperl-build-manpage () - "Create a virtual manpage in Emacs from the POD in the file." - (interactive) - (require 'man) - (cond - ((featurep 'xemacs) - (let ((Manual-program "perldoc")) - (manual-entry buffer-file-name))) - (t - (let* ((manual-program "perldoc")) - (Man-getpage-in-background buffer-file-name))))) - -(defun cperl-pod2man-build-command () - "Builds the entire background manpage and cleaning command." - (let ((command (concat pod2man-program " %s 2>/dev/null")) - (flist (and (boundp 'Man-filter-list) Man-filter-list))) - (while (and flist (car flist)) - (let ((pcom (car (car flist))) - (pargs (cdr (car flist)))) - (setq command - (concat command " | " pcom " " - (mapconcat '(lambda (phrase) - (if (not (stringp phrase)) - (error "Malformed Man-filter-list")) - phrase) - pargs " "))) - (setq flist (cdr flist)))) - command)) - - -(defun cperl-next-interpolated-REx-1 () - "Move point to next REx which has interpolated parts without //o. -Skips RExes consisting of one interpolated variable. - -Note that skipped RExen are not performance hits." - (interactive "") - (cperl-next-interpolated-REx 1)) - -(defun cperl-next-interpolated-REx-0 () - "Move point to next REx which has interpolated parts without //o." - (interactive "") - (cperl-next-interpolated-REx 0)) - -(defun cperl-next-interpolated-REx (&optional skip beg limit) - "Move point to next REx which has interpolated parts. -SKIP is a list of possible types to skip, BEG and LIMIT are the starting -point and the limit of search (default to point and end of buffer). - -SKIP may be a number, then it behaves as list of numbers up to SKIP; this -semantic may be used as a numeric argument. - -Types are 0 for / $rex /o (interpolated once), 1 for /$rex/ (if $rex is -a result of qr//, this is not a performance hit), t for the rest." - (interactive "P") - (if (numberp skip) (setq skip (list 0 skip))) - (or beg (setq beg (point))) - (or limit (setq limit (point-max))) ; needed for n-s-p-c - (let (pp) - (and (eq (get-text-property beg 'syntax-type) 'string) - (setq beg (next-single-property-change beg 'syntax-type nil limit))) - (cperl-map-pods-heres - (function (lambda (s e p) - (if (memq (get-text-property s 'REx-interpolated) skip) - t - (setq pp s) - nil))) ; nil stops - 'REx-interpolated beg limit) - (if pp (goto-char pp) - (message "No more interpolated REx")))) - -;;; Initial version contributed by Trey Belew -(defun cperl-here-doc-spell (&optional beg end) - "Spell-check HERE-documents in the Perl buffer. -If a region is highlighted, restricts to the region." - (interactive "") - (cperl-pod-spell t beg end)) - -(defun cperl-pod-spell (&optional do-heres beg end) - "Spell-check POD documentation. -If invoked with prefix argument, will do HERE-DOCs instead. -If a region is highlighted, restricts to the region." - (interactive "P") - (save-excursion - (let (beg end) - (if (cperl-mark-active) - (setq beg (min (mark) (point)) - end (max (mark) (point))) - (setq beg (point-min) - end (point-max))) - (cperl-map-pods-heres (function - (lambda (s e p) - (if do-heres - (setq e (save-excursion - (goto-char e) - (forward-line -1) - (point)))) - (ispell-region s e) - t)) - (if do-heres 'here-doc-group 'in-pod) - beg end)))) - -(defun cperl-map-pods-heres (func &optional prop s end) - "Executes a function over regions of pods or here-documents. -PROP is the text-property to search for; default to `in-pod'. Stop when -function returns nil." - (let (pos posend has-prop (cont t)) - (or prop (setq prop 'in-pod)) - (or s (setq s (point-min))) - (or end (setq end (point-max))) - (cperl-update-syntaxification end end) - (save-excursion - (goto-char (setq pos s)) - (while (and cont (< pos end)) - (setq has-prop (get-text-property pos prop)) - (setq posend (next-single-property-change pos prop nil end)) - (and has-prop - (setq cont (funcall func pos posend prop))) - (setq pos posend))))) - -;;; Based on code by Masatake YAMATO: -(defun cperl-get-here-doc-region (&optional pos pod) - "Return HERE document region around the point. -Return nil if the point is not in a HERE document region. If POD is non-nil, -will return a POD section if point is in a POD section." - (or pos (setq pos (point))) - (cperl-update-syntaxification pos pos) - (if (or (eq 'here-doc (get-text-property pos 'syntax-type)) - (and pod - (eq 'pod (get-text-property pos 'syntax-type)))) - (let ((b (cperl-beginning-of-property pos 'syntax-type)) - (e (next-single-property-change pos 'syntax-type))) - (cons b (or e (point-max)))))) - -(defun cperl-narrow-to-here-doc (&optional pos) - "Narrows editing region to the HERE-DOC at POS. -POS defaults to the point." - (interactive "d") - (or pos (setq pos (point))) - (let ((p (cperl-get-here-doc-region pos))) - (or p (error "Not inside a HERE document")) - (narrow-to-region (car p) (cdr p)) - (message - "When you are finished with narrow editing, type C-x n w"))) - -(defun cperl-select-this-pod-or-here-doc (&optional pos) - "Select the HERE-DOC (or POD section) at POS. -POS defaults to the point." - (interactive "d") - (let ((p (cperl-get-here-doc-region pos t))) - (if p - (progn - (goto-char (car p)) - (push-mark (cdr p) nil t)) ; Message, activate in transient-mode - (message "I do not think POS is in POD or a HERE-doc...")))) - -(defun cperl-facemenu-add-face-function (face end) - "A callback to process user-initiated font-change requests. -Translates `bold', `italic', and `bold-italic' requests to insertion of -corresponding POD directives, and `underline' to C<> POD directive. - -Such requests are usually bound to M-o LETTER." - (or (get-text-property (point) 'in-pod) - (error "Faces can only be set within POD")) - (setq facemenu-end-add-face (if (eq face 'bold-italic) ">>" ">")) - (cdr (or (assq face '((bold . "B<") - (italic . "I<") - (bold-italic . "B window-size 0) - (point-min) - (point-max))) - p) - (goto-char pos) - (normal-mode) - ;; Why needed??? With older font-locks??? - (set (make-local-variable 'font-lock-cache-position) (make-marker)) - (while (if (> window-size 0) - (< pos (point-max)) - (> pos (point-min))) - (setq p (progn - (forward-line window-size) - (point))) - (font-lock-fontify-region (min p pos) (max p pos)) - (setq pos p)))) - - -(defun cperl-lazy-install ()) ; Avoid a warning -(defun cperl-lazy-unstall ()) ; Avoid a warning - -(if (fboundp 'run-with-idle-timer) - (progn - (defvar cperl-help-shown nil - "Non-nil means that the help was already shown now.") - - (defvar cperl-lazy-installed nil - "Non-nil means that the lazy-help handlers are installed now.") - - (defun cperl-lazy-install () - "Switches on Auto-Help on Perl constructs (put in the message area). -Delay of auto-help controlled by `cperl-lazy-help-time'." - (interactive) - (make-local-variable 'cperl-help-shown) - (if (and (cperl-val 'cperl-lazy-help-time) - (not cperl-lazy-installed)) - (progn - (add-hook 'post-command-hook 'cperl-lazy-hook) - (run-with-idle-timer - (cperl-val 'cperl-lazy-help-time 1000000 5) - t - 'cperl-get-help-defer) - (setq cperl-lazy-installed t)))) - - (defun cperl-lazy-unstall () - "Switches off Auto-Help on Perl constructs (put in the message area). -Delay of auto-help controlled by `cperl-lazy-help-time'." - (interactive) - (remove-hook 'post-command-hook 'cperl-lazy-hook) - (cancel-function-timers 'cperl-get-help-defer) - (setq cperl-lazy-installed nil)) - - (defun cperl-lazy-hook () - (setq cperl-help-shown nil)) - - (defun cperl-get-help-defer () - (if (not (memq major-mode '(perl-mode cperl-mode))) nil - (let ((cperl-message-on-help-error nil) (cperl-help-from-timer t)) - (cperl-get-help) - (setq cperl-help-shown t)))) - (cperl-lazy-install))) - - -;;; Plug for wrong font-lock: - -(defun cperl-font-lock-unfontify-region-function (beg end) - (let* ((modified (buffer-modified-p)) (buffer-undo-list t) - (inhibit-read-only t) (inhibit-point-motion-hooks t) - before-change-functions after-change-functions - deactivate-mark buffer-file-name buffer-file-truename) - (remove-text-properties beg end '(face nil)) - (if (and (not modified) (buffer-modified-p)) - (set-buffer-modified-p nil)))) - -(defun cperl-font-lock-fontify-region-function (beg end loudly) - "Extends the region to safe positions, then calls the default function. -Newer `font-lock's can do it themselves. -We unwind only as far as needed for fontification. Syntaxification may -do extra unwind via `cperl-unwind-to-safe'." - (save-excursion - (goto-char beg) - (while (and beg - (progn - (beginning-of-line) - (eq (get-text-property (setq beg (point)) 'syntax-type) - 'multiline))) - (if (setq beg (cperl-beginning-of-property beg 'syntax-type)) - (goto-char beg))) - (setq beg (point)) - (goto-char end) - (while (and end - (progn - (or (bolp) (condition-case nil - (forward-line 1) - (error nil))) - (eq (get-text-property (setq end (point)) 'syntax-type) - 'multiline))) - (setq end (next-single-property-change end 'syntax-type nil (point-max))) - (goto-char end)) - (setq end (point))) - (font-lock-default-fontify-region beg end loudly)) - -(defvar cperl-d-l nil) -(defun cperl-fontify-syntaxically (end) - ;; Some vars for debugging only - ;; (message "Syntaxifying...") - (let ((dbg (point)) (iend end) (idone cperl-syntax-done-to) - (istate (car cperl-syntax-state)) - start from-start edebug-backtrace-buffer) - (if (eq cperl-syntaxify-by-font-lock 'backtrace) - (progn - (require 'edebug) - (let ((f 'edebug-backtrace)) - (funcall f)))) ; Avoid compile-time warning - (or cperl-syntax-done-to - (setq cperl-syntax-done-to (point-min) - from-start t)) - (setq start (if (and cperl-hook-after-change - (not from-start)) - cperl-syntax-done-to ; Fontify without change; ignore start - ;; Need to forget what is after `start' - (min cperl-syntax-done-to (point)))) - (goto-char start) - (beginning-of-line) - (setq start (point)) - (and cperl-syntaxify-unwind - (setq end (cperl-unwind-to-safe t end) - start (point))) - (and (> end start) - (setq cperl-syntax-done-to start) ; In case what follows fails - (cperl-find-pods-heres start end t nil t)) - (if (memq cperl-syntaxify-by-font-lock '(backtrace message)) - (message "Syxify req=%s..%s actual=%s..%s done-to: %s=>%s statepos: %s=>%s" - dbg iend start end idone cperl-syntax-done-to - istate (car cperl-syntax-state))) ; For debugging - nil)) ; Do not iterate - -(defun cperl-fontify-update (end) - (let ((pos (point-min)) prop posend) - (setq end (point-max)) - (while (< pos end) - (setq prop (get-text-property pos 'cperl-postpone) - posend (next-single-property-change pos 'cperl-postpone nil end)) - (and prop (put-text-property pos posend (car prop) (cdr prop))) - (setq pos posend))) - nil) ; Do not iterate - -(defun cperl-fontify-update-bad (end) - ;; Since fontification happens with different region than syntaxification, - ;; do to the end of buffer, not to END;;; likewise, start earlier if needed - (let* ((pos (point)) (prop (get-text-property pos 'cperl-postpone)) posend) - (if prop - (setq pos (or (cperl-beginning-of-property - (cperl-1+ pos) 'cperl-postpone) - (point-min)))) - (while (< pos end) - (setq posend (next-single-property-change pos 'cperl-postpone)) - (and prop (put-text-property pos posend (car prop) (cdr prop))) - (setq pos posend) - (setq prop (get-text-property pos 'cperl-postpone)))) - nil) ; Do not iterate - -;; Called when any modification is made to buffer text. -(defun cperl-after-change-function (beg end old-len) - ;; We should have been informed about changes by `font-lock'. Since it - ;; does not inform as which calls are defered, do it ourselves - (if cperl-syntax-done-to - (setq cperl-syntax-done-to (min cperl-syntax-done-to beg)))) - -(defun cperl-update-syntaxification (from to) - (if (and cperl-use-syntax-table-text-property - cperl-syntaxify-by-font-lock - (or (null cperl-syntax-done-to) - (< cperl-syntax-done-to to))) - (progn - (save-excursion - (goto-char from) - (cperl-fontify-syntaxically to))))) - -(defvar cperl-version - (let ((v "Revision: 5.23")) - (string-match ":\\s *\\([0-9.]+\\)" v) - (substring v (match-beginning 1) (match-end 1))) - "Version of IZ-supported CPerl package this file is based on.") - -(provide 'cperl-mode) - -;;; arch-tag: 42e5b19b-e187-4537-929f-1a7408980ce6 -;;; cperl-mode.el ends here diff --git a/emacs_el/google-weather.el b/emacs_el/google-weather.el index d86165d..54fe506 100644 --- a/emacs_el/google-weather.el +++ b/emacs_el/google-weather.el @@ -31,13 +31,16 @@ (require 'xml) (require 'time-date) +(eval-when-compile + (require 'cl)) + (defgroup google-weather nil "Google Weather." :group 'comm) (defconst google-weather-url "http://www.google.com/ig/api" - "URL used to access the Google Weather API.") + "URL of the Google Weather API.") (defconst google-weather-image-url "http://www.google.com" @@ -57,7 +60,7 @@ (if cache-time (time-less-p (time-add - (url-is-cached url) + cache-time (seconds-to-time expire-time)) (current-time)) t))))) @@ -115,7 +118,7 @@ See `google-weather-retrieve-data' for the use of EXPIRE-TIME." (cddr (assoc 'forecast_information (google-weather-data->weather data)))) (defun google-weather-assoc (key data) - "Do some sort of magic 'assoc to find fields in DATA." + "Extract value of field KEY from DATA." (cdr (assoc 'data (cadr (assoc key data))))) (defun google-weather-data->city (data) @@ -125,19 +128,19 @@ See `google-weather-retrieve-data' for the use of EXPIRE-TIME." (google-weather-data->forecast-information data))) (defun google-weather-data->postal-code (data) - "Return the postal code where the data come from." + "Return the postal code where the DATA come from." (google-weather-assoc 'postal_code (google-weather-data->forecast-information data))) (defun google-weather-data->unit-system (data) - "Return the unit system used for data." + "Return the unit system used for DATA." (google-weather-assoc 'unit_system (google-weather-data->forecast-information data))) (defun google-weather-data->forecast-date (data) - "Return the unit system used for data." + "Return the unit system used for DATA." (google-weather-assoc 'forecast_date (google-weather-data->forecast-information data))) @@ -168,12 +171,14 @@ See `google-weather-retrieve-data' for the use of EXPIRE-TIME." (defun google-weather-data->forecast-for-date (data date) "Return forecast for DATE from DATA. -DATE should be in the same format used by calendar i.e. (MONTH DAY YEAR)." - (cdr (assoc date - (google-weather-data->forecast data)))) +DATE should be in the same format used by calendar, +i.e. (MONTH DAY YEAR)." + (cdr (assoc date (google-weather-data->forecast data)))) (defun google-weather-data->temperature-symbol (data) - "Return the temperature to be used according to `google-weather-unit-system-temperature-assoc' in DATA." + "Return the temperature to be used according in DATA. +It uses `google-weather-unit-system-temperature-assoc' to find a +match." (cdr (assoc (google-weather-data->unit-system data) google-weather-unit-system-temperature-assoc))) (provide 'google-weather) diff --git a/emacs_el/org-google-weather.el b/emacs_el/org-google-weather.el index e86ec2e..63f601b 100644 --- a/emacs_el/org-google-weather.el +++ b/emacs_el/org-google-weather.el @@ -73,13 +73,17 @@ Valid %-sequences are: '((chance_of_rain . "weather-showers-scattered.png") (chance_of_snow . "weather-snow.png") (chance_of_storm . "weather-storm.png") + (cn_cloudy . "weather-overcast.png") (cn_heavyrun . "weather-showers.png") + (cn_sunny . "weather-clear.png") (cloudy . "weather-overcast.png") (dust . "weather-fog.png") (flurries . "weather-storm.png") (fog . "weather-fog.png") (haze . "weather-fog.png") (icy . "weather-snow.png") + (jp_sunny . "weather-clear.png") + (jp_cloudy . "weather-overcast.png") (mist . "weather-storm.png") (mostly_cloudy . "weather-overcast.png") (mostly_sunny . "weather-clear.png") @@ -91,7 +95,7 @@ Valid %-sequences are: (storm . "weather-storm.png") (thunderstorm . "weather-storm.png") (sunny . "weather-clear.png")) - "Icons to used to illustrate the weather.") + "Icons to use to illustrate the weather.") ;;;###autoload (defun org-google-weather (&optional location language) @@ -108,25 +112,25 @@ If LOCATION is not set, use org-google-weather-location." (high (cadr (assoc 'high forecast))) (city (google-weather-data->city data)) ;; But *they* told me it's just about calling functions! - (icon (cdr - (assoc - (intern - (file-name-sans-extension - (file-name-nondirectory - (cadr (assoc 'icon forecast))))) - org-google-weather-icon-alist))) + (icon (when (window-system) + (cdr + (assoc + (intern + (file-name-sans-extension + (file-name-nondirectory + (cadr (assoc 'icon forecast))))) + org-google-weather-icon-alist)))) (temp-symbol (google-weather-data->temperature-symbol data))) (format-spec org-google-weather-format - `((?i . ,(if org-google-weather-display-icon-p - (concat (propertize "icon" - 'display - (create-image - (concat - org-google-weather-icon-directory - "/" - icon)) - 'rear-nonsticky '(display)) - " ") + `((?i . ,(if (and icon org-google-weather-display-icon-p) + (propertize "icon" + 'display + (create-image + (concat + org-google-weather-icon-directory + "/" + icon)) + 'rear-nonsticky '(display)) "")) (?c . ,condition) (?L . ,location) diff --git a/emacs_el/post.el b/emacs_el/post.el index 6c1cade..4684073 100644 --- a/emacs_el/post.el +++ b/emacs_el/post.el @@ -1,9 +1,9 @@ -; $Id: post.el,v 2.4 2004/07/23 23:13:17 rreid Exp rreid $ +; $Id: post.el,v 1.10 2008/02/24 23:49:23 rreid Exp $ ;; post.el --- Use (X?)Emacs(client) as an external editor for mail and news. ;;; Authors: Eric Kidd , ;;; Dave Pearson , -;;; Rob Reid , +;;; Rob Reid , ;;; Roland Rosenfeld ;; This is free software distributed under the GPL, yadda, yadda, yadda. @@ -11,15 +11,18 @@ ;; information. Send us your feature requests and patches, and we'll try ;; to integrate everything. -;;; Maintainer: Rob Reid +;;; Maintainers: Rob Reid and +;;; Philip J. Hollenback ;;; Keywords: mail ;;; Commentary: -;; This is a major mode for use with Mutt, the spiffy *nix mailreader du jour -;; (See http://www.mutt.org/), slrn, the spiffy *nix newsreader du jour, or -;; whatever you can get it to work with. To use this mode, add the following -;; line to the .emacs file in your home directory: +;; This is a major mode for use with mutt (http://www.mutt.org/), slrn, or most +;; email and newsreaders that allow you to use an external editor. +;; +;; Installation: +;; +;; Add the following line to the .emacs(.el) file in your home directory: ;; ;; (load "/your/local/path/to/this/file/post") ;; @@ -30,7 +33,8 @@ ;; your sitewide default.el to (require 'post). ;; ;; You may find the latest version of this mode at -;; http://astro.utoronto.ca/~reid/mutt/ +;; http://www.cv.nrao.edu/~rreid/software/email/ or possibly +;; http://sourceforge.net/projects/post-mode/ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -56,6 +60,25 @@ ;;; Revision History ;;; ;;; $Log: post.el,v $ +;;; Revision 1.10 2008/02/24 23:49:23 rreid +;;; *** empty log message *** +;;; +;;; Revision 1.9 2008/02/24 23:46:23 rreid +;;; I really hate the way RCS/VC mucks around with the version number and log. +;;; It's not as dwim as it thinks it is. +;;; +;;; Revision 1.8 2008/02/24 23:43:46 rreid +;;; Updated email address. +;;; +;;; Revision 2.402 2008/02/24 23:31:19 rreid +;;; Emacs 22 finally fixed (how-many) to return an int instead of a string, +;;; i.e. 13 instead of '13 occurrences'. A few people noticed that the change +;;; broke my workaround, but Erik Mugele submitted the winning patch that works +;;; for all emacs versions (I hope). +;;; +;;; This, and the below, are real entries, with real version numbers. Some of +;;; the above are fake commits to get the version number back in sync. +;;; ;;; Revision 2.401 2004/07/23 16:27:29 rreid ;;; Fixed post-delete-quoted-signatures to not remove sneaky things like quoted ;;; double dash arrows. Thanks go to Felix Klee for a clear bug report. @@ -286,12 +309,18 @@ ;; XEmacs gnuserv uses slightly different functions than the GNU Emacs ;; server, and some people are still wasting time and CPU cycles by starting ;; up a new emacs each time. - (cond ((fboundp 'server-edit) - (fset 'post-finish 'server-edit)) - ((fboundp 'gnuserv-kill-buffer-function) - (fset 'post-finish 'gnuserv-kill-buffer-function)) - (t - (fset 'post-finish 'save-buffers-kill-emacs))) + (fset 'post-finish (cond ((fboundp 'server-edit) + 'server-edit) + ((fboundp 'gnuserv-kill-buffer-function) + 'gnuserv-kill-buffer-function) + (t + 'save-buffers-kill-emacs))) +;; (cond ((fboundp 'server-edit) +;; (fset 'post-finish 'server-edit)) +;; ((fboundp 'gnuserv-kill-buffer-function) +;; (fset 'post-finish 'gnuserv-kill-buffer-function)) +;; (t +;; (fset 'post-finish 'save-buffers-kill-emacs))) ;; If customize isn't available just use defvar instead. (unless (fboundp 'defgroup) @@ -318,7 +347,7 @@ is very primitive), you can type \\[fill-paragraph] to rewrap the paragraph." :type 'boolean :group 'post) -(defcustom post-mail-message "mutt-[a-z0-9]+-[0-9]+-[0-9]+\\'" +(defcustom post-mail-message "mutt-[a-z0-9]+-[0-9]+-[0-9]+.*\\'" "*Regular expression which matches your mailer's temporary files." :type 'string :group 'post) @@ -666,7 +695,7 @@ post-signature-text-face) (cond (post-has-attachment) ((equal post-should-prompt-for-attachment 'Never)) ((or (equal post-should-prompt-for-attachment 'Always) - (post-body-says-attach)) + (post-body-says-attach-p)) (post-prompt-for-attachment))) (basic-save-buffer) @@ -679,7 +708,8 @@ post-signature-text-face) ;; Added by Rob Reid 10/13/1998 to prevent accumulating *Composing* buffers ;; when using (emacs|gnu)client. Helped by Eric Marsden's Eliza example in ;; http://www.ssc.com/lg/issue29/marsden.html - (kill-buffer post-buf)) +; (kill-buffer post-buf) +) (defun post-goto-body () "Go to the beginning of the message body." @@ -826,7 +856,7 @@ the signatures in `post-variable-signature-source' must be separated by (nth r marks-st) (nth r marks-end)))) (kill-buffer (current-buffer))) (goto-char (post-kill-signature)) - (insert-string "-- \n") + (insert "-- \n") (insert sig) (if (file-readable-p post-fixed-signature-source) (insert-file-contents post-fixed-signature-source) @@ -863,7 +893,7 @@ the signatures in `post-variable-signature-source' must be separated by (let ((sig (buffer-substring-no-properties sig-start sig-end))) (switch-to-buffer post-select-signature-last-buffer) (goto-char (post-kill-signature)) - (insert-string "-- \n") + (insert "-- \n") (insert sig)) (if (file-readable-p post-fixed-signature-source) (insert-file-contents post-fixed-signature-source)) @@ -898,7 +928,7 @@ the signatures in `post-variable-signature-source' must be separated by (setq sig-to-load (buffer-substring-no-properties sig-start (point))) (switch-to-buffer post-select-signature-last-buffer) (goto-char (post-kill-signature)) - (insert-string "-- \n") + (insert "-- \n") (insert-file (concat post-signature-directory sig-to-load)) (message "Signature set to %s%s" post-signature-directory sig-to-load) (post-select-signature-quit))) @@ -911,8 +941,47 @@ the signatures in `post-variable-signature-source' must be separated by (goto-char post-select-signature-last-point) (delete-other-windows)) +(defun post-attach-file () + "Prompt for an attachment." + (interactive) + (let ((file (read-file-name "Attach file: " nil nil t nil)) + (description (string-read "Description: "))) + (header-attach-file file description))) + ;;; Non-interactive functions +(defun post-prompt-for-attachment () + "Prompt for an attachment." + (if (y-or-n-p "Do you want to attach anything? ") + (post-attach-file))) + +(defun post-references-p () + "Is there a References header in this buffer?" + (save-excursion + (goto-char (point-min)) + (looking-at "^References: "))) + +(defun post-body-says-attach-p () + "Check if attach appears in the body." + (post-goto-body) + + ;; Aargh it's annoying that how-many returns a string, + ;; "13 occurences" instead of a number, 13. + ;; As of Emacs 22 how-many returns an integer number. Consideration + ;; must be taken for both newer and older versions. + (let ((total-attach (how-many post-attachment-regexp))) + (if (string= (type-of total-attach) 'string) + (setq total-attach (string-to-number (how-many post-attachment-regexp)))) + ;; And this mess is just to catch the unlikely false alarm of + ;; "attach" being in the signature, but not in the body. + (if (> total-attach 0) + (progn (post-goto-signature) + (if (string= (type-of (how-many post-attachment-regexp)) 'string) + (> total-attach (string-to-number (how-many + post-attachment-regexp))) + (> total-attach (how-many + post-attachment-regexp))))))) + (defun post-ask-for-address-with-default (header) "Prompt for an email address, showing default. Argument HEADER the header type." @@ -1073,33 +1142,6 @@ When you finish editing this message, type \\[post-save-current-buffer-and-exit] (message (substitute-command-keys "Type \\[describe-mode] for help composing; \\[post-save-current-buffer-and-exit] when done.")))) -(defun post-references-p () - "Is there a References header in this buffer?" - (save-excursion - (goto-char (point-min)) - (looking-at "^References: "))) - -(defun post-body-says-attach () - "Check if attach appears in the body." - (post-goto-body) - - ;; Aargh it's annoying that how-many returns a string, - ;; "13 occurences" instead of a number, 13. - (let ((total-attach (string-to-int (how-many post-attachment-regexp)))) - ;; And this mess is just to catch the unlikely false alarm of - ;; "attach" being in the signature, but not in the body. - (if (> total-attach 0) - (progn (post-goto-signature) - (> total-attach (string-to-int (how-many - post-attachment-regexp))))))) - -(defun post-prompt-for-attachment () - "Prompt for an attachment." - (if (y-or-n-p "Do you want to attach anything? ") - (let ((file (read-file-name "Attach file: " nil nil t nil)) - (description (string-read "Description: "))) - (header-attach-file file description)))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Post Header Mode @@ -1144,7 +1186,7 @@ Optional argument ARG ." (when (re-search-forward (concat "^\\($\\|" field ": \\)")) (if (looking-at "^$") (progn - (insert-string field ": \n") + (insert field ": \n") (forward-char -1)) (header-position-on-value)))))) @@ -1177,7 +1219,7 @@ Argument DESCRIPTION MIME description." (widen) (goto-char (point-min)) (search-forward-regexp "^$") - (insert-string (concat "Attach: " (file-truename file) " " + (insert (concat "Attach: " (file-truename file) " " description "\n")) (message (concat "Attached '" file "'.")) (setq post-has-attachment t)))))) @@ -1286,7 +1328,7 @@ Optional argument DEFAULT ." (cond ((post-find-header-line header) (beginning-of-line) (kill-line) - (insert-string (concat header ": " value))) + (insert (concat header ": " value))) (t (header-append-value header value)))) (message "%s set to %s" header value)) @@ -1295,7 +1337,7 @@ Optional argument DEFAULT ." "Add a HEADER and set it's VALUE (if header exists, will add multiple headers)." (goto-char (point-min)) (search-forward-regexp "^$" nil t) - (insert-string (concat header ": " value "\n"))) + (insert (concat header ": " value "\n"))) ;;; Setup the mode map for the select-signature buffer. (if post-select-signature-mode-map nil diff --git a/emacs_el/vc-bzr.el b/emacs_el/vc-bzr.el deleted file mode 100644 index ad70500..0000000 --- a/emacs_el/vc-bzr.el +++ /dev/null @@ -1,596 +0,0 @@ -;;; vc-bzr.el --- VC backend for the bzr revision control system - -;; Copyright (C) 2006--2008 Free Software Foundation, Inc. - -;; Author: Dave Love , Riccardo Murri -;; Keywords: tools -;; Created: Sept 2006 -;; Version: 2008-01-04 (Bzr revno 25) -;; URL: http://launchpad.net/vc-bzr - -;; This file is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - - -;;; Commentary: - -;; See concerning bzr. See -;; for alternate development -;; branches of `vc-bzr'. - -;; Load this library to register bzr support in VC. In GNU Emacs -;; 22.1, you will need to register the `Bzr' backend with VC: add -;; these lines to your .emacs:: -;; -;; (unless (memq 'Bzr vc-handled-backends) -;; (add-to-list 'vc-handled-backends 'Bzr)) - -;; Known bugs -;; ========== - -;; When edititing a symlink and *both* the symlink and its target -;; are bzr-versioned, `vc-bzr` presently runs `bzr status` on the -;; symlink, thereby not detecting whether the actual contents -;; (that is, the target contents) are changed. -;; See https://bugs.launchpad.net/vc-bzr/+bug/116607 - -;; For an up-to-date list of bugs, please see: -;; https://bugs.launchpad.net/vc-bzr/+bugs - - -;;; Code: - -(eval-when-compile - (require 'cl) - (require 'vc)) ; for vc-exec-after - -;; Clear up the cache to force vc-call to check again and discover -;; new functions when we reload this file. -(put 'Bzr 'vc-functions nil) - -(defgroup vc-bzr nil - "VC bzr backend." -;;:version "22.2" - :group 'vc) - -(defcustom vc-bzr-program "bzr" - "Name of the bzr command (excluding any arguments)." - :group 'vc-bzr - :type 'string) - -(defcustom vc-bzr-diff-switches nil - "String/list of strings specifying extra switches for bzr diff under VC." - :type '(choice (const :tag "None" nil) - (string :tag "Argument String") - (repeat :tag "Argument List" :value ("") string)) - :group 'vc-bzr) - -(defcustom vc-bzr-log-switches nil - "String/list of strings specifying extra switches for `bzr log' under VC." - :type '(choice (const :tag "None" nil) - (string :tag "Argument String") - (repeat :tag "Argument List" :value ("") string)) - :group 'vc-bzr) - -;; since v0.9, bzr supports removing the progress indicators -;; by setting environment variable BZR_PROGRESS_BAR to "none". -(defun vc-bzr-command (bzr-command buffer okstatus file-or-list &rest args) - "Wrapper round `vc-do-command' using `vc-bzr-program' as COMMAND. -Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and -`LC_ALL=C' to the environment." - (let ((process-environment - (list* "BZR_PROGRESS_BAR=none" ; Suppress progress output (bzr >=0.9) - "LC_MESSAGES=C" ; Force English output - process-environment))) - (apply 'vc-do-command buffer okstatus vc-bzr-program - file-or-list bzr-command args))) - -;;;###autoload -(defconst vc-bzr-admin-dirname ".bzr" - "Name of the directory containing Bzr repository status files.") -;;;###autoload -(defconst vc-bzr-admin-checkout-format-file - (concat vc-bzr-admin-dirname "/checkout/format")) -(defconst vc-bzr-admin-dirstate - (concat vc-bzr-admin-dirname "/checkout/dirstate")) -(defconst vc-bzr-admin-branch-format-file - (concat vc-bzr-admin-dirname "/branch/format")) -(defconst vc-bzr-admin-revhistory - (concat vc-bzr-admin-dirname "/branch/revision-history")) -(defconst vc-bzr-admin-lastrev - (concat vc-bzr-admin-dirname "/branch/last-revision")) - -;;;###autoload (defun vc-bzr-registered (file) -;;;###autoload (if (vc-find-root file vc-bzr-admin-checkout-format-file) -;;;###autoload (progn -;;;###autoload (load "vc-bzr") -;;;###autoload (vc-bzr-registered file)))) - -(defun vc-bzr-root (file) - "Return the root directory of the bzr repository containing FILE." - ;; Cache technique copied from vc-arch.el. - (or (vc-file-getprop file 'bzr-root) - (vc-file-setprop - file 'bzr-root - (vc-find-root file vc-bzr-admin-checkout-format-file)))) - -(defun vc-bzr-registered (file) - "Return non-nil if FILE is registered with bzr. - -For speed, this function tries first to parse Bzr internal file -`checkout/dirstate', but it may fail if Bzr internal file format -has changed. As a safeguard, the `checkout/dirstate' file is -only parsed if it contains the string `#bazaar dirstate flat -format 3' in the first line. - -If the `checkout/dirstate' file cannot be parsed, fall back to -running `vc-bzr-state'." - (lexical-let ((root (vc-bzr-root file))) - (when root ; Short cut. - ;; This looks at internal files. May break if they change - ;; their format. - (lexical-let ((dirstate (expand-file-name vc-bzr-admin-dirstate root))) - (if (not (file-readable-p dirstate)) - (vc-bzr-state file) ; Expensive. - (with-temp-buffer - (insert-file-contents dirstate) - (goto-char (point-min)) - (if (not (looking-at "#bazaar dirstate flat format 3")) - (vc-bzr-state file) ; Some other unknown format? - (let* ((relfile (file-relative-name file root)) - (reldir (file-name-directory relfile))) - (re-search-forward - (concat "^\0" - (if reldir (regexp-quote (directory-file-name reldir))) - "\0" - (regexp-quote (file-name-nondirectory relfile)) - "\0") - nil t))))))))) - -(defconst vc-bzr-state-words - "added\\|ignored\\|kind changed\\|modified\\|removed\\|renamed\\|unknown" - "Regexp matching file status words as reported in `bzr' output.") - -(defun vc-bzr-file-name-relative (filename) - "Return file name FILENAME stripped of the initial Bzr repository path." - (lexical-let* - ((filename* (expand-file-name filename)) - (rootdir (vc-bzr-root filename*))) - (when rootdir - (file-relative-name filename* rootdir)))) - -(defun vc-bzr-status (file) - "Return FILE status according to Bzr. -Return value is a cons (STATUS . WARNING), where WARNING is a -string or nil, and STATUS is one of the symbols: `added', -`ignored', `kindchanged', `modified', `removed', `renamed', `unknown', -which directly correspond to `bzr status' output, or 'unchanged -for files whose copy in the working tree is identical to the one -in the branch repository, or nil for files that are not -registered with Bzr. - -If any error occurred in running `bzr status', then return nil." - (with-temp-buffer - (let ((ret (condition-case nil - (vc-bzr-command "status" t 0 file) - (file-error nil))) ; vc-bzr-program not found. - (status 'unchanged)) - ;; the only secure status indication in `bzr status' output - ;; is a couple of lines following the pattern:: - ;; | : - ;; | - ;; if the file is up-to-date, we get no status report from `bzr', - ;; so if the regexp search for the above pattern fails, we consider - ;; the file to be up-to-date. - (goto-char (point-min)) - (when (re-search-forward - ;; bzr prints paths relative to the repository root. - (concat "^\\(" vc-bzr-state-words "\\):[ \t\n]+" - (regexp-quote (vc-bzr-file-name-relative file)) - ;; Bzr appends a '/' to directory names and - ;; '*' to executable files - (if (file-directory-p file) "/?" "\\*?") - "[ \t\n]*$") - nil t) - (lexical-let ((statusword (match-string 1))) - ;; Erase the status text that matched. - (delete-region (match-beginning 0) (match-end 0)) - (setq status - (intern (replace-regexp-in-string " " "" statusword))))) - (when status - (goto-char (point-min)) - (skip-chars-forward " \n\t") ;Throw away spaces. - (cons status - ;; "bzr" will output warnings and informational messages to - ;; stderr; due to Emacs' `vc-do-command' (and, it seems, - ;; `start-process' itself) limitations, we cannot catch stderr - ;; and stdout into different buffers. So, if there's anything - ;; left in the buffer after removing the above status - ;; keywords, let us just presume that any other message from - ;; "bzr" is a user warning, and display it. - (unless (eobp) (buffer-substring (point) (point-max)))))))) - -(defun vc-bzr-state (file) - (lexical-let ((result (vc-bzr-status file))) - (when (consp result) - (if (cdr result) - (message "Warnings in `bzr' output: %s" (cdr result))) - (cdr (assq (car result) - '((added . edited) - (kindchanged . edited) - (renamed . edited) - (modified . edited) - (removed . edited) - (ignored . nil) - (unknown . nil) - (unchanged . up-to-date))))))) - -(defun vc-bzr-workfile-unchanged-p (file) - (eq 'unchanged (car (vc-bzr-status file)))) - -(defun vc-bzr-workfile-version (file) - (lexical-let* - ((rootdir (vc-bzr-root file)) - (branch-format-file (expand-file-name vc-bzr-admin-branch-format-file - rootdir)) - (revhistory-file (expand-file-name vc-bzr-admin-revhistory rootdir)) - (lastrev-file (expand-file-name vc-bzr-admin-lastrev rootdir))) - ;; This looks at internal files to avoid forking a bzr process. - ;; May break if they change their format. - (if (file-exists-p branch-format-file) - (with-temp-buffer - (insert-file-contents branch-format-file) - (goto-char (point-min)) - (cond - ((or - (looking-at "Bazaar-NG branch, format 0.0.4") - (looking-at "Bazaar-NG branch format 5")) - ;; count lines in .bzr/branch/revision-history - (insert-file-contents revhistory-file) - (number-to-string (count-lines (line-end-position) (point-max)))) - ((looking-at "Bazaar Branch Format 6 (bzr 0.15)") - ;; revno is the first number in .bzr/branch/last-revision - (insert-file-contents lastrev-file) - (if (re-search-forward "[0-9]+" nil t) - (buffer-substring (match-beginning 0) (match-end 0)))))) - ;; fallback to calling "bzr revno" - (lexical-let* - ((result (vc-bzr-command-discarding-stderr - vc-bzr-program "revno" file)) - (exitcode (car result)) - (output (cdr result))) - (cond - ((eq exitcode 0) (substring output 0 -1)) - (t nil)))))) - -(defun vc-bzr-checkout-model (file) - 'implicit) - -(defun vc-bzr-create-repo () - "Create a new Bzr repository." - (vc-bzr-command "init" nil 0 nil)) - -(defun vc-bzr-init-version (&optional file) - "Always return nil, as Bzr cannot register explicit versions." - nil) - -(defun vc-bzr-register (files &optional rev comment) - "Register FILE under bzr. -Signal an error unless REV is nil. -COMMENT is ignored." - (if rev (error "Can't register explicit version with bzr")) - (vc-bzr-command "add" nil 0 files)) - -;; Could run `bzr status' in the directory and see if it succeeds, but -;; that's relatively expensive. -(defalias 'vc-bzr-responsible-p 'vc-bzr-root - "Return non-nil if FILE is (potentially) controlled by bzr. -The criterion is that there is a `.bzr' directory in the same -or a superior directory.") - -(defun vc-bzr-could-register (file) - "Return non-nil if FILE could be registered under bzr." - (and (vc-bzr-responsible-p file) ; shortcut - (condition-case () - (with-temp-buffer - (vc-bzr-command "add" t 0 file "--dry-run") - ;; The command succeeds with no output if file is - ;; registered (in bzr 0.8). - (goto-char (point-min)) - (looking-at "added ")) - (error)))) - -(defun vc-bzr-unregister (file) - "Unregister FILE from bzr." - (vc-bzr-command "remove" nil 0 file "--keep")) - -(defun vc-bzr-checkin (files rev comment) - "Check FILE in to bzr with log message COMMENT. -REV non-nil gets an error." - (if rev (error "Can't check in a specific version with bzr")) - (vc-bzr-command "commit" nil 0 files "-m" comment)) - -(defun vc-bzr-find-version (file rev buffer) - "Fetch version REV of file FILE and put it into BUFFER." - (with-current-buffer buffer - (if (and rev (stringp rev) (not (string= rev ""))) - (vc-bzr-command "cat" t 0 file "-r" rev) - (vc-bzr-command "cat" t 0 file)))) - -(defun vc-bzr-checkout (file &optional editable rev destfile) - "Checkout revision REV of FILE from bzr to DESTFILE. -EDITABLE is ignored." - (unless destfile - (setq destfile (vc-version-backup-file-name file rev))) - (let ((coding-system-for-read 'binary) - (coding-system-for-write 'binary)) - (with-temp-file destfile - (if (and rev (stringp rev) (not (string= rev ""))) - (vc-bzr-command "cat" t 0 file "-r" rev) - (vc-bzr-command "cat" t 0 file))))) - -(defun vc-bzr-revert (file &optional contents-done) - (unless contents-done - (with-temp-buffer (vc-bzr-command "revert" t 0 file)))) - -(defvar log-view-message-re) -(defvar log-view-file-re) -(defvar log-view-font-lock-keywords) -(defvar log-view-current-tag-function) - -(define-derived-mode vc-bzr-log-view-mode log-view-mode "Bzr-Log-View" - (remove-hook 'log-view-mode-hook 'vc-bzr-log-view-mode) ;Deactivate the hack. - (require 'add-log) - ;; Don't have file markers, so use impossible regexp. - (set (make-local-variable 'log-view-file-re) "\\'\\`") - (set (make-local-variable 'log-view-message-re) - "^ *-+\n *\\(?:revno: \\([0-9]+\\)\\|merged: .+\\)") - (set (make-local-variable 'log-view-font-lock-keywords) - ;; log-view-font-lock-keywords is careful to use the buffer-local - ;; value of log-view-message-re only since Emacs-23. - (append `((,log-view-message-re . 'log-view-message-face)) - ;; log-view-font-lock-keywords - '(("^ *committer: \ -\\([^<(]+?\\)[ ]*[(<]\\([[:alnum:]_.+-]+@[[:alnum:]_.-]+\\)[>)]" - (1 'change-log-name) - (2 'change-log-email)) - ("^ *timestamp: \\(.*\\)" (1 'change-log-date-face)))))) - -(defun vc-bzr-print-log (files &optional buffer) ; get buffer arg in Emacs 22 - "Get bzr change log for FILES into specified BUFFER." - ;; FIXME: `vc-bzr-command' runs `bzr log' with `LC_MESSAGES=C', so - ;; the log display may not what the user wants - but I see no other - ;; way of getting the above regexps working. - (apply 'vc-bzr-command "log" buffer 0 files - (if (stringp vc-bzr-log-switches) - (list vc-bzr-log-switches) - vc-bzr-log-switches)) - ;; FIXME: Until Emacs-23, VC was missing a hook to sort out the mode for - ;; the buffer, or at least set the regexps right. - (unless (fboundp 'vc-default-log-view-mode) - (add-hook 'log-view-mode-hook 'vc-bzr-log-view-mode))) - -(defun vc-bzr-show-log-entry (version) - "Find entry for patch name VERSION in bzr change log buffer." - (goto-char (point-min)) - (let (case-fold-search) - (if (re-search-forward (concat "^-+\nrevno: " version "$") nil t) - (beginning-of-line 0) - (goto-char (point-min))))) - -(autoload 'vc-diff-switches-list "vc" nil nil t) - -(defun vc-bzr-diff (files &optional rev1 rev2 buffer) - "VC bzr backend for diff." - (let ((working (vc-workfile-version (if (consp files) (car files) files)))) - (if (and (equal rev1 working) (not rev2)) - (setq rev1 nil)) - (if (and (not rev1) rev2) - (setq rev1 working)) - ;; bzr diff produces condition code 1 for some reason. - (apply #'vc-bzr-command "diff" (or buffer "*vc-diff*") 1 files - "--diff-options" (mapconcat 'identity (vc-diff-switches-list bzr) - " ") - (when rev1 - (if rev2 - (list "-r" (format "%s..%s" rev1 rev2)) - (list "-r" rev1)))))) - -(defalias 'vc-bzr-diff-tree 'vc-bzr-diff) - - -;; FIXME: vc-{next,previous}-version need fixing in vc.el to deal with -;; straight integer versions. - -(defun vc-bzr-delete-file (file) - "Delete FILE and delete it in the bzr repository." - (condition-case () - (delete-file file) - (file-error nil)) - (vc-bzr-command "remove" nil 0 file)) - -(defun vc-bzr-rename-file (old new) - "Rename file from OLD to NEW using `bzr mv'." - (vc-bzr-command "mv" nil 0 new old)) - -(defvar vc-bzr-annotation-table nil - "Internal use.") -(make-variable-buffer-local 'vc-bzr-annotation-table) - -(defun vc-bzr-annotate-command (file buffer &optional version) - "Prepare BUFFER for `vc-annotate' on FILE. -Each line is tagged with the revision number, which has a `help-echo' -property containing author and date information." - (apply #'vc-bzr-command "annotate" buffer 0 file "--long" "--all" - (if version (list "-r" version))) - (with-current-buffer buffer - ;; Store the tags for the annotated source lines in a hash table - ;; to allow saving space by sharing the text properties. - (setq vc-bzr-annotation-table (make-hash-table :test 'equal)) - (goto-char (point-min)) - (while (re-search-forward "^\\( *[0-9]+\\) +\\(.+\\) +\\([0-9]\\{8\\}\\) |" - nil t) - (let* ((rev (match-string 1)) - (author (match-string 2)) - (date (match-string 3)) - (key (match-string 0)) - (tag (gethash key vc-bzr-annotation-table))) - (unless tag - (setq tag (propertize rev 'help-echo (concat "Author: " author - ", date: " date) - 'mouse-face 'highlight)) - (puthash key tag vc-bzr-annotation-table)) - (replace-match "") - (insert tag " |"))))) - -;; Definition from Emacs 22 -(unless (fboundp 'vc-annotate-convert-time) - (defun vc-annotate-convert-time (time) - "Convert a time value to a floating-point number of days. -The argument TIME is a list as returned by `current-time' or -`encode-time', only the first two elements of that list are considered." - (/ (+ (* (float (car time)) (lsh 1 16)) (cadr time)) 24 3600))) - -(defun vc-bzr-annotate-time () - (when (re-search-forward "^ *[0-9]+ |" nil t) - (let ((prop (get-text-property (line-beginning-position) 'help-echo))) - (string-match "[0-9]+\\'" prop) - (vc-annotate-convert-time - (encode-time 0 0 0 - (string-to-number (substring (match-string 0 prop) 6 8)) - (string-to-number (substring (match-string 0 prop) 4 6)) - (string-to-number (substring (match-string 0 prop) 0 4)) - ))))) - -(defun vc-bzr-annotate-extract-revision-at-line () - "Return revision for current line of annoation buffer, or nil. -Return nil if current line isn't annotated." - (save-excursion - (beginning-of-line) - (if (looking-at " *\\([0-9]+\\) | ") - (match-string-no-properties 1)))) - -;; Not needed for Emacs 22 -(defun vc-bzr-annotate-difference (point) - (let ((next-time (vc-bzr-annotate-time))) - (if next-time - (- (vc-annotate-convert-time (current-time)) next-time)))) - -(defun vc-bzr-command-discarding-stderr (command &rest args) - "Execute shell command COMMAND (with ARGS); return its output and exitcode. -Return value is a cons (EXITCODE . OUTPUT), where EXITCODE is -the (numerical) exit code of the process, and OUTPUT is a string -containing whatever the process sent to its standard output -stream. Standard error output is discarded." - (with-temp-buffer - (cons - (apply #'call-process command nil (list (current-buffer) nil) nil args) - (buffer-substring (point-min) (point-max))))) - -;; TODO: it would be nice to mark the conflicted files in VC Dired, -;; and implement a command to run ediff and `bzr resolve' once the -;; changes have been merged. -(defun vc-bzr-dir-state (dir &optional localp) - "Find the VC state of all files in DIR. -Optional argument LOCALP is always ignored." - (let ((bzr-root-directory (vc-bzr-root dir)) - (at-start t) - current-bzr-state current-vc-state) - ;; Check that DIR is a bzr repository. - (unless (file-name-absolute-p bzr-root-directory) - (error "Cannot find bzr repository for directory `%s'" dir)) - ;; `bzr ls --versioned' lists all versioned files; - ;; assume they are up-to-date, unless we are given - ;; evidence of the contrary. - (setq at-start t) - (with-temp-buffer - (vc-bzr-command "ls" t 0 nil "--versioned" "--non-recursive") - (goto-char (point-min)) - (while (or at-start - (eq 0 (forward-line))) - (setq at-start nil) - (let ((file (expand-file-name - (buffer-substring-no-properties - (line-beginning-position) (line-end-position)) - bzr-root-directory))) - ;; files are up-to-date unless they appear in the `bzr - ;; status' output below - (vc-file-setprop file 'vc-state 'up-to-date) - ;; XXX: is this correct? what happens if one - ;; mixes different SCMs in the same dir? - ;; Anyway, we're looking at the output of `bzr ls --versioned', - ;; so we know these files are registered with Bzr. - (vc-file-setprop file 'vc-backend 'Bzr)))) - ;; `bzr status' reports on added/modified/renamed and unknown/ignored files - (setq at-start t) - (with-temp-buffer - (vc-bzr-command "status" t 0 nil) - (goto-char (point-min)) - (while (or at-start - (eq 0 (forward-line))) - (setq at-start nil) - (cond - ((looking-at "^added") - (setq current-vc-state 'edited) - (setq current-bzr-state 'added)) - ((looking-at "^kind changed") - (setq current-vc-state 'edited) - (setq current-bzr-state 'kindchanged)) - ((looking-at "^modified") - (setq current-vc-state 'edited) - (setq current-bzr-state 'modified)) - ((looking-at "^renamed") - (setq current-vc-state 'edited) - (setq current-bzr-state 'renamed)) - ((looking-at "^\\(unknown\\|ignored\\)") - (setq current-vc-state nil) - (setq current-bzr-state 'not-versioned)) - ((looking-at " ") - ;; file names are indented by two spaces - (when current-vc-state - (let ((file (expand-file-name - (buffer-substring-no-properties - (match-end 0) (line-end-position)) - bzr-root-directory))) - (vc-file-setprop file 'vc-state current-vc-state) - (vc-file-setprop file 'vc-bzr-state current-bzr-state) - (when (eq 'added current-bzr-state) - (vc-file-setprop file 'vc-workfile-version "0")))) - (when (eq 'not-versioned current-bzr-state) - (let ((file (expand-file-name - (buffer-substring-no-properties - (match-end 0) (line-end-position)) - bzr-root-directory))) - (vc-file-setprop file 'vc-backend 'none) - (vc-file-setprop file 'vc-state nil)))) - (t - ;; skip this part of `bzr status' output - (setq current-vc-state nil) - (setq current-bzr-state nil))))))) - -(defun vc-bzr-dired-state-info (file) - "Bzr-specific version of `vc-dired-state-info'." - (if (eq 'edited (vc-state file)) - (concat "(" (symbol-name (or (vc-file-getprop file 'vc-bzr-state) - 'edited)) ")") - ;; else fall back to default vc.el representation - (vc-default-dired-state-info 'Bzr file))) - -(eval-after-load "vc" - '(add-to-list 'vc-directory-exclusion-list vc-bzr-admin-dirname t)) - -(provide 'vc-bzr) -;; arch-tag: 8101bad8-4e92-4e7d-85ae-d8e08b4e7c06 -;;; vc-bzr.el ends here -- 2.39.2