1;;; cperl-mode.el --- Perl code editing commands for Emacs 2 3;; Copyright (C) 1985, 1986, 1987, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 4;; 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 5;; Free Software Foundation, Inc. 6 7;; Author: Ilya Zakharevich and Bob Olson 8;; Maintainer: Ilya Zakharevich <ilyaz@cpan.org> 9;; Keywords: languages, Perl 10 11;; This file is part of GNU Emacs. 12 13;; GNU Emacs is free software; you can redistribute it and/or modify 14;; it under the terms of the GNU General Public License as published by 15;; the Free Software Foundation; either version 2, or (at your option) 16;; any later version. 17 18;; GNU Emacs is distributed in the hope that it will be useful, 19;; but WITHOUT ANY WARRANTY; without even the implied warranty of 20;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 21;; GNU General Public License for more details. 22 23;; You should have received a copy of the GNU General Public License 24;; along with GNU Emacs; see the file COPYING. If not, write to the 25;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 26;; Boston, MA 02110-1301, USA. 27 28;;; Corrections made by Ilya Zakharevich ilyaz@cpan.org 29 30;;; Commentary: 31 32;; You can either fine-tune the bells and whistles of this mode or 33;; bulk enable them by putting 34 35;; (setq cperl-hairy t) 36 37;; in your .emacs file. (Emacs rulers do not consider it politically 38;; correct to make whistles enabled by default.) 39 40;; DO NOT FORGET to read micro-docs (available from `Perl' menu) <<<<<< 41;; or as help on variables `cperl-tips', `cperl-problems', <<<<<< 42;; `cperl-praise', `cperl-speed'. <<<<<< 43 44;; The mode information (on C-h m) provides some customization help. 45;; If you use font-lock feature of this mode, it is advisable to use 46;; either lazy-lock-mode or fast-lock-mode. I prefer lazy-lock. 47 48;; Faces used now: three faces for first-class and second-class keywords 49;; and control flow words, one for each: comments, string, labels, 50;; functions definitions and packages, arrays, hashes, and variable 51;; definitions. If you do not see all these faces, your font-lock does 52;; not define them, so you need to define them manually. 53 54;; This mode supports font-lock, imenu and mode-compile. In the 55;; hairy version font-lock is on, but you should activate imenu 56;; yourself (note that mode-compile is not standard yet). Well, you 57;; can use imenu from keyboard anyway (M-x imenu), but it is better 58;; to bind it like that: 59 60;; (define-key global-map [M-S-down-mouse-3] 'imenu) 61 62;;; Font lock bugs as of v4.32: 63 64;; The following kinds of Perl code erroneously start strings: 65;; \$` \$' \$" 66;; $opt::s $opt_s $opt{s} (s => ...) /\s+.../ 67;; likewise with m, tr, y, q, qX instead of s 68 69;;; Code: 70 71(defvar vc-rcs-header) 72(defvar vc-sccs-header) 73 74(eval-when-compile 75 (condition-case nil 76 (require 'custom) 77 (error nil)) 78 (condition-case nil 79 (require 'man) 80 (error nil)) 81 (defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) 82 (defvar cperl-can-font-lock 83 (or cperl-xemacs-p 84 (and (boundp 'emacs-major-version) 85 (or window-system 86 (> emacs-major-version 20))))) 87 (if cperl-can-font-lock 88 (require 'font-lock)) 89 (defvar msb-menu-cond) 90 (defvar gud-perldb-history) 91 (defvar font-lock-background-mode) ; not in Emacs 92 (defvar font-lock-display-type) ; ditto 93 (defvar paren-backwards-message) ; Not in newer XEmacs? 94 (or (fboundp 'defgroup) 95 (defmacro defgroup (name val doc &rest arr) 96 nil)) 97 (or (fboundp 'custom-declare-variable) 98 (defmacro defcustom (name val doc &rest arr) 99 (` (defvar (, name) (, val) (, doc))))) 100 (or (and (fboundp 'custom-declare-variable) 101 (string< "19.31" emacs-version)) ; Checked with 19.30: defface does not work 102 (defmacro defface (&rest arr) 103 nil)) 104 ;; Avoid warning (tmp definitions) 105 (or (fboundp 'x-color-defined-p) 106 (defmacro x-color-defined-p (col) 107 (cond ((fboundp 'color-defined-p) (` (color-defined-p (, col)))) 108 ;; XEmacs >= 19.12 109 ((fboundp 'valid-color-name-p) (` (valid-color-name-p (, col)))) 110 ;; XEmacs 19.11 111 ((fboundp 'x-valid-color-name-p) (` (x-valid-color-name-p (, col)))) 112 (t '(error "Cannot implement color-defined-p"))))) 113 (defmacro cperl-is-face (arg) ; Takes quoted arg 114 (cond ((fboundp 'find-face) 115 (` (find-face (, arg)))) 116 (;;(and (fboundp 'face-list) 117 ;; (face-list)) 118 (fboundp 'face-list) 119 (` (member (, arg) (and (fboundp 'face-list) 120 (face-list))))) 121 (t 122 (` (boundp (, arg)))))) 123 (defmacro cperl-make-face (arg descr) ; Takes unquoted arg 124 (cond ((fboundp 'make-face) 125 (` (make-face (quote (, arg))))) 126 (t 127 (` (defvar (, arg) (quote (, arg)) (, descr)))))) 128 (defmacro cperl-force-face (arg descr) ; Takes unquoted arg 129 (` (progn 130 (or (cperl-is-face (quote (, arg))) 131 (cperl-make-face (, arg) (, descr))) 132 (or (boundp (quote (, arg))) ; We use unquoted variants too 133 (defvar (, arg) (quote (, arg)) (, descr)))))) 134 (if cperl-xemacs-p 135 (defmacro cperl-etags-snarf-tag (file line) 136 (` (progn 137 (beginning-of-line 2) 138 (list (, file) (, line))))) 139 (defmacro cperl-etags-snarf-tag (file line) 140 (` (etags-snarf-tag)))) 141 (if cperl-xemacs-p 142 (defmacro cperl-etags-goto-tag-location (elt) 143 (`;;(progn 144 ;; (switch-to-buffer (get-file-buffer (elt (, elt) 0))) 145 ;; (set-buffer (get-file-buffer (elt (, elt) 0))) 146 ;; Probably will not work due to some save-excursion??? 147 ;; Or save-file-position? 148 ;; (message "Did I get to line %s?" (elt (, elt) 1)) 149 (goto-line (string-to-int (elt (, elt) 1))))) 150 ;;) 151 (defmacro cperl-etags-goto-tag-location (elt) 152 (` (etags-goto-tag-location (, elt)))))) 153 154(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) 155 156(defvar cperl-can-font-lock 157 (or cperl-xemacs-p 158 (and (boundp 'emacs-major-version) 159 (or window-system 160 (> emacs-major-version 20))))) 161 162(defun cperl-choose-color (&rest list) 163 (let (answer) 164 (while list 165 (or answer 166 (if (or (x-color-defined-p (car list)) 167 (null (cdr list))) 168 (setq answer (car list)))) 169 (setq list (cdr list))) 170 answer)) 171 172(defgroup cperl nil 173 "Major mode for editing Perl code." 174 :prefix "cperl-" 175 :group 'languages 176 :version "20.3") 177 178(defgroup cperl-indentation-details nil 179 "Indentation." 180 :prefix "cperl-" 181 :group 'cperl) 182 183(defgroup cperl-affected-by-hairy nil 184 "Variables affected by `cperl-hairy'." 185 :prefix "cperl-" 186 :group 'cperl) 187 188(defgroup cperl-autoinsert-details nil 189 "Auto-insert tuneup." 190 :prefix "cperl-" 191 :group 'cperl) 192 193(defgroup cperl-faces nil 194 "Fontification colors." 195 :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces) 196 :prefix "cperl-" 197 :group 'cperl) 198 199(defgroup cperl-speed nil 200 "Speed vs. validity tuneup." 201 :prefix "cperl-" 202 :group 'cperl) 203 204(defgroup cperl-help-system nil 205 "Help system tuneup." 206 :prefix "cperl-" 207 :group 'cperl) 208 209 210(defcustom cperl-extra-newline-before-brace nil 211 "*Non-nil means that if, elsif, while, until, else, for, foreach 212and do constructs look like: 213 214 if () 215 { 216 } 217 218instead of: 219 220 if () { 221 }" 222 :type 'boolean 223 :group 'cperl-autoinsert-details) 224 225(defcustom cperl-extra-newline-before-brace-multiline 226 cperl-extra-newline-before-brace 227 "*Non-nil means the same as `cperl-extra-newline-before-brace', but 228for constructs with multiline if/unless/while/until/for/foreach condition." 229 :type 'boolean 230 :group 'cperl-autoinsert-details) 231 232(defcustom cperl-indent-level 2 233 "*Indentation of CPerl statements with respect to containing block." 234 :type 'integer 235 :group 'cperl-indentation-details) 236(put 'cperl-indent-level 'safe-local-variable 'integerp) 237 238(defcustom cperl-lineup-step nil 239 "*`cperl-lineup' will always lineup at multiple of this number. 240If nil, the value of `cperl-indent-level' will be used." 241 :type '(choice (const nil) integer) 242 :group 'cperl-indentation-details) 243 244(defcustom cperl-brace-imaginary-offset 0 245 "*Imagined indentation of a Perl open brace that actually follows a statement. 246An open brace following other text is treated as if it were this far 247to the right of the start of its line." 248 :type 'integer 249 :group 'cperl-indentation-details) 250 251(defcustom cperl-brace-offset 0 252 "*Extra indentation for braces, compared with other text in same context." 253 :type 'integer 254 :group 'cperl-indentation-details) 255(defcustom cperl-label-offset -2 256 "*Offset of CPerl label lines relative to usual indentation." 257 :type 'integer 258 :group 'cperl-indentation-details) 259(defcustom cperl-min-label-indent 1 260 "*Minimal offset of CPerl label lines." 261 :type 'integer 262 :group 'cperl-indentation-details) 263(defcustom cperl-continued-statement-offset 2 264 "*Extra indent for lines not starting new statements." 265 :type 'integer 266 :group 'cperl-indentation-details) 267(defcustom cperl-continued-brace-offset 0 268 "*Extra indent for substatements that start with open-braces. 269This is in addition to cperl-continued-statement-offset." 270 :type 'integer 271 :group 'cperl-indentation-details) 272(defcustom cperl-close-paren-offset -1 273 "*Extra indent for substatements that start with close-parenthesis." 274 :type 'integer 275 :group 'cperl-indentation-details) 276 277(defcustom cperl-indent-wrt-brace t 278 "*Non-nil means indent statements in if/etc block relative brace, not if/etc. 279Versions 5.2 ... 5.20 behaved as if this were `nil'." 280 :type 'boolean 281 :group 'cperl-indentation-details) 282 283(defcustom cperl-auto-newline nil 284 "*Non-nil means automatically newline before and after braces, 285and after colons and semicolons, inserted in CPerl code. The following 286\\[cperl-electric-backspace] will remove the inserted whitespace. 287Insertion after colons requires both this variable and 288`cperl-auto-newline-after-colon' set." 289 :type 'boolean 290 :group 'cperl-autoinsert-details) 291 292(defcustom cperl-autoindent-on-semi nil 293 "*Non-nil means automatically indent after insertion of (semi)colon. 294Active if `cperl-auto-newline' is false." 295 :type 'boolean 296 :group 'cperl-autoinsert-details) 297 298(defcustom cperl-auto-newline-after-colon nil 299 "*Non-nil means automatically newline even after colons. 300Subject to `cperl-auto-newline' setting." 301 :type 'boolean 302 :group 'cperl-autoinsert-details) 303 304(defcustom cperl-tab-always-indent t 305 "*Non-nil means TAB in CPerl mode should always reindent the current line, 306regardless of where in the line point is when the TAB command is used." 307 :type 'boolean 308 :group 'cperl-indentation-details) 309 310(defcustom cperl-font-lock nil 311 "*Non-nil (and non-null) means CPerl buffers will use `font-lock-mode'. 312Can be overwritten by `cperl-hairy' if nil." 313 :type '(choice (const null) boolean) 314 :group 'cperl-affected-by-hairy) 315 316(defcustom cperl-electric-lbrace-space nil 317 "*Non-nil (and non-null) means { after $ should be preceded by ` '. 318Can be overwritten by `cperl-hairy' if nil." 319 :type '(choice (const null) boolean) 320 :group 'cperl-affected-by-hairy) 321 322(defcustom cperl-electric-parens-string "({[]})<" 323 "*String of parentheses that should be electric in CPerl. 324Closing ones are electric only if the region is highlighted." 325 :type 'string 326 :group 'cperl-affected-by-hairy) 327 328(defcustom cperl-electric-parens nil 329 "*Non-nil (and non-null) means parentheses should be electric in CPerl. 330Can be overwritten by `cperl-hairy' if nil." 331 :type '(choice (const null) boolean) 332 :group 'cperl-affected-by-hairy) 333 334(defvar zmacs-regions) ; Avoid warning 335 336(defcustom cperl-electric-parens-mark 337 (and window-system 338 (or (and (boundp 'transient-mark-mode) ; For Emacs 339 transient-mark-mode) 340 (and (boundp 'zmacs-regions) ; For XEmacs 341 zmacs-regions))) 342 "*Not-nil means that electric parens look for active mark. 343Default is yes if there is visual feedback on mark." 344 :type 'boolean 345 :group 'cperl-autoinsert-details) 346 347(defcustom cperl-electric-linefeed nil 348 "*If true, LFD should be hairy in CPerl, otherwise C-c LFD is hairy. 349In any case these two mean plain and hairy linefeeds together. 350Can be overwritten by `cperl-hairy' if nil." 351 :type '(choice (const null) boolean) 352 :group 'cperl-affected-by-hairy) 353 354(defcustom cperl-electric-keywords nil 355 "*Not-nil (and non-null) means keywords are electric in CPerl. 356Can be overwritten by `cperl-hairy' if nil. 357 358Uses `abbrev-mode' to do the expansion. If you want to use your 359own abbrevs in cperl-mode, but do not want keywords to be 360electric, you must redefine `cperl-mode-abbrev-table': do 361\\[edit-abbrevs], search for `cperl-mode-abbrev-table', and, in 362that paragraph, delete the words that appear at the ends of lines and 363that begin with \"cperl-electric\". 364" 365 :type '(choice (const null) boolean) 366 :group 'cperl-affected-by-hairy) 367 368(defcustom cperl-electric-backspace-untabify t 369 "*Not-nil means electric-backspace will untabify in CPerl." 370 :type 'boolean 371 :group 'cperl-autoinsert-details) 372 373(defcustom cperl-hairy nil 374 "*Not-nil means most of the bells and whistles are enabled in CPerl. 375Affects: `cperl-font-lock', `cperl-electric-lbrace-space', 376`cperl-electric-parens', `cperl-electric-linefeed', `cperl-electric-keywords', 377`cperl-info-on-command-no-prompt', `cperl-clobber-lisp-bindings', 378`cperl-lazy-help-time'." 379 :type 'boolean 380 :group 'cperl-affected-by-hairy) 381 382(defcustom cperl-comment-column 32 383 "*Column to put comments in CPerl (use \\[cperl-indent] to lineup with code)." 384 :type 'integer 385 :group 'cperl-indentation-details) 386 387(defcustom cperl-indent-comment-at-column-0 nil 388 "*Non-nil means that comment started at column 0 should be indentable." 389 :type 'boolean 390 :group 'cperl-indentation-details) 391 392(defcustom cperl-vc-sccs-header '("($sccs) = ('%W\%' =~ /(\\d+(\\.\\d+)+)/) ;") 393 "*Special version of `vc-sccs-header' that is used in CPerl mode buffers." 394 :type '(repeat string) 395 :group 'cperl) 396 397(defcustom cperl-vc-rcs-header '("($rcs) = (' $Id\$ ' =~ /(\\d+(\\.\\d+)+)/);") 398 "*Special version of `vc-rcs-header' that is used in CPerl mode buffers." 399 :type '(repeat string) 400 :group 'cperl) 401 402;; This became obsolete... 403(defvar cperl-vc-header-alist nil) 404(make-obsolete-variable 405 'cperl-vc-header-alist 406 "use cperl-vc-rcs-header or cperl-vc-sccs-header instead.") 407 408(defcustom cperl-clobber-mode-lists 409 (not 410 (and 411 (boundp 'interpreter-mode-alist) 412 (assoc "miniperl" interpreter-mode-alist) 413 (assoc "\\.\\([pP][Llm]\\|al\\)$" auto-mode-alist))) 414 "*Whether to install us into `interpreter-' and `extension' mode lists." 415 :type 'boolean 416 :group 'cperl) 417 418(defcustom cperl-info-on-command-no-prompt nil 419 "*Not-nil (and non-null) means not to prompt on C-h f. 420The opposite behavior is always available if prefixed with C-c. 421Can be overwritten by `cperl-hairy' if nil." 422 :type '(choice (const null) boolean) 423 :group 'cperl-affected-by-hairy) 424 425(defcustom cperl-clobber-lisp-bindings nil 426 "*Not-nil (and non-null) means not overwrite C-h f. 427The function is available on \\[cperl-info-on-command], \\[cperl-get-help]. 428Can be overwritten by `cperl-hairy' if nil." 429 :type '(choice (const null) boolean) 430 :group 'cperl-affected-by-hairy) 431 432(defcustom cperl-lazy-help-time nil 433 "*Not-nil (and non-null) means to show lazy help after given idle time. 434Can be overwritten by `cperl-hairy' to be 5 sec if nil." 435 :type '(choice (const null) (const nil) integer) 436 :group 'cperl-affected-by-hairy) 437 438(defcustom cperl-pod-face 'font-lock-comment-face 439 "*Face for POD highlighting." 440 :type 'face 441 :group 'cperl-faces) 442 443(defcustom cperl-pod-head-face 'font-lock-variable-name-face 444 "*Face for POD highlighting. 445Font for POD headers." 446 :type 'face 447 :group 'cperl-faces) 448 449(defcustom cperl-here-face 'font-lock-string-face 450 "*Face for here-docs highlighting." 451 :type 'face 452 :group 'cperl-faces) 453 454;;; Some double-evaluation happened with font-locks... Needed with 21.2... 455(defvar cperl-singly-quote-face cperl-xemacs-p) 456 457(defcustom cperl-invalid-face 'underline 458 "*Face for highlighting trailing whitespace." 459 :type 'face 460 :version "21.1" 461 :group 'cperl-faces) 462 463(defcustom cperl-pod-here-fontify '(featurep 'font-lock) 464 "*Not-nil after evaluation means to highlight POD and here-docs sections." 465 :type 'boolean 466 :group 'cperl-faces) 467 468(defcustom cperl-fontify-m-as-s t 469 "*Not-nil means highlight 1arg regular expressions operators same as 2arg." 470 :type 'boolean 471 :group 'cperl-faces) 472 473(defcustom cperl-highlight-variables-indiscriminately nil 474 "*Non-nil means perform additional highlighting on variables. 475Currently only changes how scalar variables are highlighted. 476Note that that variable is only read at initialization time for 477the variable `cperl-font-lock-keywords-2', so changing it after you've 478entered CPerl mode the first time will have no effect." 479 :type 'boolean 480 :group 'cperl) 481 482(defcustom cperl-pod-here-scan t 483 "*Not-nil means look for POD and here-docs sections during startup. 484You can always make lookup from menu or using \\[cperl-find-pods-heres]." 485 :type 'boolean 486 :group 'cperl-speed) 487 488(defcustom cperl-regexp-scan t 489 "*Not-nil means make marking of regular expression more thorough. 490Effective only with `cperl-pod-here-scan'." 491 :type 'boolean 492 :group 'cperl-speed) 493 494(defcustom cperl-hook-after-change t 495 "*Not-nil means install hook to know which regions of buffer are changed. 496May significantly speed up delayed fontification. Changes take effect 497after reload." 498 :type 'boolean 499 :group 'cperl-speed) 500 501(defcustom cperl-imenu-addback nil 502 "*Not-nil means add backreferences to generated `imenu's. 503May require patched `imenu' and `imenu-go'. Obsolete." 504 :type 'boolean 505 :group 'cperl-help-system) 506 507(defcustom cperl-max-help-size 66 508 "*Non-nil means shrink-wrapping of info-buffer allowed up to these percents." 509 :type '(choice integer (const nil)) 510 :group 'cperl-help-system) 511 512(defcustom cperl-shrink-wrap-info-frame t 513 "*Non-nil means shrink-wrapping of info-buffer-frame allowed." 514 :type 'boolean 515 :group 'cperl-help-system) 516 517(defcustom cperl-info-page "perl" 518 "*Name of the info page containing perl docs. 519Older version of this page was called `perl5', newer `perl'." 520 :type 'string 521 :group 'cperl-help-system) 522 523(defcustom cperl-use-syntax-table-text-property 524 (boundp 'parse-sexp-lookup-properties) 525 "*Non-nil means CPerl sets up and uses `syntax-table' text property." 526 :type 'boolean 527 :group 'cperl-speed) 528 529(defcustom cperl-use-syntax-table-text-property-for-tags 530 cperl-use-syntax-table-text-property 531 "*Non-nil means: set up and use `syntax-table' text property generating TAGS." 532 :type 'boolean 533 :group 'cperl-speed) 534 535(defcustom cperl-scan-files-regexp "\\.\\([pP][Llm]\\|xs\\)$" 536 "*Regexp to match files to scan when generating TAGS." 537 :type 'regexp 538 :group 'cperl) 539 540(defcustom cperl-noscan-files-regexp 541 "/\\(\\.\\.?\\|SCCS\\|RCS\\|CVS\\|blib\\)$" 542 "*Regexp to match files/dirs to skip when generating TAGS." 543 :type 'regexp 544 :group 'cperl) 545 546(defcustom cperl-regexp-indent-step nil 547 "*Indentation used when beautifying regexps. 548If nil, the value of `cperl-indent-level' will be used." 549 :type '(choice integer (const nil)) 550 :group 'cperl-indentation-details) 551 552(defcustom cperl-indent-left-aligned-comments t 553 "*Non-nil means that the comment starting in leftmost column should indent." 554 :type 'boolean 555 :group 'cperl-indentation-details) 556 557(defcustom cperl-under-as-char nil 558 "*Non-nil means that the _ (underline) should be treated as word char." 559 :type 'boolean 560 :group 'cperl) 561 562(defcustom cperl-extra-perl-args "" 563 "*Extra arguments to use when starting Perl. 564Currently used with `cperl-check-syntax' only." 565 :type 'string 566 :group 'cperl) 567 568(defcustom cperl-message-electric-keyword t 569 "*Non-nil means that the `cperl-electric-keyword' prints a help message." 570 :type 'boolean 571 :group 'cperl-help-system) 572 573(defcustom cperl-indent-region-fix-constructs 1 574 "*Amount of space to insert between `}' and `else' or `elsif' 575in `cperl-indent-region'. Set to nil to leave as is. Values other 576than 1 and nil will probably not work." 577 :type '(choice (const nil) (const 1)) 578 :group 'cperl-indentation-details) 579 580(defcustom cperl-break-one-line-blocks-when-indent t 581 "*Non-nil means that one-line if/unless/while/until/for/foreach BLOCKs 582need to be reformatted into multiline ones when indenting a region." 583 :type 'boolean 584 :group 'cperl-indentation-details) 585 586(defcustom cperl-fix-hanging-brace-when-indent t 587 "*Non-nil means that BLOCK-end `}' may be put on a separate line 588when indenting a region. 589Braces followed by else/elsif/while/until are excepted." 590 :type 'boolean 591 :group 'cperl-indentation-details) 592 593(defcustom cperl-merge-trailing-else t 594 "*Non-nil means that BLOCK-end `}' followed by else/elsif/continue 595may be merged to be on the same line when indenting a region." 596 :type 'boolean 597 :group 'cperl-indentation-details) 598 599(defcustom cperl-indent-parens-as-block nil 600 "*Non-nil means that non-block ()-, {}- and []-groups are indented as blocks, 601but for trailing \",\" inside the group, which won't increase indentation. 602One should tune up `cperl-close-paren-offset' as well." 603 :type 'boolean 604 :group 'cperl-indentation-details) 605 606(defcustom cperl-syntaxify-by-font-lock 607 (and cperl-can-font-lock 608 (boundp 'parse-sexp-lookup-properties)) 609 "*Non-nil means that CPerl uses `font-lock's routines for syntaxification." 610 :type '(choice (const message) boolean) 611 :group 'cperl-speed) 612 613(defcustom cperl-syntaxify-unwind 614 t 615 "*Non-nil means that CPerl unwinds to a start of a long construction 616when syntaxifying a chunk of buffer." 617 :type 'boolean 618 :group 'cperl-speed) 619 620(defcustom cperl-syntaxify-for-menu 621 t 622 "*Non-nil means that CPerl syntaxifies up to the point before showing menu. 623This way enabling/disabling of menu items is more correct." 624 :type 'boolean 625 :group 'cperl-speed) 626 627(defcustom cperl-ps-print-face-properties 628 '((font-lock-keyword-face nil nil bold shadow) 629 (font-lock-variable-name-face nil nil bold) 630 (font-lock-function-name-face nil nil bold italic box) 631 (font-lock-constant-face nil "LightGray" bold) 632 (cperl-array-face nil "LightGray" bold underline) 633 (cperl-hash-face nil "LightGray" bold italic underline) 634 (font-lock-comment-face nil "LightGray" italic) 635 (font-lock-string-face nil nil italic underline) 636 (cperl-nonoverridable-face nil nil italic underline) 637 (font-lock-type-face nil nil underline) 638 (font-lock-warning-face nil "LightGray" bold italic box) 639 (underline nil "LightGray" strikeout)) 640 "List given as an argument to `ps-extend-face-list' in `cperl-ps-print'." 641 :type '(repeat (cons symbol 642 (cons (choice (const nil) string) 643 (cons (choice (const nil) string) 644 (repeat symbol))))) 645 :group 'cperl-faces) 646 647(defvar cperl-dark-background 648 (cperl-choose-color "navy" "os2blue" "darkgreen")) 649(defvar cperl-dark-foreground 650 (cperl-choose-color "orchid1" "orange")) 651 652(defface cperl-nonoverridable-face 653 `((((class grayscale) (background light)) 654 (:background "Gray90" :slant italic :underline t)) 655 (((class grayscale) (background dark)) 656 (:foreground "Gray80" :slant italic :underline t :weight bold)) 657 (((class color) (background light)) 658 (:foreground "chartreuse3")) 659 (((class color) (background dark)) 660 (:foreground ,cperl-dark-foreground)) 661 (t (:weight bold :underline t))) 662 "Font Lock mode face used non-overridable keywords and modifiers of regexps." 663 :group 'cperl-faces) 664 665(defface cperl-array-face 666 `((((class grayscale) (background light)) 667 (:background "Gray90" :weight bold)) 668 (((class grayscale) (background dark)) 669 (:foreground "Gray80" :weight bold)) 670 (((class color) (background light)) 671 (:foreground "Blue" :background "lightyellow2" :weight bold)) 672 (((class color) (background dark)) 673 (:foreground "yellow" :background ,cperl-dark-background :weight bold)) 674 (t (:weight bold))) 675 "Font Lock mode face used to highlight array names." 676 :group 'cperl-faces) 677 678(defface cperl-hash-face 679 `((((class grayscale) (background light)) 680 (:background "Gray90" :weight bold :slant italic)) 681 (((class grayscale) (background dark)) 682 (:foreground "Gray80" :weight bold :slant italic)) 683 (((class color) (background light)) 684 (:foreground "Red" :background "lightyellow2" :weight bold :slant italic)) 685 (((class color) (background dark)) 686 (:foreground "Red" :background ,cperl-dark-background :weight bold :slant italic)) 687 (t (:weight bold :slant italic))) 688 "Font Lock mode face used to highlight hash names." 689 :group 'cperl-faces) 690 691 692 693;;; Short extra-docs. 694 695(defvar cperl-tips 'please-ignore-this-line 696 "Get maybe newer version of this package from 697 http://ilyaz.org/software/emacs 698Subdirectory `cperl-mode' may contain yet newer development releases and/or 699patches to related files. 700 701For best results apply to an older Emacs the patches from 702 ftp://ftp.math.ohio-state.edu/pub/users/ilya/cperl-mode/patches 703\(this upgrades syntax-parsing abilities of Emacsen v19.34 and 704v20.2 up to the level of Emacs v20.3 - a must for a good Perl 705mode.) As of beginning of 2003, XEmacs may provide a similar ability. 706 707Get support packages choose-color.el (or font-lock-extra.el before 70819.30), imenu-go.el from the same place. \(Look for other files there 709too... ;-). Get a patch for imenu.el in 19.29. Note that for 19.30 and 710later you should use choose-color.el *instead* of font-lock-extra.el 711\(and you will not get smart highlighting in C :-(). 712 713Note that to enable Compile choices in the menu you need to install 714mode-compile.el. 715 716If your Emacs does not default to `cperl-mode' on Perl files, and you 717want it to: put the following into your .emacs file: 718 719 (defalias 'perl-mode 'cperl-mode) 720 721Get perl5-info from 722 $CPAN/doc/manual/info/perl5-old/perl5-info.tar.gz 723Also, one can generate a newer documentation running `pod2texi' converter 724 $CPAN/doc/manual/info/perl5/pod2texi-0.1.tar.gz 725 726If you use imenu-go, run imenu on perl5-info buffer (you can do it 727from Perl menu). If many files are related, generate TAGS files from 728Tools/Tags submenu in Perl menu. 729 730If some class structure is too complicated, use Tools/Hierarchy-view 731from Perl menu, or hierarchic view of imenu. The second one uses the 732current buffer only, the first one requires generation of TAGS from 733Perl/Tools/Tags menu beforehand. 734 735Run Perl/Tools/Insert-spaces-if-needed to fix your lazy typing. 736 737Switch auto-help on/off with Perl/Tools/Auto-help. 738 739Though with contemporary Emaxen CPerl mode should maintain the correct 740parsing of Perl even when editing, sometimes it may be lost. Fix this by 741 742 \\[normal-mode] 743 744In cases of more severe confusion sometimes it is helpful to do 745 746 \\[load-library] cperl-mode RET 747 \\[normal-mode] 748 749Before reporting (non-)problems look in the problem section of online 750micro-docs on what I know about CPerl problems.") 751 752(defvar cperl-problems 'please-ignore-this-line 753 "Description of problems in CPerl mode. 754Some faces will not be shown on some versions of Emacs unless you 755install choose-color.el, available from 756 http://ilyaz.org/software/emacs 757 758`fill-paragraph' on a comment may leave the point behind the 759paragraph. It also triggers a bug in some versions of Emacs (CPerl tries 760to detect it and bulk out). 761 762See documentation of a variable `cperl-problems-old-emaxen' for the 763problems which disappear if you upgrade Emacs to a reasonably new 764version (20.3 for Emacs, and those of 2004 for XEmacs).") 765 766(defvar cperl-problems-old-emaxen 'please-ignore-this-line 767 "Description of problems in CPerl mode specific for older Emacs versions. 768 769Emacs had a _very_ restricted syntax parsing engine until version 77020.1. Most problems below are corrected starting from this version of 771Emacs, and all of them should be fixed in version 20.3. (Or apply 772patches to Emacs 19.33/34 - see tips.) XEmacs was very backward in 773this respect (until 2003). 774 775Note that even with newer Emacsen in some very rare cases the details 776of interaction of `font-lock' and syntaxification may be not cleaned 777up yet. You may get slightly different colors basing on the order of 778fontification and syntaxification. Say, the initial faces is correct, 779but editing the buffer breaks this. 780 781Even with older Emacsen CPerl mode tries to corrects some Emacs 782misunderstandings, however, for efficiency reasons the degree of 783correction is different for different operations. The partially 784corrected problems are: POD sections, here-documents, regexps. The 785operations are: highlighting, indentation, electric keywords, electric 786braces. 787 788This may be confusing, since the regexp s#//#/#\; may be highlighted 789as a comment, but it will be recognized as a regexp by the indentation 790code. Or the opposite case, when a POD section is highlighted, but 791may break the indentation of the following code (though indentation 792should work if the balance of delimiters is not broken by POD). 793 794The main trick (to make $ a \"backslash\") makes constructions like 795${aaa} look like unbalanced braces. The only trick I can think of is 796to insert it as $ {aaa} (valid in perl5, not in perl4). 797 798Similar problems arise in regexps, when /(\\s|$)/ should be rewritten 799as /($|\\s)/. Note that such a transposition is not always possible. 800 801The solution is to upgrade your Emacs or patch an older one. Note 802that Emacs 20.2 has some bugs related to `syntax-table' text 803properties. Patches are available on the main CPerl download site, 804and on CPAN. 805 806If these bugs cannot be fixed on your machine (say, you have an inferior 807environment and cannot recompile), you may still disable all the fancy stuff 808via `cperl-use-syntax-table-text-property'.") 809 810(defvar cperl-praise 'please-ignore-this-line 811 "Advantages of CPerl mode. 812 8130) It uses the newest `syntax-table' property ;-); 814 8151) It does 99% of Perl syntax correct (as opposed to 80-90% in Perl 816mode - but the latter number may have improved too in last years) even 817with old Emaxen which do not support `syntax-table' property. 818 819When using `syntax-table' property for syntax assist hints, it should 820handle 99.995% of lines correct - or somesuch. It automatically 821updates syntax assist hints when you edit your script. 822 8232) It is generally believed to be \"the most user-friendly Emacs 824package\" whatever it may mean (I doubt that the people who say similar 825things tried _all_ the rest of Emacs ;-), but this was not a lonely 826voice); 827 8283) Everything is customizable, one-by-one or in a big sweep; 829 8304) It has many easily-accessable \"tools\": 831 a) Can run program, check syntax, start debugger; 832 b) Can lineup vertically \"middles\" of rows, like `=' in 833 a = b; 834 cc = d; 835 c) Can insert spaces where this impoves readability (in one 836 interactive sweep over the buffer); 837 d) Has support for imenu, including: 838 1) Separate unordered list of \"interesting places\"; 839 2) Separate TOC of POD sections; 840 3) Separate list of packages; 841 4) Hierarchical view of methods in (sub)packages; 842 5) and functions (by the full name - with package); 843 e) Has an interface to INFO docs for Perl; The interface is 844 very flexible, including shrink-wrapping of 845 documentation buffer/frame; 846 f) Has a builtin list of one-line explanations for perl constructs. 847 g) Can show these explanations if you stay long enough at the 848 corresponding place (or on demand); 849 h) Has an enhanced fontification (using 3 or 4 additional faces 850 comparing to font-lock - basically, different 851 namespaces in Perl have different colors); 852 i) Can construct TAGS basing on its knowledge of Perl syntax, 853 the standard menu has 6 different way to generate 854 TAGS (if \"by directory\", .xs files - with C-language 855 bindings - are included in the scan); 856 j) Can build a hierarchical view of classes (via imenu) basing 857 on generated TAGS file; 858 k) Has electric parentheses, electric newlines, uses Abbrev 859 for electric logical constructs 860 while () {} 861 with different styles of expansion (context sensitive 862 to be not so bothering). Electric parentheses behave 863 \"as they should\" in a presence of a visible region. 864 l) Changes msb.el \"on the fly\" to insert a group \"Perl files\"; 865 m) Can convert from 866 if (A) { B } 867 to 868 B if A; 869 870 n) Highlights (by user-choice) either 3-delimiters constructs 871 (such as tr/a/b/), or regular expressions and `y/tr'; 872 o) Highlights trailing whitespace; 873 p) Is able to manipulate Perl Regular Expressions to ease 874 conversion to a more readable form. 875 q) Can ispell POD sections and HERE-DOCs. 876 r) Understands comments and character classes inside regular 877 expressions; can find matching () and [] in a regular expression. 878 s) Allows indentation of //x-style regular expressions; 879 t) Highlights different symbols in regular expressions according 880 to their function; much less problems with backslashitis; 881 u) Allows to find regular expressions which contain interpolated parts. 882 8835) The indentation engine was very smart, but most of tricks may be 884not needed anymore with the support for `syntax-table' property. Has 885progress indicator for indentation (with `imenu' loaded). 886 8876) Indent-region improves inline-comments as well; also corrects 888whitespace *inside* the conditional/loop constructs. 889 8907) Fill-paragraph correctly handles multi-line comments; 891 8928) Can switch to different indentation styles by one command, and restore 893the settings present before the switch. 894 8959) When doing indentation of control constructs, may correct 896line-breaks/spacing between elements of the construct. 897 89810) Uses a linear-time algorith for indentation of regions (on Emaxen with 899capable syntax engines). 900 90111) Syntax-highlight, indentation, sexp-recognition inside regular expressions. 902") 903 904(defvar cperl-speed 'please-ignore-this-line 905 "This is an incomplete compendium of what is available in other parts 906of CPerl documentation. (Please inform me if I skept anything.) 907 908There is a perception that CPerl is slower than alternatives. This part 909of documentation is designed to overcome this misconception. 910 911*By default* CPerl tries to enable the most comfortable settings. 912From most points of view, correctly working package is infinitely more 913comfortable than a non-correctly working one, thus by default CPerl 914prefers correctness over speed. Below is the guide how to change 915settings if your preferences are different. 916 917A) Speed of loading the file. When loading file, CPerl may perform a 918scan which indicates places which cannot be parsed by primitive Emacs 919syntax-parsing routines, and marks them up so that either 920 921 A1) CPerl may work around these deficiencies (for big chunks, mostly 922 PODs and HERE-documents), or 923 A2) On capable Emaxen CPerl will use improved syntax-handlings 924 which reads mark-up hints directly. 925 926 The scan in case A2 is much more comprehensive, thus may be slower. 927 928 User can disable syntax-engine-helping scan of A2 by setting 929 `cperl-use-syntax-table-text-property' 930 variable to nil (if it is set to t). 931 932 One can disable the scan altogether (both A1 and A2) by setting 933 `cperl-pod-here-scan' 934 to nil. 935 936B) Speed of editing operations. 937 938 One can add a (minor) speedup to editing operations by setting 939 `cperl-use-syntax-table-text-property' 940 variable to nil (if it is set to t). This will disable 941 syntax-engine-helping scan, thus will make many more Perl 942 constructs be wrongly recognized by CPerl, thus may lead to 943 wrongly matched parentheses, wrong indentation, etc. 944 945 One can unset `cperl-syntaxify-unwind'. This might speed up editing 946 of, say, long POD sections.") 947 948(defvar cperl-tips-faces 'please-ignore-this-line 949 "CPerl mode uses following faces for highlighting: 950 951 `cperl-array-face' Array names 952 `cperl-hash-face' Hash names 953 `font-lock-comment-face' Comments, PODs and whatever is considered 954 syntaxically to be not code 955 `font-lock-constant-face' HERE-doc delimiters, labels, delimiters of 956 2-arg operators s/y/tr/ or of RExen, 957 `font-lock-warning-face' Special-cased m// and s//foo/, 958 `font-lock-function-name-face' _ as a target of a file tests, file tests, 959 subroutine names at the moment of definition 960 (except those conflicting with Perl operators), 961 package names (when recognized), format names 962 `font-lock-keyword-face' Control flow switch constructs, declarators 963 `cperl-nonoverridable-face' Non-overridable keywords, modifiers of RExen 964 `font-lock-string-face' Strings, qw() constructs, RExen, POD sections, 965 literal parts and the terminator of formats 966 and whatever is syntaxically considered 967 as string literals 968 `font-lock-type-face' Overridable keywords 969 `font-lock-variable-name-face' Variable declarations, indirect array and 970 hash names, POD headers/item names 971 `cperl-invalid' Trailing whitespace 972 973Note that in several situations the highlighting tries to inform about 974possible confusion, such as different colors for function names in 975declarations depending on what they (do not) override, or special cases 976m// and s/// which do not do what one would expect them to do. 977 978Help with best setup of these faces for printout requested (for each of 979the faces: please specify bold, italic, underline, shadow and box.) 980 981In regular expressions (except character classes): 982 `font-lock-string-face' \"Normal\" stuff and non-0-length constructs 983 `font-lock-constant-face': Delimiters 984 `font-lock-warning-face' Special-cased m// and s//foo/, 985 Mismatched closing delimiters, parens 986 we couldn't match, misplaced quantifiers, 987 unrecognized escape sequences 988 `cperl-nonoverridable-face' Modifiers, as gism in m/REx/gism 989 `font-lock-type-face' POSIX classes inside charclasses, 990 escape sequences with arguments (\x \23 \p \N) 991 and others match-a-char escape sequences 992 `font-lock-keyword-face' Capturing parens, and | 993 `font-lock-function-name-face' Special symbols: $ ^ . [ ] [^ ] (?{ }) (??{ }) 994 `font-lock-builtin-face' \"Remaining\" 0-length constructs, executable 995 parts of a REx, not-capturing parens 996 `font-lock-variable-name-face' Interpolated constructs, embedded code 997 `font-lock-comment-face' Embedded comments 998 999") 1000 1001 1002 1003;;; Portability stuff: 1004 1005(defmacro cperl-define-key (emacs-key definition &optional xemacs-key) 1006 `(define-key cperl-mode-map 1007 ,(if xemacs-key 1008 `(if cperl-xemacs-p ,xemacs-key ,emacs-key) 1009 emacs-key) 1010 ,definition)) 1011 1012(defvar cperl-del-back-ch 1013 (car (append (where-is-internal 'delete-backward-char) 1014 (where-is-internal 'backward-delete-char-untabify))) 1015 "Character generated by key bound to `delete-backward-char'.") 1016 1017(and (vectorp cperl-del-back-ch) (= (length cperl-del-back-ch) 1) 1018 (setq cperl-del-back-ch (aref cperl-del-back-ch 0))) 1019 1020(defun cperl-mark-active () (mark)) ; Avoid undefined warning 1021(if cperl-xemacs-p 1022 (progn 1023 ;; "Active regions" are on: use region only if active 1024 ;; "Active regions" are off: use region unconditionally 1025 (defun cperl-use-region-p () 1026 (if zmacs-regions (mark) t))) 1027 (defun cperl-use-region-p () 1028 (if transient-mark-mode mark-active t)) 1029 (defun cperl-mark-active () mark-active)) 1030 1031(defsubst cperl-enable-font-lock () 1032 cperl-can-font-lock) 1033 1034(defun cperl-putback-char (c) ; Emacs 19 1035 (set 'unread-command-events (list c))) ; Avoid undefined warning 1036 1037(if cperl-xemacs-p 1038 (defun cperl-putback-char (c) ; XEmacs >= 19.12 1039 (setq unread-command-events (list (eval '(character-to-event c)))))) 1040 1041(or (fboundp 'uncomment-region) 1042 (defun uncomment-region (beg end) 1043 (interactive "r") 1044 (comment-region beg end -1))) 1045 1046(defvar cperl-do-not-fontify 1047 (if (string< emacs-version "19.30") 1048 'fontified 1049 'lazy-lock) 1050 "Text property which inhibits refontification.") 1051 1052(defsubst cperl-put-do-not-fontify (from to &optional post) 1053 ;; If POST, do not do it with postponed fontification 1054 (if (and post cperl-syntaxify-by-font-lock) 1055 nil 1056 (put-text-property (max (point-min) (1- from)) 1057 to cperl-do-not-fontify t))) 1058 1059(defcustom cperl-mode-hook nil 1060 "Hook run by CPerl mode." 1061 :type 'hook 1062 :group 'cperl) 1063 1064(defvar cperl-syntax-state nil) 1065(defvar cperl-syntax-done-to nil) 1066(defvar cperl-emacs-can-parse (> (length (save-excursion 1067 (parse-partial-sexp (point) (point)))) 9)) 1068 1069;; Make customization possible "in reverse" 1070(defsubst cperl-val (symbol &optional default hairy) 1071 (cond 1072 ((eq (symbol-value symbol) 'null) default) 1073 (cperl-hairy (or hairy t)) 1074 (t (symbol-value symbol)))) 1075 1076 1077(defun cperl-make-indent (column &optional minimum keep) 1078 "Makes indent of the current line the requested amount. 1079Unless KEEP, removes the old indentation. Works around a bug in ancient 1080versions of Emacs." 1081 (let ((prop (get-text-property (point) 'syntax-type))) 1082 (or keep 1083 (delete-horizontal-space)) 1084 (indent-to column minimum) 1085 ;; In old versions (e.g., 19.33) `indent-to' would not inherit properties 1086 (and prop 1087 (> (current-column) 0) 1088 (save-excursion 1089 (beginning-of-line) 1090 (or (get-text-property (point) 'syntax-type) 1091 (and (looking-at "\\=[ \t]") 1092 (put-text-property (point) (match-end 0) 1093 'syntax-type prop))))))) 1094 1095;;; Probably it is too late to set these guys already, but it can help later: 1096 1097;;;(and cperl-clobber-mode-lists 1098;;;(setq auto-mode-alist 1099;;; (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist )) 1100;;;(and (boundp 'interpreter-mode-alist) 1101;;; (setq interpreter-mode-alist (append interpreter-mode-alist 1102;;; '(("miniperl" . perl-mode)))))) 1103(eval-when-compile 1104 (mapcar (lambda (p) 1105 (condition-case nil 1106 (require p) 1107 (error nil))) 1108 '(imenu easymenu etags timer man info)) 1109 (if (fboundp 'ps-extend-face-list) 1110 (defmacro cperl-ps-extend-face-list (arg) 1111 `(ps-extend-face-list ,arg)) 1112 (defmacro cperl-ps-extend-face-list (arg) 1113 `(error "This version of Emacs has no `ps-extend-face-list'"))) 1114 ;; Calling `cperl-enable-font-lock' below doesn't compile on XEmacs, 1115 ;; macros instead of defsubsts don't work on Emacs, so we do the 1116 ;; expansion manually. Any other suggestions? 1117 (require 'cl)) 1118 1119(defvar cperl-mode-abbrev-table nil 1120 "Abbrev table in use in CPerl mode buffers.") 1121 1122(add-hook 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-"))) 1123 1124(defvar cperl-mode-map () "Keymap used in CPerl mode.") 1125 1126(if cperl-mode-map nil 1127 (setq cperl-mode-map (make-sparse-keymap)) 1128 (cperl-define-key "{" 'cperl-electric-lbrace) 1129 (cperl-define-key "[" 'cperl-electric-paren) 1130 (cperl-define-key "(" 'cperl-electric-paren) 1131 (cperl-define-key "<" 'cperl-electric-paren) 1132 (cperl-define-key "}" 'cperl-electric-brace) 1133 (cperl-define-key "]" 'cperl-electric-rparen) 1134 (cperl-define-key ")" 'cperl-electric-rparen) 1135 (cperl-define-key ";" 'cperl-electric-semi) 1136 (cperl-define-key ":" 'cperl-electric-terminator) 1137 (cperl-define-key "\C-j" 'newline-and-indent) 1138 (cperl-define-key "\C-c\C-j" 'cperl-linefeed) 1139 (cperl-define-key "\C-c\C-t" 'cperl-invert-if-unless) 1140 (cperl-define-key "\C-c\C-a" 'cperl-toggle-auto-newline) 1141 (cperl-define-key "\C-c\C-k" 'cperl-toggle-abbrev) 1142 (cperl-define-key "\C-c\C-w" 'cperl-toggle-construct-fix) 1143 (cperl-define-key "\C-c\C-f" 'auto-fill-mode) 1144 (cperl-define-key "\C-c\C-e" 'cperl-toggle-electric) 1145 (cperl-define-key "\C-c\C-b" 'cperl-find-bad-style) 1146 (cperl-define-key "\C-c\C-p" 'cperl-pod-spell) 1147 (cperl-define-key "\C-c\C-d" 'cperl-here-doc-spell) 1148 (cperl-define-key "\C-c\C-n" 'cperl-narrow-to-here-doc) 1149 (cperl-define-key "\C-c\C-v" 'cperl-next-interpolated-REx) 1150 (cperl-define-key "\C-c\C-x" 'cperl-next-interpolated-REx-0) 1151 (cperl-define-key "\C-c\C-y" 'cperl-next-interpolated-REx-1) 1152 (cperl-define-key "\C-c\C-ha" 'cperl-toggle-autohelp) 1153 (cperl-define-key "\C-c\C-hp" 'cperl-perldoc) 1154 (cperl-define-key "\C-c\C-hP" 'cperl-perldoc-at-point) 1155 (cperl-define-key "\e\C-q" 'cperl-indent-exp) ; Usually not bound 1156 (cperl-define-key [?\C-\M-\|] 'cperl-lineup 1157 [(control meta |)]) 1158 ;;(cperl-define-key "\M-q" 'cperl-fill-paragraph) 1159 ;;(cperl-define-key "\e;" 'cperl-indent-for-comment) 1160 (cperl-define-key "\177" 'cperl-electric-backspace) 1161 (cperl-define-key "\t" 'cperl-indent-command) 1162 ;; don't clobber the backspace binding: 1163 (cperl-define-key "\C-c\C-hF" 'cperl-info-on-command 1164 [(control c) (control h) F]) 1165 (if (cperl-val 'cperl-clobber-lisp-bindings) 1166 (progn 1167 (cperl-define-key "\C-hf" 1168 ;;(concat (char-to-string help-char) "f") ; does not work 1169 'cperl-info-on-command 1170 [(control h) f]) 1171 (cperl-define-key "\C-hv" 1172 ;;(concat (char-to-string help-char) "v") ; does not work 1173 'cperl-get-help 1174 [(control h) v]) 1175 (cperl-define-key "\C-c\C-hf" 1176 ;;(concat (char-to-string help-char) "f") ; does not work 1177 (key-binding "\C-hf") 1178 [(control c) (control h) f]) 1179 (cperl-define-key "\C-c\C-hv" 1180 ;;(concat (char-to-string help-char) "v") ; does not work 1181 (key-binding "\C-hv") 1182 [(control c) (control h) v])) 1183 (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command 1184 [(control c) (control h) f]) 1185 (cperl-define-key "\C-c\C-hv" 1186 ;;(concat (char-to-string help-char) "v") ; does not work 1187 'cperl-get-help 1188 [(control c) (control h) v])) 1189 (if (and cperl-xemacs-p 1190 (<= emacs-minor-version 11) (<= emacs-major-version 19)) 1191 (progn 1192 ;; substitute-key-definition is usefulness-deenhanced... 1193 ;;;;;(cperl-define-key "\M-q" 'cperl-fill-paragraph) 1194 (cperl-define-key "\e;" 'cperl-indent-for-comment) 1195 (cperl-define-key "\e\C-\\" 'cperl-indent-region)) 1196 (or (boundp 'fill-paragraph-function) 1197 (substitute-key-definition 1198 'fill-paragraph 'cperl-fill-paragraph 1199 cperl-mode-map global-map)) 1200 (substitute-key-definition 1201 'indent-sexp 'cperl-indent-exp 1202 cperl-mode-map global-map) 1203 (substitute-key-definition 1204 'indent-region 'cperl-indent-region 1205 cperl-mode-map global-map) 1206 (substitute-key-definition 1207 'indent-for-comment 'cperl-indent-for-comment 1208 cperl-mode-map global-map))) 1209 1210(defvar cperl-menu) 1211(defvar cperl-lazy-installed) 1212(defvar cperl-old-style nil) 1213(condition-case nil 1214 (progn 1215 (require 'easymenu) 1216 (easy-menu-define 1217 cperl-menu cperl-mode-map "Menu for CPerl mode" 1218 '("Perl" 1219 ["Beginning of function" beginning-of-defun t] 1220 ["End of function" end-of-defun t] 1221 ["Mark function" mark-defun t] 1222 ["Indent expression" cperl-indent-exp t] 1223 ["Fill paragraph/comment" fill-paragraph t] 1224 "----" 1225 ["Line up a construction" cperl-lineup (cperl-use-region-p)] 1226 ["Invert if/unless/while etc" cperl-invert-if-unless t] 1227 ("Regexp" 1228 ["Beautify" cperl-beautify-regexp 1229 cperl-use-syntax-table-text-property] 1230 ["Beautify one level deep" (cperl-beautify-regexp 1) 1231 cperl-use-syntax-table-text-property] 1232 ["Beautify a group" cperl-beautify-level 1233 cperl-use-syntax-table-text-property] 1234 ["Beautify a group one level deep" (cperl-beautify-level 1) 1235 cperl-use-syntax-table-text-property] 1236 ["Contract a group" cperl-contract-level 1237 cperl-use-syntax-table-text-property] 1238 ["Contract groups" cperl-contract-levels 1239 cperl-use-syntax-table-text-property] 1240 "----" 1241 ["Find next interpolated" cperl-next-interpolated-REx 1242 (next-single-property-change (point-min) 'REx-interpolated)] 1243 ["Find next interpolated (no //o)" 1244 cperl-next-interpolated-REx-0 1245 (or (text-property-any (point-min) (point-max) 'REx-interpolated t) 1246 (text-property-any (point-min) (point-max) 'REx-interpolated 1))] 1247 ["Find next interpolated (neither //o nor whole-REx)" 1248 cperl-next-interpolated-REx-1 1249 (text-property-any (point-min) (point-max) 'REx-interpolated t)]) 1250 ["Insert spaces if needed to fix style" cperl-find-bad-style t] 1251 ["Refresh \"hard\" constructions" cperl-find-pods-heres t] 1252 "----" 1253 ["Indent region" cperl-indent-region (cperl-use-region-p)] 1254 ["Comment region" cperl-comment-region (cperl-use-region-p)] 1255 ["Uncomment region" cperl-uncomment-region (cperl-use-region-p)] 1256 "----" 1257 ["Run" mode-compile (fboundp 'mode-compile)] 1258 ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill) 1259 (get-buffer "*compilation*"))] 1260 ["Next error" next-error (get-buffer "*compilation*")] 1261 ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)] 1262 "----" 1263 ["Debugger" cperl-db t] 1264 "----" 1265 ("Tools" 1266 ["Imenu" imenu (fboundp 'imenu)] 1267 ["Imenu on Perl Info" cperl-imenu-on-info (featurep 'imenu)] 1268 "----" 1269 ["Ispell PODs" cperl-pod-spell 1270 ;; Better not to update syntaxification here: 1271 ;; debugging syntaxificatio can be broken by this??? 1272 (or 1273 (get-text-property (point-min) 'in-pod) 1274 (< (progn 1275 (and cperl-syntaxify-for-menu 1276 (cperl-update-syntaxification (point-max) (point-max))) 1277 (next-single-property-change (point-min) 'in-pod nil (point-max))) 1278 (point-max)))] 1279 ["Ispell HERE-DOCs" cperl-here-doc-spell 1280 (< (progn 1281 (and cperl-syntaxify-for-menu 1282 (cperl-update-syntaxification (point-max) (point-max))) 1283 (next-single-property-change (point-min) 'here-doc-group nil (point-max))) 1284 (point-max))] 1285 ["Narrow to this HERE-DOC" cperl-narrow-to-here-doc 1286 (eq 'here-doc (progn 1287 (and cperl-syntaxify-for-menu 1288 (cperl-update-syntaxification (point) (point))) 1289 (get-text-property (point) 'syntax-type)))] 1290 ["Select this HERE-DOC or POD section" 1291 cperl-select-this-pod-or-here-doc 1292 (memq (progn 1293 (and cperl-syntaxify-for-menu 1294 (cperl-update-syntaxification (point) (point))) 1295 (get-text-property (point) 'syntax-type)) 1296 '(here-doc pod))] 1297 "----" 1298 ["CPerl pretty print (exprmntl)" cperl-ps-print 1299 (fboundp 'ps-extend-face-list)] 1300 "----" 1301 ["Syntaxify region" cperl-find-pods-heres-region 1302 (cperl-use-region-p)] 1303 ["Profile syntaxification" cperl-time-fontification t] 1304 ["Debug errors in delayed fontification" cperl-emulate-lazy-lock t] 1305 ["Debug unwind for syntactic scan" cperl-toggle-set-debug-unwind t] 1306 ["Debug backtrace on syntactic scan (BEWARE!!!)" 1307 (cperl-toggle-set-debug-unwind nil t) t] 1308 "----" 1309 ["Class Hierarchy from TAGS" cperl-tags-hier-init t] 1310 ;;["Update classes" (cperl-tags-hier-init t) tags-table-list] 1311 ("Tags" 1312;;; ["Create tags for current file" cperl-etags t] 1313;;; ["Add tags for current file" (cperl-etags t) t] 1314;;; ["Create tags for Perl files in directory" (cperl-etags nil t) t] 1315;;; ["Add tags for Perl files in directory" (cperl-etags t t) t] 1316;;; ["Create tags for Perl files in (sub)directories" 1317;;; (cperl-etags nil 'recursive) t] 1318;;; ["Add tags for Perl files in (sub)directories" 1319;;; (cperl-etags t 'recursive) t]) 1320;;;; cperl-write-tags (&optional file erase recurse dir inbuffer) 1321 ["Create tags for current file" (cperl-write-tags nil t) t] 1322 ["Add tags for current file" (cperl-write-tags) t] 1323 ["Create tags for Perl files in directory" 1324 (cperl-write-tags nil t nil t) t] 1325 ["Add tags for Perl files in directory" 1326 (cperl-write-tags nil nil nil t) t] 1327 ["Create tags for Perl files in (sub)directories" 1328 (cperl-write-tags nil t t t) t] 1329 ["Add tags for Perl files in (sub)directories" 1330 (cperl-write-tags nil nil t t) t])) 1331 ("Perl docs" 1332 ["Define word at point" imenu-go-find-at-position 1333 (fboundp 'imenu-go-find-at-position)] 1334 ["Help on function" cperl-info-on-command t] 1335 ["Help on function at point" cperl-info-on-current-command t] 1336 ["Help on symbol at point" cperl-get-help t] 1337 ["Perldoc" cperl-perldoc t] 1338 ["Perldoc on word at point" cperl-perldoc-at-point t] 1339 ["View manpage of POD in this file" cperl-build-manpage t] 1340 ["Auto-help on" cperl-lazy-install 1341 (and (fboundp 'run-with-idle-timer) 1342 (not cperl-lazy-installed))] 1343 ["Auto-help off" cperl-lazy-unstall 1344 (and (fboundp 'run-with-idle-timer) 1345 cperl-lazy-installed)]) 1346 ("Toggle..." 1347 ["Auto newline" cperl-toggle-auto-newline t] 1348 ["Electric parens" cperl-toggle-electric t] 1349 ["Electric keywords" cperl-toggle-abbrev t] 1350 ["Fix whitespace on indent" cperl-toggle-construct-fix t] 1351 ["Auto-help on Perl constructs" cperl-toggle-autohelp t] 1352 ["Auto fill" auto-fill-mode t]) 1353 ("Indent styles..." 1354 ["CPerl" (cperl-set-style "CPerl") t] 1355 ["PerlStyle" (cperl-set-style "PerlStyle") t] 1356 ["GNU" (cperl-set-style "GNU") t] 1357 ["C++" (cperl-set-style "C++") t] 1358 ["K&R" (cperl-set-style "K&R") t] 1359 ["BSD" (cperl-set-style "BSD") t] 1360 ["Whitesmith" (cperl-set-style "Whitesmith") t] 1361 ["Memorize Current" (cperl-set-style "Current") t] 1362 ["Memorized" (cperl-set-style-back) cperl-old-style]) 1363 ("Micro-docs" 1364 ["Tips" (describe-variable 'cperl-tips) t] 1365 ["Problems" (describe-variable 'cperl-problems) t] 1366 ["Speed" (describe-variable 'cperl-speed) t] 1367 ["Praise" (describe-variable 'cperl-praise) t] 1368 ["Faces" (describe-variable 'cperl-tips-faces) t] 1369 ["CPerl mode" (describe-function 'cperl-mode) t] 1370 ["CPerl version" 1371 (message "The version of master-file for this CPerl is %s-Emacs" 1372 cperl-version) t])))) 1373 (error nil)) 1374 1375(autoload 'c-macro-expand "cmacexp" 1376 "Display the result of expanding all C macros occurring in the region. 1377The expansion is entirely correct because it uses the C preprocessor." 1378 t) 1379 1380;;; These two must be unwound, otherwise take exponential time 1381(defconst cperl-maybe-white-and-comment-rex "[ \t\n]*\\(#[^\n]*\n[ \t\n]*\\)*" 1382"Regular expression to match optional whitespace with interpspersed comments. 1383Should contain exactly one group.") 1384 1385;;; This one is tricky to unwind; still very inefficient... 1386(defconst cperl-white-and-comment-rex "\\([ \t\n]\\|#[^\n]*\n\\)+" 1387"Regular expression to match whitespace with interpspersed comments. 1388Should contain exactly one group.") 1389 1390 1391;;; Is incorporated in `cperl-imenu--function-name-regexp-perl' 1392;;; `cperl-outline-regexp', `defun-prompt-regexp'. 1393;;; Details of groups in this may be used in several functions; see comments 1394;;; near mentioned above variable(s)... 1395;;; sub($$):lvalue{} sub:lvalue{} Both allowed... 1396(defsubst cperl-after-sub-regexp (named attr) ; 9 groups without attr... 1397 "Match the text after `sub' in a subroutine declaration. 1398If NAMED is nil, allows anonymous subroutines. Matches up to the first \":\" 1399of attributes (if present), or end of the name or prototype (whatever is 1400the last)." 1401 (concat ; Assume n groups before this... 1402 "\\(" ; n+1=name-group 1403 cperl-white-and-comment-rex ; n+2=pre-name 1404 "\\(::[a-zA-Z_0-9:']+\\|[a-zA-Z_'][a-zA-Z_0-9:']*\\)" ; n+3=name 1405 "\\)" ; END n+1=name-group 1406 (if named "" "?") 1407 "\\(" ; n+4=proto-group 1408 cperl-maybe-white-and-comment-rex ; n+5=pre-proto 1409 "\\(([^()]*)\\)" ; n+6=prototype 1410 "\\)?" ; END n+4=proto-group 1411 "\\(" ; n+7=attr-group 1412 cperl-maybe-white-and-comment-rex ; n+8=pre-attr 1413 "\\(" ; n+9=start-attr 1414 ":" 1415 (if attr (concat 1416 "\\(" 1417 cperl-maybe-white-and-comment-rex ; whitespace-comments 1418 "\\(\\sw\\|_\\)+" ; attr-name 1419 ;; attr-arg (1 level of internal parens allowed!) 1420 "\\((\\(\\\\.\\|[^\\\\()]\\|([^\\\\()]*)\\)*)\\)?" 1421 "\\(" ; optional : (XXX allows trailing???) 1422 cperl-maybe-white-and-comment-rex ; whitespace-comments 1423 ":\\)?" 1424 "\\)+") 1425 "[^:]") 1426 "\\)" 1427 "\\)?" ; END n+6=proto-group 1428 )) 1429 1430;;; Details of groups in this are used in `cperl-imenu--create-perl-index' 1431;;; and `cperl-outline-level'. 1432;;;; Was: 2=sub|package; now 2=package-group, 5=package-name 8=sub-name (+3) 1433(defvar cperl-imenu--function-name-regexp-perl 1434 (concat 1435 "^\\(" ; 1 = all 1436 "\\([ \t]*package" ; 2 = package-group 1437 "\\(" ; 3 = package-name-group 1438 cperl-white-and-comment-rex ; 4 = pre-package-name 1439 "\\([a-zA-Z_0-9:']+\\)\\)?\\)" ; 5 = package-name 1440 "\\|" 1441 "[ \t]*sub" 1442 (cperl-after-sub-regexp 'named nil) ; 8=name 11=proto 14=attr-start 1443 cperl-maybe-white-and-comment-rex ; 15=pre-block 1444 "\\|" 1445 "=head\\([1-4]\\)[ \t]+" ; 16=level 1446 "\\([^\n]+\\)$" ; 17=text 1447 "\\)")) 1448 1449(defvar cperl-outline-regexp 1450 (concat cperl-imenu--function-name-regexp-perl "\\|" "\\`")) 1451 1452(defvar cperl-mode-syntax-table nil 1453 "Syntax table in use in CPerl mode buffers.") 1454 1455(defvar cperl-string-syntax-table nil 1456 "Syntax table in use in CPerl mode string-like chunks.") 1457 1458(defsubst cperl-1- (p) 1459 (max (point-min) (1- p))) 1460 1461(defsubst cperl-1+ (p) 1462 (min (point-max) (1+ p))) 1463 1464(if cperl-mode-syntax-table 1465 () 1466 (setq cperl-mode-syntax-table (make-syntax-table)) 1467 (modify-syntax-entry ?\\ "\\" cperl-mode-syntax-table) 1468 (modify-syntax-entry ?/ "." cperl-mode-syntax-table) 1469 (modify-syntax-entry ?* "." cperl-mode-syntax-table) 1470 (modify-syntax-entry ?+ "." cperl-mode-syntax-table) 1471 (modify-syntax-entry ?- "." cperl-mode-syntax-table) 1472 (modify-syntax-entry ?= "." cperl-mode-syntax-table) 1473 (modify-syntax-entry ?% "." cperl-mode-syntax-table) 1474 (modify-syntax-entry ?< "." cperl-mode-syntax-table) 1475 (modify-syntax-entry ?> "." cperl-mode-syntax-table) 1476 (modify-syntax-entry ?& "." cperl-mode-syntax-table) 1477 (modify-syntax-entry ?$ "\\" cperl-mode-syntax-table) 1478 (modify-syntax-entry ?\n ">" cperl-mode-syntax-table) 1479 (modify-syntax-entry ?# "<" cperl-mode-syntax-table) 1480 (modify-syntax-entry ?' "\"" cperl-mode-syntax-table) 1481 (modify-syntax-entry ?` "\"" cperl-mode-syntax-table) 1482 (if cperl-under-as-char 1483 (modify-syntax-entry ?_ "w" cperl-mode-syntax-table)) 1484 (modify-syntax-entry ?: "_" cperl-mode-syntax-table) 1485 (modify-syntax-entry ?| "." cperl-mode-syntax-table) 1486 (setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table)) 1487 (modify-syntax-entry ?$ "." cperl-string-syntax-table) 1488 (modify-syntax-entry ?\{ "." cperl-string-syntax-table) 1489 (modify-syntax-entry ?\} "." cperl-string-syntax-table) 1490 (modify-syntax-entry ?# "." cperl-string-syntax-table)) ; (?# comment ) 1491 1492 1493 1494(defvar cperl-faces-init nil) 1495;; Fix for msb.el 1496(defvar cperl-msb-fixed nil) 1497(defvar cperl-use-major-mode 'cperl-mode) 1498(defvar cperl-font-lock-multiline-start nil) 1499(defvar cperl-font-lock-multiline nil) 1500(defvar cperl-compilation-error-regexp-alist nil) 1501(defvar cperl-font-locking nil) 1502 1503;;;###autoload 1504(defun cperl-mode () 1505 "Major mode for editing Perl code. 1506Expression and list commands understand all C brackets. 1507Tab indents for Perl code. 1508Paragraphs are separated by blank lines only. 1509Delete converts tabs to spaces as it moves back. 1510 1511Various characters in Perl almost always come in pairs: {}, (), [], 1512sometimes <>. When the user types the first, she gets the second as 1513well, with optional special formatting done on {}. (Disabled by 1514default.) You can always quote (with \\[quoted-insert]) the left 1515\"paren\" to avoid the expansion. The processing of < is special, 1516since most the time you mean \"less\". CPerl mode tries to guess 1517whether you want to type pair <>, and inserts is if it 1518appropriate. You can set `cperl-electric-parens-string' to the string that 1519contains the parenths from the above list you want to be electrical. 1520Electricity of parenths is controlled by `cperl-electric-parens'. 1521You may also set `cperl-electric-parens-mark' to have electric parens 1522look for active mark and \"embrace\" a region if possible.' 1523 1524CPerl mode provides expansion of the Perl control constructs: 1525 1526 if, else, elsif, unless, while, until, continue, do, 1527 for, foreach, formy and foreachmy. 1528 1529and POD directives (Disabled by default, see `cperl-electric-keywords'.) 1530 1531The user types the keyword immediately followed by a space, which 1532causes the construct to be expanded, and the point is positioned where 1533she is most likely to want to be. eg. when the user types a space 1534following \"if\" the following appears in the buffer: if () { or if () 1535} { } and the cursor is between the parentheses. The user can then 1536type some boolean expression within the parens. Having done that, 1537typing \\[cperl-linefeed] places you - appropriately indented - on a 1538new line between the braces (if you typed \\[cperl-linefeed] in a POD 1539directive line, then appropriate number of new lines is inserted). 1540 1541If CPerl decides that you want to insert \"English\" style construct like 1542 1543 bite if angry; 1544 1545it will not do any expansion. See also help on variable 1546`cperl-extra-newline-before-brace'. (Note that one can switch the 1547help message on expansion by setting `cperl-message-electric-keyword' 1548to nil.) 1549 1550\\[cperl-linefeed] is a convenience replacement for typing carriage 1551return. It places you in the next line with proper indentation, or if 1552you type it inside the inline block of control construct, like 1553 1554 foreach (@lines) {print; print} 1555 1556and you are on a boundary of a statement inside braces, it will 1557transform the construct into a multiline and will place you into an 1558appropriately indented blank line. If you need a usual 1559`newline-and-indent' behavior, it is on \\[newline-and-indent], 1560see documentation on `cperl-electric-linefeed'. 1561 1562Use \\[cperl-invert-if-unless] to change a construction of the form 1563 1564 if (A) { B } 1565 1566into 1567 1568 B if A; 1569 1570\\{cperl-mode-map} 1571 1572Setting the variable `cperl-font-lock' to t switches on font-lock-mode 1573\(even with older Emacsen), `cperl-electric-lbrace-space' to t switches 1574on electric space between $ and {, `cperl-electric-parens-string' is 1575the string that contains parentheses that should be electric in CPerl 1576\(see also `cperl-electric-parens-mark' and `cperl-electric-parens'), 1577setting `cperl-electric-keywords' enables electric expansion of 1578control structures in CPerl. `cperl-electric-linefeed' governs which 1579one of two linefeed behavior is preferable. You can enable all these 1580options simultaneously (recommended mode of use) by setting 1581`cperl-hairy' to t. In this case you can switch separate options off 1582by setting them to `null'. Note that one may undo the extra 1583whitespace inserted by semis and braces in `auto-newline'-mode by 1584consequent \\[cperl-electric-backspace]. 1585 1586If your site has perl5 documentation in info format, you can use commands 1587\\[cperl-info-on-current-command] and \\[cperl-info-on-command] to access it. 1588These keys run commands `cperl-info-on-current-command' and 1589`cperl-info-on-command', which one is which is controlled by variable 1590`cperl-info-on-command-no-prompt' and `cperl-clobber-lisp-bindings' 1591\(in turn affected by `cperl-hairy'). 1592 1593Even if you have no info-format documentation, short one-liner-style 1594help is available on \\[cperl-get-help], and one can run perldoc or 1595man via menu. 1596 1597It is possible to show this help automatically after some idle time. 1598This is regulated by variable `cperl-lazy-help-time'. Default with 1599`cperl-hairy' (if the value of `cperl-lazy-help-time' is nil) is 5 1600secs idle time . It is also possible to switch this on/off from the 1601menu, or via \\[cperl-toggle-autohelp]. Requires `run-with-idle-timer'. 1602 1603Use \\[cperl-lineup] to vertically lineup some construction - put the 1604beginning of the region at the start of construction, and make region 1605span the needed amount of lines. 1606 1607Variables `cperl-pod-here-scan', `cperl-pod-here-fontify', 1608`cperl-pod-face', `cperl-pod-head-face' control processing of POD and 1609here-docs sections. With capable Emaxen results of scan are used 1610for indentation too, otherwise they are used for highlighting only. 1611 1612Variables controlling indentation style: 1613 `cperl-tab-always-indent' 1614 Non-nil means TAB in CPerl mode should always reindent the current line, 1615 regardless of where in the line point is when the TAB command is used. 1616 `cperl-indent-left-aligned-comments' 1617 Non-nil means that the comment starting in leftmost column should indent. 1618 `cperl-auto-newline' 1619 Non-nil means automatically newline before and after braces, 1620 and after colons and semicolons, inserted in Perl code. The following 1621 \\[cperl-electric-backspace] will remove the inserted whitespace. 1622 Insertion after colons requires both this variable and 1623 `cperl-auto-newline-after-colon' set. 1624 `cperl-auto-newline-after-colon' 1625 Non-nil means automatically newline even after colons. 1626 Subject to `cperl-auto-newline' setting. 1627 `cperl-indent-level' 1628 Indentation of Perl statements within surrounding block. 1629 The surrounding block's indentation is the indentation 1630 of the line on which the open-brace appears. 1631 `cperl-continued-statement-offset' 1632 Extra indentation given to a substatement, such as the 1633 then-clause of an if, or body of a while, or just a statement continuation. 1634 `cperl-continued-brace-offset' 1635 Extra indentation given to a brace that starts a substatement. 1636 This is in addition to `cperl-continued-statement-offset'. 1637 `cperl-brace-offset' 1638 Extra indentation for line if it starts with an open brace. 1639 `cperl-brace-imaginary-offset' 1640 An open brace following other text is treated as if it the line started 1641 this far to the right of the actual line indentation. 1642 `cperl-label-offset' 1643 Extra indentation for line that is a label. 1644 `cperl-min-label-indent' 1645 Minimal indentation for line that is a label. 1646 1647Settings for classic indent-styles: K&R BSD=C++ GNU PerlStyle=Whitesmith 1648 `cperl-indent-level' 5 4 2 4 1649 `cperl-brace-offset' 0 0 0 0 1650 `cperl-continued-brace-offset' -5 -4 0 0 1651 `cperl-label-offset' -5 -4 -2 -4 1652 `cperl-continued-statement-offset' 5 4 2 4 1653 1654CPerl knows several indentation styles, and may bulk set the 1655corresponding variables. Use \\[cperl-set-style] to do this. Use 1656\\[cperl-set-style-back] to restore the memorized preexisting values 1657\(both available from menu). See examples in `cperl-style-examples'. 1658 1659Part of the indentation style is how different parts of if/elsif/else 1660statements are broken into lines; in CPerl, this is reflected on how 1661templates for these constructs are created (controlled by 1662`cperl-extra-newline-before-brace'), and how reflow-logic should treat \"continuation\" blocks of else/elsif/continue, controlled by the same variable, 1663and by `cperl-extra-newline-before-brace-multiline', 1664`cperl-merge-trailing-else', `cperl-indent-region-fix-constructs'. 1665 1666If `cperl-indent-level' is 0, the statement after opening brace in 1667column 0 is indented on 1668`cperl-brace-offset'+`cperl-continued-statement-offset'. 1669 1670Turning on CPerl mode calls the hooks in the variable `cperl-mode-hook' 1671with no args. 1672 1673DO NOT FORGET to read micro-docs (available from `Perl' menu) 1674or as help on variables `cperl-tips', `cperl-problems', 1675`cperl-praise', `cperl-speed'." 1676 (interactive) 1677 (kill-all-local-variables) 1678 (use-local-map cperl-mode-map) 1679 (if (cperl-val 'cperl-electric-linefeed) 1680 (progn 1681 (local-set-key "\C-J" 'cperl-linefeed) 1682 (local-set-key "\C-C\C-J" 'newline-and-indent))) 1683 (if (and 1684 (cperl-val 'cperl-clobber-lisp-bindings) 1685 (cperl-val 'cperl-info-on-command-no-prompt)) 1686 (progn 1687 ;; don't clobber the backspace binding: 1688 (cperl-define-key "\C-hf" 'cperl-info-on-current-command [(control h) f]) 1689 (cperl-define-key "\C-c\C-hf" 'cperl-info-on-command 1690 [(control c) (control h) f]))) 1691 (setq major-mode cperl-use-major-mode) 1692 (setq mode-name "CPerl") 1693 (let ((prev-a-c abbrevs-changed)) 1694 (define-abbrev-table 'cperl-mode-abbrev-table '( 1695 ("if" "if" cperl-electric-keyword 0) 1696 ("elsif" "elsif" cperl-electric-keyword 0) 1697 ("while" "while" cperl-electric-keyword 0) 1698 ("until" "until" cperl-electric-keyword 0) 1699 ("unless" "unless" cperl-electric-keyword 0) 1700 ("else" "else" cperl-electric-else 0) 1701 ("continue" "continue" cperl-electric-else 0) 1702 ("for" "for" cperl-electric-keyword 0) 1703 ("foreach" "foreach" cperl-electric-keyword 0) 1704 ("formy" "formy" cperl-electric-keyword 0) 1705 ("foreachmy" "foreachmy" cperl-electric-keyword 0) 1706 ("do" "do" cperl-electric-keyword 0) 1707 ("=pod" "=pod" cperl-electric-pod 0) 1708 ("=over" "=over" cperl-electric-pod 0) 1709 ("=head1" "=head1" cperl-electric-pod 0) 1710 ("=head2" "=head2" cperl-electric-pod 0) 1711 ("pod" "pod" cperl-electric-pod 0) 1712 ("over" "over" cperl-electric-pod 0) 1713 ("head1" "head1" cperl-electric-pod 0) 1714 ("head2" "head2" cperl-electric-pod 0))) 1715 (setq abbrevs-changed prev-a-c)) 1716 (setq local-abbrev-table cperl-mode-abbrev-table) 1717 (if (cperl-val 'cperl-electric-keywords) 1718 (abbrev-mode 1)) 1719 (set-syntax-table cperl-mode-syntax-table) 1720 ;; Until Emacs is multi-threaded, we do not actually need it local: 1721 (make-local-variable 'cperl-font-lock-multiline-start) 1722 (make-local-variable 'cperl-font-locking) 1723 (make-local-variable 'outline-regexp) 1724 ;; (setq outline-regexp imenu-example--function-name-regexp-perl) 1725 (setq outline-regexp cperl-outline-regexp) 1726 (make-local-variable 'outline-level) 1727 (setq outline-level 'cperl-outline-level) 1728 (make-local-variable 'paragraph-start) 1729 (setq paragraph-start (concat "^$\\|" page-delimiter)) 1730 (make-local-variable 'paragraph-separate) 1731 (setq paragraph-separate paragraph-start) 1732 (make-local-variable 'paragraph-ignore-fill-prefix) 1733 (setq paragraph-ignore-fill-prefix t) 1734 (if cperl-xemacs-p 1735 (progn 1736 (make-local-variable 'paren-backwards-message) 1737 (set 'paren-backwards-message t))) 1738 (make-local-variable 'indent-line-function) 1739 (setq indent-line-function 'cperl-indent-line) 1740 (make-local-variable 'require-final-newline) 1741 (setq require-final-newline mode-require-final-newline) 1742 (make-local-variable 'comment-start) 1743 (setq comment-start "# ") 1744 (make-local-variable 'comment-end) 1745 (setq comment-end "") 1746 (make-local-variable 'comment-column) 1747 (setq comment-column cperl-comment-column) 1748 (make-local-variable 'comment-start-skip) 1749 (setq comment-start-skip "#+ *") 1750 (make-local-variable 'defun-prompt-regexp) 1751;;; "[ \t]*sub" 1752;;; (cperl-after-sub-regexp 'named nil) ; 8=name 11=proto 14=attr-start 1753;;; cperl-maybe-white-and-comment-rex ; 15=pre-block 1754 (setq defun-prompt-regexp 1755 (concat "^[ \t]*\\(sub" 1756 (cperl-after-sub-regexp 'named 'attr-groups) 1757 "\\|" ; per toke.c 1758 "\\(BEGIN\\|CHECK\\|INIT\\|END\\|AUTOLOAD\\|DESTROY\\)" 1759 "\\)" 1760 cperl-maybe-white-and-comment-rex)) 1761 (make-local-variable 'comment-indent-function) 1762 (setq comment-indent-function 'cperl-comment-indent) 1763 (and (boundp 'fill-paragraph-function) 1764 (progn 1765 (make-local-variable 'fill-paragraph-function) 1766 (set 'fill-paragraph-function 'cperl-fill-paragraph))) 1767 (make-local-variable 'parse-sexp-ignore-comments) 1768 (setq parse-sexp-ignore-comments t) 1769 (make-local-variable 'indent-region-function) 1770 (setq indent-region-function 'cperl-indent-region) 1771 ;;(setq auto-fill-function 'cperl-do-auto-fill) ; Need to switch on and off! 1772 (make-local-variable 'imenu-create-index-function) 1773 (setq imenu-create-index-function 1774 (function cperl-imenu--create-perl-index)) 1775 (make-local-variable 'imenu-sort-function) 1776 (setq imenu-sort-function nil) 1777 (make-local-variable 'vc-rcs-header) 1778 (set 'vc-rcs-header cperl-vc-rcs-header) 1779 (make-local-variable 'vc-sccs-header) 1780 (set 'vc-sccs-header cperl-vc-sccs-header) 1781 ;; This one is obsolete... 1782 (make-local-variable 'vc-header-alist) 1783 (set 'vc-header-alist (or cperl-vc-header-alist ; Avoid warning 1784 (` ((SCCS (, (car cperl-vc-sccs-header))) 1785 (RCS (, (car cperl-vc-rcs-header))))))) 1786 (cond ((boundp 'compilation-error-regexp-alist-alist);; xemacs 20.x 1787 (make-local-variable 'compilation-error-regexp-alist-alist) 1788 (set 'compilation-error-regexp-alist-alist 1789 (cons (cons 'cperl cperl-compilation-error-regexp-alist) 1790 (symbol-value 'compilation-error-regexp-alist-alist))) 1791 (if (fboundp 'compilation-build-compilation-error-regexp-alist) 1792 (let ((f 'compilation-build-compilation-error-regexp-alist)) 1793 (funcall f)) 1794 (make-local-variable 'compilation-error-regexp-alist) 1795 (push 'cperl compilation-error-regexp-alist))) 1796 ((boundp 'compilation-error-regexp-alist);; xmeacs 19.x 1797 (make-local-variable 'compilation-error-regexp-alist) 1798 (set 'compilation-error-regexp-alist 1799 (append cperl-compilation-error-regexp-alist 1800 (symbol-value 'compilation-error-regexp-alist))))) 1801 (make-local-variable 'font-lock-defaults) 1802 (setq font-lock-defaults 1803 (cond 1804 ((string< emacs-version "19.30") 1805 '(cperl-font-lock-keywords-2 nil nil ((?_ . "w")))) 1806 ((string< emacs-version "19.33") ; Which one to use? 1807 '((cperl-font-lock-keywords 1808 cperl-font-lock-keywords-1 1809 cperl-font-lock-keywords-2) nil nil ((?_ . "w")))) 1810 (t 1811 '((cperl-load-font-lock-keywords 1812 cperl-load-font-lock-keywords-1 1813 cperl-load-font-lock-keywords-2) nil nil ((?_ . "w")))))) 1814 (make-local-variable 'cperl-syntax-state) 1815 (setq cperl-syntax-state nil) ; reset syntaxification cache 1816 (if cperl-use-syntax-table-text-property 1817 (progn 1818 (make-local-variable 'parse-sexp-lookup-properties) 1819 ;; Do not introduce variable if not needed, we check it! 1820 (set 'parse-sexp-lookup-properties t) 1821 ;; Fix broken font-lock: 1822 (or (boundp 'font-lock-unfontify-region-function) 1823 (set 'font-lock-unfontify-region-function 1824 'font-lock-default-unfontify-region)) 1825 (unless cperl-xemacs-p ; Our: just a plug for wrong font-lock 1826 (make-local-variable 'font-lock-unfontify-region-function) 1827 (set 'font-lock-unfontify-region-function ; not present with old Emacs 1828 'cperl-font-lock-unfontify-region-function)) 1829 (make-local-variable 'cperl-syntax-done-to) 1830 (setq cperl-syntax-done-to nil) ; reset syntaxification cache 1831 (make-local-variable 'font-lock-syntactic-keywords) 1832 (setq font-lock-syntactic-keywords 1833 (if cperl-syntaxify-by-font-lock 1834 '((cperl-fontify-syntaxically)) 1835 ;; unless font-lock-syntactic-keywords, font-lock (pre-22.1) 1836 ;; used to ignore syntax-table text-properties. (t) is a hack 1837 ;; to make font-lock think that font-lock-syntactic-keywords 1838 ;; are defined. 1839 '(t))))) 1840 (if (boundp 'font-lock-multiline) ; Newer font-lock; use its facilities 1841 (progn 1842 (setq cperl-font-lock-multiline t) ; Not localized... 1843 (set (make-local-variable 'font-lock-multiline) t)) 1844 (make-local-variable 'font-lock-fontify-region-function) 1845 (set 'font-lock-fontify-region-function ; not present with old Emacs 1846 'cperl-font-lock-fontify-region-function)) 1847 (make-local-variable 'font-lock-fontify-region-function) 1848 (set 'font-lock-fontify-region-function ; not present with old Emacs 1849 'cperl-font-lock-fontify-region-function) 1850 (make-local-variable 'cperl-old-style) 1851 (if (boundp 'normal-auto-fill-function) ; 19.33 and later 1852 (set (make-local-variable 'normal-auto-fill-function) 1853 'cperl-do-auto-fill) 1854 (or (fboundp 'cperl-old-auto-fill-mode) 1855 (progn 1856 (fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode)) 1857 (defun auto-fill-mode (&optional arg) 1858 (interactive "P") 1859 (eval '(cperl-old-auto-fill-mode arg)) ; Avoid a warning 1860 (and auto-fill-function (memq major-mode '(perl-mode cperl-mode)) 1861 (setq auto-fill-function 'cperl-do-auto-fill)))))) 1862 (if (cperl-enable-font-lock) 1863 (if (cperl-val 'cperl-font-lock) 1864 (progn (or cperl-faces-init (cperl-init-faces)) 1865 (font-lock-mode 1)))) 1866 (set (make-local-variable 'facemenu-add-face-function) 1867 'cperl-facemenu-add-face-function) ; XXXX What this guy is for??? 1868 (and (boundp 'msb-menu-cond) 1869 (not cperl-msb-fixed) 1870 (cperl-msb-fix)) 1871 (if (featurep 'easymenu) 1872 (easy-menu-add cperl-menu)) ; A NOP in Emacs. 1873 (run-mode-hooks 'cperl-mode-hook) 1874 (if cperl-hook-after-change 1875 (add-hook 'after-change-functions 'cperl-after-change-function nil t)) 1876 ;; After hooks since fontification will break this 1877 (if cperl-pod-here-scan 1878 (or cperl-syntaxify-by-font-lock 1879 (progn (or cperl-faces-init (cperl-init-faces-weak)) 1880 (cperl-find-pods-heres))))) 1881 1882;; Fix for perldb - make default reasonable 1883(defun cperl-db () 1884 (interactive) 1885 (require 'gud) 1886 (perldb (read-from-minibuffer "Run perldb (like this): " 1887 (if (consp gud-perldb-history) 1888 (car gud-perldb-history) 1889 (concat "perl " ;;(file-name-nondirectory 1890 ;; I have problems 1891 ;; in OS/2 1892 ;; otherwise 1893 (buffer-file-name))) 1894 nil nil 1895 '(gud-perldb-history . 1)))) 1896 1897(defun cperl-msb-fix () 1898 ;; Adds perl files to msb menu, supposes that msb is already loaded 1899 (setq cperl-msb-fixed t) 1900 (let* ((l (length msb-menu-cond)) 1901 (last (nth (1- l) msb-menu-cond)) 1902 (precdr (nthcdr (- l 2) msb-menu-cond)) ; cdr of this is last 1903 (handle (1- (nth 1 last)))) 1904 (setcdr precdr (list 1905 (list 1906 '(memq major-mode '(cperl-mode perl-mode)) 1907 handle 1908 "Perl Files (%d)") 1909 last)))) 1910 1911;; This is used by indent-for-comment 1912;; to decide how much to indent a comment in CPerl code 1913;; based on its context. Do fallback if comment is found wrong. 1914 1915(defvar cperl-wrong-comment) 1916(defvar cperl-st-cfence '(14)) ; Comment-fence 1917(defvar cperl-st-sfence '(15)) ; String-fence 1918(defvar cperl-st-punct '(1)) 1919(defvar cperl-st-word '(2)) 1920(defvar cperl-st-bra '(4 . ?\>)) 1921(defvar cperl-st-ket '(5 . ?\<)) 1922 1923 1924(defun cperl-comment-indent () ; called at point at supposed comment 1925 (let ((p (point)) (c (current-column)) was phony) 1926 (if (and (not cperl-indent-comment-at-column-0) 1927 (looking-at "^#")) 1928 0 ; Existing comment at bol stays there. 1929 ;; Wrong comment found 1930 (save-excursion 1931 (setq was (cperl-to-comment-or-eol) 1932 phony (eq (get-text-property (point) 'syntax-table) 1933 cperl-st-cfence)) 1934 (if phony 1935 (progn ; Too naive??? 1936 (re-search-forward "#\\|$") ; Hmm, what about embedded #? 1937 (if (eq (preceding-char) ?\#) 1938 (forward-char -1)) 1939 (setq was nil))) 1940 (if (= (point) p) ; Our caller found a correct place 1941 (progn 1942 (skip-chars-backward " \t") 1943 (setq was (current-column)) 1944 (if (eq was 0) 1945 comment-column 1946 (max (1+ was) ; Else indent at comment column 1947 comment-column))) 1948 ;; No, the caller found a random place; we need to edit ourselves 1949 (if was nil 1950 (insert comment-start) 1951 (backward-char (length comment-start))) 1952 (setq cperl-wrong-comment t) 1953 (cperl-make-indent comment-column 1) ; Indent min 1 1954 c))))) 1955 1956;;;(defun cperl-comment-indent-fallback () 1957;;; "Is called if the standard comment-search procedure fails. 1958;;;Point is at start of real comment." 1959;;; (let ((c (current-column)) target cnt prevc) 1960;;; (if (= c comment-column) nil 1961;;; (setq cnt (skip-chars-backward "[ \t]")) 1962;;; (setq target (max (1+ (setq prevc 1963;;; (current-column))) ; Else indent at comment column 1964;;; comment-column)) 1965;;; (if (= c comment-column) nil 1966;;; (delete-backward-char cnt) 1967;;; (while (< prevc target) 1968;;; (insert "\t") 1969;;; (setq prevc (current-column))) 1970;;; (if (> prevc target) (progn (delete-char -1) (setq prevc (current-column)))) 1971;;; (while (< prevc target) 1972;;; (insert " ") 1973;;; (setq prevc (current-column))))))) 1974 1975(defun cperl-indent-for-comment () 1976 "Substitute for `indent-for-comment' in CPerl." 1977 (interactive) 1978 (let (cperl-wrong-comment) 1979 (indent-for-comment) 1980 (if cperl-wrong-comment ; set by `cperl-comment-indent' 1981 (progn (cperl-to-comment-or-eol) 1982 (forward-char (length comment-start)))))) 1983 1984(defun cperl-comment-region (b e arg) 1985 "Comment or uncomment each line in the region in CPerl mode. 1986See `comment-region'." 1987 (interactive "r\np") 1988 (let ((comment-start "#")) 1989 (comment-region b e arg))) 1990 1991(defun cperl-uncomment-region (b e arg) 1992 "Uncomment or comment each line in the region in CPerl mode. 1993See `comment-region'." 1994 (interactive "r\np") 1995 (let ((comment-start "#")) 1996 (comment-region b e (- arg)))) 1997 1998(defvar cperl-brace-recursing nil) 1999 2000(defun cperl-electric-brace (arg &optional only-before) 2001 "Insert character and correct line's indentation. 2002If ONLY-BEFORE and `cperl-auto-newline', will insert newline before the 2003place (even in empty line), but not after. If after \")\" and the inserted 2004char is \"{\", insert extra newline before only if 2005`cperl-extra-newline-before-brace'." 2006 (interactive "P") 2007 (let (insertpos 2008 (other-end (if (and cperl-electric-parens-mark 2009 (cperl-mark-active) 2010 (< (mark) (point))) 2011 (mark) 2012 nil))) 2013 (if (and other-end 2014 (not cperl-brace-recursing) 2015 (cperl-val 'cperl-electric-parens) 2016 (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))) 2017 ;; Need to insert a matching pair 2018 (progn 2019 (save-excursion 2020 (setq insertpos (point-marker)) 2021 (goto-char other-end) 2022 (setq last-command-char ?\{) 2023 (cperl-electric-lbrace arg insertpos)) 2024 (forward-char 1)) 2025 ;; Check whether we close something "usual" with `}' 2026 (if (and (eq last-command-char ?\}) 2027 (not 2028 (condition-case nil 2029 (save-excursion 2030 (up-list (- (prefix-numeric-value arg))) 2031 ;;(cperl-after-block-p (point-min)) 2032 (or (cperl-after-expr-p nil "{;)") 2033 ;; after sub, else, continue 2034 (cperl-after-block-p nil 'pre))) 2035 (error nil)))) 2036 ;; Just insert the guy 2037 (self-insert-command (prefix-numeric-value arg)) 2038 (if (and (not arg) ; No args, end (of empty line or auto) 2039 (eolp) 2040 (or (and (null only-before) 2041 (save-excursion 2042 (skip-chars-backward " \t") 2043 (bolp))) 2044 (and (eq last-command-char ?\{) ; Do not insert newline 2045 ;; if after ")" and `cperl-extra-newline-before-brace' 2046 ;; is nil, do not insert extra newline. 2047 (not cperl-extra-newline-before-brace) 2048 (save-excursion 2049 (skip-chars-backward " \t") 2050 (eq (preceding-char) ?\)))) 2051 (if cperl-auto-newline 2052 (progn (cperl-indent-line) (newline) t) nil))) 2053 (progn 2054 (self-insert-command (prefix-numeric-value arg)) 2055 (cperl-indent-line) 2056 (if cperl-auto-newline 2057 (setq insertpos (1- (point)))) 2058 (if (and cperl-auto-newline (null only-before)) 2059 (progn 2060 (newline) 2061 (cperl-indent-line))) 2062 (save-excursion 2063 (if insertpos (progn (goto-char insertpos) 2064 (search-forward (make-string 2065 1 last-command-char)) 2066 (setq insertpos (1- (point))))) 2067 (delete-char -1)))) 2068 (if insertpos 2069 (save-excursion 2070 (goto-char insertpos) 2071 (self-insert-command (prefix-numeric-value arg))) 2072 (self-insert-command (prefix-numeric-value arg))))))) 2073 2074(defun cperl-electric-lbrace (arg &optional end) 2075 "Insert character, correct line's indentation, correct quoting by space." 2076 (interactive "P") 2077 (let ((cperl-brace-recursing t) 2078 (cperl-auto-newline cperl-auto-newline) 2079 (other-end (or end 2080 (if (and cperl-electric-parens-mark 2081 (cperl-mark-active) 2082 (> (mark) (point))) 2083 (save-excursion 2084 (goto-char (mark)) 2085 (point-marker)) 2086 nil))) 2087 pos after) 2088 (and (cperl-val 'cperl-electric-lbrace-space) 2089 (eq (preceding-char) ?$) 2090 (save-excursion 2091 (skip-chars-backward "$") 2092 (looking-at "\\(\\$\\$\\)*\\$\\([^\\$]\\|$\\)")) 2093 (insert ?\s)) 2094 ;; Check whether we are in comment 2095 (if (and 2096 (save-excursion 2097 (beginning-of-line) 2098 (not (looking-at "[ \t]*#"))) 2099 (cperl-after-expr-p nil "{;)")) 2100 nil 2101 (setq cperl-auto-newline nil)) 2102 (cperl-electric-brace arg) 2103 (and (cperl-val 'cperl-electric-parens) 2104 (eq last-command-char ?{) 2105 (memq last-command-char 2106 (append cperl-electric-parens-string nil)) 2107 (or (if other-end (goto-char (marker-position other-end))) 2108 t) 2109 (setq last-command-char ?} pos (point)) 2110 (progn (cperl-electric-brace arg t) 2111 (goto-char pos))))) 2112 2113(defun cperl-electric-paren (arg) 2114 "Insert an opening parenthesis or a matching pair of parentheses. 2115See `cperl-electric-parens'." 2116 (interactive "P") 2117 (let ((beg (save-excursion (beginning-of-line) (point))) 2118 (other-end (if (and cperl-electric-parens-mark 2119 (cperl-mark-active) 2120 (> (mark) (point))) 2121 (save-excursion 2122 (goto-char (mark)) 2123 (point-marker)) 2124 nil))) 2125 (if (and (cperl-val 'cperl-electric-parens) 2126 (memq last-command-char 2127 (append cperl-electric-parens-string nil)) 2128 (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)) 2129 ;;(not (save-excursion (search-backward "#" beg t))) 2130 (if (eq last-command-char ?<) 2131 (progn 2132 (and abbrev-mode ; later it is too late, may be after `for' 2133 (expand-abbrev)) 2134 (cperl-after-expr-p nil "{;(,:=")) 2135 1)) 2136 (progn 2137 (self-insert-command (prefix-numeric-value arg)) 2138 (if other-end (goto-char (marker-position other-end))) 2139 (insert (make-string 2140 (prefix-numeric-value arg) 2141 (cdr (assoc last-command-char '((?{ .?}) 2142 (?[ . ?]) 2143 (?( . ?)) 2144 (?< . ?>)))))) 2145 (forward-char (- (prefix-numeric-value arg)))) 2146 (self-insert-command (prefix-numeric-value arg))))) 2147 2148(defun cperl-electric-rparen (arg) 2149 "Insert a matching pair of parentheses if marking is active. 2150If not, or if we are not at the end of marking range, would self-insert. 2151Affected by `cperl-electric-parens'." 2152 (interactive "P") 2153 (let ((beg (save-excursion (beginning-of-line) (point))) 2154 (other-end (if (and cperl-electric-parens-mark 2155 (cperl-val 'cperl-electric-parens) 2156 (memq last-command-char 2157 (append cperl-electric-parens-string nil)) 2158 (cperl-mark-active) 2159 (< (mark) (point))) 2160 (mark) 2161 nil)) 2162 p) 2163 (if (and other-end 2164 (cperl-val 'cperl-electric-parens) 2165 (memq last-command-char '( ?\) ?\] ?\} ?\> )) 2166 (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)) 2167 ;;(not (save-excursion (search-backward "#" beg t))) 2168 ) 2169 (progn 2170 (self-insert-command (prefix-numeric-value arg)) 2171 (setq p (point)) 2172 (if other-end (goto-char other-end)) 2173 (insert (make-string 2174 (prefix-numeric-value arg) 2175 (cdr (assoc last-command-char '((?\} . ?\{) 2176 (?\] . ?\[) 2177 (?\) . ?\() 2178 (?\> . ?\<)))))) 2179 (goto-char (1+ p))) 2180 (self-insert-command (prefix-numeric-value arg))))) 2181 2182(defun cperl-electric-keyword () 2183 "Insert a construction appropriate after a keyword. 2184Help message may be switched off by setting `cperl-message-electric-keyword' 2185to nil." 2186 (let ((beg (save-excursion (beginning-of-line) (point))) 2187 (dollar (and (eq last-command-char ?$) 2188 (eq this-command 'self-insert-command))) 2189 (delete (and (memq last-command-char '(?\s ?\n ?\t ?\f)) 2190 (memq this-command '(self-insert-command newline)))) 2191 my do) 2192 (and (save-excursion 2193 (condition-case nil 2194 (progn 2195 (backward-sexp 1) 2196 (setq do (looking-at "do\\>"))) 2197 (error nil)) 2198 (cperl-after-expr-p nil "{;:")) 2199 (save-excursion 2200 (not 2201 (re-search-backward 2202 "[#\"'`]\\|\\<q\\(\\|[wqxr]\\)\\>" 2203 beg t))) 2204 (save-excursion (or (not (re-search-backward "^=" nil t)) 2205 (or 2206 (looking-at "=cut") 2207 (and cperl-use-syntax-table-text-property 2208 (not (eq (get-text-property (point) 2209 'syntax-type) 2210 'pod)))))) 2211 (save-excursion (forward-sexp -1) 2212 (not (memq (following-char) (append "$@%&*" nil)))) 2213 (progn 2214 (and (eq (preceding-char) ?y) 2215 (progn ; "foreachmy" 2216 (forward-char -2) 2217 (insert " ") 2218 (forward-char 2) 2219 (setq my t dollar t 2220 delete 2221 (memq this-command '(self-insert-command newline))))) 2222 (and dollar (insert " $")) 2223 (cperl-indent-line) 2224 ;;(insert " () {\n}") 2225 (cond 2226 (cperl-extra-newline-before-brace 2227 (insert (if do "\n" " ()\n")) 2228 (insert "{") 2229 (cperl-indent-line) 2230 (insert "\n") 2231 (cperl-indent-line) 2232 (insert "\n}") 2233 (and do (insert " while ();"))) 2234 (t 2235 (insert (if do " {\n} while ();" " () {\n}")))) 2236 (or (looking-at "[ \t]\\|$") (insert " ")) 2237 (cperl-indent-line) 2238 (if dollar (progn (search-backward "$") 2239 (if my 2240 (forward-char 1) 2241 (delete-char 1))) 2242 (search-backward ")") 2243 (if (eq last-command-char ?\() 2244 (progn ; Avoid "if (())" 2245 (delete-backward-char 1) 2246 (delete-backward-char -1)))) 2247 (if delete 2248 (cperl-putback-char cperl-del-back-ch)) 2249 (if cperl-message-electric-keyword 2250 (message "Precede char by C-q to avoid expansion")))))) 2251 2252(defun cperl-ensure-newlines (n &optional pos) 2253 "Make sure there are N newlines after the point." 2254 (or pos (setq pos (point))) 2255 (if (looking-at "\n") 2256 (forward-char 1) 2257 (insert "\n")) 2258 (if (> n 1) 2259 (cperl-ensure-newlines (1- n) pos) 2260 (goto-char pos))) 2261 2262(defun cperl-electric-pod () 2263 "Insert a POD chunk appropriate after a =POD directive." 2264 (let ((delete (and (memq last-command-char '(?\s ?\n ?\t ?\f)) 2265 (memq this-command '(self-insert-command newline)))) 2266 head1 notlast name p really-delete over) 2267 (and (save-excursion 2268 (forward-word -1) 2269 (and 2270 (eq (preceding-char) ?=) 2271 (progn 2272 (setq head1 (looking-at "head1\\>[ \t]*$")) 2273 (setq over (and (looking-at "over\\>[ \t]*$") 2274 (not (looking-at "over[ \t]*\n\n\n*=item\\>")))) 2275 (forward-char -1) 2276 (bolp)) 2277 (or 2278 (get-text-property (point) 'in-pod) 2279 (cperl-after-expr-p nil "{;:") 2280 (and (re-search-backward "\\(\\`\n?\\|^\n\\)=\\sw+" (point-min) t) 2281 (not (looking-at "\n*=cut")) 2282 (or (not cperl-use-syntax-table-text-property) 2283 (eq (get-text-property (point) 'syntax-type) 'pod)))))) 2284 (progn 2285 (save-excursion 2286 (setq notlast (re-search-forward "^\n=" nil t))) 2287 (or notlast 2288 (progn 2289 (insert "\n\n=cut") 2290 (cperl-ensure-newlines 2) 2291 (forward-word -2) 2292 (if (and head1 2293 (not 2294 (save-excursion 2295 (forward-char -1) 2296 (re-search-backward "\\(\\`\n?\\|\n\n\\)=head1\\>" 2297 nil t)))) ; Only one 2298 (progn 2299 (forward-word 1) 2300 (setq name (file-name-sans-extension 2301 (file-name-nondirectory (buffer-file-name))) 2302 p (point)) 2303 (insert " NAME\n\n" name 2304 " - \n\n=head1 SYNOPSIS\n\n\n\n" 2305 "=head1 DESCRIPTION") 2306 (cperl-ensure-newlines 4) 2307 (goto-char p) 2308 (forward-word 2) 2309 (end-of-line) 2310 (setq really-delete t)) 2311 (forward-word 1)))) 2312 (if over 2313 (progn 2314 (setq p (point)) 2315 (insert "\n\n=item \n\n\n\n" 2316 "=back") 2317 (cperl-ensure-newlines 2) 2318 (goto-char p) 2319 (forward-word 1) 2320 (end-of-line) 2321 (setq really-delete t))) 2322 (if (and delete really-delete) 2323 (cperl-putback-char cperl-del-back-ch)))))) 2324 2325(defun cperl-electric-else () 2326 "Insert a construction appropriate after a keyword. 2327Help message may be switched off by setting `cperl-message-electric-keyword' 2328to nil." 2329 (let ((beg (save-excursion (beginning-of-line) (point)))) 2330 (and (save-excursion 2331 (backward-sexp 1) 2332 (cperl-after-expr-p nil "{;:")) 2333 (save-excursion 2334 (not 2335 (re-search-backward 2336 "[#\"'`]\\|\\<q\\(\\|[wqxr]\\)\\>" 2337 beg t))) 2338 (save-excursion (or (not (re-search-backward "^=" nil t)) 2339 (looking-at "=cut") 2340 (and cperl-use-syntax-table-text-property 2341 (not (eq (get-text-property (point) 2342 'syntax-type) 2343 'pod))))) 2344 (progn 2345 (cperl-indent-line) 2346 ;;(insert " {\n\n}") 2347 (cond 2348 (cperl-extra-newline-before-brace 2349 (insert "\n") 2350 (insert "{") 2351 (cperl-indent-line) 2352 (insert "\n\n}")) 2353 (t 2354 (insert " {\n\n}"))) 2355 (or (looking-at "[ \t]\\|$") (insert " ")) 2356 (cperl-indent-line) 2357 (forward-line -1) 2358 (cperl-indent-line) 2359 (cperl-putback-char cperl-del-back-ch) 2360 (setq this-command 'cperl-electric-else) 2361 (if cperl-message-electric-keyword 2362 (message "Precede char by C-q to avoid expansion")))))) 2363 2364(defun cperl-linefeed () 2365 "Go to end of line, open a new line and indent appropriately. 2366If in POD, insert appropriate lines." 2367 (interactive) 2368 (let ((beg (save-excursion (beginning-of-line) (point))) 2369 (end (save-excursion (end-of-line) (point))) 2370 (pos (point)) start over cut res) 2371 (if (and ; Check if we need to split: 2372 ; i.e., on a boundary and inside "{...}" 2373 (save-excursion (cperl-to-comment-or-eol) 2374 (>= (point) pos)) ; Not in a comment 2375 (or (save-excursion 2376 (skip-chars-backward " \t" beg) 2377 (forward-char -1) 2378 (looking-at "[;{]")) ; After { or ; + spaces 2379 (looking-at "[ \t]*}") ; Before } 2380 (re-search-forward "\\=[ \t]*;" end t)) ; Before spaces + ; 2381 (save-excursion 2382 (and 2383 (eq (car (parse-partial-sexp pos end -1)) -1) 2384 ; Leave the level of parens 2385 (looking-at "[,; \t]*\\($\\|#\\)") ; Comma to allow anon subr 2386 ; Are at end 2387 (cperl-after-block-p (point-min)) 2388 (progn 2389 (backward-sexp 1) 2390 (setq start (point-marker)) 2391 (<= start pos))))) ; Redundant? Are after the 2392 ; start of parens group. 2393 (progn 2394 (skip-chars-backward " \t") 2395 (or (memq (preceding-char) (append ";{" nil)) 2396 (insert ";")) 2397 (insert "\n") 2398 (forward-line -1) 2399 (cperl-indent-line) 2400 (goto-char start) 2401 (or (looking-at "{[ \t]*$") ; If there is a statement 2402 ; before, move it to separate line 2403 (progn 2404 (forward-char 1) 2405 (insert "\n") 2406 (cperl-indent-line))) 2407 (forward-line 1) ; We are on the target line 2408 (cperl-indent-line) 2409 (beginning-of-line) 2410 (or (looking-at "[ \t]*}[,; \t]*$") ; If there is a statement 2411 ; after, move it to separate line 2412 (progn 2413 (end-of-line) 2414 (search-backward "}" beg) 2415 (skip-chars-backward " \t") 2416 (or (memq (preceding-char) (append ";{" nil)) 2417 (insert ";")) 2418 (insert "\n") 2419 (cperl-indent-line) 2420 (forward-line -1))) 2421 (forward-line -1) ; We are on the line before target 2422 (end-of-line) 2423 (newline-and-indent)) 2424 (end-of-line) ; else - no splitting 2425 (cond 2426 ((and (looking-at "\n[ \t]*{$") 2427 (save-excursion 2428 (skip-chars-backward " \t") 2429 (eq (preceding-char) ?\)))) ; Probably if () {} group 2430 ; with an extra newline. 2431 (forward-line 2) 2432 (cperl-indent-line)) 2433 ((save-excursion ; In POD header 2434 (forward-paragraph -1) 2435 ;; (re-search-backward "\\(\\`\n?\\|\n\n\\)=head1\\b") 2436 ;; We are after \n now, so look for the rest 2437 (if (looking-at "\\(\\`\n?\\|\n\\)=\\sw+") 2438 (progn 2439 (setq cut (looking-at "\\(\\`\n?\\|\n\\)=cut\\>")) 2440 (setq over (looking-at "\\(\\`\n?\\|\n\\)=over\\>")) 2441 t))) 2442 (if (and over 2443 (progn 2444 (forward-paragraph -1) 2445 (forward-word 1) 2446 (setq pos (point)) 2447 (setq cut (buffer-substring (point) 2448 (save-excursion 2449 (end-of-line) 2450 (point)))) 2451 (delete-char (- (save-excursion (end-of-line) (point)) 2452 (point))) 2453 (setq res (expand-abbrev)) 2454 (save-excursion 2455 (goto-char pos) 2456 (insert cut)) 2457 res)) 2458 nil 2459 (cperl-ensure-newlines (if cut 2 4)) 2460 (forward-line 2))) 2461 ((get-text-property (point) 'in-pod) ; In POD section 2462 (cperl-ensure-newlines 4) 2463 (forward-line 2)) 2464 ((looking-at "\n[ \t]*$") ; Next line is empty - use it. 2465 (forward-line 1) 2466 (cperl-indent-line)) 2467 (t 2468 (newline-and-indent)))))) 2469 2470(defun cperl-electric-semi (arg) 2471 "Insert character and correct line's indentation." 2472 (interactive "P") 2473 (if cperl-auto-newline 2474 (cperl-electric-terminator arg) 2475 (self-insert-command (prefix-numeric-value arg)) 2476 (if cperl-autoindent-on-semi 2477 (cperl-indent-line)))) 2478 2479(defun cperl-electric-terminator (arg) 2480 "Insert character and correct line's indentation." 2481 (interactive "P") 2482 (let ((end (point)) 2483 (auto (and cperl-auto-newline 2484 (or (not (eq last-command-char ?:)) 2485 cperl-auto-newline-after-colon))) 2486 insertpos) 2487 (if (and ;;(not arg) 2488 (eolp) 2489 (not (save-excursion 2490 (beginning-of-line) 2491 (skip-chars-forward " \t") 2492 (or 2493 ;; Ignore in comment lines 2494 (= (following-char) ?#) 2495 ;; Colon is special only after a label 2496 ;; So quickly rule out most other uses of colon 2497 ;; and do no indentation for them. 2498 (and (eq last-command-char ?:) 2499 (save-excursion 2500 (forward-word 1) 2501 (skip-chars-forward " \t") 2502 (and (< (point) end) 2503 (progn (goto-char (- end 1)) 2504 (not (looking-at ":")))))) 2505 (progn 2506 (beginning-of-defun) 2507 (let ((pps (parse-partial-sexp (point) end))) 2508 (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))))) 2509 (progn 2510 (self-insert-command (prefix-numeric-value arg)) 2511 ;;(forward-char -1) 2512 (if auto (setq insertpos (point-marker))) 2513 ;;(forward-char 1) 2514 (cperl-indent-line) 2515 (if auto 2516 (progn 2517 (newline) 2518 (cperl-indent-line))) 2519 (save-excursion 2520 (if insertpos (goto-char (1- (marker-position insertpos))) 2521 (forward-char -1)) 2522 (delete-char 1)))) 2523 (if insertpos 2524 (save-excursion 2525 (goto-char insertpos) 2526 (self-insert-command (prefix-numeric-value arg))) 2527 (self-insert-command (prefix-numeric-value arg))))) 2528 2529(defun cperl-electric-backspace (arg) 2530 "Backspace, or remove the whitespace around the point inserted by an electric 2531key. Will untabify if `cperl-electric-backspace-untabify' is non-nil." 2532 (interactive "p") 2533 (if (and cperl-auto-newline 2534 (memq last-command '(cperl-electric-semi 2535 cperl-electric-terminator 2536 cperl-electric-lbrace)) 2537 (memq (preceding-char) '(?\s ?\t ?\n))) 2538 (let (p) 2539 (if (eq last-command 'cperl-electric-lbrace) 2540 (skip-chars-forward " \t\n")) 2541 (setq p (point)) 2542 (skip-chars-backward " \t\n") 2543 (delete-region (point) p)) 2544 (and (eq last-command 'cperl-electric-else) 2545 ;; We are removing the whitespace *inside* cperl-electric-else 2546 (setq this-command 'cperl-electric-else-really)) 2547 (if (and cperl-auto-newline 2548 (eq last-command 'cperl-electric-else-really) 2549 (memq (preceding-char) '(?\s ?\t ?\n))) 2550 (let (p) 2551 (skip-chars-forward " \t\n") 2552 (setq p (point)) 2553 (skip-chars-backward " \t\n") 2554 (delete-region (point) p)) 2555 (if cperl-electric-backspace-untabify 2556 (backward-delete-char-untabify arg) 2557 (delete-backward-char arg))))) 2558 2559(put 'cperl-electric-backspace 'delete-selection 'supersede) 2560 2561(defun cperl-inside-parens-p () ;; NOT USED???? 2562 (condition-case () 2563 (save-excursion 2564 (save-restriction 2565 (narrow-to-region (point) 2566 (progn (beginning-of-defun) (point))) 2567 (goto-char (point-max)) 2568 (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\())) 2569 (error nil))) 2570 2571(defun cperl-indent-command (&optional whole-exp) 2572 "Indent current line as Perl code, or in some cases insert a tab character. 2573If `cperl-tab-always-indent' is non-nil (the default), always indent current 2574line. Otherwise, indent the current line only if point is at the left margin 2575or in the line's indentation; otherwise insert a tab. 2576 2577A numeric argument, regardless of its value, 2578means indent rigidly all the lines of the expression starting after point 2579so that this line becomes properly indented. 2580The relative indentation among the lines of the expression are preserved." 2581 (interactive "P") 2582 (cperl-update-syntaxification (point) (point)) 2583 (if whole-exp 2584 ;; If arg, always indent this line as Perl 2585 ;; and shift remaining lines of expression the same amount. 2586 (let ((shift-amt (cperl-indent-line)) 2587 beg end) 2588 (save-excursion 2589 (if cperl-tab-always-indent 2590 (beginning-of-line)) 2591 (setq beg (point)) 2592 (forward-sexp 1) 2593 (setq end (point)) 2594 (goto-char beg) 2595 (forward-line 1) 2596 (setq beg (point))) 2597 (if (and shift-amt (> end beg)) 2598 (indent-code-rigidly beg end shift-amt "#"))) 2599 (if (and (not cperl-tab-always-indent) 2600 (save-excursion 2601 (skip-chars-backward " \t") 2602 (not (bolp)))) 2603 (insert-tab) 2604 (cperl-indent-line)))) 2605 2606(defun cperl-indent-line (&optional parse-data) 2607 "Indent current line as Perl code. 2608Return the amount the indentation changed by." 2609 (let ((case-fold-search nil) 2610 (pos (- (point-max) (point))) 2611 indent i beg shift-amt) 2612 (setq indent (cperl-calculate-indent parse-data) 2613 i indent) 2614 (beginning-of-line) 2615 (setq beg (point)) 2616 (cond ((or (eq indent nil) (eq indent t)) 2617 (setq indent (current-indentation) i nil)) 2618 ;;((eq indent t) ; Never? 2619 ;; (setq indent (cperl-calculate-indent-within-comment))) 2620 ;;((looking-at "[ \t]*#") 2621 ;; (setq indent 0)) 2622 (t 2623 (skip-chars-forward " \t") 2624 (if (listp indent) (setq indent (car indent))) 2625 (cond ((looking-at "[A-Za-z_][A-Za-z_0-9]*:[^:]") 2626 (and (> indent 0) 2627 (setq indent (max cperl-min-label-indent 2628 (+ indent cperl-label-offset))))) 2629 ((= (following-char) ?}) 2630 (setq indent (- indent cperl-indent-level))) 2631 ((memq (following-char) '(?\) ?\])) ; To line up with opening paren. 2632 (setq indent (+ indent cperl-close-paren-offset))) 2633 ((= (following-char) ?{) 2634 (setq indent (+ indent cperl-brace-offset)))))) 2635 (skip-chars-forward " \t") 2636 (setq shift-amt (and i (- indent (current-column)))) 2637 (if (or (not shift-amt) 2638 (zerop shift-amt)) 2639 (if (> (- (point-max) pos) (point)) 2640 (goto-char (- (point-max) pos))) 2641 ;;;(delete-region beg (point)) 2642 ;;;(indent-to indent) 2643 (cperl-make-indent indent) 2644 ;; If initial point was within line's indentation, 2645 ;; position after the indentation. Else stay at same point in text. 2646 (if (> (- (point-max) pos) (point)) 2647 (goto-char (- (point-max) pos)))) 2648 shift-amt)) 2649 2650(defun cperl-after-label () 2651 ;; Returns true if the point is after label. Does not do save-excursion. 2652 (and (eq (preceding-char) ?:) 2653 (memq (char-syntax (char-after (- (point) 2))) 2654 '(?w ?_)) 2655 (progn 2656 (backward-sexp) 2657 (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:[^:]")))) 2658 2659(defun cperl-get-state (&optional parse-start start-state) 2660 ;; returns list (START STATE DEPTH PRESTART), 2661 ;; START is a good place to start parsing, or equal to 2662 ;; PARSE-START if preset, 2663 ;; STATE is what is returned by `parse-partial-sexp'. 2664 ;; DEPTH is true is we are immediately after end of block 2665 ;; which contains START. 2666 ;; PRESTART is the position basing on which START was found. 2667 (save-excursion 2668 (let ((start-point (point)) depth state start prestart) 2669 (if (and parse-start 2670 (<= parse-start start-point)) 2671 (goto-char parse-start) 2672 (beginning-of-defun) 2673 (setq start-state nil)) 2674 (setq prestart (point)) 2675 (if start-state nil 2676 ;; Try to go out, if sub is not on the outermost level 2677 (while (< (point) start-point) 2678 (setq start (point) parse-start start depth nil 2679 state (parse-partial-sexp start start-point -1)) 2680 (if (> (car state) -1) nil 2681 ;; The current line could start like }}}, so the indentation 2682 ;; corresponds to a different level than what we reached 2683 (setq depth t) 2684 (beginning-of-line 2))) ; Go to the next line. 2685 (if start (goto-char start))) ; Not at the start of file 2686 (setq start (point)) 2687 (or state (setq state (parse-partial-sexp start start-point -1 nil start-state))) 2688 (list start state depth prestart)))) 2689 2690(defvar cperl-look-for-prop '((pod in-pod) (here-doc-delim here-doc-group))) 2691 2692(defun cperl-beginning-of-property (p prop &optional lim) 2693 "Given that P has a property PROP, find where the property starts. 2694Will not look before LIM." 2695 ;;; XXXX What to do at point-max??? 2696 (or (previous-single-property-change (cperl-1+ p) prop lim) 2697 (point-min)) 2698;;; (cond ((eq p (point-min)) 2699;;; p) 2700;;; ((and lim (<= p lim)) 2701;;; p) 2702;;; ((not (get-text-property (1- p) prop)) 2703;;; p) 2704;;; (t (or (previous-single-property-change p look-prop lim) 2705;;; (point-min)))) 2706 ) 2707 2708(defun cperl-sniff-for-indent (&optional parse-data) ; was parse-start 2709 ;; Old workhorse for calculation of indentation; the major problem 2710 ;; is that it mixes the sniffer logic to understand what the current line 2711 ;; MEANS with the logic to actually calculate where to indent it. 2712 ;; The latter part should be eventually moved to `cperl-calculate-indent'; 2713 ;; actually, this is mostly done now... 2714 (cperl-update-syntaxification (point) (point)) 2715 (let ((res (get-text-property (point) 'syntax-type))) 2716 (save-excursion 2717 (cond 2718 ((and (memq res '(pod here-doc here-doc-delim format)) 2719 (not (get-text-property (point) 'indentable))) 2720 (vector res)) 2721 ;; before start of POD - whitespace found since do not have 'pod! 2722 ((looking-at "[ \t]*\n=") 2723 (error "Spaces before POD section!")) 2724 ((and (not cperl-indent-left-aligned-comments) 2725 (looking-at "^#")) 2726 [comment-special:at-beginning-of-line]) 2727 ((get-text-property (point) 'in-pod) 2728 [in-pod]) 2729 (t 2730 (beginning-of-line) 2731 (let* ((indent-point (point)) 2732 (char-after-pos (save-excursion 2733 (skip-chars-forward " \t") 2734 (point))) 2735 (char-after (char-after char-after-pos)) 2736 (pre-indent-point (point)) 2737 p prop look-prop is-block delim) 2738 (save-excursion ; Know we are not in POD, find appropriate pos before 2739 (cperl-backward-to-noncomment nil) 2740 (setq p (max (point-min) (1- (point))) 2741 prop (get-text-property p 'syntax-type) 2742 look-prop (or (nth 1 (assoc prop cperl-look-for-prop)) 2743 'syntax-type)) 2744 (if (memq prop '(pod here-doc format here-doc-delim)) 2745 (progn 2746 (goto-char (cperl-beginning-of-property p look-prop)) 2747 (beginning-of-line) 2748 (setq pre-indent-point (point))))) 2749 (goto-char pre-indent-point) ; Orig line skipping preceeding pod/etc 2750 (let* ((case-fold-search nil) 2751 (s-s (cperl-get-state (car parse-data) (nth 1 parse-data))) 2752 (start (or (nth 2 parse-data) ; last complete sexp terminated 2753 (nth 0 s-s))) ; Good place to start parsing 2754 (state (nth 1 s-s)) 2755 (containing-sexp (car (cdr state))) 2756 old-indent) 2757 (if (and 2758 ;;containing-sexp ;; We are buggy at toplevel :-( 2759 parse-data) 2760 (progn 2761 (setcar parse-data pre-indent-point) 2762 (setcar (cdr parse-data) state) 2763 (or (nth 2 parse-data) 2764 (setcar (cddr parse-data) start)) 2765 ;; Before this point: end of statement 2766 (setq old-indent (nth 3 parse-data)))) 2767 (cond ((get-text-property (point) 'indentable) 2768 ;; indent to "after" the surrounding open 2769 ;; (same offset as `cperl-beautify-regexp-piece'), 2770 ;; skip blanks if we do not close the expression. 2771 (setq delim ; We do not close the expression 2772 (get-text-property 2773 (cperl-1+ char-after-pos) 'indentable) 2774 p (1+ (cperl-beginning-of-property 2775 (point) 'indentable)) 2776 is-block ; misused for: preceeding line in REx 2777 (save-excursion ; Find preceeding line 2778 (cperl-backward-to-noncomment p) 2779 (beginning-of-line) 2780 (if (<= (point) p) 2781 (progn ; get indent from the first line 2782 (goto-char p) 2783 (skip-chars-forward " \t") 2784 (if (memq (char-after (point)) 2785 (append "#\n" nil)) 2786 nil ; Can't use intentation of this line... 2787 (point))) 2788 (skip-chars-forward " \t") 2789 (point))) 2790 prop (parse-partial-sexp p char-after-pos)) 2791 (cond ((not delim) ; End the REx, ignore is-block 2792 (vector 'indentable 'terminator p is-block)) 2793 (is-block ; Indent w.r.t. preceeding line 2794 (vector 'indentable 'cont-line char-after-pos 2795 is-block char-after p)) 2796 (t ; No preceeding line... 2797 (vector 'indentable 'first-line p)))) 2798 ((get-text-property char-after-pos 'REx-part2) 2799 (vector 'REx-part2 (point))) 2800 ((nth 3 state) 2801 [comment]) 2802 ((nth 4 state) 2803 [string]) 2804 ;; XXXX Do we need to special-case this? 2805 ((null containing-sexp) 2806 ;; Line is at top level. May be data or function definition, 2807 ;; or may be function argument declaration. 2808 ;; Indent like the previous top level line 2809 ;; unless that ends in a closeparen without semicolon, 2810 ;; in which case this line is the first argument decl. 2811 (skip-chars-forward " \t") 2812 (cperl-backward-to-noncomment (or old-indent (point-min))) 2813 (setq state 2814 (or (bobp) 2815 (eq (point) old-indent) ; old-indent was at comment 2816 (eq (preceding-char) ?\;) 2817 ;; Had ?\) too 2818 (and (eq (preceding-char) ?\}) 2819 (cperl-after-block-and-statement-beg 2820 (point-min))) ; Was start - too close 2821 (memq char-after (append ")]}" nil)) 2822 (and (eq (preceding-char) ?\:) ; label 2823 (progn 2824 (forward-sexp -1) 2825 (skip-chars-backward " \t") 2826 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:"))) 2827 (get-text-property (point) 'first-format-line))) 2828 2829 ;; Look at previous line that's at column 0 2830 ;; to determine whether we are in top-level decls 2831 ;; or function's arg decls. Set basic-indent accordingly. 2832 ;; Now add a little if this is a continuation line. 2833 (and state 2834 parse-data 2835 (not (eq char-after ?\C-j)) 2836 (setcdr (cddr parse-data) 2837 (list pre-indent-point))) 2838 (vector 'toplevel start char-after state (nth 2 s-s))) 2839 ((not 2840 (or (setq is-block 2841 (and (setq delim (= (char-after containing-sexp) ?{)) 2842 (save-excursion ; Is it a hash? 2843 (goto-char containing-sexp) 2844 (cperl-block-p)))) 2845 cperl-indent-parens-as-block)) 2846 ;; group is an expression, not a block: 2847 ;; indent to just after the surrounding open parens, 2848 ;; skip blanks if we do not close the expression. 2849 (goto-char (1+ containing-sexp)) 2850 (or (memq char-after 2851 (append (if delim "}" ")]}") nil)) 2852 (looking-at "[ \t]*\\(#\\|$\\)") 2853 (skip-chars-forward " \t")) 2854 (setq old-indent (point)) ; delim=is-brace 2855 (vector 'in-parens char-after (point) delim containing-sexp)) 2856 (t 2857 ;; Statement level. Is it a continuation or a new statement? 2858 ;; Find previous non-comment character. 2859 (goto-char pre-indent-point) ; Skip one level of POD/etc 2860 (cperl-backward-to-noncomment containing-sexp) 2861 ;; Back up over label lines, since they don't 2862 ;; affect whether our line is a continuation. 2863 ;; (Had \, too) 2864 (while;;(or (eq (preceding-char) ?\,) 2865 (and (eq (preceding-char) ?:) 2866 (or;;(eq (char-after (- (point) 2)) ?\') ; ???? 2867 (memq (char-syntax (char-after (- (point) 2))) 2868 '(?w ?_)))) 2869 ;;) 2870 ;; This is always FALSE? 2871 (if (eq (preceding-char) ?\,) 2872 ;; Will go to beginning of line, essentially. 2873 ;; Will ignore embedded sexpr XXXX. 2874 (cperl-backward-to-start-of-continued-exp containing-sexp)) 2875 (beginning-of-line) 2876 (cperl-backward-to-noncomment containing-sexp)) 2877 ;; Now we get non-label preceeding the indent point 2878 (if (not (or (eq (1- (point)) containing-sexp) 2879 (memq (preceding-char) 2880 (append (if is-block " ;{" " ,;{") '(nil))) 2881 (and (eq (preceding-char) ?\}) 2882 (cperl-after-block-and-statement-beg 2883 containing-sexp)) 2884 (get-text-property (point) 'first-format-line))) 2885 ;; This line is continuation of preceding line's statement; 2886 ;; indent `cperl-continued-statement-offset' more than the 2887 ;; previous line of the statement. 2888 ;; 2889 ;; There might be a label on this line, just 2890 ;; consider it bad style and ignore it. 2891 (progn 2892 (cperl-backward-to-start-of-continued-exp containing-sexp) 2893 (vector 'continuation (point) char-after is-block delim)) 2894 ;; This line starts a new statement. 2895 ;; Position following last unclosed open brace 2896 (goto-char containing-sexp) 2897 ;; Is line first statement after an open-brace? 2898 (or 2899 ;; If no, find that first statement and indent like 2900 ;; it. If the first statement begins with label, do 2901 ;; not believe when the indentation of the label is too 2902 ;; small. 2903 (save-excursion 2904 (forward-char 1) 2905 (let ((colon-line-end 0)) 2906 (while 2907 (progn (skip-chars-forward " \t\n") 2908 (looking-at "#\\|[a-zA-Z0-9_$]*:[^:]\\|=[a-zA-Z]")) 2909 ;; Skip over comments and labels following openbrace. 2910 (cond ((= (following-char) ?\#) 2911 (forward-line 1)) 2912 ((= (following-char) ?\=) 2913 (goto-char 2914 (or (next-single-property-change (point) 'in-pod) 2915 (point-max)))) ; do not loop if no syntaxification 2916 ;; label: 2917 (t 2918 (save-excursion (end-of-line) 2919 (setq colon-line-end (point))) 2920 (search-forward ":")))) 2921 ;; We are at beginning of code (NOT label or comment) 2922 ;; First, the following code counts 2923 ;; if it is before the line we want to indent. 2924 (and (< (point) indent-point) 2925 (vector 'have-prev-sibling (point) colon-line-end 2926 containing-sexp)))) 2927 (progn 2928 ;; If no previous statement, 2929 ;; indent it relative to line brace is on. 2930 2931 ;; For open-braces not the first thing in a line, 2932 ;; add in cperl-brace-imaginary-offset. 2933 2934 ;; If first thing on a line: ????? 2935 ;; Move back over whitespace before the openbrace. 2936 (setq ; brace first thing on a line 2937 old-indent (progn (skip-chars-backward " \t") (bolp))) 2938 ;; Should we indent w.r.t. earlier than start? 2939 ;; Move to start of control group, possibly on a different line 2940 (or cperl-indent-wrt-brace 2941 (cperl-backward-to-noncomment (point-min))) 2942 ;; If the openbrace is preceded by a parenthesized exp, 2943 ;; move to the beginning of that; 2944 (if (eq (preceding-char) ?\)) 2945 (progn 2946 (forward-sexp -1) 2947 (cperl-backward-to-noncomment (point-min)))) 2948 ;; In the case it starts a subroutine, indent with 2949 ;; respect to `sub', not with respect to the 2950 ;; first thing on the line, say in the case of 2951 ;; anonymous sub in a hash. 2952 (if (and;; Is it a sub in group starting on this line? 2953 (cond ((get-text-property (point) 'attrib-group) 2954 (goto-char (cperl-beginning-of-property 2955 (point) 'attrib-group))) 2956 ((eq (preceding-char) ?b) 2957 (forward-sexp -1) 2958 (looking-at "sub\\>"))) 2959 (setq p (nth 1 ; start of innermost containing list 2960 (parse-partial-sexp 2961 (save-excursion (beginning-of-line) 2962 (point)) 2963 (point))))) 2964 (progn 2965 (goto-char (1+ p)) ; enclosing block on the same line 2966 (skip-chars-forward " \t") 2967 (vector 'code-start-in-block containing-sexp char-after 2968 (and delim (not is-block)) ; is a HASH 2969 old-indent ; brace first thing on a line 2970 t (point) ; have something before... 2971 ) 2972 ;;(current-column) 2973 ) 2974 ;; Get initial indentation of the line we are on. 2975 ;; If line starts with label, calculate label indentation 2976 (vector 'code-start-in-block containing-sexp char-after 2977 (and delim (not is-block)) ; is a HASH 2978 old-indent ; brace first thing on a line 2979 nil (point) ; nothing interesting before 2980 )))))))))))))) 2981 2982(defvar cperl-indent-rules-alist 2983 '((pod nil) ; via `syntax-type' property 2984 (here-doc nil) ; via `syntax-type' property 2985 (here-doc-delim nil) ; via `syntax-type' property 2986 (format nil) ; via `syntax-type' property 2987 (in-pod nil) ; via `in-pod' property 2988 (comment-special:at-beginning-of-line nil) 2989 (string t) 2990 (comment nil)) 2991 "Alist of indentation rules for CPerl mode. 2992The values mean: 2993 nil: do not indent; 2994 number: add this amount of indentation. 2995 2996Not finished.") 2997 2998(defun cperl-calculate-indent (&optional parse-data) ; was parse-start 2999 "Return appropriate indentation for current line as Perl code. 3000In usual case returns an integer: the column to indent to. 3001Returns nil if line starts inside a string, t if in a comment. 3002 3003Will not correct the indentation for labels, but will correct it for braces 3004and closing parentheses and brackets." 3005 ;; This code is still a broken architecture: in some cases we need to 3006 ;; compensate for some modifications which `cperl-indent-line' will add later 3007 (save-excursion 3008 (let ((i (cperl-sniff-for-indent parse-data)) what p) 3009 (cond 3010 ;;((or (null i) (eq i t) (numberp i)) 3011 ;; i) 3012 ((vectorp i) 3013 (setq what (assoc (elt i 0) cperl-indent-rules-alist)) 3014 (cond 3015 (what (cadr what)) ; Load from table 3016 ;; 3017 ;; Indenters for regular expressions with //x and qw() 3018 ;; 3019 ((eq 'REx-part2 (elt i 0)) ;; [self start] start of /REP in s//REP/x 3020 (goto-char (elt i 1)) 3021 (condition-case nil ; Use indentation of the 1st part 3022 (forward-sexp -1)) 3023 (current-column)) 3024 ((eq 'indentable (elt i 0)) ; Indenter for REGEXP qw() etc 3025 (cond ;;; [indentable terminator start-pos is-block] 3026 ((eq 'terminator (elt i 1)) ; Lone terminator of "indentable string" 3027 (goto-char (elt i 2)) ; After opening parens 3028 (1- (current-column))) 3029 ((eq 'first-line (elt i 1)); [indentable first-line start-pos] 3030 (goto-char (elt i 2)) 3031 (+ (or cperl-regexp-indent-step cperl-indent-level) 3032 -1 3033 (current-column))) 3034 ((eq 'cont-line (elt i 1)); [indentable cont-line pos prev-pos first-char start-pos] 3035 ;; Indent as the level after closing parens 3036 (goto-char (elt i 2)) ; indent line 3037 (skip-chars-forward " \t)") ; Skip closing parens 3038 (setq p (point)) 3039 (goto-char (elt i 3)) ; previous line 3040 (skip-chars-forward " \t)") ; Skip closing parens 3041 ;; Number of parens in between: 3042 (setq p (nth 0 (parse-partial-sexp (point) p)) 3043 what (elt i 4)) ; First char on current line 3044 (goto-char (elt i 3)) ; previous line 3045 (+ (* p (or cperl-regexp-indent-step cperl-indent-level)) 3046 (cond ((eq what ?\) ) 3047 (- cperl-close-paren-offset)) ; compensate 3048 ((eq what ?\| ) 3049 (- (or cperl-regexp-indent-step cperl-indent-level))) 3050 (t 0)) 3051 (if (eq (following-char) ?\| ) 3052 (or cperl-regexp-indent-step cperl-indent-level) 3053 0) 3054 (current-column))) 3055 (t 3056 (error "Unrecognized value of indent: %s" i)))) 3057 ;; 3058 ;; Indenter for stuff at toplevel 3059 ;; 3060 ((eq 'toplevel (elt i 0)) ;; [toplevel start char-after state immed-after-block] 3061 (+ (save-excursion ; To beg-of-defun, or end of last sexp 3062 (goto-char (elt i 1)) ; start = Good place to start parsing 3063 (- (current-indentation) ; 3064 (if (elt i 4) cperl-indent-level 0))) ; immed-after-block 3065 (if (eq (elt i 2) ?{) cperl-continued-brace-offset 0) ; char-after 3066 ;; Look at previous line that's at column 0 3067 ;; to determine whether we are in top-level decls 3068 ;; or function's arg decls. Set basic-indent accordingly. 3069 ;; Now add a little if this is a continuation line. 3070 (if (elt i 3) ; state (XXX What is the semantic???) 3071 0 3072 cperl-continued-statement-offset))) 3073 ;; 3074 ;; Indenter for stuff in "parentheses" (or brackets, braces-as-hash) 3075 ;; 3076 ((eq 'in-parens (elt i 0)) 3077 ;; in-parens char-after old-indent-point is-brace containing-sexp 3078 3079 ;; group is an expression, not a block: 3080 ;; indent to just after the surrounding open parens, 3081 ;; skip blanks if we do not close the expression. 3082 (+ (progn 3083 (goto-char (elt i 2)) ; old-indent-point 3084 (current-column)) 3085 (if (and (elt i 3) ; is-brace 3086 (eq (elt i 1) ?\})) ; char-after 3087 ;; Correct indentation of trailing ?\} 3088 (+ cperl-indent-level cperl-close-paren-offset) 3089 0))) 3090 ;; 3091 ;; Indenter for continuation lines 3092 ;; 3093 ((eq 'continuation (elt i 0)) 3094 ;; [continuation statement-start char-after is-block is-brace] 3095 (goto-char (elt i 1)) ; statement-start 3096 (+ (if (memq (elt i 2) (append "}])" nil)) ; char-after 3097 0 ; Closing parenth 3098 cperl-continued-statement-offset) 3099 (if (or (elt i 3) ; is-block 3100 (not (elt i 4)) ; is-brace 3101 (not (eq (elt i 2) ?\}))) ; char-after 3102 0 3103 ;; Now it is a hash reference 3104 (+ cperl-indent-level cperl-close-paren-offset)) 3105 ;; Labels do not take :: ... 3106 (if (looking-at "\\(\\w\\|_\\)+[ \t]*:") 3107 (if (> (current-indentation) cperl-min-label-indent) 3108 (- (current-indentation) cperl-label-offset) 3109 ;; Do not move `parse-data', this should 3110 ;; be quick anyway (this comment comes 3111 ;; from different location): 3112 (cperl-calculate-indent)) 3113 (current-column)) 3114 (if (eq (elt i 2) ?\{) ; char-after 3115 cperl-continued-brace-offset 0))) 3116 ;; 3117 ;; Indenter for lines in a block which are not leading lines 3118 ;; 3119 ((eq 'have-prev-sibling (elt i 0)) 3120 ;; [have-prev-sibling sibling-beg colon-line-end block-start] 3121 (goto-char (elt i 1)) 3122 (if (> (elt i 2) (point)) ; colon-line-end; After-label, same line 3123 (if (> (current-indentation) 3124 cperl-min-label-indent) 3125 (- (current-indentation) cperl-label-offset) 3126 ;; Do not believe: `max' was involved in calculation of indent 3127 (+ cperl-indent-level 3128 (save-excursion 3129 (goto-char (elt i 3)) ; block-start 3130 (current-indentation)))) 3131 (current-column))) 3132 ;; 3133 ;; Indenter for the first line in a block 3134 ;; 3135 ((eq 'code-start-in-block (elt i 0)) 3136 ;;[code-start-in-block before-brace char-after 3137 ;; is-a-HASH-ref brace-is-first-thing-on-a-line 3138 ;; group-starts-before-start-of-sub start-of-control-group] 3139 (goto-char (elt i 1)) 3140 ;; For open brace in column zero, don't let statement 3141 ;; start there too. If cperl-indent-level=0, 3142 ;; use cperl-brace-offset + cperl-continued-statement-offset instead. 3143 (+ (if (and (bolp) (zerop cperl-indent-level)) 3144 (+ cperl-brace-offset cperl-continued-statement-offset) 3145 cperl-indent-level) 3146 (if (and (elt i 3) ; is-a-HASH-ref 3147 (eq (elt i 2) ?\})) ; char-after: End of a hash reference 3148 (+ cperl-indent-level cperl-close-paren-offset) 3149 0) 3150 ;; Unless openbrace is the first nonwhite thing on the line, 3151 ;; add the cperl-brace-imaginary-offset. 3152 (if (elt i 4) 0 ; brace-is-first-thing-on-a-line 3153 cperl-brace-imaginary-offset) 3154 (progn 3155 (goto-char (elt i 6)) ; start-of-control-group 3156 (if (elt i 5) ; group-starts-before-start-of-sub 3157 (current-column) 3158 ;; Get initial indentation of the line we are on. 3159 ;; If line starts with label, calculate label indentation 3160 (if (save-excursion 3161 (beginning-of-line) 3162 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]")) 3163 (if (> (current-indentation) cperl-min-label-indent) 3164 (- (current-indentation) cperl-label-offset) 3165 ;; Do not move `parse-data', this should 3166 ;; be quick anyway: 3167 (cperl-calculate-indent)) 3168 (current-indentation)))))) 3169 (t 3170 (error "Unrecognized value of indent: %s" i)))) 3171 (t 3172 (error "Got strange value of indent: %s" i)))))) 3173 3174(defvar cperl-indent-alist 3175 '((string nil) 3176 (comment nil) 3177 (toplevel 0) 3178 (toplevel-after-parenth 2) 3179 (toplevel-continued 2) 3180 (expression 1)) 3181 "Alist of indentation rules for CPerl mode. 3182The values mean: 3183 nil: do not indent; 3184 number: add this amount of indentation. 3185 3186Not finished, not used.") 3187 3188(defun cperl-where-am-i (&optional parse-start start-state) 3189 ;; Unfinished 3190 "Return a list of lists ((TYPE POS)...) of good points before the point. 3191POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'. 3192 3193Not finished, not used." 3194 (save-excursion 3195 (let* ((start-point (point)) unused 3196 (s-s (cperl-get-state)) 3197 (start (nth 0 s-s)) 3198 (state (nth 1 s-s)) 3199 (prestart (nth 3 s-s)) 3200 (containing-sexp (car (cdr state))) 3201 (case-fold-search nil) 3202 (res (list (list 'parse-start start) (list 'parse-prestart prestart)))) 3203 (cond ((nth 3 state) ; In string 3204 (setq res (cons (list 'string nil (nth 3 state)) res))) ; What started string 3205 ((nth 4 state) ; In comment 3206 (setq res (cons '(comment) res))) 3207 ((null containing-sexp) 3208 ;; Line is at top level. 3209 ;; Indent like the previous top level line 3210 ;; unless that ends in a closeparen without semicolon, 3211 ;; in which case this line is the first argument decl. 3212 (cperl-backward-to-noncomment (or parse-start (point-min))) 3213 ;;(skip-chars-backward " \t\f\n") 3214 (cond 3215 ((or (bobp) 3216 (memq (preceding-char) (append ";}" nil))) 3217 (setq res (cons (list 'toplevel start) res))) 3218 ((eq (preceding-char) ?\) ) 3219 (setq res (cons (list 'toplevel-after-parenth start) res))) 3220 (t 3221 (setq res (cons (list 'toplevel-continued start) res))))) 3222 ((/= (char-after containing-sexp) ?{) 3223 ;; line is expression, not statement: 3224 ;; indent to just after the surrounding open. 3225 ;; skip blanks if we do not close the expression. 3226 (setq res (cons (list 'expression-blanks 3227 (progn 3228 (goto-char (1+ containing-sexp)) 3229 (or (looking-at "[ \t]*\\(#\\|$\\)") 3230 (skip-chars-forward " \t")) 3231 (point))) 3232 (cons (list 'expression containing-sexp) res)))) 3233 ((progn 3234 ;; Containing-expr starts with \{. Check whether it is a hash. 3235 (goto-char containing-sexp) 3236 (not (cperl-block-p))) 3237 (setq res (cons (list 'expression-blanks 3238 (progn 3239 (goto-char (1+ containing-sexp)) 3240 (or (looking-at "[ \t]*\\(#\\|$\\)") 3241 (skip-chars-forward " \t")) 3242 (point))) 3243 (cons (list 'expression containing-sexp) res)))) 3244 (t 3245 ;; Statement level. 3246 (setq res (cons (list 'in-block containing-sexp) res)) 3247 ;; Is it a continuation or a new statement? 3248 ;; Find previous non-comment character. 3249 (cperl-backward-to-noncomment containing-sexp) 3250 ;; Back up over label lines, since they don't 3251 ;; affect whether our line is a continuation. 3252 ;; Back up comma-delimited lines too ????? 3253 (while (or (eq (preceding-char) ?\,) 3254 (save-excursion (cperl-after-label))) 3255 (if (eq (preceding-char) ?\,) 3256 ;; Will go to beginning of line, essentially 3257 ;; Will ignore embedded sexpr XXXX. 3258 (cperl-backward-to-start-of-continued-exp containing-sexp)) 3259 (beginning-of-line) 3260 (cperl-backward-to-noncomment containing-sexp)) 3261 ;; Now we get the answer. 3262 (if (not (memq (preceding-char) (append ";}{" '(nil)))) ; Was ?\, 3263 ;; This line is continuation of preceding line's statement. 3264 (list (list 'statement-continued containing-sexp)) 3265 ;; This line starts a new statement. 3266 ;; Position following last unclosed open. 3267 (goto-char containing-sexp) 3268 ;; Is line first statement after an open-brace? 3269 (or 3270 ;; If no, find that first statement and indent like 3271 ;; it. If the first statement begins with label, do 3272 ;; not believe when the indentation of the label is too 3273 ;; small. 3274 (save-excursion 3275 (forward-char 1) 3276 (let ((colon-line-end 0)) 3277 (while (progn (skip-chars-forward " \t\n" start-point) 3278 (and (< (point) start-point) 3279 (looking-at 3280 "#\\|[a-zA-Z_][a-zA-Z0-9_]*:[^:]"))) 3281 ;; Skip over comments and labels following openbrace. 3282 (cond ((= (following-char) ?\#) 3283 ;;(forward-line 1) 3284 (end-of-line)) 3285 ;; label: 3286 (t 3287 (save-excursion (end-of-line) 3288 (setq colon-line-end (point))) 3289 (search-forward ":")))) 3290 ;; Now at the point, after label, or at start 3291 ;; of first statement in the block. 3292 (and (< (point) start-point) 3293 (if (> colon-line-end (point)) 3294 ;; Before statement after label 3295 (if (> (current-indentation) 3296 cperl-min-label-indent) 3297 (list (list 'label-in-block (point))) 3298 ;; Do not believe: `max' is involved 3299 (list 3300 (list 'label-in-block-min-indent (point)))) 3301 ;; Before statement 3302 (list 'statement-in-block (point)))))) 3303 ;; If no previous statement, 3304 ;; indent it relative to line brace is on. 3305 ;; For open brace in column zero, don't let statement 3306 ;; start there too. If cperl-indent-level is zero, 3307 ;; use cperl-brace-offset + cperl-continued-statement-offset instead. 3308 ;; For open-braces not the first thing in a line, 3309 ;; add in cperl-brace-imaginary-offset. 3310 3311 ;; If first thing on a line: ????? 3312 (setq unused ; This is not finished... 3313 (+ (if (and (bolp) (zerop cperl-indent-level)) 3314 (+ cperl-brace-offset cperl-continued-statement-offset) 3315 cperl-indent-level) 3316 ;; Move back over whitespace before the openbrace. 3317 ;; If openbrace is not first nonwhite thing on the line, 3318 ;; add the cperl-brace-imaginary-offset. 3319 (progn (skip-chars-backward " \t") 3320 (if (bolp) 0 cperl-brace-imaginary-offset)) 3321 ;; If the openbrace is preceded by a parenthesized exp, 3322 ;; move to the beginning of that; 3323 ;; possibly a different line 3324 (progn 3325 (if (eq (preceding-char) ?\)) 3326 (forward-sexp -1)) 3327 ;; Get initial indentation of the line we are on. 3328 ;; If line starts with label, calculate label indentation 3329 (if (save-excursion 3330 (beginning-of-line) 3331 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]")) 3332 (if (> (current-indentation) cperl-min-label-indent) 3333 (- (current-indentation) cperl-label-offset) 3334 (cperl-calculate-indent)) 3335 (current-indentation))))))))) 3336 res))) 3337 3338(defun cperl-calculate-indent-within-comment () 3339 "Return the indentation amount for line, assuming that 3340the current line is to be regarded as part of a block comment." 3341 (let (end star-start) 3342 (save-excursion 3343 (beginning-of-line) 3344 (skip-chars-forward " \t") 3345 (setq end (point)) 3346 (and (= (following-char) ?#) 3347 (forward-line -1) 3348 (cperl-to-comment-or-eol) 3349 (setq end (point))) 3350 (goto-char end) 3351 (current-column)))) 3352 3353 3354(defun cperl-to-comment-or-eol () 3355 "Go to position before comment on the current line, or to end of line. 3356Returns true if comment is found. In POD will not move the point." 3357 ;; If the line is inside other syntax groups (qq-style strings, HERE-docs) 3358 ;; then looks for literal # or end-of-line. 3359 (let (state stop-in cpoint (lim (progn (end-of-line) (point))) pr e) 3360 (or cperl-font-locking 3361 (cperl-update-syntaxification lim lim)) 3362 (beginning-of-line) 3363 (if (setq pr (get-text-property (point) 'syntax-type)) 3364 (setq e (next-single-property-change (point) 'syntax-type nil (point-max)))) 3365 (if (or (eq pr 'pod) 3366 (if (or (not e) (> e lim)) ; deep inside a group 3367 (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t))) 3368 (if (eq (preceding-char) ?\#) (progn (backward-char 1) t)) 3369 ;; Else - need to do it the hard way 3370 (and (and e (<= e lim)) 3371 (goto-char e)) 3372 (while (not stop-in) 3373 (setq state (parse-partial-sexp (point) lim nil nil nil t)) 3374 ; stop at comment 3375 ;; If fails (beginning-of-line inside sexp), then contains not-comment 3376 (if (nth 4 state) ; After `#'; 3377 ; (nth 2 state) can be 3378 ; beginning of m,s,qq and so 3379 ; on 3380 (if (nth 2 state) 3381 (progn 3382 (setq cpoint (point)) 3383 (goto-char (nth 2 state)) 3384 (cond 3385 ((looking-at "\\(s\\|tr\\)\\>") 3386 (or (re-search-forward 3387 "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*" 3388 lim 'move) 3389 (setq stop-in t))) 3390 ((looking-at "\\(m\\|q\\([qxwr]\\)?\\)\\>") 3391 (or (re-search-forward 3392 "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#" 3393 lim 'move) 3394 (setq stop-in t))) 3395 (t ; It was fair comment 3396 (setq stop-in t) ; Finish 3397 (goto-char (1- cpoint))))) 3398 (setq stop-in t) ; Finish 3399 (forward-char -1)) 3400 (setq stop-in t))) ; Finish 3401 (nth 4 state)))) 3402 3403(defsubst cperl-modify-syntax-type (at how) 3404 (if (< at (point-max)) 3405 (progn 3406 (put-text-property at (1+ at) 'syntax-table how) 3407 (put-text-property at (1+ at) 'rear-nonsticky '(syntax-table))))) 3408 3409(defun cperl-protect-defun-start (s e) 3410 ;; C code looks for "^\\s(" to skip comment backward in "hard" situations 3411 (save-excursion 3412 (goto-char s) 3413 (while (re-search-forward "^\\s(" e 'to-end) 3414 (put-text-property (1- (point)) (point) 'syntax-table cperl-st-punct)))) 3415 3416(defun cperl-commentify (bb e string &optional noface) 3417 (if cperl-use-syntax-table-text-property 3418 (if (eq noface 'n) ; Only immediate 3419 nil 3420 ;; We suppose that e is _after_ the end of construction, as after eol. 3421 (setq string (if string cperl-st-sfence cperl-st-cfence)) 3422 (if (> bb (- e 2)) 3423 ;; one-char string/comment?! 3424 (cperl-modify-syntax-type bb cperl-st-punct) 3425 (cperl-modify-syntax-type bb string) 3426 (cperl-modify-syntax-type (1- e) string)) 3427 (if (and (eq string cperl-st-sfence) (> (- e 2) bb)) 3428 (put-text-property (1+ bb) (1- e) 3429 'syntax-table cperl-string-syntax-table)) 3430 (cperl-protect-defun-start bb e)) 3431 ;; Fontify 3432 (or noface 3433 (not cperl-pod-here-fontify) 3434 (put-text-property bb e 'face (if string 'font-lock-string-face 3435 'font-lock-comment-face))))) 3436 3437(defvar cperl-starters '(( ?\( . ?\) ) 3438 ( ?\[ . ?\] ) 3439 ( ?\{ . ?\} ) 3440 ( ?\< . ?\> ))) 3441 3442(defun cperl-cached-syntax-table (st) 3443 "Get a syntax table cached in ST, or create and cache into ST a syntax table. 3444All the entries of the syntax table are \".\", except for a backslash, which 3445is quoting." 3446 (if (car-safe st) 3447 (car st) 3448 (setcar st (make-syntax-table)) 3449 (setq st (car st)) 3450 (let ((i 0)) 3451 (while (< i 256) 3452 (modify-syntax-entry i "." st) 3453 (setq i (1+ i)))) 3454 (modify-syntax-entry ?\\ "\\" st) 3455 st)) 3456 3457(defun cperl-forward-re (lim end is-2arg st-l err-l argument 3458 &optional ostart oend) 3459"Find the end of a regular expression or a stringish construct (q[] etc). 3460The point should be before the starting delimiter. 3461 3462Goes to LIM if none is found. If IS-2ARG is non-nil, assumes that it 3463is s/// or tr/// like expression. If END is nil, generates an error 3464message if needed. If SET-ST is non-nil, will use (or generate) a 3465cached syntax table in ST-L. If ERR-L is non-nil, will store the 3466error message in its CAR (unless it already contains some error 3467message). ARGUMENT should be the name of the construct (used in error 3468messages). OSTART, OEND may be set in recursive calls when processing 3469the second argument of 2ARG construct. 3470 3471Works *before* syntax recognition is done. In IS-2ARG situation may 3472modify syntax-type text property if the situation is too hard." 3473 (let (b starter ender st i i2 go-forward reset-st set-st) 3474 (skip-chars-forward " \t") 3475 ;; ender means matching-char matcher. 3476 (setq b (point) 3477 starter (if (eobp) 0 (char-after b)) 3478 ender (cdr (assoc starter cperl-starters))) 3479 ;; What if starter == ?\\ ???? 3480 (setq st (cperl-cached-syntax-table st-l)) 3481 (setq set-st t) 3482 ;; Whether we have an intermediate point 3483 (setq i nil) 3484 ;; Prepare the syntax table: 3485 (if (not ender) ; m/blah/, s/x//, s/x/y/ 3486 (modify-syntax-entry starter "$" st) 3487 (modify-syntax-entry starter (concat "(" (list ender)) st) 3488 (modify-syntax-entry ender (concat ")" (list starter)) st)) 3489 (condition-case bb 3490 (progn 3491 ;; We use `$' syntax class to find matching stuff, but $$ 3492 ;; is recognized the same as $, so we need to check this manually. 3493 (if (and (eq starter (char-after (cperl-1+ b))) 3494 (not ender)) 3495 ;; $ has TeXish matching rules, so $$ equiv $... 3496 (forward-char 2) 3497 (setq reset-st (syntax-table)) 3498 (set-syntax-table st) 3499 (forward-sexp 1) 3500 (if (<= (point) (1+ b)) 3501 (error "Unfinished regular expression")) 3502 (set-syntax-table reset-st) 3503 (setq reset-st nil) 3504 ;; Now the problem is with m;blah;; 3505 (and (not ender) 3506 (eq (preceding-char) 3507 (char-after (- (point) 2))) 3508 (save-excursion 3509 (forward-char -2) 3510 (= 0 (% (skip-chars-backward "\\\\") 2))) 3511 (forward-char -1))) 3512 ;; Now we are after the first part. 3513 (and is-2arg ; Have trailing part 3514 (not ender) 3515 (eq (following-char) starter) ; Empty trailing part 3516 (progn 3517 (or (eq (char-syntax (following-char)) ?.) 3518 ;; Make trailing letter into punctuation 3519 (cperl-modify-syntax-type (point) cperl-st-punct)) 3520 (setq is-2arg nil go-forward t))) ; Ignore the tail 3521 (if is-2arg ; Not number => have second part 3522 (progn 3523 (setq i (point) i2 i) 3524 (if ender 3525 (if (memq (following-char) '(?\s ?\t ?\n ?\f)) 3526 (progn 3527 (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+") 3528 (goto-char (match-end 0)) 3529 (skip-chars-forward " \t\n\f")) 3530 (setq i2 (point)))) 3531 (forward-char -1)) 3532 (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st) 3533 (if ender (modify-syntax-entry ender "." st)) 3534 (setq set-st nil) 3535 (setq ender (cperl-forward-re lim end nil st-l err-l 3536 argument starter ender) 3537 ender (nth 2 ender))))) 3538 (error (goto-char lim) 3539 (setq set-st nil) 3540 (if reset-st 3541 (set-syntax-table reset-st)) 3542 (or end 3543 (message 3544 "End of `%s%s%c ... %c' string/RE not found: %s" 3545 argument 3546 (if ostart (format "%c ... %c" ostart (or oend ostart)) "") 3547 starter (or ender starter) bb) 3548 (or (car err-l) (setcar err-l b))))) 3549 (if set-st 3550 (progn 3551 (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st) 3552 (if ender (modify-syntax-entry ender "." st)))) 3553 ;; i: have 2 args, after end of the first arg 3554 ;; i2: start of the second arg, if any (before delim iff `ender'). 3555 ;; ender: the last arg bounded by parens-like chars, the second one of them 3556 ;; starter: the starting delimiter of the first arg 3557 ;; go-forward: has 2 args, and the second part is empty 3558 (list i i2 ender starter go-forward))) 3559 3560(defun cperl-forward-group-in-re (&optional st-l) 3561 "Find the end of a group in a REx. 3562Return the error message (if any). Does not work if delimiter is `)'. 3563Works before syntax recognition is done." 3564 ;; Works *before* syntax recognition is done 3565 (or st-l (setq st-l (list nil))) ; Avoid overwriting '() 3566 (let (st b reset-st) 3567 (condition-case b 3568 (progn 3569 (setq st (cperl-cached-syntax-table st-l)) 3570 (modify-syntax-entry ?\( "()" st) 3571 (modify-syntax-entry ?\) ")(" st) 3572 (setq reset-st (syntax-table)) 3573 (set-syntax-table st) 3574 (forward-sexp 1)) 3575 (error (message 3576 "cperl-forward-group-in-re: error %s" b))) 3577 ;; now restore the initial state 3578 (if st 3579 (progn 3580 (modify-syntax-entry ?\( "." st) 3581 (modify-syntax-entry ?\) "." st))) 3582 (if reset-st 3583 (set-syntax-table reset-st)) 3584 b)) 3585 3586 3587(defvar font-lock-string-face) 3588;;(defvar font-lock-reference-face) 3589(defvar font-lock-constant-face) 3590(defsubst cperl-postpone-fontification (b e type val &optional now) 3591 ;; Do after syntactic fontification? 3592 (if cperl-syntaxify-by-font-lock 3593 (or now (put-text-property b e 'cperl-postpone (cons type val))) 3594 (put-text-property b e type val))) 3595 3596;;; Here is how the global structures (those which cannot be 3597;;; recognized locally) are marked: 3598;; a) PODs: 3599;; Start-to-end is marked `in-pod' ==> t 3600;; Each non-literal part is marked `syntax-type' ==> `pod' 3601;; Each literal part is marked `syntax-type' ==> `in-pod' 3602;; b) HEREs: 3603;; Start-to-end is marked `here-doc-group' ==> t 3604;; The body is marked `syntax-type' ==> `here-doc' 3605;; The delimiter is marked `syntax-type' ==> `here-doc-delim' 3606;; c) FORMATs: 3607;; First line (to =) marked `first-format-line' ==> t 3608;; After-this--to-end is marked `syntax-type' ==> `format' 3609;; d) 'Q'uoted string: 3610;; part between markers inclusive is marked `syntax-type' ==> `string' 3611;; part between `q' and the first marker is marked `syntax-type' ==> `prestring' 3612;; second part of s///e is marked `syntax-type' ==> `multiline' 3613;; e) Attributes of subroutines: `attrib-group' ==> t 3614;; (or 0 if declaration); up to `{' or ';': `syntax-type' => `sub-decl'. 3615;; f) Multiline my/our declaration lists etc: `syntax-type' => `multiline' 3616 3617;;; In addition, some parts of RExes may be marked as `REx-interpolated' 3618;;; (value: 0 in //o, 1 if "interpolated variable" is whole-REx, t otherwise). 3619 3620(defun cperl-unwind-to-safe (before &optional end) 3621 ;; if BEFORE, go to the previous start-of-line on each step of unwinding 3622 (let ((pos (point)) opos) 3623 (while (and pos (progn 3624 (beginning-of-line) 3625 (get-text-property (setq pos (point)) 'syntax-type))) 3626 (setq opos pos 3627 pos (cperl-beginning-of-property pos 'syntax-type)) 3628 (if (eq pos (point-min)) 3629 (setq pos nil)) 3630 (if pos 3631 (if before 3632 (progn 3633 (goto-char (cperl-1- pos)) 3634 (beginning-of-line) 3635 (setq pos (point))) 3636 (goto-char (setq pos (cperl-1- pos)))) 3637 ;; Up to the start 3638 (goto-char (point-min)))) 3639 ;; Skip empty lines 3640 (and (looking-at "\n*=") 3641 (/= 0 (skip-chars-backward "\n")) 3642 (forward-char)) 3643 (setq pos (point)) 3644 (if end 3645 ;; Do the same for end, going small steps 3646 (save-excursion 3647 (while (and end (get-text-property end 'syntax-type)) 3648 (setq pos end 3649 end (next-single-property-change end 'syntax-type nil (point-max))) 3650 (if end (progn (goto-char end) 3651 (or (bolp) (forward-line 1)) 3652 (setq end (point))))) 3653 (or end pos))))) 3654 3655;;; These are needed for byte-compile (at least with v19) 3656(defvar cperl-nonoverridable-face) 3657(defvar font-lock-variable-name-face) 3658(defvar font-lock-function-name-face) 3659(defvar font-lock-keyword-face) 3660(defvar font-lock-builtin-face) 3661(defvar font-lock-type-face) 3662(defvar font-lock-comment-face) 3663(defvar font-lock-warning-face) 3664 3665(defun cperl-find-sub-attrs (&optional st-l b-fname e-fname pos) 3666 "Syntaxically mark (and fontify) attributes of a subroutine. 3667Should be called with the point before leading colon of an attribute." 3668 ;; Works *before* syntax recognition is done 3669 (or st-l (setq st-l (list nil))) ; Avoid overwriting '() 3670 (let (st b p reset-st after-first (start (point)) start1 end1) 3671 (condition-case b 3672 (while (looking-at 3673 (concat 3674 "\\(" ; 1=optional? colon 3675 ":" cperl-maybe-white-and-comment-rex ; 2=whitespace/comment? 3676 "\\)" 3677 (if after-first "?" "") 3678 ;; No space between name and paren allowed... 3679 "\\(\\sw+\\)" ; 3=name 3680 "\\((\\)?")) ; 4=optional paren 3681 (and (match-beginning 1) 3682 (cperl-postpone-fontification 3683 (match-beginning 0) (cperl-1+ (match-beginning 0)) 3684 'face font-lock-constant-face)) 3685 (setq start1 (match-beginning 3) end1 (match-end 3)) 3686 (cperl-postpone-fontification start1 end1 3687 'face font-lock-constant-face) 3688 (goto-char end1) ; end or before `(' 3689 (if (match-end 4) ; Have attribute arguments... 3690 (progn 3691 (if st nil 3692 (setq st (cperl-cached-syntax-table st-l)) 3693 (modify-syntax-entry ?\( "()" st) 3694 (modify-syntax-entry ?\) ")(" st)) 3695 (setq reset-st (syntax-table) p (point)) 3696 (set-syntax-table st) 3697 (forward-sexp 1) 3698 (set-syntax-table reset-st) 3699 (setq reset-st nil) 3700 (cperl-commentify p (point) t))) ; mark as string 3701 (forward-comment (buffer-size)) 3702 (setq after-first t)) 3703 (error (message 3704 "L%d: attribute `%s': %s" 3705 (count-lines (point-min) (point)) 3706 (and start1 end1 (buffer-substring start1 end1)) b) 3707 (setq start nil))) 3708 (and start 3709 (progn 3710 (put-text-property start (point) 3711 'attrib-group (if (looking-at "{") t 0)) 3712 (and pos 3713 (< 1 (count-lines (+ 3 pos) (point))) ; end of `sub' 3714 ;; Apparently, we do not need `multiline': faces added now 3715 (put-text-property (+ 3 pos) (cperl-1+ (point)) 3716 'syntax-type 'sub-decl)) 3717 (and b-fname ; Fontify here: the following condition 3718 (cperl-postpone-fontification ; is too hard to determine by 3719 b-fname e-fname 'face ; a REx, so do it here 3720 (if (looking-at "{") 3721 font-lock-function-name-face 3722 font-lock-variable-name-face))))) 3723 ;; now restore the initial state 3724 (if st 3725 (progn 3726 (modify-syntax-entry ?\( "." st) 3727 (modify-syntax-entry ?\) "." st))) 3728 (if reset-st 3729 (set-syntax-table reset-st)))) 3730 3731(defsubst cperl-look-at-leading-count (is-x-REx e) 3732 (if (re-search-forward (concat "\\=" (if is-x-REx "[ \t\n]*" "") "[{?+*]") 3733 (1- e) t) ; return nil on failure, no moving 3734 (if (eq ?\{ (preceding-char)) nil 3735 (cperl-postpone-fontification 3736 (1- (point)) (point) 3737 'face font-lock-warning-face)))) 3738 3739;;; Debugging this may require (setq max-specpdl-size 2000)... 3740(defun cperl-find-pods-heres (&optional min max non-inter end ignore-max end-of-here-doc) 3741 "Scans the buffer for hard-to-parse Perl constructions. 3742If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify 3743the sections using `cperl-pod-head-face', `cperl-pod-face', 3744`cperl-here-face'." 3745 (interactive) 3746 (or min (setq min (point-min) 3747 cperl-syntax-state nil 3748 cperl-syntax-done-to min)) 3749 (or max (setq max (point-max))) 3750 (let* ((cperl-pod-here-fontify (eval cperl-pod-here-fontify)) go tmpend 3751 face head-face here-face b e bb tag qtag b1 e1 argument i c tail tb 3752 is-REx is-x-REx REx-subgr-start REx-subgr-end was-subgr i2 hairy-RE 3753 (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t) 3754 (modified (buffer-modified-p)) overshoot is-o-REx 3755 (after-change-functions nil) 3756 (cperl-font-locking t) 3757 (use-syntax-state (and cperl-syntax-state 3758 (>= min (car cperl-syntax-state)))) 3759 (state-point (if use-syntax-state 3760 (car cperl-syntax-state) 3761 (point-min))) 3762 (state (if use-syntax-state 3763 (cdr cperl-syntax-state))) 3764 ;; (st-l '(nil)) (err-l '(nil)) ; Would overwrite - propagates from a function call to a function call! 3765 (st-l (list nil)) (err-l (list nil)) 3766 ;; Somehow font-lock may be not loaded yet... 3767 ;; (e.g., when building TAGS via command-line call) 3768 (font-lock-string-face (if (boundp 'font-lock-string-face) 3769 font-lock-string-face 3770 'font-lock-string-face)) 3771 (my-cperl-delimiters-face (if (boundp 'font-lock-constant-face) 3772 font-lock-constant-face 3773 'font-lock-constant-face)) 3774 (my-cperl-REx-spec-char-face ; [] ^.$ and wrapper-of ({}) 3775 (if (boundp 'font-lock-function-name-face) 3776 font-lock-function-name-face 3777 'font-lock-function-name-face)) 3778 (font-lock-variable-name-face ; interpolated vars and ({})-code 3779 (if (boundp 'font-lock-variable-name-face) 3780 font-lock-variable-name-face 3781 'font-lock-variable-name-face)) 3782 (font-lock-function-name-face ; used in `cperl-find-sub-attrs' 3783 (if (boundp 'font-lock-function-name-face) 3784 font-lock-function-name-face 3785 'font-lock-function-name-face)) 3786 (font-lock-constant-face ; used in `cperl-find-sub-attrs' 3787 (if (boundp 'font-lock-constant-face) 3788 font-lock-constant-face 3789 'font-lock-constant-face)) 3790 (my-cperl-REx-0length-face ; 0-length, (?:)etc, non-literal \ 3791 (if (boundp 'font-lock-builtin-face) 3792 font-lock-builtin-face 3793 'font-lock-builtin-face)) 3794 (font-lock-comment-face 3795 (if (boundp 'font-lock-comment-face) 3796 font-lock-comment-face 3797 'font-lock-comment-face)) 3798 (font-lock-warning-face 3799 (if (boundp 'font-lock-warning-face) 3800 font-lock-warning-face 3801 'font-lock-warning-face)) 3802 (my-cperl-REx-ctl-face ; (|) 3803 (if (boundp 'font-lock-keyword-face) 3804 font-lock-keyword-face 3805 'font-lock-keyword-face)) 3806 (my-cperl-REx-modifiers-face ; //gims 3807 (if (boundp 'cperl-nonoverridable-face) 3808 cperl-nonoverridable-face 3809 'cperl-nonoverridable-face)) 3810 (my-cperl-REx-length1-face ; length=1 escaped chars, POSIX classes 3811 (if (boundp 'font-lock-type-face) 3812 font-lock-type-face 3813 'font-lock-type-face)) 3814 (stop-point (if ignore-max 3815 (point-max) 3816 max)) 3817 (search 3818 (concat 3819 "\\(\\`\n?\\|^\n\\)=" ; POD 3820 "\\|" 3821 ;; One extra () before this: 3822 "<<" ; HERE-DOC 3823 "\\(" ; 1 + 1 3824 ;; First variant "BLAH" or just ``. 3825 "[ \t]*" ; Yes, whitespace is allowed! 3826 "\\([\"'`]\\)" ; 2 + 1 = 3 3827 "\\([^\"'`\n]*\\)" ; 3 + 1 3828 "\\3" 3829 "\\|" 3830 ;; Second variant: Identifier or \ID (same as 'ID') or empty 3831 "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1 3832 ;; Do not have <<= or << 30 or <<30 or << $blah. 3833 ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1 3834 "\\(\\)" ; To preserve count of pars :-( 6 + 1 3835 "\\)" 3836 "\\|" 3837 ;; 1+6 extra () before this: 3838 "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" ;FRMAT 3839 (if cperl-use-syntax-table-text-property 3840 (concat 3841 "\\|" 3842 ;; 1+6+2=9 extra () before this: 3843 "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" ; QUOTED CONSTRUCT 3844 "\\|" 3845 ;; 1+6+2+1=10 extra () before this: 3846 "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob> 3847 "\\|" 3848 ;; 1+6+2+1+1=11 extra () before this 3849 "\\<sub\\>" ; sub with proto/attr 3850 "\\(" 3851 cperl-white-and-comment-rex 3852 "\\(::[a-zA-Z_:'0-9]*\\|[a-zA-Z_'][a-zA-Z_:'0-9]*\\)\\)?" ; name 3853 "\\(" 3854 cperl-maybe-white-and-comment-rex 3855 "\\(([^()]*)\\|:[^:]\\)\\)" ; prototype or attribute start 3856 "\\|" 3857 ;; 1+6+2+1+1+6=17 extra () before this: 3858 "\\$\\(['{]\\)" ; $' or ${foo} 3859 "\\|" 3860 ;; 1+6+2+1+1+6+1=18 extra () before this (old pack'var syntax; 3861 ;; we do not support intervening comments...): 3862 "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'" 3863 ;; 1+6+2+1+1+6+1+1=19 extra () before this: 3864 "\\|" 3865 "__\\(END\\|DATA\\)__" ; __END__ or __DATA__ 3866 ;; 1+6+2+1+1+6+1+1+1=20 extra () before this: 3867 "\\|" 3868 "\\\\\\(['`\"($]\\)") ; BACKWACKED something-hairy 3869 "")))) 3870 (unwind-protect 3871 (progn 3872 (save-excursion 3873 (or non-inter 3874 (message "Scanning for \"hard\" Perl constructions...")) 3875 ;;(message "find: %s --> %s" min max) 3876 (and cperl-pod-here-fontify 3877 ;; We had evals here, do not know why... 3878 (setq face cperl-pod-face 3879 head-face cperl-pod-head-face 3880 here-face cperl-here-face)) 3881 (remove-text-properties min max 3882 '(syntax-type t in-pod t syntax-table t 3883 attrib-group t 3884 REx-interpolated t 3885 cperl-postpone t 3886 syntax-subtype t 3887 rear-nonsticky t 3888 front-sticky t 3889 here-doc-group t 3890 first-format-line t 3891 REx-part2 t 3892 indentable t)) 3893 ;; Need to remove face as well... 3894 (goto-char min) 3895 (and (eq system-type 'emx) 3896 (eq (point) 1) 3897 (let ((case-fold-search t)) 3898 (looking-at "extproc[ \t]")) ; Analogue of #! 3899 (cperl-commentify min 3900 (save-excursion (end-of-line) (point)) 3901 nil)) 3902 (while (and 3903 (< (point) max) 3904 (re-search-forward search max t)) 3905 (setq tmpend nil) ; Valid for most cases 3906 (setq b (match-beginning 0) 3907 state (save-excursion (parse-partial-sexp 3908 state-point b nil nil state)) 3909 state-point b) 3910 (cond 3911 ;; 1+6+2+1+1+6=17 extra () before this: 3912 ;; "\\$\\(['{]\\)" 3913 ((match-beginning 18) ; $' or ${foo} 3914 (if (eq (preceding-char) ?\') ; $' 3915 (progn 3916 (setq b (1- (point)) 3917 state (parse-partial-sexp 3918 state-point (1- b) nil nil state) 3919 state-point (1- b)) 3920 (if (nth 3 state) ; in string 3921 (cperl-modify-syntax-type (1- b) cperl-st-punct)) 3922 (goto-char (1+ b))) 3923 ;; else: ${ 3924 (setq bb (match-beginning 0)) 3925 (cperl-modify-syntax-type bb cperl-st-punct))) 3926 ;; No processing in strings/comments beyond this point: 3927 ((or (nth 3 state) (nth 4 state)) 3928 t) ; Do nothing in comment/string 3929 ((match-beginning 1) ; POD section 3930 ;; "\\(\\`\n?\\|^\n\\)=" 3931 (setq b (match-beginning 0) 3932 state (parse-partial-sexp 3933 state-point b nil nil state) 3934 state-point b) 3935 (if (or (nth 3 state) (nth 4 state) 3936 (looking-at "cut\\>")) 3937 (if (or (nth 3 state) (nth 4 state) ignore-max) 3938 nil ; Doing a chunk only 3939 (message "=cut is not preceded by a POD section") 3940 (or (car err-l) (setcar err-l (point)))) 3941 (beginning-of-line) 3942 3943 (setq b (point) 3944 bb b 3945 tb (match-beginning 0) 3946 b1 nil) ; error condition 3947 ;; We do not search to max, since we may be called from 3948 ;; some hook of fontification, and max is random 3949 (or (re-search-forward "^\n=cut\\>" stop-point 'toend) 3950 (progn 3951 (goto-char b) 3952 (if (re-search-forward "\n=cut\\>" stop-point 'toend) 3953 (progn 3954 (message "=cut is not preceded by an empty line") 3955 (setq b1 t) 3956 (or (car err-l) (setcar err-l b)))))) 3957 (beginning-of-line 2) ; An empty line after =cut is not POD! 3958 (setq e (point)) 3959 (and (> e max) 3960 (progn 3961 (remove-text-properties 3962 max e '(syntax-type t in-pod t syntax-table t 3963 attrib-group t 3964 REx-interpolated t 3965 cperl-postpone t 3966 syntax-subtype t 3967 here-doc-group t 3968 rear-nonsticky t 3969 front-sticky t 3970 first-format-line t 3971 REx-part2 t 3972 indentable t)) 3973 (setq tmpend tb))) 3974 (put-text-property b e 'in-pod t) 3975 (put-text-property b e 'syntax-type 'in-pod) 3976 (goto-char b) 3977 (while (re-search-forward "\n\n[ \t]" e t) 3978 ;; We start 'pod 1 char earlier to include the preceding line 3979 (beginning-of-line) 3980 (put-text-property (cperl-1- b) (point) 'syntax-type 'pod) 3981 (cperl-put-do-not-fontify b (point) t) 3982 ;; mark the non-literal parts as PODs 3983 (if cperl-pod-here-fontify 3984 (cperl-postpone-fontification b (point) 'face face t)) 3985 (re-search-forward "\n\n[^ \t\f\n]" e 'toend) 3986 (beginning-of-line) 3987 (setq b (point))) 3988 (put-text-property (cperl-1- (point)) e 'syntax-type 'pod) 3989 (cperl-put-do-not-fontify (point) e t) 3990 (if cperl-pod-here-fontify 3991 (progn 3992 ;; mark the non-literal parts as PODs 3993 (cperl-postpone-fontification (point) e 'face face t) 3994 (goto-char bb) 3995 (if (looking-at 3996 "=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$") 3997 ;; mark the headers 3998 (cperl-postpone-fontification 3999 (match-beginning 1) (match-end 1) 4000 'face head-face)) 4001 (while (re-search-forward 4002 ;; One paragraph 4003 "^\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$" 4004 e 'toend) 4005 ;; mark the headers 4006 (cperl-postpone-fontification 4007 (match-beginning 1) (match-end 1) 4008 'face head-face)))) 4009 (cperl-commentify bb e nil) 4010 (goto-char e) 4011 (or (eq e (point-max)) 4012 (forward-char -1)))) ; Prepare for immediate POD start. 4013 ;; Here document 4014 ;; We can do many here-per-line; 4015 ;; but multiline quote on the same line as <<HERE confuses us... 4016 ;; ;; One extra () before this: 4017 ;;"<<" 4018 ;; "\\(" ; 1 + 1 4019 ;; ;; First variant "BLAH" or just ``. 4020 ;; "[ \t]*" ; Yes, whitespace is allowed! 4021 ;; "\\([\"'`]\\)" ; 2 + 1 4022 ;; "\\([^\"'`\n]*\\)" ; 3 + 1 4023 ;; "\\3" 4024 ;; "\\|" 4025 ;; ;; Second variant: Identifier or \ID or empty 4026 ;; "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1 4027 ;; ;; Do not have <<= or << 30 or <<30 or << $blah. 4028 ;; ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1 4029 ;; "\\(\\)" ; To preserve count of pars :-( 6 + 1 4030 ;; "\\)" 4031 ((match-beginning 2) ; 1 + 1 4032 (setq b (point) 4033 tb (match-beginning 0) 4034 c (and ; not HERE-DOC 4035 (match-beginning 5) 4036 (save-match-data 4037 (or (looking-at "[ \t]*(") ; << function_call() 4038 (save-excursion ; 1 << func_name, or $foo << 10 4039 (condition-case nil 4040 (progn 4041 (goto-char tb) 4042 ;;; XXX What to do: foo <<bar ??? 4043 ;;; XXX Need to support print {a} <<B ??? 4044 (forward-sexp -1) 4045 (save-match-data 4046 ; $foo << b; $f .= <<B; 4047 ; ($f+1) << b; a($f) . <<B; 4048 ; foo 1, <<B; $x{a} <<b; 4049 (cond 4050 ((looking-at "[0-9$({]") 4051 (forward-sexp 1) 4052 (and 4053 (looking-at "[ \t]*<<") 4054 (condition-case nil 4055 ;; print $foo <<EOF 4056 (progn 4057 (forward-sexp -2) 4058 (not 4059 (looking-at "\\(printf?\\|system\\|exec\\|sort\\)\\>"))) 4060 (error t))))))) 4061 (error nil))) ; func(<<EOF) 4062 (and (not (match-beginning 6)) ; Empty 4063 (looking-at 4064 "[ \t]*[=0-9$@%&(]")))))) 4065 (if c ; Not here-doc 4066 nil ; Skip it. 4067 (setq c (match-end 2)) ; 1 + 1 4068 (if (match-beginning 5) ;4 + 1 4069 (setq b1 (match-beginning 5) ; 4 + 1 4070 e1 (match-end 5)) ; 4 + 1 4071 (setq b1 (match-beginning 4) ; 3 + 1 4072 e1 (match-end 4))) ; 3 + 1 4073 (setq tag (buffer-substring b1 e1) 4074 qtag (regexp-quote tag)) 4075 (cond (cperl-pod-here-fontify 4076 ;; Highlight the starting delimiter 4077 (cperl-postpone-fontification 4078 b1 e1 'face my-cperl-delimiters-face) 4079 (cperl-put-do-not-fontify b1 e1 t))) 4080 (forward-line) 4081 (setq i (point)) 4082 (if end-of-here-doc 4083 (goto-char end-of-here-doc)) 4084 (setq b (point)) 4085 ;; We do not search to max, since we may be called from 4086 ;; some hook of fontification, and max is random 4087 (or (and (re-search-forward (concat "^" qtag "$") 4088 stop-point 'toend) 4089 ;;;(eq (following-char) ?\n) ; XXXX WHY??? 4090 ) 4091 (progn ; Pretend we matched at the end 4092 (goto-char (point-max)) 4093 (re-search-forward "\\'") 4094 (message "End of here-document `%s' not found." tag) 4095 (or (car err-l) (setcar err-l b)))) 4096 (if cperl-pod-here-fontify 4097 (progn 4098 ;; Highlight the ending delimiter 4099 (cperl-postpone-fontification 4100 (match-beginning 0) (match-end 0) 4101 'face my-cperl-delimiters-face) 4102 (cperl-put-do-not-fontify b (match-end 0) t) 4103 ;; Highlight the HERE-DOC 4104 (cperl-postpone-fontification b (match-beginning 0) 4105 'face here-face))) 4106 (setq e1 (cperl-1+ (match-end 0))) 4107 (put-text-property b (match-beginning 0) 4108 'syntax-type 'here-doc) 4109 (put-text-property (match-beginning 0) e1 4110 'syntax-type 'here-doc-delim) 4111 (put-text-property b e1 'here-doc-group t) 4112 ;; This makes insertion at the start of HERE-DOC update 4113 ;; the whole construct: 4114 (put-text-property b (cperl-1+ b) 'front-sticky '(syntax-type)) 4115 (cperl-commentify b e1 nil) 4116 (cperl-put-do-not-fontify b (match-end 0) t) 4117 ;; Cache the syntax info... 4118 (setq cperl-syntax-state (cons state-point state)) 4119 ;; ... and process the rest of the line... 4120 (setq overshoot 4121 (elt ; non-inter ignore-max 4122 (cperl-find-pods-heres c i t end t e1) 1)) 4123 (if (and overshoot (> overshoot (point))) 4124 (goto-char overshoot) 4125 (setq overshoot e1)) 4126 (if (> e1 max) 4127 (setq tmpend tb)))) 4128 ;; format 4129 ((match-beginning 8) 4130 ;; 1+6=7 extra () before this: 4131 ;;"^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" 4132 (setq b (point) 4133 name (if (match-beginning 8) ; 7 + 1 4134 (buffer-substring (match-beginning 8) ; 7 + 1 4135 (match-end 8)) ; 7 + 1 4136 "") 4137 tb (match-beginning 0)) 4138 (setq argument nil) 4139 (put-text-property (save-excursion 4140 (beginning-of-line) 4141 (point)) 4142 b 'first-format-line 't) 4143 (if cperl-pod-here-fontify 4144 (while (and (eq (forward-line) 0) 4145 (not (looking-at "^[.;]$"))) 4146 (cond 4147 ((looking-at "^#")) ; Skip comments 4148 ((and argument ; Skip argument multi-lines 4149 (looking-at "^[ \t]*{")) 4150 (forward-sexp 1) 4151 (setq argument nil)) 4152 (argument ; Skip argument lines 4153 (setq argument nil)) 4154 (t ; Format line 4155 (setq b1 (point)) 4156 (setq argument (looking-at "^[^\n]*[@^]")) 4157 (end-of-line) 4158 ;; Highlight the format line 4159 (cperl-postpone-fontification b1 (point) 4160 'face font-lock-string-face) 4161 (cperl-commentify b1 (point) nil) 4162 (cperl-put-do-not-fontify b1 (point) t)))) 4163 ;; We do not search to max, since we may be called from 4164 ;; some hook of fontification, and max is random 4165 (re-search-forward "^[.;]$" stop-point 'toend)) 4166 (beginning-of-line) 4167 (if (looking-at "^\\.$") ; ";" is not supported yet 4168 (progn 4169 ;; Highlight the ending delimiter 4170 (cperl-postpone-fontification (point) (+ (point) 2) 4171 'face font-lock-string-face) 4172 (cperl-commentify (point) (+ (point) 2) nil) 4173 (cperl-put-do-not-fontify (point) (+ (point) 2) t)) 4174 (message "End of format `%s' not found." name) 4175 (or (car err-l) (setcar err-l b))) 4176 (forward-line) 4177 (if (> (point) max) 4178 (setq tmpend tb)) 4179 (put-text-property b (point) 'syntax-type 'format)) 4180 ;; qq-like String or Regexp: 4181 ((or (match-beginning 10) (match-beginning 11)) 4182 ;; 1+6+2=9 extra () before this: 4183 ;; "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" 4184 ;; "\\|" 4185 ;; "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob> 4186 (setq b1 (if (match-beginning 10) 10 11) 4187 argument (buffer-substring 4188 (match-beginning b1) (match-end b1)) 4189 b (point) ; end of qq etc 4190 i b 4191 c (char-after (match-beginning b1)) 4192 bb (char-after (1- (match-beginning b1))) ; tmp holder 4193 ;; bb == "Not a stringy" 4194 bb (if (eq b1 10) ; user variables/whatever 4195 (and (memq bb (append "$@%*#_:-&>" nil)) ; $#y) 4196 (cond ((eq bb ?-) (eq c ?s)) ; -s file test 4197 ((eq bb ?\:) ; $opt::s 4198 (eq (char-after 4199 (- (match-beginning b1) 2)) 4200 ?\:)) 4201 ((eq bb ?\>) ; $foo->s 4202 (eq (char-after 4203 (- (match-beginning b1) 2)) 4204 ?\-)) 4205 ((eq bb ?\&) 4206 (not (eq (char-after ; &&m/blah/ 4207 (- (match-beginning b1) 2)) 4208 ?\&))) 4209 (t t))) 4210 ;; <file> or <$file> 4211 (and (eq c ?\<) 4212 ;; Do not stringify <FH>, <$fh> : 4213 (save-match-data 4214 (looking-at 4215 "\\$?\\([_a-zA-Z:][_a-zA-Z0-9:]*\\)?>")))) 4216 tb (match-beginning 0)) 4217 (goto-char (match-beginning b1)) 4218 (cperl-backward-to-noncomment (point-min)) 4219 (or bb 4220 (if (eq b1 11) ; bare /blah/ or ?blah? or <foo> 4221 (setq argument "" 4222 b1 nil 4223 bb ; Not a regexp? 4224 (not 4225 ;; What is below: regexp-p? 4226 (and 4227 (or (memq (preceding-char) 4228 (append (if (memq c '(?\? ?\<)) 4229 ;; $a++ ? 1 : 2 4230 "~{(=|&*!,;:[" 4231 "~{(=|&+-*!,;:[") nil)) 4232 (and (eq (preceding-char) ?\}) 4233 (cperl-after-block-p (point-min))) 4234 (and (eq (char-syntax (preceding-char)) ?w) 4235 (progn 4236 (forward-sexp -1) 4237;; After these keywords `/' starts a RE. One should add all the 4238;; functions/builtins which expect an argument, but ... 4239 (if (eq (preceding-char) ?-) 4240 ;; -d ?foo? is a RE 4241 (looking-at "[a-zA-Z]\\>") 4242 (and 4243 (not (memq (preceding-char) 4244 '(?$ ?@ ?& ?%))) 4245 (looking-at 4246 "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>"))))) 4247 (and (eq (preceding-char) ?.) 4248 (eq (char-after (- (point) 2)) ?.)) 4249 (bobp)) 4250 ;; m|blah| ? foo : bar; 4251 (not 4252 (and (eq c ?\?) 4253 cperl-use-syntax-table-text-property 4254 (not (bobp)) 4255 (progn 4256 (forward-char -1) 4257 (looking-at "\\s|")))))) 4258 b (1- b)) 4259 ;; s y tr m 4260 ;; Check for $a -> y 4261 (setq b1 (preceding-char) 4262 go (point)) 4263 (if (and (eq b1 ?>) 4264 (eq (char-after (- go 2)) ?-)) 4265 ;; Not a regexp 4266 (setq bb t)))) 4267 (or bb 4268 (progn 4269 (goto-char b) 4270 (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+") 4271 (goto-char (match-end 0)) 4272 (skip-chars-forward " \t\n\f")) 4273 (cond ((and (eq (following-char) ?\}) 4274 (eq b1 ?\{)) 4275 ;; Check for $a[23]->{ s }, @{s} and *{s::foo} 4276 (goto-char (1- go)) 4277 (skip-chars-backward " \t\n\f") 4278 (if (memq (preceding-char) (append "$@%&*" nil)) 4279 (setq bb t) ; @{y} 4280 (condition-case nil 4281 (forward-sexp -1) 4282 (error nil))) 4283 (if (or bb 4284 (looking-at ; $foo -> {s} 4285 "[$@]\\$*\\([a-zA-Z0-9_:]+\\|[^{]\\)\\([ \t\n]*->\\)?[ \t\n]*{") 4286 (and ; $foo[12] -> {s} 4287 (memq (following-char) '(?\{ ?\[)) 4288 (progn 4289 (forward-sexp 1) 4290 (looking-at "\\([ \t\n]*->\\)?[ \t\n]*{")))) 4291 (setq bb t) 4292 (goto-char b))) 4293 ((and (eq (following-char) ?=) 4294 (eq (char-after (1+ (point))) ?\>)) 4295 ;; Check for { foo => 1, s => 2 } 4296 ;; Apparently s=> is never a substitution... 4297 (setq bb t)) 4298 ((and (eq (following-char) ?:) 4299 (eq b1 ?\{) ; Check for $ { s::bar } 4300 (looking-at "::[a-zA-Z0-9_:]*[ \t\n\f]*}") 4301 (progn 4302 (goto-char (1- go)) 4303 (skip-chars-backward " \t\n\f") 4304 (memq (preceding-char) 4305 (append "$@%&*" nil)))) 4306 (setq bb t)) 4307 ((eobp) 4308 (setq bb t))))) 4309 (if bb 4310 (goto-char i) 4311 ;; Skip whitespace and comments... 4312 (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+") 4313 (goto-char (match-end 0)) 4314 (skip-chars-forward " \t\n\f")) 4315 (if (> (point) b) 4316 (put-text-property b (point) 'syntax-type 'prestring)) 4317 ;; qtag means two-arg matcher, may be reset to 4318 ;; 2 or 3 later if some special quoting is needed. 4319 ;; e1 means matching-char matcher. 4320 (setq b (point) ; before the first delimiter 4321 ;; has 2 args 4322 i2 (string-match "^\\([sy]\\|tr\\)$" argument) 4323 ;; We do not search to max, since we may be called from 4324 ;; some hook of fontification, and max is random 4325 i (cperl-forward-re stop-point end 4326 i2 4327 st-l err-l argument) 4328 ;; If `go', then it is considered as 1-arg, `b1' is nil 4329 ;; as in s/foo//x; the point is before final "slash" 4330 b1 (nth 1 i) ; start of the second part 4331 tag (nth 2 i) ; ender-char, true if second part 4332 ; is with matching chars [] 4333 go (nth 4 i) ; There is a 1-char part after the end 4334 i (car i) ; intermediate point 4335 e1 (point) ; end 4336 ;; Before end of the second part if non-matching: /// 4337 tail (if (and i (not tag)) 4338 (1- e1)) 4339 e (if i i e1) ; end of the first part 4340 qtag nil ; need to preserve backslashitis 4341 is-x-REx nil is-o-REx nil); REx has //x //o modifiers 4342 ;; If s{} (), then b/b1 are at "{", "(", e1/i after ")", "}" 4343 ;; Commenting \\ is dangerous, what about ( ? 4344 (and i tail 4345 (eq (char-after i) ?\\) 4346 (setq qtag t)) 4347 (and (if go (looking-at ".\\sw*x") 4348 (looking-at "\\sw*x")) ; qr//x 4349 (setq is-x-REx t)) 4350 (and (if go (looking-at ".\\sw*o") 4351 (looking-at "\\sw*o")) ; //o 4352 (setq is-o-REx t)) 4353 (if (null i) 4354 ;; Considered as 1arg form 4355 (progn 4356 (cperl-commentify b (point) t) 4357 (put-text-property b (point) 'syntax-type 'string) 4358 (if (or is-x-REx 4359 ;; ignore other text properties: 4360 (string-match "^qw$" argument)) 4361 (put-text-property b (point) 'indentable t)) 4362 (and go 4363 (setq e1 (cperl-1+ e1)) 4364 (or (eobp) 4365 (forward-char 1)))) 4366 (cperl-commentify b i t) 4367 (if (looking-at "\\sw*e") ; s///e 4368 (progn 4369 ;; Cache the syntax info... 4370 (setq cperl-syntax-state (cons state-point state)) 4371 (and 4372 ;; silent: 4373 (car (cperl-find-pods-heres b1 (1- (point)) t end)) 4374 ;; Error 4375 (goto-char (1+ max))) 4376 (if (and tag (eq (preceding-char) ?\>)) 4377 (progn 4378 (cperl-modify-syntax-type (1- (point)) cperl-st-ket) 4379 (cperl-modify-syntax-type i cperl-st-bra))) 4380 (put-text-property b i 'syntax-type 'string) 4381 (put-text-property i (point) 'syntax-type 'multiline) 4382 (if is-x-REx 4383 (put-text-property b i 'indentable t))) 4384 (cperl-commentify b1 (point) t) 4385 (put-text-property b (point) 'syntax-type 'string) 4386 (if is-x-REx 4387 (put-text-property b i 'indentable t)) 4388 (if qtag 4389 (cperl-modify-syntax-type (1+ i) cperl-st-punct)) 4390 (setq tail nil))) 4391 ;; Now: tail: if the second part is non-matching without ///e 4392 (if (eq (char-syntax (following-char)) ?w) 4393 (progn 4394 (forward-word 1) ; skip modifiers s///s 4395 (if tail (cperl-commentify tail (point) t)) 4396 (cperl-postpone-fontification 4397 e1 (point) 'face my-cperl-REx-modifiers-face))) 4398 ;; Check whether it is m// which means "previous match" 4399 ;; and highlight differently 4400 (setq is-REx 4401 (and (string-match "^\\([sm]?\\|qr\\)$" argument) 4402 (or (not (= (length argument) 0)) 4403 (not (eq c ?\<))))) 4404 (if (and is-REx 4405 (eq e (+ 2 b)) 4406 ;; split // *is* using zero-pattern 4407 (save-excursion 4408 (condition-case nil 4409 (progn 4410 (goto-char tb) 4411 (forward-sexp -1) 4412 (not (looking-at "split\\>"))) 4413 (error t)))) 4414 (cperl-postpone-fontification 4415 b e 'face font-lock-warning-face) 4416 (if (or i2 ; Has 2 args 4417 (and cperl-fontify-m-as-s 4418 (or 4419 (string-match "^\\(m\\|qr\\)$" argument) 4420 (and (eq 0 (length argument)) 4421 (not (eq ?\< (char-after b))))))) 4422 (progn 4423 (cperl-postpone-fontification 4424 b (cperl-1+ b) 'face my-cperl-delimiters-face) 4425 (cperl-postpone-fontification 4426 (1- e) e 'face my-cperl-delimiters-face))) 4427 (if (and is-REx cperl-regexp-scan) 4428 ;; Process RExen: embedded comments, charclasses and ] 4429;;;/\3333\xFg\x{FFF}a\ppp\PPP\qqq\C\99f(?{ foo })(??{ foo })/; 4430;;;/a\.b[^a[:ff:]b]x$ab->$[|$,$ab->[cd]->[ef]|$ab[xy].|^${a,b}{c,d}/; 4431;;;/(?<=foo)(?<!bar)(x)(?:$ab|\$\/)$|\\\b\x888\776\[\:$/xxx; 4432;;;m?(\?\?{b,a})? + m/(??{aa})(?(?=xx)aa|bb)(?#aac)/; 4433;;;m$(^ab[c]\$)$ + m+(^ab[c]\$\+)+ + m](^ab[c\]$|.+)] + m)(^ab[c]$|.+\)); 4434;;;m^a[\^b]c^ + m.a[^b]\.c.; 4435 (save-excursion 4436 (goto-char (1+ b)) 4437 ;; First 4438 (cperl-look-at-leading-count is-x-REx e) 4439 (setq hairy-RE 4440 (concat 4441 (if is-x-REx 4442 (if (eq (char-after b) ?\#) 4443 "\\((\\?\\\\#\\)\\|\\(\\\\#\\)" 4444 "\\((\\?#\\)\\|\\(#\\)") 4445 ;; keep the same count: add a fake group 4446 (if (eq (char-after b) ?\#) 4447 "\\((\\?\\\\#\\)\\(\\)" 4448 "\\((\\?#\\)\\(\\)")) 4449 "\\|" 4450 "\\(\\[\\)" ; 3=[ 4451 "\\|" 4452 "\\(]\\)" ; 4=] 4453 "\\|" 4454 ;; XXXX Will not be able to use it in s))) 4455 (if (eq (char-after b) ?\) ) 4456 "\\())))\\)" ; Will never match 4457 (if (eq (char-after b) ?? ) 4458 ;;"\\((\\\\\\?\\(\\\\\\?\\)?{\\)" 4459 "\\((\\\\\\?\\\\\\?{\\|()\\\\\\?{\\)" 4460 "\\((\\?\\??{\\)")) ; 5= (??{ (?{ 4461 "\\|" ; 6= 0-length, 7: name, 8,9:code, 10:group 4462 "\\(" ;; XXXX 1-char variables, exc. |()\s 4463 "[$@]" 4464 "\\(" 4465 "[_a-zA-Z:][_a-zA-Z0-9:]*" 4466 "\\|" 4467 "{[^{}]*}" ; only one-level allowed 4468 "\\|" 4469 "[^{(|) \t\r\n\f]" 4470 "\\)" 4471 "\\(" ;;8,9:code part of array/hash elt 4472 "\\(" "->" "\\)?" 4473 "\\[[^][]*\\]" 4474 "\\|" 4475 "{[^{}]*}" 4476 "\\)*" 4477 ;; XXXX: what if u is delim? 4478 "\\|" 4479 "[)^|$.*?+]" 4480 "\\|" 4481 "{[0-9]+}" 4482 "\\|" 4483 "{[0-9]+,[0-9]*}" 4484 "\\|" 4485 "\\\\[luLUEQbBAzZG]" 4486 "\\|" 4487 "(" ; Group opener 4488 "\\(" ; 10 group opener follower 4489 "\\?\\((\\?\\)" ; 11: in (?(?=C)A|B) 4490 "\\|" 4491 "\\?[:=!>?{]" ; "?" something 4492 "\\|" 4493 "\\?[-imsx]+[:)]" ; (?i) (?-s:.) 4494 "\\|" 4495 "\\?([0-9]+)" ; (?(1)foo|bar) 4496 "\\|" 4497 "\\?<[=!]" 4498 ;;;"\\|" 4499 ;;; "\\?" 4500 "\\)?" 4501 "\\)" 4502 "\\|" 4503 "\\\\\\(.\\)" ; 12=\SYMBOL 4504 )) 4505 (while 4506 (and (< (point) (1- e)) 4507 (re-search-forward hairy-RE (1- e) 'to-end)) 4508 (goto-char (match-beginning 0)) 4509 (setq REx-subgr-start (point) 4510 was-subgr (following-char)) 4511 (cond 4512 ((match-beginning 6) ; 0-length builtins, groups 4513 (goto-char (match-end 0)) 4514 (if (match-beginning 11) 4515 (goto-char (match-beginning 11))) 4516 (if (>= (point) e) 4517 (goto-char (1- e))) 4518 (cperl-postpone-fontification 4519 (match-beginning 0) (point) 4520 'face 4521 (cond 4522 ((eq was-subgr ?\) ) 4523 (condition-case nil 4524 (save-excursion 4525 (forward-sexp -1) 4526 (if (> (point) b) 4527 (if (if (eq (char-after b) ?? ) 4528 (looking-at "(\\\\\\?") 4529 (eq (char-after (1+ (point))) ?\?)) 4530 my-cperl-REx-0length-face 4531 my-cperl-REx-ctl-face) 4532 font-lock-warning-face)) 4533 (error font-lock-warning-face))) 4534 ((eq was-subgr ?\| ) 4535 my-cperl-REx-ctl-face) 4536 ((eq was-subgr ?\$ ) 4537 (if (> (point) (1+ REx-subgr-start)) 4538 (progn 4539 (put-text-property 4540 (match-beginning 0) (point) 4541 'REx-interpolated 4542 (if is-o-REx 0 4543 (if (and (eq (match-beginning 0) 4544 (1+ b)) 4545 (eq (point) 4546 (1- e))) 1 t))) 4547 font-lock-variable-name-face) 4548 my-cperl-REx-spec-char-face)) 4549 ((memq was-subgr (append "^." nil) ) 4550 my-cperl-REx-spec-char-face) 4551 ((eq was-subgr ?\( ) 4552 (if (not (match-beginning 10)) 4553 my-cperl-REx-ctl-face 4554 my-cperl-REx-0length-face)) 4555 (t my-cperl-REx-0length-face))) 4556 (if (and (memq was-subgr (append "(|" nil)) 4557 (not (string-match "(\\?[-imsx]+)" 4558 (match-string 0)))) 4559 (cperl-look-at-leading-count is-x-REx e)) 4560 (setq was-subgr nil)) ; We do stuff here 4561 ((match-beginning 12) ; \SYMBOL 4562 (forward-char 2) 4563 (if (>= (point) e) 4564 (goto-char (1- e)) 4565 ;; How many chars to not highlight: 4566 ;; 0-len special-alnums in other branch => 4567 ;; Generic: \non-alnum (1), \alnum (1+face) 4568 ;; Is-delim: \non-alnum (1/spec-2) alnum-1 (=what hai) 4569 (setq REx-subgr-start (point) 4570 qtag (preceding-char)) 4571 (cperl-postpone-fontification 4572 (- (point) 2) (- (point) 1) 'face 4573 (if (memq qtag 4574 (append "ghijkmoqvFHIJKMORTVY" nil)) 4575 font-lock-warning-face 4576 my-cperl-REx-0length-face)) 4577 (if (and (eq (char-after b) qtag) 4578 (memq qtag (append ".])^$|*?+" nil))) 4579 (progn 4580 (if (and cperl-use-syntax-table-text-property 4581 (eq qtag ?\) )) 4582 (put-text-property 4583 REx-subgr-start (1- (point)) 4584 'syntax-table cperl-st-punct)) 4585 (cperl-postpone-fontification 4586 (1- (point)) (point) 'face 4587 ; \] can't appear below 4588 (if (memq qtag (append ".]^$" nil)) 4589 'my-cperl-REx-spec-char-face 4590 (if (memq qtag (append "*?+" nil)) 4591 'my-cperl-REx-0length-face 4592 'my-cperl-REx-ctl-face))))) ; )| 4593 ;; Test for arguments: 4594 (cond 4595 ;; This is not pretty: the 5.8.7 logic: 4596 ;; \0numx -> octal (up to total 3 dig) 4597 ;; \DIGIT -> backref unless \0 4598 ;; \DIGITs -> backref if legal 4599 ;; otherwise up to 3 -> octal 4600 ;; Do not try to distinguish, we guess 4601 ((or (and (memq qtag (append "01234567" nil)) 4602 (re-search-forward 4603 "\\=[01234567]?[01234567]?" 4604 (1- e) 'to-end)) 4605 (and (memq qtag (append "89" nil)) 4606 (re-search-forward 4607 "\\=[0123456789]*" (1- e) 'to-end)) 4608 (and (eq qtag ?x) 4609 (re-search-forward 4610 "\\=[0-9a-fA-F][0-9a-fA-F]?\\|\\={[0-9a-fA-F]+}" 4611 (1- e) 'to-end)) 4612 (and (memq qtag (append "pPN" nil)) 4613 (re-search-forward "\\={[^{}]+}\\|." 4614 (1- e) 'to-end)) 4615 (eq (char-syntax qtag) ?w)) 4616 (cperl-postpone-fontification 4617 (1- REx-subgr-start) (point) 4618 'face my-cperl-REx-length1-face)))) 4619 (setq was-subgr nil)) ; We do stuff here 4620 ((match-beginning 3) ; [charclass] 4621 (forward-char 1) 4622 (if (eq (char-after b) ?^ ) 4623 (and (eq (following-char) ?\\ ) 4624 (eq (char-after (cperl-1+ (point))) 4625 ?^ ) 4626 (forward-char 2)) 4627 (and (eq (following-char) ?^ ) 4628 (forward-char 1))) 4629 (setq argument b ; continue? 4630 tag nil ; list of POSIX classes 4631 qtag (point)) 4632 (if (eq (char-after b) ?\] ) 4633 (and (eq (following-char) ?\\ ) 4634 (eq (char-after (cperl-1+ (point))) 4635 ?\] ) 4636 (setq qtag (1+ qtag)) 4637 (forward-char 2)) 4638 (and (eq (following-char) ?\] ) 4639 (forward-char 1))) 4640 ;; Apparently, I can't put \] into a charclass 4641 ;; in m]]: m][\\\]\]] produces [\\]] 4642;;; POSIX? [:word:] [:^word:] only inside [] 4643;;; "\\=\\(\\\\.\\|[^][\\\\]\\|\\[:\\^?\sw+:]\\|\\[[^:]\\)*]") 4644 (while 4645 (and argument 4646 (re-search-forward 4647 (if (eq (char-after b) ?\] ) 4648 "\\=\\(\\\\[^]]\\|[^]\\\\]\\)*\\\\]" 4649 "\\=\\(\\\\.\\|[^]\\\\]\\)*]") 4650 (1- e) 'toend)) 4651 ;; Is this ] an end of POSIX class? 4652 (if (save-excursion 4653 (and 4654 (search-backward "[" argument t) 4655 (< REx-subgr-start (point)) 4656 (not 4657 (and ; Should work with delim = \ 4658 (eq (preceding-char) ?\\ ) 4659 (= (% (skip-chars-backward 4660 "\\\\") 2) 0))) 4661 (looking-at 4662 (cond 4663 ((eq (char-after b) ?\] ) 4664 "\\\\*\\[:\\^?\\sw+:\\\\\\]") 4665 ((eq (char-after b) ?\: ) 4666 "\\\\*\\[\\\\:\\^?\\sw+\\\\:]") 4667 ((eq (char-after b) ?^ ) 4668 "\\\\*\\[:\\(\\\\\\^\\)?\\sw+:\]") 4669 ((eq (char-syntax (char-after b)) 4670 ?w) 4671 (concat 4672 "\\\\*\\[:\\(\\\\\\^\\)?\\(\\\\" 4673 (char-to-string (char-after b)) 4674 "\\|\\sw\\)+:\]")) 4675 (t "\\\\*\\[:\\^?\\sw*:]"))) 4676 (setq argument (point)))) 4677 (setq tag (cons (cons argument (point)) 4678 tag) 4679 argument (point)) ; continue 4680 (setq argument nil))) 4681 (and argument 4682 (message "Couldn't find end of charclass in a REx, pos=%s" 4683 REx-subgr-start)) 4684 (if (and cperl-use-syntax-table-text-property 4685 (> (- (point) 2) REx-subgr-start)) 4686 (put-text-property 4687 (1+ REx-subgr-start) (1- (point)) 4688 'syntax-table cperl-st-punct)) 4689 (cperl-postpone-fontification 4690 REx-subgr-start qtag 4691 'face my-cperl-REx-spec-char-face) 4692 (cperl-postpone-fontification 4693 (1- (point)) (point) 'face 4694 my-cperl-REx-spec-char-face) 4695 (if (eq (char-after b) ?\] ) 4696 (cperl-postpone-fontification 4697 (- (point) 2) (1- (point)) 4698 'face my-cperl-REx-0length-face)) 4699 (while tag 4700 (cperl-postpone-fontification 4701 (car (car tag)) (cdr (car tag)) 4702 'face my-cperl-REx-length1-face) 4703 (setq tag (cdr tag))) 4704 (setq was-subgr nil)) ; did facing already 4705 ;; Now rare stuff: 4706 ((and (match-beginning 2) ; #-comment 4707 (/= (match-beginning 2) (match-end 2))) 4708 (beginning-of-line 2) 4709 (if (> (point) e) 4710 (goto-char (1- e)))) 4711 ((match-beginning 4) ; character "]" 4712 (setq was-subgr nil) ; We do stuff here 4713 (goto-char (match-end 0)) 4714 (if cperl-use-syntax-table-text-property 4715 (put-text-property 4716 (1- (point)) (point) 4717 'syntax-table cperl-st-punct)) 4718 (cperl-postpone-fontification 4719 (1- (point)) (point) 4720 'face font-lock-warning-face)) 4721 ((match-beginning 5) ; before (?{}) (??{}) 4722 (setq tag (match-end 0)) 4723 (if (or (setq qtag 4724 (cperl-forward-group-in-re st-l)) 4725 (and (>= (point) e) 4726 (setq qtag "no matching `)' found")) 4727 (and (not (eq (char-after (- (point) 2)) 4728 ?\} )) 4729 (setq qtag "Can't find })"))) 4730 (progn 4731 (goto-char (1- e)) 4732 (message qtag)) 4733 (cperl-postpone-fontification 4734 (1- tag) (1- (point)) 4735 'face font-lock-variable-name-face) 4736 (cperl-postpone-fontification 4737 REx-subgr-start (1- tag) 4738 'face my-cperl-REx-spec-char-face) 4739 (cperl-postpone-fontification 4740 (1- (point)) (point) 4741 'face my-cperl-REx-spec-char-face) 4742 (if cperl-use-syntax-table-text-property 4743 (progn 4744 (put-text-property 4745 (- (point) 2) (1- (point)) 4746 'syntax-table cperl-st-cfence) 4747 (put-text-property 4748 (+ REx-subgr-start 2) 4749 (+ REx-subgr-start 3) 4750 'syntax-table cperl-st-cfence)))) 4751 (setq was-subgr nil)) 4752 (t ; (?#)-comment 4753 ;; Inside "(" and "\" arn't special in any way 4754 ;; Works also if the outside delimiters are (). 4755 (or;;(if (eq (char-after b) ?\) ) 4756 ;;(re-search-forward 4757 ;; "[^\\\\]\\(\\\\\\\\\\)*\\\\)" 4758 ;; (1- e) 'toend) 4759 (search-forward ")" (1- e) 'toend) 4760 ;;) 4761 (message 4762 "Couldn't find end of (?#...)-comment in a REx, pos=%s" 4763 REx-subgr-start)))) 4764 (if (>= (point) e) 4765 (goto-char (1- e))) 4766 (cond 4767 (was-subgr 4768 (setq REx-subgr-end (point)) 4769 (cperl-commentify 4770 REx-subgr-start REx-subgr-end nil) 4771 (cperl-postpone-fontification 4772 REx-subgr-start REx-subgr-end 4773 'face font-lock-comment-face)))))) 4774 (if (and is-REx is-x-REx) 4775 (put-text-property (1+ b) (1- e) 4776 'syntax-subtype 'x-REx))) 4777 (if i2 4778 (progn 4779 (cperl-postpone-fontification 4780 (1- e1) e1 'face my-cperl-delimiters-face) 4781 (if (assoc (char-after b) cperl-starters) 4782 (progn 4783 (cperl-postpone-fontification 4784 b1 (1+ b1) 'face my-cperl-delimiters-face) 4785 (put-text-property b1 (1+ b1) 4786 'REx-part2 t))))) 4787 (if (> (point) max) 4788 (setq tmpend tb)))) 4789 ((match-beginning 17) ; sub with prototype or attribute 4790 ;; 1+6+2+1+1=11 extra () before this (sub with proto/attr): 4791 ;;"\\<sub\\>\\(" ;12 4792 ;; cperl-white-and-comment-rex ;13 4793 ;; "\\([a-zA-Z_:'0-9]+\\)\\)?" ; name ;14 4794 ;;"\\(" cperl-maybe-white-and-comment-rex ;15,16 4795 ;; "\\(([^()]*)\\|:[^:]\\)\\)" ; 17:proto or attribute start 4796 (setq b1 (match-beginning 14) e1 (match-end 14)) 4797 (if (memq (char-after (1- b)) 4798 '(?\$ ?\@ ?\% ?\& ?\*)) 4799 nil 4800 (goto-char b) 4801 (if (eq (char-after (match-beginning 17)) ?\( ) 4802 (progn 4803 (cperl-commentify ; Prototypes; mark as string 4804 (match-beginning 17) (match-end 17) t) 4805 (goto-char (match-end 0)) 4806 ;; Now look for attributes after prototype: 4807 (forward-comment (buffer-size)) 4808 (and (looking-at ":[^:]") 4809 (cperl-find-sub-attrs st-l b1 e1 b))) 4810 ;; treat attributes without prototype 4811 (goto-char (match-beginning 17)) 4812 (cperl-find-sub-attrs st-l b1 e1 b)))) 4813 ;; 1+6+2+1+1+6+1=18 extra () before this: 4814 ;; "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'") 4815 ((match-beginning 19) ; old $abc'efg syntax 4816 (setq bb (match-end 0)) 4817 ;;;(if (nth 3 state) nil ; in string 4818 (put-text-property (1- bb) bb 'syntax-table cperl-st-word) 4819 (goto-char bb)) 4820 ;; 1+6+2+1+1+6+1+1=19 extra () before this: 4821 ;; "__\\(END\\|DATA\\)__" 4822 ((match-beginning 20) ; __END__, __DATA__ 4823 (setq bb (match-end 0)) 4824 ;; (put-text-property b (1+ bb) 'syntax-type 'pod) ; Cheat 4825 (cperl-commentify b bb nil) 4826 (setq end t)) 4827 ;; "\\\\\\(['`\"($]\\)" 4828 ((match-beginning 21) 4829 ;; Trailing backslash; make non-quoting outside string/comment 4830 (setq bb (match-end 0)) 4831 (goto-char b) 4832 (skip-chars-backward "\\\\") 4833 ;;;(setq i2 (= (% (skip-chars-backward "\\\\") 2) -1)) 4834 (cperl-modify-syntax-type b cperl-st-punct) 4835 (goto-char bb)) 4836 (t (error "Error in regexp of the sniffer"))) 4837 (if (> (point) stop-point) 4838 (progn 4839 (if end 4840 (message "Garbage after __END__/__DATA__ ignored") 4841 (message "Unbalanced syntax found while scanning") 4842 (or (car err-l) (setcar err-l b))) 4843 (goto-char stop-point)))) 4844 (setq cperl-syntax-state (cons state-point state) 4845 ;; Do not mark syntax as done past tmpend??? 4846 cperl-syntax-done-to (or tmpend (max (point) max))) 4847 ;;(message "state-at=%s, done-to=%s" state-point cperl-syntax-done-to) 4848 ) 4849 (if (car err-l) (goto-char (car err-l)) 4850 (or non-inter 4851 (message "Scanning for \"hard\" Perl constructions... done")))) 4852 (and (buffer-modified-p) 4853 (not modified) 4854 (set-buffer-modified-p nil)) 4855 ;; I do not understand what this is doing here. It breaks font-locking 4856 ;; because it resets the syntax-table from font-lock-syntax-table to 4857 ;; cperl-mode-syntax-table. 4858 ;; (set-syntax-table cperl-mode-syntax-table) 4859 ) 4860 (list (car err-l) overshoot))) 4861 4862(defun cperl-find-pods-heres-region (min max) 4863 (interactive "r") 4864 (cperl-find-pods-heres min max)) 4865 4866(defun cperl-backward-to-noncomment (lim) 4867 ;; Stops at lim or after non-whitespace that is not in comment 4868 ;; XXXX Wrongly understands end-of-multiline strings with # as comment 4869 (let (stop p pr) 4870 (while (and (not stop) (> (point) (or lim (point-min)))) 4871 (skip-chars-backward " \t\n\f" lim) 4872 (setq p (point)) 4873 (beginning-of-line) 4874 (if (memq (setq pr (get-text-property (point) 'syntax-type)) 4875 '(pod here-doc here-doc-delim)) 4876 (cperl-unwind-to-safe nil) 4877 (or (and (looking-at "^[ \t]*\\(#\\|$\\)") 4878 (not (memq pr '(string prestring)))) 4879 (progn (cperl-to-comment-or-eol) (bolp)) 4880 (progn 4881 (skip-chars-backward " \t") 4882 (if (< p (point)) (goto-char p)) 4883 (setq stop t))))))) 4884 4885;; Used only in `cperl-calculate-indent'... 4886(defun cperl-block-p () ; Do not C-M-q ! One string contains ";" ! 4887 ;; Positions is before ?\{. Checks whether it starts a block. 4888 ;; No save-excursion! This is more a distinguisher of a block/hash ref... 4889 (cperl-backward-to-noncomment (point-min)) 4890 (or (memq (preceding-char) (append ";){}$@&%\C-@" nil)) ; Or label! \C-@ at bobp 4891 ; Label may be mixed up with `$blah :' 4892 (save-excursion (cperl-after-label)) 4893 (get-text-property (cperl-1- (point)) 'attrib-group) 4894 (and (memq (char-syntax (preceding-char)) '(?w ?_)) 4895 (progn 4896 (backward-sexp) 4897 ;; sub {BLK}, print {BLK} $data, but NOT `bless', `return', `tr' 4898 (or (and (looking-at "[a-zA-Z0-9_:]+[ \t\n\f]*[{#]") ; Method call syntax 4899 (not (looking-at "\\(bless\\|return\\|q[wqrx]?\\|tr\\|[smy]\\)\\>"))) 4900 ;; sub bless::foo {} 4901 (progn 4902 (cperl-backward-to-noncomment (point-min)) 4903 (and (eq (preceding-char) ?b) 4904 (progn 4905 (forward-sexp -1) 4906 (looking-at "sub[ \t\n\f#]"))))))))) 4907 4908;;; What is the difference of (cperl-after-block-p lim t) and (cperl-block-p)? 4909;;; No save-excursion; condition-case ... In (cperl-block-p) the block 4910;;; may be a part of an in-statement construct, such as 4911;;; ${something()}, print {FH} $data. 4912;;; Moreover, one takes positive approach (looks for else,grep etc) 4913;;; another negative (looks for bless,tr etc) 4914(defun cperl-after-block-p (lim &optional pre-block) 4915 "Return true if the preceeding } (if PRE-BLOCK, following {) delimits a block. 4916Would not look before LIM. Assumes that LIM is a good place to begin a 4917statement. The kind of block we treat here is one after which a new 4918statement would start; thus the block in ${func()} does not count." 4919 (save-excursion 4920 (condition-case nil 4921 (progn 4922 (or pre-block (forward-sexp -1)) 4923 (cperl-backward-to-noncomment lim) 4924 (or (eq (point) lim) 4925 ;; if () {} // sub f () {} // sub f :a(') {} 4926 (eq (preceding-char) ?\) ) 4927 ;; label: {} 4928 (save-excursion (cperl-after-label)) 4929 ;; sub :attr {} 4930 (get-text-property (cperl-1- (point)) 'attrib-group) 4931 (if (memq (char-syntax (preceding-char)) '(?w ?_)) ; else {} 4932 (save-excursion 4933 (forward-sexp -1) 4934 ;; else {} but not else::func {} 4935 (or (and (looking-at "\\(else\\|continue\\|grep\\|map\\|BEGIN\\|END\\|CHECK\\|INIT\\)\\>") 4936 (not (looking-at "\\(\\sw\\|_\\)+::"))) 4937 ;; sub f {} 4938 (progn 4939 (cperl-backward-to-noncomment lim) 4940 (and (eq (preceding-char) ?b) 4941 (progn 4942 (forward-sexp -1) 4943 (looking-at "sub[ \t\n\f#]")))))) 4944 ;; What preceeds is not word... XXXX Last statement in sub??? 4945 (cperl-after-expr-p lim)))) 4946 (error nil)))) 4947 4948(defun cperl-after-expr-p (&optional lim chars test) 4949 "Return true if the position is good for start of expression. 4950TEST is the expression to evaluate at the found position. If absent, 4951CHARS is a string that contains good characters to have before us (however, 4952`}' is treated \"smartly\" if it is not in the list)." 4953 (let ((lim (or lim (point-min))) 4954 stop p pr) 4955 (cperl-update-syntaxification (point) (point)) 4956 (save-excursion 4957 (while (and (not stop) (> (point) lim)) 4958 (skip-chars-backward " \t\n\f" lim) 4959 (setq p (point)) 4960 (beginning-of-line) 4961 ;;(memq (setq pr (get-text-property (point) 'syntax-type)) 4962 ;; '(pod here-doc here-doc-delim)) 4963 (if (get-text-property (point) 'here-doc-group) 4964 (progn 4965 (goto-char 4966 (cperl-beginning-of-property (point) 'here-doc-group)) 4967 (beginning-of-line 0))) 4968 (if (get-text-property (point) 'in-pod) 4969 (progn 4970 (goto-char 4971 (cperl-beginning-of-property (point) 'in-pod)) 4972 (beginning-of-line 0))) 4973 (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip 4974 ;; Else: last iteration, or a label 4975 (cperl-to-comment-or-eol) ; Will not move past "." after a format 4976 (skip-chars-backward " \t") 4977 (if (< p (point)) (goto-char p)) 4978 (setq p (point)) 4979 (if (and (eq (preceding-char) ?:) 4980 (progn 4981 (forward-char -1) 4982 (skip-chars-backward " \t\n\f" lim) 4983 (memq (char-syntax (preceding-char)) '(?w ?_)))) 4984 (forward-sexp -1) ; Possibly label. Skip it 4985 (goto-char p) 4986 (setq stop t)))) 4987 (or (bobp) ; ???? Needed 4988 (eq (point) lim) 4989 (looking-at "[ \t]*__\\(END\\|DATA\\)__") ; After this anything goes 4990 (progn 4991 (if test (eval test) 4992 (or (memq (preceding-char) (append (or chars "{;") nil)) 4993 (and (eq (preceding-char) ?\}) 4994 (cperl-after-block-p lim)) 4995 (and (eq (following-char) ?.) ; in format: see comment above 4996 (eq (get-text-property (point) 'syntax-type) 4997 'format))))))))) 4998 4999(defun cperl-backward-to-start-of-expr (&optional lim) 5000 (condition-case nil 5001 (progn 5002 (while (and (or (not lim) 5003 (> (point) lim)) 5004 (not (cperl-after-expr-p lim))) 5005 (forward-sexp -1) 5006 ;; May be after $, @, $# etc of a variable 5007 (skip-chars-backward "$@%#"))) 5008 (error nil))) 5009 5010(defun cperl-at-end-of-expr (&optional lim) 5011 ;; Since the SEXP approach below is very fragile, do some overengineering 5012 (or (looking-at (concat cperl-maybe-white-and-comment-rex "[;}]")) 5013 (condition-case nil 5014 (save-excursion 5015 ;; If nothing interesting after, does as (forward-sexp -1); 5016 ;; otherwise fails, or ends at a start of following sexp. 5017 ;; XXXX PROBLEMS: if what follows (after ";") @FOO, or ${bar} 5018 ;; may be stuck after @ or $; just put some stupid workaround now: 5019 (let ((p (point))) 5020 (forward-sexp 1) 5021 (forward-sexp -1) 5022 (while (memq (preceding-char) (append "%&@$*" nil)) 5023 (forward-char -1)) 5024 (or (< (point) p) 5025 (cperl-after-expr-p lim)))) 5026 (error t)))) 5027 5028(defun cperl-forward-to-end-of-expr (&optional lim) 5029 (let ((p (point)))) 5030 (condition-case nil 5031 (progn 5032 (while (and (< (point) (or lim (point-max))) 5033 (not (cperl-at-end-of-expr))) 5034 (forward-sexp 1))) 5035 (error nil))) 5036 5037(defun cperl-backward-to-start-of-continued-exp (lim) 5038 (if (memq (preceding-char) (append ")]}\"'`" nil)) 5039 (forward-sexp -1)) 5040 (beginning-of-line) 5041 (if (<= (point) lim) 5042 (goto-char (1+ lim))) 5043 (skip-chars-forward " \t")) 5044 5045(defun cperl-after-block-and-statement-beg (lim) 5046 ;; We assume that we are after ?\} 5047 (and 5048 (cperl-after-block-p lim) 5049 (save-excursion 5050 (forward-sexp -1) 5051 (cperl-backward-to-noncomment (point-min)) 5052 (or (bobp) 5053 (eq (point) lim) 5054 (not (= (char-syntax (preceding-char)) ?w)) 5055 (progn 5056 (forward-sexp -1) 5057 (not 5058 (looking-at 5059 "\\(map\\|grep\\|printf?\\|system\\|exec\\|tr\\|s\\)\\>"))))))) 5060 5061 5062(defun cperl-indent-exp () 5063 "Simple variant of indentation of continued-sexp. 5064 5065Will not indent comment if it starts at `comment-indent' or looks like 5066continuation of the comment on the previous line. 5067 5068If `cperl-indent-region-fix-constructs', will improve spacing on 5069conditional/loop constructs." 5070 (interactive) 5071 (save-excursion 5072 (let ((tmp-end (progn (end-of-line) (point))) top done) 5073 (save-excursion 5074 (beginning-of-line) 5075 (while (null done) 5076 (setq top (point)) 5077 ;; Plan A: if line has an unfinished paren-group, go to end-of-group 5078 (while (= -1 (nth 0 (parse-partial-sexp (point) tmp-end -1))) 5079 (setq top (point))) ; Get the outermost parenths in line 5080 (goto-char top) 5081 (while (< (point) tmp-end) 5082 (parse-partial-sexp (point) tmp-end nil t) ; To start-sexp or eol 5083 (or (eolp) (forward-sexp 1))) 5084 (if (> (point) tmp-end) ; Yes, there an unfinished block 5085 nil 5086 (if (eq ?\) (preceding-char)) 5087 (progn ;; Plan B: find by REGEXP block followup this line 5088 (setq top (point)) 5089 (condition-case nil 5090 (progn 5091 (forward-sexp -2) 5092 (if (eq (following-char) ?$ ) ; for my $var (list) 5093 (progn 5094 (forward-sexp -1) 5095 (if (looking-at "\\(my\\|local\\|our\\)\\>") 5096 (forward-sexp -1)))) 5097 (if (looking-at 5098 (concat "\\(\\elsif\\|if\\|unless\\|while\\|until" 5099 "\\|for\\(each\\)?\\>\\(\\(" 5100 cperl-maybe-white-and-comment-rex 5101 "\\(my\\|local\\|our\\)\\)?" 5102 cperl-maybe-white-and-comment-rex 5103 "\\$[_a-zA-Z0-9]+\\)?\\)\\>")) 5104 (progn 5105 (goto-char top) 5106 (forward-sexp 1) 5107 (setq top (point))))) 5108 (error (setq done t))) 5109 (goto-char top)) 5110 (if (looking-at ; Try Plan C: continuation block 5111 (concat cperl-maybe-white-and-comment-rex 5112 "\\<\\(else\\|elsif\|continue\\)\\>")) 5113 (progn 5114 (goto-char (match-end 0)) 5115 (save-excursion 5116 (end-of-line) 5117 (setq tmp-end (point)))) 5118 (setq done t)))) 5119 (save-excursion 5120 (end-of-line) 5121 (setq tmp-end (point)))) 5122 (goto-char tmp-end) 5123 (setq tmp-end (point-marker))) 5124 (if cperl-indent-region-fix-constructs 5125 (cperl-fix-line-spacing tmp-end)) 5126 (cperl-indent-region (point) tmp-end)))) 5127 5128(defun cperl-fix-line-spacing (&optional end parse-data) 5129 "Improve whitespace in a conditional/loop construct. 5130Returns some position at the last line." 5131 (interactive) 5132 (or end 5133 (setq end (point-max))) 5134 (let ((ee (save-excursion (end-of-line) (point))) 5135 (cperl-indent-region-fix-constructs 5136 (or cperl-indent-region-fix-constructs 1)) 5137 p pp ml have-brace ret) 5138 (save-excursion 5139 (beginning-of-line) 5140 (setq ret (point)) 5141 ;; }? continue 5142 ;; blah; } 5143 (if (not 5144 (or (looking-at "[ \t]*\\(els\\(e\\|if\\)\\|continue\\|if\\|while\\|for\\(each\\)?\\|until\\)") 5145 (setq have-brace (save-excursion (search-forward "}" ee t))))) 5146 nil ; Do not need to do anything 5147 ;; Looking at: 5148 ;; } 5149 ;; else 5150 (if cperl-merge-trailing-else 5151 (if (looking-at 5152 "[ \t]*}[ \t]*\n[ \t\n]*\\(els\\(e\\|if\\)\\|continue\\)\\>") 5153 (progn 5154 (search-forward "}") 5155 (setq p (point)) 5156 (skip-chars-forward " \t\n") 5157 (delete-region p (point)) 5158 (insert (make-string cperl-indent-region-fix-constructs ?\s)) 5159 (beginning-of-line))) 5160 (if (looking-at "[ \t]*}[ \t]*\\(els\\(e\\|if\\)\\|continue\\)\\>") 5161 (save-excursion 5162 (search-forward "}") 5163 (delete-horizontal-space) 5164 (insert "\n") 5165 (setq ret (point)) 5166 (if (cperl-indent-line parse-data) 5167 (progn 5168 (cperl-fix-line-spacing end parse-data) 5169 (setq ret (point))))))) 5170 ;; Looking at: 5171 ;; } else 5172 (if (looking-at "[ \t]*}\\(\t*\\|[ \t][ \t]+\\)\\<\\(els\\(e\\|if\\)\\|continue\\)\\>") 5173 (progn 5174 (search-forward "}") 5175 (delete-horizontal-space) 5176 (insert (make-string cperl-indent-region-fix-constructs ?\s)) 5177 (beginning-of-line))) 5178 ;; Looking at: 5179 ;; else { 5180 (if (looking-at 5181 "[ \t]*}?[ \t]*\\<\\(\\els\\(e\\|if\\)\\|continue\\|unless\\|if\\|while\\|for\\(each\\)?\\|until\\)\\>\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]") 5182 (progn 5183 (forward-word 1) 5184 (delete-horizontal-space) 5185 (insert (make-string cperl-indent-region-fix-constructs ?\s)) 5186 (beginning-of-line))) 5187 ;; Looking at: 5188 ;; foreach my $var 5189 (if (looking-at 5190 "[ \t]*\\<for\\(each\\)?[ \t]+\\(my\\|local\\|our\\)\\(\t*\\|[ \t][ \t]+\\)[^ \t\n]") 5191 (progn 5192 (forward-word 2) 5193 (delete-horizontal-space) 5194 (insert (make-string cperl-indent-region-fix-constructs ?\s)) 5195 (beginning-of-line))) 5196 ;; Looking at: 5197 ;; foreach my $var ( 5198 (if (looking-at 5199 "[ \t]*\\<for\\(each\\)?[ \t]+\\(my\\|local\\|our\\)[ \t]*\\$[_a-zA-Z0-9]+\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]") 5200 (progn 5201 (forward-sexp 3) 5202 (delete-horizontal-space) 5203 (insert 5204 (make-string cperl-indent-region-fix-constructs ?\s)) 5205 (beginning-of-line))) 5206 ;; Looking at (with or without "}" at start, ending after "({"): 5207 ;; } foreach my $var () OR { 5208 (if (looking-at 5209 "[ \t]*\\(}[ \t]*\\)?\\<\\(\\els\\(e\\|if\\)\\|continue\\|if\\|unless\\|while\\|for\\(each\\)?\\(\\([ \t]+\\(my\\|local\\|our\\)\\)?[ \t]*\\$[_a-zA-Z0-9]+\\)?\\|until\\)\\>\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{") 5210 (progn 5211 (setq ml (match-beginning 8)) ; "(" or "{" after control word 5212 (re-search-forward "[({]") 5213 (forward-char -1) 5214 (setq p (point)) 5215 (if (eq (following-char) ?\( ) 5216 (progn 5217 (forward-sexp 1) 5218 (setq pp (point))) ; past parenth-group 5219 ;; after `else' or nothing 5220 (if ml ; after `else' 5221 (skip-chars-backward " \t\n") 5222 (beginning-of-line)) 5223 (setq pp nil)) 5224 ;; Now after the sexp before the brace 5225 ;; Multiline expr should be special 5226 (setq ml (and pp (save-excursion (goto-char p) 5227 (search-forward "\n" pp t)))) 5228 (if (and (or (not pp) (< pp end)) ; Do not go too far... 5229 (looking-at "[ \t\n]*{")) 5230 (progn 5231 (cond 5232 ((bolp) ; Were before `{', no if/else/etc 5233 nil) 5234 ((looking-at "\\(\t*\\| [ \t]+\\){") ; Not exactly 1 SPACE 5235 (delete-horizontal-space) 5236 (if (if ml 5237 cperl-extra-newline-before-brace-multiline 5238 cperl-extra-newline-before-brace) 5239 (progn 5240 (delete-horizontal-space) 5241 (insert "\n") 5242 (setq ret (point)) 5243 (if (cperl-indent-line parse-data) 5244 (progn 5245 (cperl-fix-line-spacing end parse-data) 5246 (setq ret (point))))) 5247 (insert 5248 (make-string cperl-indent-region-fix-constructs ?\s)))) 5249 ((and (looking-at "[ \t]*\n") 5250 (not (if ml 5251 cperl-extra-newline-before-brace-multiline 5252 cperl-extra-newline-before-brace))) 5253 (setq pp (point)) 5254 (skip-chars-forward " \t\n") 5255 (delete-region pp (point)) 5256 (insert 5257 (make-string cperl-indent-region-fix-constructs ?\ ))) 5258 ((and (looking-at "[\t ]*{") 5259 (if ml cperl-extra-newline-before-brace-multiline 5260 cperl-extra-newline-before-brace)) 5261 (delete-horizontal-space) 5262 (insert "\n") 5263 (setq ret (point)) 5264 (if (cperl-indent-line parse-data) 5265 (progn 5266 (cperl-fix-line-spacing end parse-data) 5267 (setq ret (point)))))) 5268 ;; Now we are before `{' 5269 (if (looking-at "[ \t\n]*{[ \t]*[^ \t\n#]") 5270 (progn 5271 (skip-chars-forward " \t\n") 5272 (setq pp (point)) 5273 (forward-sexp 1) 5274 (setq p (point)) 5275 (goto-char pp) 5276 (setq ml (search-forward "\n" p t)) 5277 (if (or cperl-break-one-line-blocks-when-indent ml) 5278 ;; not good: multi-line BLOCK 5279 (progn 5280 (goto-char (1+ pp)) 5281 (delete-horizontal-space) 5282 (insert "\n") 5283 (setq ret (point)) 5284 (if (cperl-indent-line parse-data) 5285 (setq ret (cperl-fix-line-spacing end parse-data))))))))))) 5286 (beginning-of-line) 5287 (setq p (point) pp (save-excursion (end-of-line) (point))) ; May be different from ee. 5288 ;; Now check whether there is a hanging `}' 5289 ;; Looking at: 5290 ;; } blah 5291 (if (and 5292 cperl-fix-hanging-brace-when-indent 5293 have-brace 5294 (not (looking-at "[ \t]*}[ \t]*\\(\\<\\(els\\(if\\|e\\)\\|continue\\|while\\|until\\)\\>\\|$\\|#\\)")) 5295 (condition-case nil 5296 (progn 5297 (up-list 1) 5298 (if (and (<= (point) pp) 5299 (eq (preceding-char) ?\} ) 5300 (cperl-after-block-and-statement-beg (point-min))) 5301 t 5302 (goto-char p) 5303 nil)) 5304 (error nil))) 5305 (progn 5306 (forward-char -1) 5307 (skip-chars-backward " \t") 5308 (if (bolp) 5309 ;; `}' was the first thing on the line, insert NL *after* it. 5310 (progn 5311 (cperl-indent-line parse-data) 5312 (search-forward "}") 5313 (delete-horizontal-space) 5314 (insert "\n")) 5315 (delete-horizontal-space) 5316 (or (eq (preceding-char) ?\;) 5317 (bolp) 5318 (and (eq (preceding-char) ?\} ) 5319 (cperl-after-block-p (point-min))) 5320 (insert ";")) 5321 (insert "\n") 5322 (setq ret (point))) 5323 (if (cperl-indent-line parse-data) 5324 (setq ret (cperl-fix-line-spacing end parse-data))) 5325 (beginning-of-line))))) 5326 ret)) 5327 5328(defvar cperl-update-start) ; Do not need to make them local 5329(defvar cperl-update-end) 5330(defun cperl-delay-update-hook (beg end old-len) 5331 (setq cperl-update-start (min beg (or cperl-update-start (point-max)))) 5332 (setq cperl-update-end (max end (or cperl-update-end (point-min))))) 5333 5334(defun cperl-indent-region (start end) 5335 "Simple variant of indentation of region in CPerl mode. 5336Should be slow. Will not indent comment if it starts at `comment-indent' 5337or looks like continuation of the comment on the previous line. 5338Indents all the lines whose first character is between START and END 5339inclusive. 5340 5341If `cperl-indent-region-fix-constructs', will improve spacing on 5342conditional/loop constructs." 5343 (interactive "r") 5344 (cperl-update-syntaxification end end) 5345 (save-excursion 5346 (let (cperl-update-start cperl-update-end (h-a-c after-change-functions)) 5347 (let ((indent-info (if cperl-emacs-can-parse 5348 (list nil nil nil) ; Cannot use '(), since will modify 5349 nil)) 5350 (pm 0) 5351 after-change-functions ; Speed it up! 5352 st comm old-comm-indent new-comm-indent p pp i empty) 5353 (if h-a-c (add-hook 'after-change-functions 'cperl-delay-update-hook)) 5354 (goto-char start) 5355 (setq old-comm-indent (and (cperl-to-comment-or-eol) 5356 (current-column)) 5357 new-comm-indent old-comm-indent) 5358 (goto-char start) 5359 (setq end (set-marker (make-marker) end)) ; indentation changes pos 5360 (or (bolp) (beginning-of-line 2)) 5361 (while (and (<= (point) end) (not (eobp))) ; bol to check start 5362 (setq st (point)) 5363 (if (or 5364 (setq empty (looking-at "[ \t]*\n")) 5365 (and (setq comm (looking-at "[ \t]*#")) 5366 (or (eq (current-indentation) (or old-comm-indent 5367 comment-column)) 5368 (setq old-comm-indent nil)))) 5369 (if (and old-comm-indent 5370 (not empty) 5371 (= (current-indentation) old-comm-indent) 5372 (not (eq (get-text-property (point) 'syntax-type) 'pod)) 5373 (not (eq (get-text-property (point) 'syntax-table) 5374 cperl-st-cfence))) 5375 (let ((comment-column new-comm-indent)) 5376 (indent-for-comment))) 5377 (progn 5378 (setq i (cperl-indent-line indent-info)) 5379 (or comm 5380 (not i) 5381 (progn 5382 (if cperl-indent-region-fix-constructs 5383 (goto-char (cperl-fix-line-spacing end indent-info))) 5384 (if (setq old-comm-indent 5385 (and (cperl-to-comment-or-eol) 5386 (not (memq (get-text-property (point) 5387 'syntax-type) 5388 '(pod here-doc))) 5389 (not (eq (get-text-property (point) 5390 'syntax-table) 5391 cperl-st-cfence)) 5392 (current-column))) 5393 (progn (indent-for-comment) 5394 (skip-chars-backward " \t") 5395 (skip-chars-backward "#") 5396 (setq new-comm-indent (current-column)))))))) 5397 (beginning-of-line 2))) 5398 ;; Now run the update hooks 5399 (and after-change-functions 5400 cperl-update-end 5401 (save-excursion 5402 (goto-char cperl-update-end) 5403 (insert " ") 5404 (delete-char -1) 5405 (goto-char cperl-update-start) 5406 (insert " ") 5407 (delete-char -1)))))) 5408 5409;; Stolen from lisp-mode with a lot of improvements 5410 5411(defun cperl-fill-paragraph (&optional justify iteration) 5412 "Like `fill-paragraph', but handle CPerl comments. 5413If any of the current line is a comment, fill the comment or the 5414block of it that point is in, preserving the comment's initial 5415indentation and initial hashes. Behaves usually outside of comment." 5416 ;; (interactive "P") ; Only works when called from fill-paragraph. -stef 5417 (let (;; Non-nil if the current line contains a comment. 5418 has-comment 5419 fill-paragraph-function ; do not recurse 5420 ;; If has-comment, the appropriate fill-prefix for the comment. 5421 comment-fill-prefix 5422 ;; Line that contains code and comment (or nil) 5423 start 5424 c spaces len dc (comment-column comment-column)) 5425 ;; Figure out what kind of comment we are looking at. 5426 (save-excursion 5427 (beginning-of-line) 5428 (cond 5429 5430 ;; A line with nothing but a comment on it? 5431 ((looking-at "[ \t]*#[# \t]*") 5432 (setq has-comment t 5433 comment-fill-prefix (buffer-substring (match-beginning 0) 5434 (match-end 0)))) 5435 5436 ;; A line with some code, followed by a comment? Remember that the 5437 ;; semi which starts the comment shouldn't be part of a string or 5438 ;; character. 5439 ((cperl-to-comment-or-eol) 5440 (setq has-comment t) 5441 (looking-at "#+[ \t]*") 5442 (setq start (point) c (current-column) 5443 comment-fill-prefix 5444 (concat (make-string (current-column) ?\s) 5445 (buffer-substring (match-beginning 0) (match-end 0))) 5446 spaces (progn (skip-chars-backward " \t") 5447 (buffer-substring (point) start)) 5448 dc (- c (current-column)) len (- start (point)) 5449 start (point-marker)) 5450 (delete-char len) 5451 (insert (make-string dc ?-))))) ; Placeholder (to avoid splitting???) 5452 (if (not has-comment) 5453 (fill-paragraph justify) ; Do the usual thing outside of comment 5454 ;; Narrow to include only the comment, and then fill the region. 5455 (save-restriction 5456 (narrow-to-region 5457 ;; Find the first line we should include in the region to fill. 5458 (if start (progn (beginning-of-line) (point)) 5459 (save-excursion 5460 (while (and (zerop (forward-line -1)) 5461 (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]"))) 5462 ;; We may have gone to far. Go forward again. 5463 (or (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]") 5464 (forward-line 1)) 5465 (point))) 5466 ;; Find the beginning of the first line past the region to fill. 5467 (save-excursion 5468 (while (progn (forward-line 1) 5469 (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]"))) 5470 (point))) 5471 ;; Remove existing hashes 5472 (save-excursion 5473 (goto-char (point-min)) 5474 (while (progn (forward-line 1) (< (point) (point-max))) 5475 (skip-chars-forward " \t") 5476 (if (looking-at "#+") 5477 (progn 5478 (if (and (eq (point) (match-beginning 0)) 5479 (not (eq (point) (match-end 0)))) nil 5480 (error 5481 "Bug in Emacs: `looking-at' in `narrow-to-region': match-data is garbage")) 5482 (delete-char (- (match-end 0) (match-beginning 0))))))) 5483 5484 ;; Lines with only hashes on them can be paragraph boundaries. 5485 (let ((paragraph-start (concat paragraph-start "\\|^[ \t#]*$")) 5486 (paragraph-separate (concat paragraph-start "\\|^[ \t#]*$")) 5487 (fill-prefix comment-fill-prefix)) 5488 (fill-paragraph justify))) 5489 (if (and start) 5490 (progn 5491 (goto-char start) 5492 (if (> dc 0) 5493 (progn (delete-char dc) (insert spaces))) 5494 (if (or (= (current-column) c) iteration) nil 5495 (setq comment-column c) 5496 (indent-for-comment) 5497 ;; Repeat once more, flagging as iteration 5498 (cperl-fill-paragraph justify t)))))) 5499 t) 5500 5501(defun cperl-do-auto-fill () 5502 ;; Break out if the line is short enough 5503 (if (> (save-excursion 5504 (end-of-line) 5505 (current-column)) 5506 fill-column) 5507 (let ((c (save-excursion (beginning-of-line) 5508 (cperl-to-comment-or-eol) (point))) 5509 (s (memq (following-char) '(?\s ?\t))) marker) 5510 (if (>= c (point)) 5511 ;; Don't break line inside code: only inside comment. 5512 nil 5513 (setq marker (point-marker)) 5514 (fill-paragraph nil) 5515 (goto-char marker) 5516 ;; Is not enough, sometimes marker is a start of line 5517 (if (bolp) (progn (re-search-forward "#+[ \t]*") 5518 (goto-char (match-end 0)))) 5519 ;; Following space could have gone: 5520 (if (or (not s) (memq (following-char) '(?\s ?\t))) nil 5521 (insert " ") 5522 (backward-char 1)) 5523 ;; Previous space could have gone: 5524 (or (memq (preceding-char) '(?\s ?\t)) (insert " ")))))) 5525 5526(defun cperl-imenu-addback (lst &optional isback name) 5527 ;; We suppose that the lst is a DAG, unless the first element only 5528 ;; loops back, and ISBACK is set. Thus this function cannot be 5529 ;; applied twice without ISBACK set. 5530 (cond ((not cperl-imenu-addback) lst) 5531 (t 5532 (or name 5533 (setq name "+++BACK+++")) 5534 (mapcar (lambda (elt) 5535 (if (and (listp elt) (listp (cdr elt))) 5536 (progn 5537 ;; In the other order it goes up 5538 ;; one level only ;-( 5539 (setcdr elt (cons (cons name lst) 5540 (cdr elt))) 5541 (cperl-imenu-addback (cdr elt) t name)))) 5542 (if isback (cdr lst) lst)) 5543 lst))) 5544 5545(defun cperl-imenu--create-perl-index (&optional regexp) 5546 (require 'imenu) ; May be called from TAGS creator 5547 (let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '()) 5548 (index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function)) 5549 (index-meth-alist '()) meth 5550 packages ends-ranges p marker is-proto 5551 (prev-pos 0) is-pack index index1 name (end-range 0) package) 5552 (goto-char (point-min)) 5553 (cperl-update-syntaxification (point-max) (point-max)) 5554 ;; Search for the function 5555 (progn ;;save-match-data 5556 (while (re-search-forward 5557 (or regexp cperl-imenu--function-name-regexp-perl) 5558 nil t) 5559 ;; 2=package-group, 5=package-name 8=sub-name 5560 (cond 5561 ((and ; Skip some noise if building tags 5562 (match-beginning 5) ; package name 5563 ;;(eq (char-after (match-beginning 2)) ?p) ; package 5564 (not (save-match-data 5565 (looking-at "[ \t\n]*;")))) ; Plain text word 'package' 5566 nil) 5567 ((and 5568 (or (match-beginning 2) 5569 (match-beginning 8)) ; package or sub 5570 ;; Skip if quoted (will not skip multi-line ''-strings :-(): 5571 (null (get-text-property (match-beginning 1) 'syntax-table)) 5572 (null (get-text-property (match-beginning 1) 'syntax-type)) 5573 (null (get-text-property (match-beginning 1) 'in-pod))) 5574 (setq is-pack (match-beginning 2)) 5575 ;; (if (looking-at "([^()]*)[ \t\n\f]*") 5576 ;; (goto-char (match-end 0))) ; Messes what follows 5577 (setq meth nil 5578 p (point)) 5579 (while (and ends-ranges (>= p (car ends-ranges))) 5580 ;; delete obsolete entries 5581 (setq ends-ranges (cdr ends-ranges) packages (cdr packages))) 5582 (setq package (or (car packages) "") 5583 end-range (or (car ends-ranges) 0)) 5584 (if is-pack ; doing "package" 5585 (progn 5586 (if (match-beginning 5) ; named package 5587 (setq name (buffer-substring (match-beginning 5) 5588 (match-end 5)) 5589 name (progn 5590 (set-text-properties 0 (length name) nil name) 5591 name) 5592 package (concat name "::") 5593 name (concat "package " name)) 5594 ;; Support nameless packages 5595 (setq name "package;" package "")) 5596 (setq end-range 5597 (save-excursion 5598 (parse-partial-sexp (point) (point-max) -1) (point)) 5599 ends-ranges (cons end-range ends-ranges) 5600 packages (cons package packages))) 5601 (setq is-proto 5602 (or (eq (following-char) ?\;) 5603 (eq 0 (get-text-property (point) 'attrib-group))))) 5604 ;; Skip this function name if it is a prototype declaration. 5605 (if (and is-proto (not is-pack)) nil 5606 (or is-pack 5607 (setq name 5608 (buffer-substring (match-beginning 8) (match-end 8))) 5609 (set-text-properties 0 (length name) nil name)) 5610 (setq marker (make-marker)) 5611 (set-marker marker (match-end (if is-pack 2 8))) 5612 (cond (is-pack nil) 5613 ((string-match "[:']" name) 5614 (setq meth t)) 5615 ((> p end-range) nil) 5616 (t 5617 (setq name (concat package name) meth t))) 5618 (setq index (cons name marker)) 5619 (if is-pack 5620 (push index index-pack-alist) 5621 (push index index-alist)) 5622 (if meth (push index index-meth-alist)) 5623 (push index index-unsorted-alist))) 5624 ((match-beginning 16) ; POD section 5625 (setq name (buffer-substring (match-beginning 17) (match-end 17)) 5626 marker (make-marker)) 5627 (set-marker marker (match-beginning 17)) 5628 (set-text-properties 0 (length name) nil name) 5629 (setq name (concat (make-string 5630 (* 3 (- (char-after (match-beginning 16)) ?1)) 5631 ?\ ) 5632 name) 5633 index (cons name marker)) 5634 (setq index1 (cons (concat "=" name) (cdr index))) 5635 (push index index-pod-alist) 5636 (push index1 index-unsorted-alist))))) 5637 (setq index-alist 5638 (if (default-value 'imenu-sort-function) 5639 (sort index-alist (default-value 'imenu-sort-function)) 5640 (nreverse index-alist))) 5641 (and index-pod-alist 5642 (push (cons "+POD headers+..." 5643 (nreverse index-pod-alist)) 5644 index-alist)) 5645 (and (or index-pack-alist index-meth-alist) 5646 (let ((lst index-pack-alist) hier-list pack elt group name) 5647 ;; Remove "package ", reverse and uniquify. 5648 (while lst 5649 (setq elt (car lst) lst (cdr lst) name (substring (car elt) 8)) 5650 (if (assoc name hier-list) nil 5651 (setq hier-list (cons (cons name (cdr elt)) hier-list)))) 5652 (setq lst index-meth-alist) 5653 (while lst 5654 (setq elt (car lst) lst (cdr lst)) 5655 (cond ((string-match "\\(::\\|'\\)[_a-zA-Z0-9]+$" (car elt)) 5656 (setq pack (substring (car elt) 0 (match-beginning 0))) 5657 (if (setq group (assoc pack hier-list)) 5658 (if (listp (cdr group)) 5659 ;; Have some functions already 5660 (setcdr group 5661 (cons (cons (substring 5662 (car elt) 5663 (+ 2 (match-beginning 0))) 5664 (cdr elt)) 5665 (cdr group))) 5666 (setcdr group (list (cons (substring 5667 (car elt) 5668 (+ 2 (match-beginning 0))) 5669 (cdr elt))))) 5670 (setq hier-list 5671 (cons (cons pack 5672 (list (cons (substring 5673 (car elt) 5674 (+ 2 (match-beginning 0))) 5675 (cdr elt)))) 5676 hier-list)))))) 5677 (push (cons "+Hierarchy+..." 5678 hier-list) 5679 index-alist))) 5680 (and index-pack-alist 5681 (push (cons "+Packages+..." 5682 (nreverse index-pack-alist)) 5683 index-alist)) 5684 (and (or index-pack-alist index-pod-alist 5685 (default-value 'imenu-sort-function)) 5686 index-unsorted-alist 5687 (push (cons "+Unsorted List+..." 5688 (nreverse index-unsorted-alist)) 5689 index-alist)) 5690 (cperl-imenu-addback index-alist))) 5691 5692 5693;; Suggested by Mark A. Hershberger 5694(defun cperl-outline-level () 5695 (looking-at outline-regexp) 5696 (cond ((not (match-beginning 1)) 0) ; beginning-of-file 5697;;;; 2=package-group, 5=package-name 8=sub-name 16=head-level 5698 ((match-beginning 2) 0) ; package 5699 ((match-beginning 8) 1) ; sub 5700 ((match-beginning 16) 5701 (- (char-after (match-beginning 16)) ?0)) ; headN ==> N 5702 (t 5))) ; should not happen 5703 5704 5705(defvar cperl-compilation-error-regexp-alist 5706 ;; This look like a paranoiac regexp: could anybody find a better one? (which WORKS). 5707 '(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]" 5708 2 3)) 5709 "Alist that specifies how to match errors in perl output.") 5710 5711 5712(defun cperl-windowed-init () 5713 "Initialization under windowed version." 5714 (cond ((featurep 'ps-print) 5715 (unless cperl-faces-init 5716 (if (boundp 'font-lock-multiline) 5717 (setq cperl-font-lock-multiline t)) 5718 (cperl-init-faces))) 5719 ((not cperl-faces-init) 5720 (add-hook 'font-lock-mode-hook 5721 (function 5722 (lambda () 5723 (if (memq major-mode '(perl-mode cperl-mode)) 5724 (progn 5725 (or cperl-faces-init (cperl-init-faces))))))) 5726 (if (fboundp 'eval-after-load) 5727 (eval-after-load 5728 "ps-print" 5729 '(or cperl-faces-init (cperl-init-faces))))))) 5730 5731(defvar cperl-font-lock-keywords-1 nil 5732 "Additional expressions to highlight in Perl mode. Minimal set.") 5733(defvar cperl-font-lock-keywords nil 5734 "Additional expressions to highlight in Perl mode. Default set.") 5735(defvar cperl-font-lock-keywords-2 nil 5736 "Additional expressions to highlight in Perl mode. Maximal set") 5737 5738(defun cperl-load-font-lock-keywords () 5739 (or cperl-faces-init (cperl-init-faces)) 5740 cperl-font-lock-keywords) 5741 5742(defun cperl-load-font-lock-keywords-1 () 5743 (or cperl-faces-init (cperl-init-faces)) 5744 cperl-font-lock-keywords-1) 5745 5746(defun cperl-load-font-lock-keywords-2 () 5747 (or cperl-faces-init (cperl-init-faces)) 5748 cperl-font-lock-keywords-2) 5749 5750(defun cperl-init-faces-weak () 5751 ;; Allow `cperl-find-pods-heres' to run. 5752 (or (boundp 'font-lock-constant-face) 5753 (cperl-force-face font-lock-constant-face 5754 "Face for constant and label names")) 5755 (or (boundp 'font-lock-warning-face) 5756 (cperl-force-face font-lock-warning-face 5757 "Face for things which should stand out")) 5758 ;;(setq font-lock-constant-face 'font-lock-constant-face) 5759 ) 5760 5761(defun cperl-init-faces () 5762 (condition-case errs 5763 (progn 5764 (require 'font-lock) 5765 (and (fboundp 'font-lock-fontify-anchored-keywords) 5766 (featurep 'font-lock-extra) 5767 (message "You have an obsolete package `font-lock-extra'. Install `choose-color'.")) 5768 (let (t-font-lock-keywords t-font-lock-keywords-1 font-lock-anchored) 5769 (if (fboundp 'font-lock-fontify-anchored-keywords) 5770 (setq font-lock-anchored t)) 5771 (setq 5772 t-font-lock-keywords 5773 (list 5774 `("[ \t]+$" 0 ',cperl-invalid-face t) 5775 (cons 5776 (concat 5777 "\\(^\\|[^$@%&\\]\\)\\<\\(" 5778 (mapconcat 5779 'identity 5780 '("if" "until" "while" "elsif" "else" "unless" "for" 5781 "foreach" "continue" "exit" "die" "last" "goto" "next" 5782 "redo" "return" "local" "exec" "sub" "do" "dump" "use" "our" 5783 "require" "package" "eval" "my" "BEGIN" "END" "CHECK" "INIT") 5784 "\\|") ; Flow control 5785 "\\)\\>") 2) ; was "\\)[ \n\t;():,\|&]" 5786 ; In what follows we use `type' style 5787 ; for overwritable builtins 5788 (list 5789 (concat 5790 "\\(^\\|[^$@%&\\]\\)\\<\\(" 5791 ;; "CORE" "__FILE__" "__LINE__" "abs" "accept" "alarm" 5792 ;; "and" "atan2" "bind" "binmode" "bless" "caller" 5793 ;; "chdir" "chmod" "chown" "chr" "chroot" "close" 5794 ;; "closedir" "cmp" "connect" "continue" "cos" "crypt" 5795 ;; "dbmclose" "dbmopen" "die" "dump" "endgrent" 5796 ;; "endhostent" "endnetent" "endprotoent" "endpwent" 5797 ;; "endservent" "eof" "eq" "exec" "exit" "exp" "fcntl" 5798 ;; "fileno" "flock" "fork" "formline" "ge" "getc" 5799 ;; "getgrent" "getgrgid" "getgrnam" "gethostbyaddr" 5800 ;; "gethostbyname" "gethostent" "getlogin" 5801 ;; "getnetbyaddr" "getnetbyname" "getnetent" 5802 ;; "getpeername" "getpgrp" "getppid" "getpriority" 5803 ;; "getprotobyname" "getprotobynumber" "getprotoent" 5804 ;; "getpwent" "getpwnam" "getpwuid" "getservbyname" 5805 ;; "getservbyport" "getservent" "getsockname" 5806 ;; "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int" 5807 ;; "ioctl" "join" "kill" "lc" "lcfirst" "le" "length" 5808 ;; "link" "listen" "localtime" "lock" "log" "lstat" "lt" 5809 ;; "mkdir" "msgctl" "msgget" "msgrcv" "msgsnd" "ne" 5810 ;; "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe" 5811 ;; "quotemeta" "rand" "read" "readdir" "readline" 5812 ;; "readlink" "readpipe" "recv" "ref" "rename" "require" 5813 ;; "reset" "reverse" "rewinddir" "rindex" "rmdir" "seek" 5814 ;; "seekdir" "select" "semctl" "semget" "semop" "send" 5815 ;; "setgrent" "sethostent" "setnetent" "setpgrp" 5816 ;; "setpriority" "setprotoent" "setpwent" "setservent" 5817 ;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite" 5818 ;; "shutdown" "sin" "sleep" "socket" "socketpair" 5819 ;; "sprintf" "sqrt" "srand" "stat" "substr" "symlink" 5820 ;; "syscall" "sysopen" "sysread" "system" "syswrite" "tell" 5821 ;; "telldir" "time" "times" "truncate" "uc" "ucfirst" 5822 ;; "umask" "unlink" "unpack" "utime" "values" "vec" 5823 ;; "wait" "waitpid" "wantarray" "warn" "write" "x" "xor" 5824 "a\\(bs\\|ccept\\|tan2\\|larm\\|nd\\)\\|" 5825 "b\\(in\\(d\\|mode\\)\\|less\\)\\|" 5826 "c\\(h\\(r\\(\\|oot\\)\\|dir\\|mod\\|own\\)\\|aller\\|rypt\\|" 5827 "lose\\(\\|dir\\)\\|mp\\|o\\(s\\|n\\(tinue\\|nect\\)\\)\\)\\|" 5828 "CORE\\|d\\(ie\\|bm\\(close\\|open\\)\\|ump\\)\\|" 5829 "e\\(x\\(p\\|it\\|ec\\)\\|q\\|nd\\(p\\(rotoent\\|went\\)\\|" 5830 "hostent\\|servent\\|netent\\|grent\\)\\|of\\)\\|" 5831 "f\\(ileno\\|cntl\\|lock\\|or\\(k\\|mline\\)\\)\\|" 5832 "g\\(t\\|lob\\|mtime\\|e\\(\\|t\\(p\\(pid\\|r\\(iority\\|" 5833 "oto\\(byn\\(ame\\|umber\\)\\|ent\\)\\)\\|eername\\|w" 5834 "\\(uid\\|ent\\|nam\\)\\|grp\\)\\|host\\(by\\(addr\\|name\\)\\|" 5835 "ent\\)\\|s\\(erv\\(by\\(port\\|name\\)\\|ent\\)\\|" 5836 "ock\\(name\\|opt\\)\\)\\|c\\|login\\|net\\(by\\(addr\\|name\\)\\|" 5837 "ent\\)\\|gr\\(ent\\|nam\\|gid\\)\\)\\)\\)\\|" 5838 "hex\\|i\\(n\\(t\\|dex\\)\\|octl\\)\\|join\\|kill\\|" 5839 "l\\(i\\(sten\\|nk\\)\\|stat\\|c\\(\\|first\\)\\|t\\|e" 5840 "\\(\\|ngth\\)\\|o\\(c\\(altime\\|k\\)\\|g\\)\\)\\|m\\(sg\\(rcv\\|snd\\|" 5841 "ctl\\|get\\)\\|kdir\\)\\|n\\(e\\|ot\\)\\|o\\(pen\\(\\|dir\\)\\|" 5842 "r\\(\\|d\\)\\|ct\\)\\|p\\(ipe\\|ack\\)\\|quotemeta\\|" 5843 "r\\(index\\|and\\|mdir\\|e\\(quire\\|ad\\(pipe\\|\\|lin" 5844 "\\(k\\|e\\)\\|dir\\)\\|set\\|cv\\|verse\\|f\\|winddir\\|name" 5845 "\\)\\)\\|s\\(printf\\|qrt\\|rand\\|tat\\|ubstr\\|e\\(t\\(p\\(r" 5846 "\\(iority\\|otoent\\)\\|went\\|grp\\)\\|hostent\\|s\\(ervent\\|" 5847 "ockopt\\)\\|netent\\|grent\\)\\|ek\\(\\|dir\\)\\|lect\\|" 5848 "m\\(ctl\\|op\\|get\\)\\|nd\\)\\|h\\(utdown\\|m\\(read\\|ctl\\|" 5849 "write\\|get\\)\\)\\|y\\(s\\(read\\|call\\|open\\|tem\\|write\\)\\|" 5850 "mlink\\)\\|in\\|leep\\|ocket\\(pair\\|\\)\\)\\|t\\(runcate\\|" 5851 "ell\\(\\|dir\\)\\|ime\\(\\|s\\)\\)\\|u\\(c\\(\\|first\\)\\|" 5852 "time\\|mask\\|n\\(pack\\|link\\)\\)\\|v\\(alues\\|ec\\)\\|" 5853 "w\\(a\\(rn\\|it\\(pid\\|\\)\\|ntarray\\)\\|rite\\)\\|" 5854 "x\\(\\|or\\)\\|__\\(FILE__\\|LINE__\\|PACKAGE__\\)" 5855 "\\)\\>") 2 'font-lock-type-face) 5856 ;; In what follows we use `other' style 5857 ;; for nonoverwritable builtins 5858 ;; Somehow 's', 'm' are not auto-generated??? 5859 (list 5860 (concat 5861 "\\(^\\|[^$@%&\\]\\)\\<\\(" 5862 ;; "AUTOLOAD" "BEGIN" "CHECK" "DESTROY" "END" "INIT" "__END__" "chomp" 5863 ;; "chop" "defined" "delete" "do" "each" "else" "elsif" 5864 ;; "eval" "exists" "for" "foreach" "format" "goto" 5865 ;; "grep" "if" "keys" "last" "local" "map" "my" "next" 5866 ;; "no" "our" "package" "pop" "pos" "print" "printf" "push" 5867 ;; "q" "qq" "qw" "qx" "redo" "return" "scalar" "shift" 5868 ;; "sort" "splice" "split" "study" "sub" "tie" "tr" 5869 ;; "undef" "unless" "unshift" "untie" "until" "use" 5870 ;; "while" "y" 5871 "AUTOLOAD\\|BEGIN\\|CHECK\\|cho\\(p\\|mp\\)\\|d\\(e\\(fined\\|lete\\)\\|" 5872 "o\\)\\|DESTROY\\|e\\(ach\\|val\\|xists\\|ls\\(e\\|if\\)\\)\\|" 5873 "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|INIT\\|if\\|keys\\|" 5874 "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|our\\|" 5875 "p\\(ackage\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|" 5876 "q\\(\\|q\\|w\\|x\\|r\\)\\|re\\(turn\\|do\\)\\|s\\(pli\\(ce\\|t\\)\\|" 5877 "calar\\|tudy\\|ub\\|hift\\|ort\\)\\|t\\(r\\|ie\\)\\|" 5878 "u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|" 5879 "while\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually 5880 "\\|[sm]" ; Added manually 5881 "\\)\\>") 2 'cperl-nonoverridable-face) 5882 ;; (mapconcat 'identity 5883 ;; '("#endif" "#else" "#ifdef" "#ifndef" "#if" 5884 ;; "#include" "#define" "#undef") 5885 ;; "\\|") 5886 '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0 5887 font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]" 5888 ;; This highlights declarations and definitions differenty. 5889 ;; We do not try to highlight in the case of attributes: 5890 ;; it is already done by `cperl-find-pods-heres' 5891 (list (concat "\\<sub" 5892 cperl-white-and-comment-rex ; whitespace/comments 5893 "\\([^ \n\t{;()]+\\)" ; 2=name (assume non-anonymous) 5894 "\\(" 5895 cperl-maybe-white-and-comment-rex ;whitespace/comments? 5896 "([^()]*)\\)?" ; prototype 5897 cperl-maybe-white-and-comment-rex ; whitespace/comments? 5898 "[{;]") 5899 2 (if cperl-font-lock-multiline 5900 '(if (eq (char-after (cperl-1- (match-end 0))) ?\{ ) 5901 'font-lock-function-name-face 5902 'font-lock-variable-name-face) 5903 ;; need to manually set 'multiline' for older font-locks 5904 '(progn 5905 (if (< 1 (count-lines (match-beginning 0) 5906 (match-end 0))) 5907 (put-text-property 5908 (+ 3 (match-beginning 0)) (match-end 0) 5909 'syntax-type 'multiline)) 5910 (if (eq (char-after (cperl-1- (match-end 0))) ?\{ ) 5911 'font-lock-function-name-face 5912 'font-lock-variable-name-face)))) 5913 '("\\<\\(package\\|require\\|use\\|import\\|no\\|bootstrap\\)[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t;]" ; require A if B; 5914 2 font-lock-function-name-face) 5915 '("^[ \t]*format[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t]*=[ \t]*$" 5916 1 font-lock-function-name-face) 5917 (cond ((featurep 'font-lock-extra) 5918 '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" 5919 (2 font-lock-string-face t) 5920 (0 '(restart 2 t)))) ; To highlight $a{bc}{ef} 5921 (font-lock-anchored 5922 '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" 5923 (2 font-lock-string-face t) 5924 ("\\=[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" 5925 nil nil 5926 (1 font-lock-string-face t)))) 5927 (t '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" 5928 2 font-lock-string-face t))) 5929 '("[\[ \t{,(]\\(-?[a-zA-Z0-9_:]+\\)[ \t]*=>" 1 5930 font-lock-string-face t) 5931 '("^[ \t]*\\([a-zA-Z0-9_]+[ \t]*:\\)[ \t]*\\($\\|{\\|\\<\\(until\\|while\\|for\\(each\\)?\\|do\\)\\>\\)" 1 5932 font-lock-constant-face) ; labels 5933 '("\\<\\(continue\\|next\\|last\\|redo\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets 5934 2 font-lock-constant-face) 5935 ;; Uncomment to get perl-mode-like vars 5936 ;;; '("[$*]{?\\(\\sw+\\)" 1 font-lock-variable-name-face) 5937 ;;; '("\\([@%]\\|\\$#\\)\\(\\sw+\\)" 5938 ;;; (2 (cons font-lock-variable-name-face '(underline)))) 5939 (cond ((featurep 'font-lock-extra) 5940 '("^[ \t]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" 5941 (3 font-lock-variable-name-face) 5942 (4 '(another 4 nil 5943 ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" 5944 (1 font-lock-variable-name-face) 5945 (2 '(restart 2 nil) nil t))) 5946 nil t))) ; local variables, multiple 5947 (font-lock-anchored 5948 ;; 1=my_etc, 2=white? 3=(+white? 4=white? 5=var 5949 (` ((, (concat "\\<\\(my\\|local\\|our\\)" 5950 cperl-maybe-white-and-comment-rex 5951 "\\((" 5952 cperl-maybe-white-and-comment-rex 5953 "\\)?\\([$@%*]\\([a-zA-Z0-9_:]+\\|[^a-zA-Z0-9_]\\)\\)")) 5954 (5 (, (if cperl-font-lock-multiline 5955 'font-lock-variable-name-face 5956 '(progn (setq cperl-font-lock-multiline-start 5957 (match-beginning 0)) 5958 'font-lock-variable-name-face)))) 5959 ((, (concat "\\=" 5960 cperl-maybe-white-and-comment-rex 5961 "," 5962 cperl-maybe-white-and-comment-rex 5963 "\\([$@%*]\\([a-zA-Z0-9_:]+\\|[^a-zA-Z0-9_]\\)\\)")) 5964 ;; Bug in font-lock: limit is used not only to limit 5965 ;; searches, but to set the "extend window for 5966 ;; facification" property. Thus we need to minimize. 5967 (, (if cperl-font-lock-multiline 5968 '(if (match-beginning 3) 5969 (save-excursion 5970 (goto-char (match-beginning 3)) 5971 (condition-case nil 5972 (forward-sexp 1) 5973 (error 5974 (condition-case nil 5975 (forward-char 200) 5976 (error nil)))) ; typeahead 5977 (1- (point))) ; report limit 5978 (forward-char -2)) ; disable continued expr 5979 '(if (match-beginning 3) 5980 (point-max) ; No limit for continuation 5981 (forward-char -2)))) ; disable continued expr 5982 (, (if cperl-font-lock-multiline 5983 nil 5984 '(progn ; Do at end 5985 ;; "my" may be already fontified (POD), 5986 ;; so cperl-font-lock-multiline-start is nil 5987 (if (or (not cperl-font-lock-multiline-start) 5988 (> 2 (count-lines 5989 cperl-font-lock-multiline-start 5990 (point)))) 5991 nil 5992 (put-text-property 5993 (1+ cperl-font-lock-multiline-start) (point) 5994 'syntax-type 'multiline)) 5995 (setq cperl-font-lock-multiline-start nil)))) 5996 (3 font-lock-variable-name-face))))) 5997 (t '("^[ \t{}]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" 5998 3 font-lock-variable-name-face))) 5999 '("\\<for\\(each\\)?\\([ \t]+\\(my\\|local\\|our\\)\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*(" 6000 4 font-lock-variable-name-face) 6001 ;; Avoid $!, and s!!, qq!! etc. when not fontifying syntaxically 6002 '("\\(?:^\\|[^smywqrx$]\\)\\(!\\)" 1 font-lock-negation-char-face) 6003 '("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend))) 6004 (setq 6005 t-font-lock-keywords-1 6006 (and (fboundp 'turn-on-font-lock) ; Check for newer font-lock 6007 ;; not yet as of XEmacs 19.12, works with 21.1.11 6008 (or 6009 (not cperl-xemacs-p) 6010 (string< "21.1.9" emacs-version) 6011 (and (string< "21.1.10" emacs-version) 6012 (string< emacs-version "21.1.2"))) 6013 '( 6014 ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1 6015 (if (eq (char-after (match-beginning 2)) ?%) 6016 'cperl-hash-face 6017 'cperl-array-face) 6018 t) ; arrays and hashes 6019 ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" 6020 1 6021 (if (= (- (match-end 2) (match-beginning 2)) 1) 6022 (if (eq (char-after (match-beginning 3)) ?{) 6023 'cperl-hash-face 6024 'cperl-array-face) ; arrays and hashes 6025 font-lock-variable-name-face) ; Just to put something 6026 t) 6027 ("\\(@\\|\\$#\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)" 6028 (1 cperl-array-face) 6029 (2 font-lock-variable-name-face)) 6030 ("\\(%\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)" 6031 (1 cperl-hash-face) 6032 (2 font-lock-variable-name-face)) 6033 ;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2") 6034 ;;; Too much noise from \s* @s[ and friends 6035 ;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)" 6036 ;;(3 font-lock-function-name-face t t) 6037 ;;(4 6038 ;; (if (cperl-slash-is-regexp) 6039 ;; font-lock-function-name-face 'default) nil t)) 6040 ))) 6041 (if cperl-highlight-variables-indiscriminately 6042 (setq t-font-lock-keywords-1 6043 (append t-font-lock-keywords-1 6044 (list '("\\([$*]{?\\sw+\\)" 1 6045 font-lock-variable-name-face))))) 6046 (setq cperl-font-lock-keywords-1 6047 (if cperl-syntaxify-by-font-lock 6048 (cons 'cperl-fontify-update 6049 t-font-lock-keywords) 6050 t-font-lock-keywords) 6051 cperl-font-lock-keywords cperl-font-lock-keywords-1 6052 cperl-font-lock-keywords-2 (append 6053 cperl-font-lock-keywords-1 6054 t-font-lock-keywords-1))) 6055 (if (fboundp 'ps-print-buffer) (cperl-ps-print-init)) 6056 (if (or (featurep 'choose-color) (featurep 'font-lock-extra)) 6057 (eval ; Avoid a warning 6058 '(font-lock-require-faces 6059 (list 6060 ;; Color-light Color-dark Gray-light Gray-dark Mono 6061 (list 'font-lock-comment-face 6062 ["Firebrick" "OrangeRed" "DimGray" "Gray80"] 6063 nil 6064 [nil nil t t t] 6065 [nil nil t t t] 6066 nil) 6067 (list 'font-lock-string-face 6068 ["RosyBrown" "LightSalmon" "Gray50" "LightGray"] 6069 nil 6070 nil 6071 [nil nil t t t] 6072 nil) 6073 (list 'font-lock-function-name-face 6074 (vector 6075 "Blue" "LightSkyBlue" "Gray50" "LightGray" 6076 (cdr (assq 'background-color ; if mono 6077 (frame-parameters)))) 6078 (vector 6079 nil nil nil nil 6080 (cdr (assq 'foreground-color ; if mono 6081 (frame-parameters)))) 6082 [nil nil t t t] 6083 nil 6084 nil) 6085 (list 'font-lock-variable-name-face 6086 ["DarkGoldenrod" "LightGoldenrod" "DimGray" "Gray90"] 6087 nil 6088 [nil nil t t t] 6089 [nil nil t t t] 6090 nil) 6091 (list 'font-lock-type-face 6092 ["DarkOliveGreen" "PaleGreen" "DimGray" "Gray80"] 6093 nil 6094 [nil nil t t t] 6095 nil 6096 [nil nil t t t]) 6097 (list 'font-lock-warning-face 6098 ["Pink" "Red" "Gray50" "LightGray"] 6099 ["gray20" "gray90" 6100 "gray80" "gray20"] 6101 [nil nil t t t] 6102 nil 6103 [nil nil t t t] 6104 ) 6105 (list 'font-lock-constant-face 6106 ["CadetBlue" "Aquamarine" "Gray50" "LightGray"] 6107 nil 6108 [nil nil t t t] 6109 nil 6110 [nil nil t t t]) 6111 (list 'cperl-nonoverridable-face 6112 ["chartreuse3" ("orchid1" "orange") 6113 nil "Gray80"] 6114 [nil nil "gray90"] 6115 [nil nil nil t t] 6116 [nil nil t t] 6117 [nil nil t t t]) 6118 (list 'cperl-array-face 6119 ["blue" "yellow" nil "Gray80"] 6120 ["lightyellow2" ("navy" "os2blue" "darkgreen") 6121 "gray90"] 6122 t 6123 nil 6124 nil) 6125 (list 'cperl-hash-face 6126 ["red" "red" nil "Gray80"] 6127 ["lightyellow2" ("navy" "os2blue" "darkgreen") 6128 "gray90"] 6129 t 6130 t 6131 nil)))) 6132 ;; Do it the dull way, without choose-color 6133 (defvar cperl-guessed-background nil 6134 "Display characteristics as guessed by cperl.") 6135 ;; (or (fboundp 'x-color-defined-p) 6136 ;; (defalias 'x-color-defined-p 6137 ;; (cond ((fboundp 'color-defined-p) 'color-defined-p) 6138 ;; ;; XEmacs >= 19.12 6139 ;; ((fboundp 'valid-color-name-p) 'valid-color-name-p) 6140 ;; ;; XEmacs 19.11 6141 ;; (t 'x-valid-color-name-p)))) 6142 (cperl-force-face font-lock-constant-face 6143 "Face for constant and label names") 6144 (cperl-force-face font-lock-variable-name-face 6145 "Face for variable names") 6146 (cperl-force-face font-lock-type-face 6147 "Face for data types") 6148 (cperl-force-face cperl-nonoverridable-face 6149 "Face for data types from another group") 6150 (cperl-force-face font-lock-warning-face 6151 "Face for things which should stand out") 6152 (cperl-force-face font-lock-comment-face 6153 "Face for comments") 6154 (cperl-force-face font-lock-function-name-face 6155 "Face for function names") 6156 (cperl-force-face cperl-hash-face 6157 "Face for hashes") 6158 (cperl-force-face cperl-array-face 6159 "Face for arrays") 6160 ;;(defvar font-lock-constant-face 'font-lock-constant-face) 6161 ;;(defvar font-lock-variable-name-face 'font-lock-variable-name-face) 6162 ;;(or (boundp 'font-lock-type-face) 6163 ;; (defconst font-lock-type-face 6164 ;; 'font-lock-type-face 6165 ;; "Face to use for data types.")) 6166 ;;(or (boundp 'cperl-nonoverridable-face) 6167 ;; (defconst cperl-nonoverridable-face 6168 ;; 'cperl-nonoverridable-face 6169 ;; "Face to use for data types from another group.")) 6170 ;;(if (not cperl-xemacs-p) nil 6171 ;; (or (boundp 'font-lock-comment-face) 6172 ;; (defconst font-lock-comment-face 6173 ;; 'font-lock-comment-face 6174 ;; "Face to use for comments.")) 6175 ;; (or (boundp 'font-lock-keyword-face) 6176 ;; (defconst font-lock-keyword-face 6177 ;; 'font-lock-keyword-face 6178 ;; "Face to use for keywords.")) 6179 ;; (or (boundp 'font-lock-function-name-face) 6180 ;; (defconst font-lock-function-name-face 6181 ;; 'font-lock-function-name-face 6182 ;; "Face to use for function names."))) 6183 (if (and 6184 (not (cperl-is-face 'cperl-array-face)) 6185 (cperl-is-face 'font-lock-emphasized-face)) 6186 (copy-face 'font-lock-emphasized-face 'cperl-array-face)) 6187 (if (and 6188 (not (cperl-is-face 'cperl-hash-face)) 6189 (cperl-is-face 'font-lock-other-emphasized-face)) 6190 (copy-face 'font-lock-other-emphasized-face 'cperl-hash-face)) 6191 (if (and 6192 (not (cperl-is-face 'cperl-nonoverridable-face)) 6193 (cperl-is-face 'font-lock-other-type-face)) 6194 (copy-face 'font-lock-other-type-face 'cperl-nonoverridable-face)) 6195 ;;(or (boundp 'cperl-hash-face) 6196 ;; (defconst cperl-hash-face 6197 ;; 'cperl-hash-face 6198 ;; "Face to use for hashes.")) 6199 ;;(or (boundp 'cperl-array-face) 6200 ;; (defconst cperl-array-face 6201 ;; 'cperl-array-face 6202 ;; "Face to use for arrays.")) 6203 ;; Here we try to guess background 6204 (let ((background 6205 (if (boundp 'font-lock-background-mode) 6206 font-lock-background-mode 6207 'light)) 6208 (face-list (and (fboundp 'face-list) (face-list)))) 6209;;;; (fset 'cperl-is-face 6210;;;; (cond ((fboundp 'find-face) 6211;;;; (symbol-function 'find-face)) 6212;;;; (face-list 6213;;;; (function (lambda (face) (member face face-list)))) 6214;;;; (t 6215;;;; (function (lambda (face) (boundp face)))))) 6216 (defvar cperl-guessed-background 6217 (if (and (boundp 'font-lock-display-type) 6218 (eq font-lock-display-type 'grayscale)) 6219 'gray 6220 background) 6221 "Background as guessed by CPerl mode") 6222 (and (not (cperl-is-face 'font-lock-constant-face)) 6223 (cperl-is-face 'font-lock-reference-face) 6224 (copy-face 'font-lock-reference-face 'font-lock-constant-face)) 6225 (if (cperl-is-face 'font-lock-type-face) nil 6226 (copy-face 'default 'font-lock-type-face) 6227 (cond 6228 ((eq background 'light) 6229 (set-face-foreground 'font-lock-type-face 6230 (if (x-color-defined-p "seagreen") 6231 "seagreen" 6232 "sea green"))) 6233 ((eq background 'dark) 6234 (set-face-foreground 'font-lock-type-face 6235 (if (x-color-defined-p "os2pink") 6236 "os2pink" 6237 "pink"))) 6238 (t 6239 (set-face-background 'font-lock-type-face "gray90")))) 6240 (if (cperl-is-face 'cperl-nonoverridable-face) 6241 nil 6242 (copy-face 'font-lock-type-face 'cperl-nonoverridable-face) 6243 (cond 6244 ((eq background 'light) 6245 (set-face-foreground 'cperl-nonoverridable-face 6246 (if (x-color-defined-p "chartreuse3") 6247 "chartreuse3" 6248 "chartreuse"))) 6249 ((eq background 'dark) 6250 (set-face-foreground 'cperl-nonoverridable-face 6251 (if (x-color-defined-p "orchid1") 6252 "orchid1" 6253 "orange"))))) 6254;;; (if (cperl-is-face 'font-lock-other-emphasized-face) nil 6255;;; (copy-face 'bold-italic 'font-lock-other-emphasized-face) 6256;;; (cond 6257;;; ((eq background 'light) 6258;;; (set-face-background 'font-lock-other-emphasized-face 6259;;; (if (x-color-defined-p "lightyellow2") 6260;;; "lightyellow2" 6261;;; (if (x-color-defined-p "lightyellow") 6262;;; "lightyellow" 6263;;; "light yellow")))) 6264;;; ((eq background 'dark) 6265;;; (set-face-background 'font-lock-other-emphasized-face 6266;;; (if (x-color-defined-p "navy") 6267;;; "navy" 6268;;; (if (x-color-defined-p "darkgreen") 6269;;; "darkgreen" 6270;;; "dark green")))) 6271;;; (t (set-face-background 'font-lock-other-emphasized-face "gray90")))) 6272;;; (if (cperl-is-face 'font-lock-emphasized-face) nil 6273;;; (copy-face 'bold 'font-lock-emphasized-face) 6274;;; (cond 6275;;; ((eq background 'light) 6276;;; (set-face-background 'font-lock-emphasized-face 6277;;; (if (x-color-defined-p "lightyellow2") 6278;;; "lightyellow2" 6279;;; "lightyellow"))) 6280;;; ((eq background 'dark) 6281;;; (set-face-background 'font-lock-emphasized-face 6282;;; (if (x-color-defined-p "navy") 6283;;; "navy" 6284;;; (if (x-color-defined-p "darkgreen") 6285;;; "darkgreen" 6286;;; "dark green")))) 6287;;; (t (set-face-background 'font-lock-emphasized-face "gray90")))) 6288 (if (cperl-is-face 'font-lock-variable-name-face) nil 6289 (copy-face 'italic 'font-lock-variable-name-face)) 6290 (if (cperl-is-face 'font-lock-constant-face) nil 6291 (copy-face 'italic 'font-lock-constant-face)))) 6292 (setq cperl-faces-init t)) 6293 (error (message "cperl-init-faces (ignored): %s" errs)))) 6294 6295 6296(defun cperl-ps-print-init () 6297 "Initialization of `ps-print' components for faces used in CPerl." 6298 (eval-after-load "ps-print" 6299 '(setq ps-bold-faces 6300 ;; font-lock-variable-name-face 6301 ;; font-lock-constant-face 6302 (append '(cperl-array-face cperl-hash-face) 6303 ps-bold-faces) 6304 ps-italic-faces 6305 ;; font-lock-constant-face 6306 (append '(cperl-nonoverridable-face cperl-hash-face) 6307 ps-italic-faces) 6308 ps-underlined-faces 6309 ;; font-lock-type-face 6310 (append '(cperl-array-face cperl-hash-face underline cperl-nonoverridable-face) 6311 ps-underlined-faces)))) 6312 6313(defvar ps-print-face-extension-alist) 6314 6315(defun cperl-ps-print (&optional file) 6316 "Pretty-print in CPerl style. 6317If optional argument FILE is an empty string, prints to printer, otherwise 6318to the file FILE. If FILE is nil, prompts for a file name. 6319 6320Style of printout regulated by the variable `cperl-ps-print-face-properties'." 6321 (interactive) 6322 (or file 6323 (setq file (read-from-minibuffer 6324 "Print to file (if empty - to printer): " 6325 (concat (buffer-file-name) ".ps") 6326 nil nil 'file-name-history))) 6327 (or (> (length file) 0) 6328 (setq file nil)) 6329 (require 'ps-print) ; To get ps-print-face-extension-alist 6330 (let ((ps-print-color-p t) 6331 (ps-print-face-extension-alist ps-print-face-extension-alist)) 6332 (cperl-ps-extend-face-list cperl-ps-print-face-properties) 6333 (ps-print-buffer-with-faces file))) 6334 6335;;; (defun cperl-ps-print-init () 6336;;; "Initialization of `ps-print' components for faces used in CPerl." 6337;;; ;; Guard against old versions 6338;;; (defvar ps-underlined-faces nil) 6339;;; (defvar ps-bold-faces nil) 6340;;; (defvar ps-italic-faces nil) 6341;;; (setq ps-bold-faces 6342;;; (append '(font-lock-emphasized-face 6343;;; cperl-array-face 6344;;; font-lock-keyword-face 6345;;; font-lock-variable-name-face 6346;;; font-lock-constant-face 6347;;; font-lock-reference-face 6348;;; font-lock-other-emphasized-face 6349;;; cperl-hash-face) 6350;;; ps-bold-faces)) 6351;;; (setq ps-italic-faces 6352;;; (append '(cperl-nonoverridable-face 6353;;; font-lock-constant-face 6354;;; font-lock-reference-face 6355;;; font-lock-other-emphasized-face 6356;;; cperl-hash-face) 6357;;; ps-italic-faces)) 6358;;; (setq ps-underlined-faces 6359;;; (append '(font-lock-emphasized-face 6360;;; cperl-array-face 6361;;; font-lock-other-emphasized-face 6362;;; cperl-hash-face 6363;;; cperl-nonoverridable-face font-lock-type-face) 6364;;; ps-underlined-faces)) 6365;;; (cons 'font-lock-type-face ps-underlined-faces)) 6366 6367 6368(if (cperl-enable-font-lock) (cperl-windowed-init)) 6369 6370(defconst cperl-styles-entries 6371 '(cperl-indent-level cperl-brace-offset cperl-continued-brace-offset 6372 cperl-label-offset cperl-extra-newline-before-brace 6373 cperl-extra-newline-before-brace-multiline 6374 cperl-merge-trailing-else 6375 cperl-continued-statement-offset)) 6376 6377(defconst cperl-style-examples 6378"##### Numbers etc are: cperl-indent-level cperl-brace-offset 6379##### cperl-continued-brace-offset cperl-label-offset 6380##### cperl-continued-statement-offset 6381##### cperl-merge-trailing-else cperl-extra-newline-before-brace 6382 6383########### (Do not forget cperl-extra-newline-before-brace-multiline) 6384 6385### CPerl (=GNU - extra-newline-before-brace + merge-trailing-else) 2/0/0/-2/2/t/nil 6386if (foo) { 6387 bar 6388 baz; 6389 label: 6390 { 6391 boon; 6392 } 6393} else { 6394 stop; 6395} 6396 6397### PerlStyle (=CPerl with 4 as indent) 4/0/0/-4/4/t/nil 6398if (foo) { 6399 bar 6400 baz; 6401 label: 6402 { 6403 boon; 6404 } 6405} else { 6406 stop; 6407} 6408 6409### GNU 2/0/0/-2/2/nil/t 6410if (foo) 6411 { 6412 bar 6413 baz; 6414 label: 6415 { 6416 boon; 6417 } 6418 } 6419else 6420 { 6421 stop; 6422 } 6423 6424### C++ (=PerlStyle with braces aligned with control words) 4/0/-4/-4/4/nil/t 6425if (foo) 6426{ 6427 bar 6428 baz; 6429 label: 6430 { 6431 boon; 6432 } 6433} 6434else 6435{ 6436 stop; 6437} 6438 6439### BSD (=C++, but will not change preexisting merge-trailing-else 6440### and extra-newline-before-brace ) 4/0/-4/-4/4 6441if (foo) 6442{ 6443 bar 6444 baz; 6445 label: 6446 { 6447 boon; 6448 } 6449} 6450else 6451{ 6452 stop; 6453} 6454 6455### K&R (=C++ with indent 5 - merge-trailing-else, but will not 6456### change preexisting extra-newline-before-brace) 5/0/-5/-5/5/nil 6457if (foo) 6458{ 6459 bar 6460 baz; 6461 label: 6462 { 6463 boon; 6464 } 6465} 6466else 6467{ 6468 stop; 6469} 6470 6471### Whitesmith (=PerlStyle, but will not change preexisting 6472### extra-newline-before-brace and merge-trailing-else) 4/0/0/-4/4 6473if (foo) 6474 { 6475 bar 6476 baz; 6477 label: 6478 { 6479 boon; 6480 } 6481 } 6482else 6483 { 6484 stop; 6485 } 6486" 6487"Examples of if/else with different indent styles (with v4.23).") 6488 6489(defconst cperl-style-alist 6490 '(("CPerl" ;; =GNU - extra-newline-before-brace + cperl-merge-trailing-else 6491 (cperl-indent-level . 2) 6492 (cperl-brace-offset . 0) 6493 (cperl-continued-brace-offset . 0) 6494 (cperl-label-offset . -2) 6495 (cperl-continued-statement-offset . 2) 6496 (cperl-extra-newline-before-brace . nil) 6497 (cperl-extra-newline-before-brace-multiline . nil) 6498 (cperl-merge-trailing-else . t)) 6499 6500 ("PerlStyle" ; CPerl with 4 as indent 6501 (cperl-indent-level . 4) 6502 (cperl-brace-offset . 0) 6503 (cperl-continued-brace-offset . 0) 6504 (cperl-label-offset . -4) 6505 (cperl-continued-statement-offset . 4) 6506 (cperl-extra-newline-before-brace . nil) 6507 (cperl-extra-newline-before-brace-multiline . nil) 6508 (cperl-merge-trailing-else . t)) 6509 6510 ("GNU" 6511 (cperl-indent-level . 2) 6512 (cperl-brace-offset . 0) 6513 (cperl-continued-brace-offset . 0) 6514 (cperl-label-offset . -2) 6515 (cperl-continued-statement-offset . 2) 6516 (cperl-extra-newline-before-brace . t) 6517 (cperl-extra-newline-before-brace-multiline . t) 6518 (cperl-merge-trailing-else . nil)) 6519 6520 ("K&R" 6521 (cperl-indent-level . 5) 6522 (cperl-brace-offset . 0) 6523 (cperl-continued-brace-offset . -5) 6524 (cperl-label-offset . -5) 6525 (cperl-continued-statement-offset . 5) 6526 ;;(cperl-extra-newline-before-brace . nil) ; ??? 6527 ;;(cperl-extra-newline-before-brace-multiline . nil) 6528 (cperl-merge-trailing-else . nil)) 6529 6530 ("BSD" 6531 (cperl-indent-level . 4) 6532 (cperl-brace-offset . 0) 6533 (cperl-continued-brace-offset . -4) 6534 (cperl-label-offset . -4) 6535 (cperl-continued-statement-offset . 4) 6536 ;;(cperl-extra-newline-before-brace . nil) ; ??? 6537 ;;(cperl-extra-newline-before-brace-multiline . nil) 6538 ;;(cperl-merge-trailing-else . nil) ; ??? 6539 ) 6540 6541 ("C++" 6542 (cperl-indent-level . 4) 6543 (cperl-brace-offset . 0) 6544 (cperl-continued-brace-offset . -4) 6545 (cperl-label-offset . -4) 6546 (cperl-continued-statement-offset . 4) 6547 (cperl-extra-newline-before-brace . t) 6548 (cperl-extra-newline-before-brace-multiline . t) 6549 (cperl-merge-trailing-else . nil)) 6550 6551 ("Whitesmith" 6552 (cperl-indent-level . 4) 6553 (cperl-brace-offset . 0) 6554 (cperl-continued-brace-offset . 0) 6555 (cperl-label-offset . -4) 6556 (cperl-continued-statement-offset . 4) 6557 ;;(cperl-extra-newline-before-brace . nil) ; ??? 6558 ;;(cperl-extra-newline-before-brace-multiline . nil) 6559 ;;(cperl-merge-trailing-else . nil) ; ??? 6560 ) 6561 ("Current")) 6562 "List of variables to set to get a particular indentation style. 6563Should be used via `cperl-set-style' or via Perl menu. 6564 6565See examples in `cperl-style-examples'.") 6566 6567(defun cperl-set-style (style) 6568 "Set CPerl mode variables to use one of several different indentation styles. 6569The arguments are a string representing the desired style. 6570The list of styles is in `cperl-style-alist', available styles 6571are CPerl, PerlStyle, GNU, K&R, BSD, C++ and Whitesmith. 6572 6573The current value of style is memorized (unless there is a memorized 6574data already), may be restored by `cperl-set-style-back'. 6575 6576Chosing \"Current\" style will not change style, so this may be used for 6577side-effect of memorizing only. Examples in `cperl-style-examples'." 6578 (interactive 6579 (let ((list (mapcar (function (lambda (elt) (list (car elt)))) 6580 cperl-style-alist))) 6581 (list (completing-read "Enter style: " list nil 'insist)))) 6582 (or cperl-old-style 6583 (setq cperl-old-style 6584 (mapcar (function 6585 (lambda (name) 6586 (cons name (eval name)))) 6587 cperl-styles-entries))) 6588 (let ((style (cdr (assoc style cperl-style-alist))) setting str sym) 6589 (while style 6590 (setq setting (car style) style (cdr style)) 6591 (set (car setting) (cdr setting))))) 6592 6593(defun cperl-set-style-back () 6594 "Restore a style memorized by `cperl-set-style'." 6595 (interactive) 6596 (or cperl-old-style (error "The style was not changed")) 6597 (let (setting) 6598 (while cperl-old-style 6599 (setq setting (car cperl-old-style) 6600 cperl-old-style (cdr cperl-old-style)) 6601 (set (car setting) (cdr setting))))) 6602 6603(defun cperl-check-syntax () 6604 (interactive) 6605 (require 'mode-compile) 6606 (let ((perl-dbg-flags (concat cperl-extra-perl-args " -wc"))) 6607 (eval '(mode-compile)))) ; Avoid a warning 6608 6609(defun cperl-info-buffer (type) 6610 ;; Returns buffer with documentation. Creates if missing. 6611 ;; If TYPE, this vars buffer. 6612 ;; Special care is taken to not stomp over an existing info buffer 6613 (let* ((bname (if type "*info-perl-var*" "*info-perl*")) 6614 (info (get-buffer bname)) 6615 (oldbuf (get-buffer "*info*"))) 6616 (if info info 6617 (save-window-excursion 6618 ;; Get Info running 6619 (require 'info) 6620 (cond (oldbuf 6621 (set-buffer oldbuf) 6622 (rename-buffer "*info-perl-tmp*"))) 6623 (save-window-excursion 6624 (info)) 6625 (Info-find-node cperl-info-page (if type "perlvar" "perlfunc")) 6626 (set-buffer "*info*") 6627 (rename-buffer bname) 6628 (cond (oldbuf 6629 (set-buffer "*info-perl-tmp*") 6630 (rename-buffer "*info*") 6631 (set-buffer bname))) 6632 (make-local-variable 'window-min-height) 6633 (setq window-min-height 2) 6634 (current-buffer))))) 6635 6636(defun cperl-word-at-point (&optional p) 6637 "Return the word at point or at P." 6638 (save-excursion 6639 (if p (goto-char p)) 6640 (or (cperl-word-at-point-hard) 6641 (progn 6642 (require 'etags) 6643 (funcall (or (and (boundp 'find-tag-default-function) 6644 find-tag-default-function) 6645 (get major-mode 'find-tag-default-function) 6646 ;; XEmacs 19.12 has `find-tag-default-hook'; it is 6647 ;; automatically used within `find-tag-default': 6648 'find-tag-default)))))) 6649 6650(defun cperl-info-on-command (command) 6651 "Show documentation for Perl command COMMAND in other window. 6652If perl-info buffer is shown in some frame, uses this frame. 6653Customized by setting variables `cperl-shrink-wrap-info-frame', 6654`cperl-max-help-size'." 6655 (interactive 6656 (let* ((default (cperl-word-at-point)) 6657 (read (read-string 6658 (format "Find doc for Perl function (default %s): " 6659 default)))) 6660 (list (if (equal read "") 6661 default 6662 read)))) 6663 6664 (let ((buffer (current-buffer)) 6665 (cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///" 6666 pos isvar height iniheight frheight buf win fr1 fr2 iniwin not-loner 6667 max-height char-height buf-list) 6668 (if (string-match "^-[a-zA-Z]$" command) 6669 (setq cmd-desc "^-X[ \t\n]")) 6670 (setq isvar (string-match "^[$@%]" command) 6671 buf (cperl-info-buffer isvar) 6672 iniwin (selected-window) 6673 fr1 (window-frame iniwin)) 6674 (set-buffer buf) 6675 (goto-char (point-min)) 6676 (or isvar 6677 (progn (re-search-forward "^-X[ \t\n]") 6678 (forward-line -1))) 6679 (if (re-search-forward cmd-desc nil t) 6680 (progn 6681 ;; Go back to beginning of the group (ex, for qq) 6682 (if (re-search-backward "^[ \t\n\f]") 6683 (forward-line 1)) 6684 (beginning-of-line) 6685 ;; Get some of 6686 (setq pos (point) 6687 buf-list (list buf "*info-perl-var*" "*info-perl*")) 6688 (while (and (not win) buf-list) 6689 (setq win (get-buffer-window (car buf-list) t)) 6690 (setq buf-list (cdr buf-list))) 6691 (or (not win) 6692 (eq (window-buffer win) buf) 6693 (set-window-buffer win buf)) 6694 (and win (setq fr2 (window-frame win))) 6695 (if (or (not fr2) (eq fr1 fr2)) 6696 (pop-to-buffer buf) 6697 (special-display-popup-frame buf) ; Make it visible 6698 (select-window win)) 6699 (goto-char pos) ; Needed (?!). 6700 ;; Resize 6701 (setq iniheight (window-height) 6702 frheight (frame-height) 6703 not-loner (< iniheight (1- frheight))) ; Are not alone 6704 (cond ((if not-loner cperl-max-help-size 6705 cperl-shrink-wrap-info-frame) 6706 (setq height 6707 (+ 2 6708 (count-lines 6709 pos 6710 (save-excursion 6711 (if (re-search-forward 6712 "^[ \t][^\n]*\n+\\([^ \t\n\f]\\|\\'\\)" nil t) 6713 (match-beginning 0) (point-max))))) 6714 max-height 6715 (if not-loner 6716 (/ (* (- frheight 3) cperl-max-help-size) 100) 6717 (setq char-height (frame-char-height)) 6718 ;; Non-functioning under OS/2: 6719 (if (eq char-height 1) (setq char-height 18)) 6720 ;; Title, menubar, + 2 for slack 6721 (- (/ (x-display-pixel-height) char-height) 4))) 6722 (if (> height max-height) (setq height max-height)) 6723 ;;(message "was %s doing %s" iniheight height) 6724 (if not-loner 6725 (enlarge-window (- height iniheight)) 6726 (set-frame-height (window-frame win) (1+ height))))) 6727 (set-window-start (selected-window) pos)) 6728 (message "No entry for %s found." command)) 6729 ;;(pop-to-buffer buffer) 6730 (select-window iniwin))) 6731 6732(defun cperl-info-on-current-command () 6733 "Show documentation for Perl command at point in other window." 6734 (interactive) 6735 (cperl-info-on-command (cperl-word-at-point))) 6736 6737(defun cperl-imenu-info-imenu-search () 6738 (if (looking-at "^-X[ \t\n]") nil 6739 (re-search-backward 6740 "^\n\\([-a-zA-Z_]+\\)[ \t\n]") 6741 (forward-line 1))) 6742 6743(defun cperl-imenu-info-imenu-name () 6744 (buffer-substring 6745 (match-beginning 1) (match-end 1))) 6746 6747(defun cperl-imenu-on-info () 6748 "Shows imenu for Perl Info Buffer. 6749Opens Perl Info buffer if needed." 6750 (interactive) 6751 (let* ((buffer (current-buffer)) 6752 imenu-create-index-function 6753 imenu-prev-index-position-function 6754 imenu-extract-index-name-function 6755 (index-item (save-restriction 6756 (save-window-excursion 6757 (set-buffer (cperl-info-buffer nil)) 6758 (setq imenu-create-index-function 6759 'imenu-default-create-index-function 6760 imenu-prev-index-position-function 6761 'cperl-imenu-info-imenu-search 6762 imenu-extract-index-name-function 6763 'cperl-imenu-info-imenu-name) 6764 (imenu-choose-buffer-index))))) 6765 (and index-item 6766 (progn 6767 (push-mark) 6768 (pop-to-buffer "*info-perl*") 6769 (cond 6770 ((markerp (cdr index-item)) 6771 (goto-char (marker-position (cdr index-item)))) 6772 (t 6773 (goto-char (cdr index-item)))) 6774 (set-window-start (selected-window) (point)) 6775 (pop-to-buffer buffer))))) 6776 6777(defun cperl-lineup (beg end &optional step minshift) 6778 "Lineup construction in a region. 6779Beginning of region should be at the start of a construction. 6780All first occurrences of this construction in the lines that are 6781partially contained in the region are lined up at the same column. 6782 6783MINSHIFT is the minimal amount of space to insert before the construction. 6784STEP is the tabwidth to position constructions. 6785If STEP is nil, `cperl-lineup-step' will be used 6786\(or `cperl-indent-level', if `cperl-lineup-step' is nil). 6787Will not move the position at the start to the left." 6788 (interactive "r") 6789 (let (search col tcol seen b) 6790 (save-excursion 6791 (goto-char end) 6792 (end-of-line) 6793 (setq end (point-marker)) 6794 (goto-char beg) 6795 (skip-chars-forward " \t\f") 6796 (setq beg (point-marker)) 6797 (indent-region beg end nil) 6798 (goto-char beg) 6799 (setq col (current-column)) 6800 (if (looking-at "[a-zA-Z0-9_]") 6801 (if (looking-at "\\<[a-zA-Z0-9_]+\\>") 6802 (setq search 6803 (concat "\\<" 6804 (regexp-quote 6805 (buffer-substring (match-beginning 0) 6806 (match-end 0))) "\\>")) 6807 (error "Cannot line up in a middle of the word")) 6808 (if (looking-at "$") 6809 (error "Cannot line up end of line")) 6810 (setq search (regexp-quote (char-to-string (following-char))))) 6811 (setq step (or step cperl-lineup-step cperl-indent-level)) 6812 (or minshift (setq minshift 1)) 6813 (while (progn 6814 (beginning-of-line 2) 6815 (and (< (point) end) 6816 (re-search-forward search end t) 6817 (goto-char (match-beginning 0)))) 6818 (setq tcol (current-column) seen t) 6819 (if (> tcol col) (setq col tcol))) 6820 (or seen 6821 (error "The construction to line up occurred only once")) 6822 (goto-char beg) 6823 (setq col (+ col minshift)) 6824 (if (/= (% col step) 0) (setq step (* step (1+ (/ col step))))) 6825 (while 6826 (progn 6827 (cperl-make-indent col) 6828 (beginning-of-line 2) 6829 (and (< (point) end) 6830 (re-search-forward search end t) 6831 (goto-char (match-beginning 0)))))))) ; No body 6832 6833(defun cperl-etags (&optional add all files) ;; NOT USED??? 6834 "Run etags with appropriate options for Perl files. 6835If optional argument ALL is `recursive', will process Perl files 6836in subdirectories too." 6837 (interactive) 6838 (let ((cmd "etags") 6839 (args '("-l" "none" "-r" 6840 ;; 1=fullname 2=package? 3=name 4=proto? 5=attrs? (VERY APPROX!) 6841 "/\\<sub[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([ \t]*:[^#{;]*\\)?\\([{#]\\|$\\)/\\3/" 6842 "-r" 6843 "/\\<package[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\([#;]\\|$\\)/\\1/" 6844 "-r" 6845 "/\\<\\(package\\)[ \\t]*;/\\1;/")) 6846 res) 6847 (if add (setq args (cons "-a" args))) 6848 (or files (setq files (list buffer-file-name))) 6849 (cond 6850 ((eq all 'recursive) 6851 ;;(error "Not implemented: recursive") 6852 (setq args (append (list "-e" 6853 "sub wanted {push @ARGV, $File::Find::name if /\\.[pP][Llm]$/} 6854 use File::Find; 6855 find(\\&wanted, '.'); 6856 exec @ARGV;" 6857 cmd) args) 6858 cmd "perl")) 6859 (all 6860 ;;(error "Not implemented: all") 6861 (setq args (append (list "-e" 6862 "push @ARGV, <*.PL *.pl *.pm>; 6863 exec @ARGV;" 6864 cmd) args) 6865 cmd "perl")) 6866 (t 6867 (setq args (append args files)))) 6868 (setq res (apply 'call-process cmd nil nil nil args)) 6869 (or (eq res 0) 6870 (message "etags returned \"%s\"" res)))) 6871 6872(defun cperl-toggle-auto-newline () 6873 "Toggle the state of `cperl-auto-newline'." 6874 (interactive) 6875 (setq cperl-auto-newline (not cperl-auto-newline)) 6876 (message "Newlines will %sbe auto-inserted now." 6877 (if cperl-auto-newline "" "not "))) 6878 6879(defun cperl-toggle-abbrev () 6880 "Toggle the state of automatic keyword expansion in CPerl mode." 6881 (interactive) 6882 (abbrev-mode (if abbrev-mode 0 1)) 6883 (message "Perl control structure will %sbe auto-inserted now." 6884 (if abbrev-mode "" "not "))) 6885 6886 6887(defun cperl-toggle-electric () 6888 "Toggle the state of parentheses doubling in CPerl mode." 6889 (interactive) 6890 (setq cperl-electric-parens (if (cperl-val 'cperl-electric-parens) 'null t)) 6891 (message "Parentheses will %sbe auto-doubled now." 6892 (if (cperl-val 'cperl-electric-parens) "" "not "))) 6893 6894(defun cperl-toggle-autohelp () 6895 "Toggle the state of Auto-Help on Perl constructs (put in the message area). 6896Delay of auto-help controlled by `cperl-lazy-help-time'." 6897 (interactive) 6898 (if (fboundp 'run-with-idle-timer) 6899 (progn 6900 (if cperl-lazy-installed 6901 (cperl-lazy-unstall) 6902 (cperl-lazy-install)) 6903 (message "Perl help messages will %sbe automatically shown now." 6904 (if cperl-lazy-installed "" "not "))) 6905 (message "Cannot automatically show Perl help messages - run-with-idle-timer missing."))) 6906 6907(defun cperl-toggle-construct-fix () 6908 "Toggle whether `indent-region'/`indent-sexp' fix whitespace too." 6909 (interactive) 6910 (setq cperl-indent-region-fix-constructs 6911 (if cperl-indent-region-fix-constructs 6912 nil 6913 1)) 6914 (message "indent-region/indent-sexp will %sbe automatically fix whitespace." 6915 (if cperl-indent-region-fix-constructs "" "not "))) 6916 6917(defun cperl-toggle-set-debug-unwind (arg &optional backtrace) 6918 "Toggle (or, with numeric argument, set) debugging state of syntaxification. 6919Nonpositive numeric argument disables debugging messages. The message 6920summarizes which regions it was decided to rescan for syntactic constructs. 6921 6922The message looks like this: 6923 6924 Syxify req=123..138 actual=101..146 done-to: 112=>146 statepos: 73=>117 6925 6926Numbers are character positions in the buffer. REQ provides the range to 6927rescan requested by `font-lock'. ACTUAL is the range actually resyntaxified; 6928for correct operation it should start and end outside any special syntactic 6929construct. DONE-TO and STATEPOS indicate changes to internal caches maintained 6930by CPerl." 6931 (interactive "P") 6932 (or arg 6933 (setq arg (if (eq cperl-syntaxify-by-font-lock 6934 (if backtrace 'backtrace 'message)) 0 1))) 6935 (setq arg (if (> arg 0) (if backtrace 'backtrace 'message) t)) 6936 (setq cperl-syntaxify-by-font-lock arg) 6937 (message "Debugging messages of syntax unwind %sabled." 6938 (if (eq arg t) "dis" "en"))) 6939 6940;;;; Tags file creation. 6941 6942(defvar cperl-tmp-buffer " *cperl-tmp*") 6943 6944(defun cperl-setup-tmp-buf () 6945 (set-buffer (get-buffer-create cperl-tmp-buffer)) 6946 (set-syntax-table cperl-mode-syntax-table) 6947 (buffer-disable-undo) 6948 (auto-fill-mode 0) 6949 (if cperl-use-syntax-table-text-property-for-tags 6950 (progn 6951 (make-local-variable 'parse-sexp-lookup-properties) 6952 ;; Do not introduce variable if not needed, we check it! 6953 (set 'parse-sexp-lookup-properties t)))) 6954 6955(defun cperl-xsub-scan () 6956 (require 'imenu) 6957 (let ((index-alist '()) 6958 (prev-pos 0) index index1 name package prefix) 6959 (goto-char (point-min)) 6960 ;; Search for the function 6961 (progn ;;save-match-data 6962 (while (re-search-forward 6963 "^\\([ \t]*MODULE\\>[^\n]*\\<PACKAGE[ \t]*=[ \t]*\\([a-zA-Z_][a-zA-Z_0-9:]*\\)\\>\\|\\([a-zA-Z_][a-zA-Z_0-9]*\\)(\\|[ \t]*BOOT:\\)" 6964 nil t) 6965 (cond 6966 ((match-beginning 2) ; SECTION 6967 (setq package (buffer-substring (match-beginning 2) (match-end 2))) 6968 (goto-char (match-beginning 0)) 6969 (skip-chars-forward " \t") 6970 (forward-char 1) 6971 (if (looking-at "[^\n]*\\<PREFIX[ \t]*=[ \t]*\\([a-zA-Z_][a-zA-Z_0-9]*\\)\\>") 6972 (setq prefix (buffer-substring (match-beginning 1) (match-end 1))) 6973 (setq prefix nil))) 6974 ((not package) nil) ; C language section 6975 ((match-beginning 3) ; XSUB 6976 (goto-char (1+ (match-beginning 3))) 6977 (setq index (imenu-example--name-and-position)) 6978 (setq name (buffer-substring (match-beginning 3) (match-end 3))) 6979 (if (and prefix (string-match (concat "^" prefix) name)) 6980 (setq name (substring name (length prefix)))) 6981 (cond ((string-match "::" name) nil) 6982 (t 6983 (setq index1 (cons (concat package "::" name) (cdr index))) 6984 (push index1 index-alist))) 6985 (setcar index name) 6986 (push index index-alist)) 6987 (t ; BOOT: section 6988 ;; (beginning-of-line) 6989 (setq index (imenu-example--name-and-position)) 6990 (setcar index (concat package "::BOOT:")) 6991 (push index index-alist))))) 6992 index-alist)) 6993 6994(defvar cperl-unreadable-ok nil) 6995 6996(defun cperl-find-tags (ifile xs topdir) 6997 (let ((b (get-buffer cperl-tmp-buffer)) ind lst elt pos ret rel 6998 (cperl-pod-here-fontify nil) f file) 6999 (save-excursion 7000 (if b (set-buffer b) 7001 (cperl-setup-tmp-buf)) 7002 (erase-buffer) 7003 (condition-case err 7004 (setq file (car (insert-file-contents ifile))) 7005 (error (if cperl-unreadable-ok nil 7006 (if (y-or-n-p 7007 (format "File %s unreadable. Continue? " ifile)) 7008 (setq cperl-unreadable-ok t) 7009 (error "Aborting: unreadable file %s" ifile))))) 7010 (if (not file) 7011 (message "Unreadable file %s" ifile) 7012 (message "Scanning file %s ..." file) 7013 (if (and cperl-use-syntax-table-text-property-for-tags 7014 (not xs)) 7015 (condition-case err ; after __END__ may have garbage 7016 (cperl-find-pods-heres nil nil noninteractive) 7017 (error (message "While scanning for syntax: %s" err)))) 7018 (if xs 7019 (setq lst (cperl-xsub-scan)) 7020 (setq ind (cperl-imenu--create-perl-index)) 7021 (setq lst (cdr (assoc "+Unsorted List+..." ind)))) 7022 (setq lst 7023 (mapcar 7024 (function 7025 (lambda (elt) 7026 (cond ((string-match "^[_a-zA-Z]" (car elt)) 7027 (goto-char (cdr elt)) 7028 (beginning-of-line) ; pos should be of the start of the line 7029 (list (car elt) 7030 (point) 7031 (1+ (count-lines 1 (point))) ; 1+ since at beg-o-l 7032 (buffer-substring (progn 7033 (goto-char (cdr elt)) 7034 ;; After name now... 7035 (or (eolp) (forward-char 1)) 7036 (point)) 7037 (progn 7038 (beginning-of-line) 7039 (point)))))))) 7040 lst)) 7041 (erase-buffer) 7042 (while lst 7043 (setq elt (car lst) lst (cdr lst)) 7044 (if elt 7045 (progn 7046 (insert (elt elt 3) 7047 127 7048 (if (string-match "^package " (car elt)) 7049 (substring (car elt) 8) 7050 (car elt) ) 7051 1 7052 (number-to-string (elt elt 2)) ; Line 7053 "," 7054 (number-to-string (1- (elt elt 1))) ; Char pos 0-based 7055 "\n") 7056 (if (and (string-match "^[_a-zA-Z]+::" (car elt)) 7057 (string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]" 7058 (elt elt 3))) 7059 ;; Need to insert the name without package as well 7060 (setq lst (cons (cons (substring (elt elt 3) 7061 (match-beginning 1) 7062 (match-end 1)) 7063 (cdr elt)) 7064 lst)))))) 7065 (setq pos (point)) 7066 (goto-char 1) 7067 (setq rel file) 7068 ;; On case-preserving filesystems (EMX on OS/2) case might be encoded in properties 7069 (set-text-properties 0 (length rel) nil rel) 7070 (and (equal topdir (substring rel 0 (length topdir))) 7071 (setq rel (substring file (length topdir)))) 7072 (insert "\f\n" rel "," (number-to-string (1- pos)) "\n") 7073 (setq ret (buffer-substring 1 (point-max))) 7074 (erase-buffer) 7075 (or noninteractive 7076 (message "Scanning file %s finished" file)) 7077 ret)))) 7078 7079(defun cperl-add-tags-recurse-noxs () 7080 "Add to TAGS data for \"pure\" Perl files in the current directory and kids. 7081Use as 7082 emacs -batch -q -no-site-file -l emacs/cperl-mode.el \ 7083 -f cperl-add-tags-recurse-noxs 7084" 7085 (cperl-write-tags nil nil t t nil t)) 7086 7087(defun cperl-add-tags-recurse-noxs-fullpath () 7088 "Add to TAGS data for \"pure\" Perl in the current directory and kids. 7089Writes down fullpath, so TAGS is relocatable (but if the build directory 7090is relocated, the file TAGS inside it breaks). Use as 7091 emacs -batch -q -no-site-file -l emacs/cperl-mode.el \ 7092 -f cperl-add-tags-recurse-noxs-fullpath 7093" 7094 (cperl-write-tags nil nil t t nil t "")) 7095 7096(defun cperl-add-tags-recurse () 7097 "Add to TAGS file data for Perl files in the current directory and kids. 7098Use as 7099 emacs -batch -q -no-site-file -l emacs/cperl-mode.el \ 7100 -f cperl-add-tags-recurse 7101" 7102 (cperl-write-tags nil nil t t)) 7103 7104(defun cperl-write-tags (&optional file erase recurse dir inbuffer noxs topdir) 7105 ;; If INBUFFER, do not select buffer, and do not save 7106 ;; If ERASE is `ignore', do not erase, and do not try to delete old info. 7107 (require 'etags) 7108 (if file nil 7109 (setq file (if dir default-directory (buffer-file-name))) 7110 (if (and (not dir) (buffer-modified-p)) (error "Save buffer first!"))) 7111 (or topdir 7112 (setq topdir default-directory)) 7113 (let ((tags-file-name "TAGS") 7114 (case-fold-search (eq system-type 'emx)) 7115 xs rel tm) 7116 (save-excursion 7117 (cond (inbuffer nil) ; Already there 7118 ((file-exists-p tags-file-name) 7119 (if cperl-xemacs-p 7120 (visit-tags-table-buffer) 7121 (visit-tags-table-buffer tags-file-name))) 7122 (t (set-buffer (find-file-noselect tags-file-name)))) 7123 (cond 7124 (dir 7125 (cond ((eq erase 'ignore)) 7126 (erase 7127 (erase-buffer) 7128 (setq erase 'ignore))) 7129 (let ((files 7130 (condition-case err 7131 (directory-files file t 7132 (if recurse nil cperl-scan-files-regexp) 7133 t) 7134 (error 7135 (if cperl-unreadable-ok nil 7136 (if (y-or-n-p 7137 (format "Directory %s unreadable. Continue? " file)) 7138 (setq cperl-unreadable-ok t 7139 tm nil) ; Return empty list 7140 (error "Aborting: unreadable directory %s" file))))))) 7141 (mapcar (function 7142 (lambda (file) 7143 (cond 7144 ((string-match cperl-noscan-files-regexp file) 7145 nil) 7146 ((not (file-directory-p file)) 7147 (if (string-match cperl-scan-files-regexp file) 7148 (cperl-write-tags file erase recurse nil t noxs topdir))) 7149 ((not recurse) nil) 7150 (t (cperl-write-tags file erase recurse t t noxs topdir))))) 7151 files))) 7152 (t 7153 (setq xs (string-match "\\.xs$" file)) 7154 (if (not (and xs noxs)) 7155 (progn 7156 (cond ((eq erase 'ignore) (goto-char (point-max))) 7157 (erase (erase-buffer)) 7158 (t 7159 (goto-char 1) 7160 (setq rel file) 7161 ;; On case-preserving filesystems (EMX on OS/2) case might be encoded in properties 7162 (set-text-properties 0 (length rel) nil rel) 7163 (and (equal topdir (substring rel 0 (length topdir))) 7164 (setq rel (substring file (length topdir)))) 7165 (if (search-forward (concat "\f\n" rel ",") nil t) 7166 (progn 7167 (search-backward "\f\n") 7168 (delete-region (point) 7169 (save-excursion 7170 (forward-char 1) 7171 (if (search-forward "\f\n" 7172 nil 'toend) 7173 (- (point) 2) 7174 (point-max))))) 7175 (goto-char (point-max))))) 7176 (insert (cperl-find-tags file xs topdir)))))) 7177 (if inbuffer nil ; Delegate to the caller 7178 (save-buffer 0) ; No backup 7179 (if (fboundp 'initialize-new-tags-table) ; Do we need something special in XEmacs? 7180 (initialize-new-tags-table)))))) 7181 7182(defvar cperl-tags-hier-regexp-list 7183 (concat 7184 "^\\(" 7185 "\\(package\\)\\>" 7186 "\\|" 7187 "sub\\>[^\n]+::" 7188 "\\|" 7189 "[a-zA-Z_][a-zA-Z_0-9:]*(\C-?[^\n]+::" ; XSUB? 7190 "\\|" 7191 "[ \t]*BOOT:\C-?[^\n]+::" ; BOOT section 7192 "\\)")) 7193 7194(defvar cperl-hierarchy '(() ()) 7195 "Global hierarchy of classes.") 7196 7197(defun cperl-tags-hier-fill () 7198 ;; Suppose we are in a tag table cooked by cperl. 7199 (goto-char 1) 7200 (let (type pack name pos line chunk ord cons1 file str info fileind) 7201 (while (re-search-forward cperl-tags-hier-regexp-list nil t) 7202 (setq pos (match-beginning 0) 7203 pack (match-beginning 2)) 7204 (beginning-of-line) 7205 (if (looking-at (concat 7206 "\\([^\n]+\\)" 7207 "\C-?" 7208 "\\([^\n]+\\)" 7209 "\C-a" 7210 "\\([0-9]+\\)" 7211 "," 7212 "\\([0-9]+\\)")) 7213 (progn 7214 (setq ;;str (buffer-substring (match-beginning 1) (match-end 1)) 7215 name (buffer-substring (match-beginning 2) (match-end 2)) 7216 ;;pos (buffer-substring (match-beginning 3) (match-end 3)) 7217 line (buffer-substring (match-beginning 3) (match-end 3)) 7218 ord (if pack 1 0) 7219 file (file-of-tag) 7220 fileind (format "%s:%s" file line) 7221 ;; Moves to beginning of the next line: 7222 info (cperl-etags-snarf-tag file line)) 7223 ;; Move back 7224 (forward-char -1) 7225 ;; Make new member of hierarchy name ==> file ==> pos if needed 7226 (if (setq cons1 (assoc name (nth ord cperl-hierarchy))) 7227 ;; Name known 7228 (setcdr cons1 (cons (cons fileind (vector file info)) 7229 (cdr cons1))) 7230 ;; First occurrence of the name, start alist 7231 (setq cons1 (cons name (list (cons fileind (vector file info))))) 7232 (if pack 7233 (setcar (cdr cperl-hierarchy) 7234 (cons cons1 (nth 1 cperl-hierarchy))) 7235 (setcar cperl-hierarchy 7236 (cons cons1 (car cperl-hierarchy))))))) 7237 (end-of-line)))) 7238 7239(defun cperl-tags-hier-init (&optional update) 7240 "Show hierarchical menu of classes and methods. 7241Finds info about classes by a scan of loaded TAGS files. 7242Supposes that the TAGS files contain fully qualified function names. 7243One may build such TAGS files from CPerl mode menu." 7244 (interactive) 7245 (require 'etags) 7246 (require 'imenu) 7247 (if (or update (null (nth 2 cperl-hierarchy))) 7248 (let ((remover (function (lambda (elt) ; (name (file1...) (file2..)) 7249 (or (nthcdr 2 elt) 7250 ;; Only in one file 7251 (setcdr elt (cdr (nth 1 elt))))))) 7252 pack name cons1 to l1 l2 l3 l4 b) 7253 ;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later! 7254 (setq cperl-hierarchy (list l1 l2 l3)) 7255 (if cperl-xemacs-p ; Not checked 7256 (progn 7257 (or tags-file-name 7258 ;; Does this work in XEmacs? 7259 (call-interactively 'visit-tags-table)) 7260 (message "Updating list of classes...") 7261 (set-buffer (get-file-buffer tags-file-name)) 7262 (cperl-tags-hier-fill)) 7263 (or tags-table-list 7264 (call-interactively 'visit-tags-table)) 7265 (mapcar 7266 (function 7267 (lambda (tagsfile) 7268 (message "Updating list of classes... %s" tagsfile) 7269 (set-buffer (get-file-buffer tagsfile)) 7270 (cperl-tags-hier-fill))) 7271 tags-table-list) 7272 (message "Updating list of classes... postprocessing...")) 7273 (mapcar remover (car cperl-hierarchy)) 7274 (mapcar remover (nth 1 cperl-hierarchy)) 7275 (setq to (list nil (cons "Packages: " (nth 1 cperl-hierarchy)) 7276 (cons "Methods: " (car cperl-hierarchy)))) 7277 (cperl-tags-treeify to 1) 7278 (setcar (nthcdr 2 cperl-hierarchy) 7279 (cperl-menu-to-keymap (cons '("+++UPDATE+++" . -999) (cdr to)))) 7280 (message "Updating list of classes: done, requesting display...") 7281 ;;(cperl-imenu-addback (nth 2 cperl-hierarchy)) 7282 )) 7283 (or (nth 2 cperl-hierarchy) 7284 (error "No items found")) 7285 (setq update 7286;;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy)) 7287 (if (if (fboundp 'display-popup-menus-p) 7288 (let ((f 'display-popup-menus-p)) 7289 (funcall f)) 7290 window-system) 7291 (x-popup-menu t (nth 2 cperl-hierarchy)) 7292 (require 'tmm) 7293 (tmm-prompt (nth 2 cperl-hierarchy)))) 7294 (if (and update (listp update)) 7295 (progn (while (cdr update) (setq update (cdr update))) 7296 (setq update (car update)))) ; Get the last from the list 7297 (if (vectorp update) 7298 (progn 7299 (find-file (elt update 0)) 7300 (cperl-etags-goto-tag-location (elt update 1)))) 7301 (if (eq update -999) (cperl-tags-hier-init t))) 7302 7303(defun cperl-tags-treeify (to level) 7304 ;; cadr of `to' is read-write. On start it is a cons 7305 (let* ((regexp (concat "^\\(" (mapconcat 7306 'identity 7307 (make-list level "[_a-zA-Z0-9]+") 7308 "::") 7309 "\\)\\(::\\)?")) 7310 (packages (cdr (nth 1 to))) 7311 (methods (cdr (nth 2 to))) 7312 l1 head tail cons1 cons2 ord writeto packs recurse 7313 root-packages root-functions ms many_ms same_name ps 7314 (move-deeper 7315 (function 7316 (lambda (elt) 7317 (cond ((and (string-match regexp (car elt)) 7318 (or (eq ord 1) (match-end 2))) 7319 (setq head (substring (car elt) 0 (match-end 1)) 7320 tail (if (match-end 2) (substring (car elt) 7321 (match-end 2))) 7322 recurse t) 7323 (if (setq cons1 (assoc head writeto)) nil 7324 ;; Need to init new head 7325 (setcdr writeto (cons (list head (list "Packages: ") 7326 (list "Methods: ")) 7327 (cdr writeto))) 7328 (setq cons1 (nth 1 writeto))) 7329 (setq cons2 (nth ord cons1)) ; Either packs or meths 7330 (setcdr cons2 (cons elt (cdr cons2)))) 7331 ((eq ord 2) 7332 (setq root-functions (cons elt root-functions))) 7333 (t 7334 (setq root-packages (cons elt root-packages)))))))) 7335 (setcdr to l1) ; Init to dynamic space 7336 (setq writeto to) 7337 (setq ord 1) 7338 (mapcar move-deeper packages) 7339 (setq ord 2) 7340 (mapcar move-deeper methods) 7341 (if recurse 7342 (mapcar (function (lambda (elt) 7343 (cperl-tags-treeify elt (1+ level)))) 7344 (cdr to))) 7345 ;;Now clean up leaders with one child only 7346 (mapcar (function (lambda (elt) 7347 (if (not (and (listp (cdr elt)) 7348 (eq (length elt) 2))) nil 7349 (setcar elt (car (nth 1 elt))) 7350 (setcdr elt (cdr (nth 1 elt)))))) 7351 (cdr to)) 7352 ;; Sort the roots of subtrees 7353 (if (default-value 'imenu-sort-function) 7354 (setcdr to 7355 (sort (cdr to) (default-value 'imenu-sort-function)))) 7356 ;; Now add back functions removed from display 7357 (mapcar (function (lambda (elt) 7358 (setcdr to (cons elt (cdr to))))) 7359 (if (default-value 'imenu-sort-function) 7360 (nreverse 7361 (sort root-functions (default-value 'imenu-sort-function))) 7362 root-functions)) 7363 ;; Now add back packages removed from display 7364 (mapcar (function (lambda (elt) 7365 (setcdr to (cons (cons (concat "package " (car elt)) 7366 (cdr elt)) 7367 (cdr to))))) 7368 (if (default-value 'imenu-sort-function) 7369 (nreverse 7370 (sort root-packages (default-value 'imenu-sort-function))) 7371 root-packages)))) 7372 7373;;;(x-popup-menu t 7374;;; '(keymap "Name1" 7375;;; ("Ret1" "aa") 7376;;; ("Head1" "ab" 7377;;; keymap "Name2" 7378;;; ("Tail1" "x") ("Tail2" "y")))) 7379 7380(defun cperl-list-fold (list name limit) 7381 (let (list1 list2 elt1 (num 0)) 7382 (if (<= (length list) limit) list 7383 (setq list1 nil list2 nil) 7384 (while list 7385 (setq num (1+ num) 7386 elt1 (car list) 7387 list (cdr list)) 7388 (if (<= num imenu-max-items) 7389 (setq list2 (cons elt1 list2)) 7390 (setq list1 (cons (cons name 7391 (nreverse list2)) 7392 list1) 7393 list2 (list elt1) 7394 num 1))) 7395 (nreverse (cons (cons name 7396 (nreverse list2)) 7397 list1))))) 7398 7399(defun cperl-menu-to-keymap (menu &optional name) 7400 (let (list) 7401 (cons 'keymap 7402 (mapcar 7403 (function 7404 (lambda (elt) 7405 (cond ((listp (cdr elt)) 7406 (setq list (cperl-list-fold 7407 (cdr elt) (car elt) imenu-max-items)) 7408 (cons nil 7409 (cons (car elt) 7410 (cperl-menu-to-keymap list)))) 7411 (t 7412 (list (cdr elt) (car elt) t))))) ; t is needed in 19.34 7413 (cperl-list-fold menu "Root" imenu-max-items))))) 7414 7415 7416(defvar cperl-bad-style-regexp 7417 (mapconcat 'identity 7418 '("[^-\n\t <>=+!.&|(*/'`\"#^][-=+<>!|&^]" ; char sign 7419 "[-<>=+^&|]+[^- \t\n=+<>~]") ; sign+ char 7420 "\\|") 7421 "Finds places such that insertion of a whitespace may help a lot.") 7422 7423(defvar cperl-not-bad-style-regexp 7424 (mapconcat 7425 'identity 7426 '("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++ 7427 "[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used. 7428 "&[(a-zA-Z0-9_$]" ; &subroutine &(var->field) 7429 "<\\$?\\sw+\\(\\.\\(\\sw\\|_\\)+\\)?>" ; <IN> <stdin.h> 7430 "-[a-zA-Z][ \t]+[_$\"'`a-zA-Z]" ; -f file, -t STDIN 7431 "-[0-9]" ; -5 7432 "\\+\\+" ; ++var 7433 "--" ; --var 7434 ".->" ; a->b 7435 "->" ; a SPACE ->b 7436 "\\[-" ; a[-1] 7437 "\\\\[&$@*\\\\]" ; \&func 7438 "^=" ; =head 7439 "\\$." ; $| 7440 "<<[a-zA-Z_'\"`]" ; <<FOO, <<'FOO' 7441 "||" 7442 "&&" 7443 "[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C<code like text> 7444 "-[a-zA-Z_0-9]+[ \t]*=>" ; -option => value 7445 ;; Unaddressed trouble spots: = -abc, f(56, -abc) --- specialcased below 7446 ;;"[*/+-|&<.]+=" 7447 ) 7448 "\\|") 7449 "If matches at the start of match found by `my-bad-c-style-regexp', 7450insertion of a whitespace will not help.") 7451 7452(defvar found-bad) 7453 7454(defun cperl-find-bad-style () 7455 "Find places in the buffer where insertion of a whitespace may help. 7456Prompts user for insertion of spaces. 7457Currently it is tuned to C and Perl syntax." 7458 (interactive) 7459 (let (found-bad (p (point))) 7460 (setq last-nonmenu-event 13) ; To disable popup 7461 (goto-char (point-min)) 7462 (map-y-or-n-p "Insert space here? " 7463 (lambda (arg) (insert " ")) 7464 'cperl-next-bad-style 7465 '("location" "locations" "insert a space into") 7466 '((?\C-r (lambda (arg) 7467 (let ((buffer-quit-function 7468 'exit-recursive-edit)) 7469 (message "Exit with Esc Esc") 7470 (recursive-edit) 7471 t)) ; Consider acted upon 7472 "edit, exit with Esc Esc") 7473 (?e (lambda (arg) 7474 (let ((buffer-quit-function 7475 'exit-recursive-edit)) 7476 (message "Exit with Esc Esc") 7477 (recursive-edit) 7478 t)) ; Consider acted upon 7479 "edit, exit with Esc Esc")) 7480 t) 7481 (if found-bad (goto-char found-bad) 7482 (goto-char p) 7483 (message "No appropriate place found")))) 7484 7485(defun cperl-next-bad-style () 7486 (let (p (not-found t) (point (point)) found) 7487 (while (and not-found 7488 (re-search-forward cperl-bad-style-regexp nil 'to-end)) 7489 (setq p (point)) 7490 (goto-char (match-beginning 0)) 7491 (if (or 7492 (looking-at cperl-not-bad-style-regexp) 7493 ;; Check for a < -b and friends 7494 (and (eq (following-char) ?\-) 7495 (save-excursion 7496 (skip-chars-backward " \t\n") 7497 (memq (preceding-char) '(?\= ?\> ?\< ?\, ?\( ?\[ ?\{)))) 7498 ;; Now check for syntax type 7499 (save-match-data 7500 (setq found (point)) 7501 (beginning-of-defun) 7502 (let ((pps (parse-partial-sexp (point) found))) 7503 (or (nth 3 pps) (nth 4 pps) (nth 5 pps))))) 7504 (goto-char (match-end 0)) 7505 (goto-char (1- p)) 7506 (setq not-found nil 7507 found-bad found))) 7508 (not not-found))) 7509 7510 7511;;; Getting help 7512(defvar cperl-have-help-regexp 7513 ;;(concat "\\(" 7514 (mapconcat 7515 'identity 7516 '("[$@%*&][0-9a-zA-Z_:]+\\([ \t]*[[{]\\)?" ; Usual variable 7517 "[$@]\\^[a-zA-Z]" ; Special variable 7518 "[$@][^ \n\t]" ; Special variable 7519 "-[a-zA-Z]" ; File test 7520 "\\\\[a-zA-Z0]" ; Special chars 7521 "^=[a-z][a-zA-Z0-9_]*" ; POD sections 7522 "[-!&*+,-./<=>?\\\\^|~]+" ; Operator 7523 "[a-zA-Z_0-9:]+" ; symbol or number 7524 "x=" 7525 "#!") 7526 ;;"\\)\\|\\(" 7527 "\\|") 7528 ;;"\\)" 7529 ;;) 7530 "Matches places in the buffer we can find help for.") 7531 7532(defvar cperl-message-on-help-error t) 7533(defvar cperl-help-from-timer nil) 7534 7535(defun cperl-word-at-point-hard () 7536 ;; Does not save-excursion 7537 ;; Get to the something meaningful 7538 (or (eobp) (eolp) (forward-char 1)) 7539 (re-search-backward "[-a-zA-Z0-9_:!&*+,-./<=>?\\\\^|~$%@]" 7540 (save-excursion (beginning-of-line) (point)) 7541 'to-beg) 7542 ;; (cond 7543 ;; ((or (eobp) (looking-at "[][ \t\n{}();,]")) ; Not at a symbol 7544 ;; (skip-chars-backward " \n\t\r({[]});,") 7545 ;; (or (bobp) (backward-char 1)))) 7546 ;; Try to backtrace 7547 (cond 7548 ((looking-at "[a-zA-Z0-9_:]") ; symbol 7549 (skip-chars-backward "a-zA-Z0-9_:") 7550 (cond 7551 ((and (eq (preceding-char) ?^) ; $^I 7552 (eq (char-after (- (point) 2)) ?\$)) 7553 (forward-char -2)) 7554 ((memq (preceding-char) (append "*$@%&\\" nil)) ; *glob 7555 (forward-char -1)) 7556 ((and (eq (preceding-char) ?\=) 7557 (eq (current-column) 1)) 7558 (forward-char -1))) ; =head1 7559 (if (and (eq (preceding-char) ?\<) 7560 (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <FH> 7561 (forward-char -1))) 7562 ((and (looking-at "=") (eq (preceding-char) ?x)) ; x= 7563 (forward-char -1)) 7564 ((and (looking-at "\\^") (eq (preceding-char) ?\$)) ; $^I 7565 (forward-char -1)) 7566 ((looking-at "[-!&*+,-./<=>?\\\\^|~]") 7567 (skip-chars-backward "-!&*+,-./<=>?\\\\^|~") 7568 (cond 7569 ((and (eq (preceding-char) ?\$) 7570 (not (eq (char-after (- (point) 2)) ?\$))) ; $- 7571 (forward-char -1)) 7572 ((and (eq (following-char) ?\>) 7573 (string-match "[a-zA-Z0-9_]" (char-to-string (preceding-char))) 7574 (save-excursion 7575 (forward-sexp -1) 7576 (and (eq (preceding-char) ?\<) 7577 (looking-at "\\$?[a-zA-Z0-9_:]+>")))) ; <FH> 7578 (search-backward "<")))) 7579 ((and (eq (following-char) ?\$) 7580 (eq (preceding-char) ?\<) 7581 (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <$fh> 7582 (forward-char -1))) 7583 (if (looking-at cperl-have-help-regexp) 7584 (buffer-substring (match-beginning 0) (match-end 0)))) 7585 7586(defun cperl-get-help () 7587 "Get one-line docs on the symbol at the point. 7588The data for these docs is a little bit obsolete and may be in fact longer 7589than a line. Your contribution to update/shorten it is appreciated." 7590 (interactive) 7591 (save-match-data ; May be called "inside" query-replace 7592 (save-excursion 7593 (let ((word (cperl-word-at-point-hard))) 7594 (if word 7595 (if (and cperl-help-from-timer ; Bail out if not in mainland 7596 (not (string-match "^#!\\|\\\\\\|^=" word)) ; Show help even in comments/strings. 7597 (or (memq (get-text-property (point) 'face) 7598 '(font-lock-comment-face font-lock-string-face)) 7599 (memq (get-text-property (point) 'syntax-type) 7600 '(pod here-doc format)))) 7601 nil 7602 (cperl-describe-perl-symbol word)) 7603 (if cperl-message-on-help-error 7604 (message "Nothing found for %s..." 7605 (buffer-substring (point) (min (+ 5 (point)) (point-max)))))))))) 7606 7607;;; Stolen from perl-descr.el by Johan Vromans: 7608 7609(defvar cperl-doc-buffer " *perl-doc*" 7610 "Where the documentation can be found.") 7611 7612(defun cperl-describe-perl-symbol (val) 7613 "Display the documentation of symbol at point, a Perl operator." 7614 (let ((enable-recursive-minibuffers t) 7615 args-file regexp) 7616 (cond 7617 ((string-match "^[&*][a-zA-Z_]" val) 7618 (setq val (concat (substring val 0 1) "NAME"))) 7619 ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*\\[" val) 7620 (setq val (concat "@" (substring val 1 (match-end 1))))) 7621 ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*{" val) 7622 (setq val (concat "%" (substring val 1 (match-end 1))))) 7623 ((and (string= val "x") (string-match "^x=" val)) 7624 (setq val "x=")) 7625 ((string-match "^\\$[\C-a-\C-z]" val) 7626 (setq val (concat "$^" (char-to-string (+ ?A -1 (aref val 1)))))) 7627 ((string-match "^CORE::" val) 7628 (setq val "CORE::")) 7629 ((string-match "^SUPER::" val) 7630 (setq val "SUPER::")) 7631 ((and (string= "<" val) (string-match "^<\\$?[a-zA-Z0-9_:]+>" val)) 7632 (setq val "<NAME>"))) 7633 (setq regexp (concat "^" 7634 "\\([^a-zA-Z0-9_:]+[ \t]+\\)?" 7635 (regexp-quote val) 7636 "\\([ \t([/]\\|$\\)")) 7637 7638 ;; get the buffer with the documentation text 7639 (cperl-switch-to-doc-buffer) 7640 7641 ;; lookup in the doc 7642 (goto-char (point-min)) 7643 (let ((case-fold-search nil)) 7644 (list 7645 (if (re-search-forward regexp (point-max) t) 7646 (save-excursion 7647 (beginning-of-line 1) 7648 (let ((lnstart (point))) 7649 (end-of-line) 7650 (message "%s" (buffer-substring lnstart (point))))) 7651 (if cperl-message-on-help-error 7652 (message "No definition for %s" val))))))) 7653 7654(defvar cperl-short-docs 'please-ignore-this-line 7655 ;; Perl4 version was written by Johan Vromans (jvromans@squirrel.nl) 7656 "# based on '@(#)@ perl-descr.el 1.9 - describe-perl-symbol' [Perl 5] 7657... Range (list context); flip/flop [no flop when flip] (scalar context). 7658! ... Logical negation. 7659... != ... Numeric inequality. 7660... !~ ... Search pattern, substitution, or translation (negated). 7661$! In numeric context: errno. In a string context: error string. 7662$\" The separator which joins elements of arrays interpolated in strings. 7663$# The output format for printed numbers. Default is %.15g or close. 7664$$ Process number of this script. Changes in the fork()ed child process. 7665$% The current page number of the currently selected output channel. 7666 7667 The following variables are always local to the current block: 7668 7669$1 Match of the 1st set of parentheses in the last match (auto-local). 7670$2 Match of the 2nd set of parentheses in the last match (auto-local). 7671$3 Match of the 3rd set of parentheses in the last match (auto-local). 7672$4 Match of the 4th set of parentheses in the last match (auto-local). 7673$5 Match of the 5th set of parentheses in the last match (auto-local). 7674$6 Match of the 6th set of parentheses in the last match (auto-local). 7675$7 Match of the 7th set of parentheses in the last match (auto-local). 7676$8 Match of the 8th set of parentheses in the last match (auto-local). 7677$9 Match of the 9th set of parentheses in the last match (auto-local). 7678$& The string matched by the last pattern match (auto-local). 7679$' The string after what was matched by the last match (auto-local). 7680$` The string before what was matched by the last match (auto-local). 7681 7682$( The real gid of this process. 7683$) The effective gid of this process. 7684$* Deprecated: Set to 1 to do multiline matching within a string. 7685$+ The last bracket matched by the last search pattern. 7686$, The output field separator for the print operator. 7687$- The number of lines left on the page. 7688$. The current input line number of the last filehandle that was read. 7689$/ The input record separator, newline by default. 7690$0 Name of the file containing the current perl script (read/write). 7691$: String may be broken after these characters to fill ^-lines in a format. 7692$; Subscript separator for multi-dim array emulation. Default \"\\034\". 7693$< The real uid of this process. 7694$= The page length of the current output channel. Default is 60 lines. 7695$> The effective uid of this process. 7696$? The status returned by the last ``, pipe close or `system'. 7697$@ The perl error message from the last eval or do @var{EXPR} command. 7698$ARGV The name of the current file used with <> . 7699$[ Deprecated: The index of the first element/char in an array/string. 7700$\\ The output record separator for the print operator. 7701$] The perl version string as displayed with perl -v. 7702$^ The name of the current top-of-page format. 7703$^A The current value of the write() accumulator for format() lines. 7704$^D The value of the perl debug (-D) flags. 7705$^E Information about the last system error other than that provided by $!. 7706$^F The highest system file descriptor, ordinarily 2. 7707$^H The current set of syntax checks enabled by `use strict'. 7708$^I The value of the in-place edit extension (perl -i option). 7709$^L What formats output to perform a formfeed. Default is \\f. 7710$^M A buffer for emergency memory allocation when running out of memory. 7711$^O The operating system name under which this copy of Perl was built. 7712$^P Internal debugging flag. 7713$^T The time the script was started. Used by -A/-M/-C file tests. 7714$^W True if warnings are requested (perl -w flag). 7715$^X The name under which perl was invoked (argv[0] in C-speech). 7716$_ The default input and pattern-searching space. 7717$| Auto-flush after write/print on current output channel? Default 0. 7718$~ The name of the current report format. 7719... % ... Modulo division. 7720... %= ... Modulo division assignment. 7721%ENV Contains the current environment. 7722%INC List of files that have been require-d or do-ne. 7723%SIG Used to set signal handlers for various signals. 7724... & ... Bitwise and. 7725... && ... Logical and. 7726... &&= ... Logical and assignment. 7727... &= ... Bitwise and assignment. 7728... * ... Multiplication. 7729... ** ... Exponentiation. 7730*NAME Glob: all objects refered by NAME. *NAM1 = *NAM2 aliases NAM1 to NAM2. 7731&NAME(arg0, ...) Subroutine call. Arguments go to @_. 7732... + ... Addition. +EXPR Makes EXPR into scalar context. 7733++ Auto-increment (magical on strings). ++EXPR EXPR++ 7734... += ... Addition assignment. 7735, Comma operator. 7736... - ... Subtraction. 7737-- Auto-decrement (NOT magical on strings). --EXPR EXPR-- 7738... -= ... Subtraction assignment. 7739-A Access time in days since script started. 7740-B File is a non-text (binary) file. 7741-C Inode change time in days since script started. 7742-M Age in days since script started. 7743-O File is owned by real uid. 7744-R File is readable by real uid. 7745-S File is a socket . 7746-T File is a text file. 7747-W File is writable by real uid. 7748-X File is executable by real uid. 7749-b File is a block special file. 7750-c File is a character special file. 7751-d File is a directory. 7752-e File exists . 7753-f File is a plain file. 7754-g File has setgid bit set. 7755-k File has sticky bit set. 7756-l File is a symbolic link. 7757-o File is owned by effective uid. 7758-p File is a named pipe (FIFO). 7759-r File is readable by effective uid. 7760-s File has non-zero size. 7761-t Tests if filehandle (STDIN by default) is opened to a tty. 7762-u File has setuid bit set. 7763-w File is writable by effective uid. 7764-x File is executable by effective uid. 7765-z File has zero size. 7766. Concatenate strings. 7767.. Range (list context); flip/flop (scalar context) operator. 7768.= Concatenate assignment strings 7769... / ... Division. /PATTERN/ioxsmg Pattern match 7770... /= ... Division assignment. 7771/PATTERN/ioxsmg Pattern match. 7772... < ... Numeric less than. <pattern> Glob. See <NAME>, <> as well. 7773<NAME> Reads line from filehandle NAME (a bareword or dollar-bareword). 7774<pattern> Glob (Unless pattern is bareword/dollar-bareword - see <NAME>). 7775<> Reads line from union of files in @ARGV (= command line) and STDIN. 7776... << ... Bitwise shift left. << start of HERE-DOCUMENT. 7777... <= ... Numeric less than or equal to. 7778... <=> ... Numeric compare. 7779... = ... Assignment. 7780... == ... Numeric equality. 7781... =~ ... Search pattern, substitution, or translation 7782... > ... Numeric greater than. 7783... >= ... Numeric greater than or equal to. 7784... >> ... Bitwise shift right. 7785... >>= ... Bitwise shift right assignment. 7786... ? ... : ... Condition=if-then-else operator. ?PAT? One-time pattern match. 7787?PATTERN? One-time pattern match. 7788@ARGV Command line arguments (not including the command name - see $0). 7789@INC List of places to look for perl scripts during do/include/use. 7790@_ Parameter array for subroutines; result of split() unless in list context. 7791\\ Creates reference to what follows, like \\$var, or quotes non-\\w in strings. 7792\\0 Octal char, e.g. \\033. 7793\\E Case modification terminator. See \\Q, \\L, and \\U. 7794\\L Lowercase until \\E . See also \\l, lc. 7795\\U Upcase until \\E . See also \\u, uc. 7796\\Q Quote metacharacters until \\E . See also quotemeta. 7797\\a Alarm character (octal 007). 7798\\b Backspace character (octal 010). 7799\\c Control character, e.g. \\c[ . 7800\\e Escape character (octal 033). 7801\\f Formfeed character (octal 014). 7802\\l Lowercase the next character. See also \\L and \\u, lcfirst. 7803\\n Newline character (octal 012 on most systems). 7804\\r Return character (octal 015 on most systems). 7805\\t Tab character (octal 011). 7806\\u Upcase the next character. See also \\U and \\l, ucfirst. 7807\\x Hex character, e.g. \\x1b. 7808... ^ ... Bitwise exclusive or. 7809__END__ Ends program source. 7810__DATA__ Ends program source. 7811__FILE__ Current (source) filename. 7812__LINE__ Current line in current source. 7813__PACKAGE__ Current package. 7814ARGV Default multi-file input filehandle. <ARGV> is a synonym for <>. 7815ARGVOUT Output filehandle with -i flag. 7816BEGIN { ... } Immediately executed (during compilation) piece of code. 7817END { ... } Pseudo-subroutine executed after the script finishes. 7818CHECK { ... } Pseudo-subroutine executed after the script is compiled. 7819INIT { ... } Pseudo-subroutine executed before the script starts running. 7820DATA Input filehandle for what follows after __END__ or __DATA__. 7821accept(NEWSOCKET,GENERICSOCKET) 7822alarm(SECONDS) 7823atan2(X,Y) 7824bind(SOCKET,NAME) 7825binmode(FILEHANDLE) 7826caller[(LEVEL)] 7827chdir(EXPR) 7828chmod(LIST) 7829chop[(LIST|VAR)] 7830chown(LIST) 7831chroot(FILENAME) 7832close(FILEHANDLE) 7833closedir(DIRHANDLE) 7834... cmp ... String compare. 7835connect(SOCKET,NAME) 7836continue of { block } continue { block }. Is executed after `next' or at end. 7837cos(EXPR) 7838crypt(PLAINTEXT,SALT) 7839dbmclose(%HASH) 7840dbmopen(%HASH,DBNAME,MODE) 7841defined(EXPR) 7842delete($HASH{KEY}) 7843die(LIST) 7844do { ... }|SUBR while|until EXPR executes at least once 7845do(EXPR|SUBR([LIST])) (with while|until executes at least once) 7846dump LABEL 7847each(%HASH) 7848endgrent 7849endhostent 7850endnetent 7851endprotoent 7852endpwent 7853endservent 7854eof[([FILEHANDLE])] 7855... eq ... String equality. 7856eval(EXPR) or eval { BLOCK } 7857exec([TRUENAME] ARGV0, ARGVs) or exec(SHELL_COMMAND_LINE) 7858exit(EXPR) 7859exp(EXPR) 7860fcntl(FILEHANDLE,FUNCTION,SCALAR) 7861fileno(FILEHANDLE) 7862flock(FILEHANDLE,OPERATION) 7863for (EXPR;EXPR;EXPR) { ... } 7864foreach [VAR] (@ARRAY) { ... } 7865fork 7866... ge ... String greater than or equal. 7867getc[(FILEHANDLE)] 7868getgrent 7869getgrgid(GID) 7870getgrnam(NAME) 7871gethostbyaddr(ADDR,ADDRTYPE) 7872gethostbyname(NAME) 7873gethostent 7874getlogin 7875getnetbyaddr(ADDR,ADDRTYPE) 7876getnetbyname(NAME) 7877getnetent 7878getpeername(SOCKET) 7879getpgrp(PID) 7880getppid 7881getpriority(WHICH,WHO) 7882getprotobyname(NAME) 7883getprotobynumber(NUMBER) 7884getprotoent 7885getpwent 7886getpwnam(NAME) 7887getpwuid(UID) 7888getservbyname(NAME,PROTO) 7889getservbyport(PORT,PROTO) 7890getservent 7891getsockname(SOCKET) 7892getsockopt(SOCKET,LEVEL,OPTNAME) 7893gmtime(EXPR) 7894goto LABEL 7895... gt ... String greater than. 7896hex(EXPR) 7897if (EXPR) { ... } [ elsif (EXPR) { ... } ... ] [ else { ... } ] or EXPR if EXPR 7898index(STR,SUBSTR[,OFFSET]) 7899int(EXPR) 7900ioctl(FILEHANDLE,FUNCTION,SCALAR) 7901join(EXPR,LIST) 7902keys(%HASH) 7903kill(LIST) 7904last [LABEL] 7905... le ... String less than or equal. 7906length(EXPR) 7907link(OLDFILE,NEWFILE) 7908listen(SOCKET,QUEUESIZE) 7909local(LIST) 7910localtime(EXPR) 7911log(EXPR) 7912lstat(EXPR|FILEHANDLE|VAR) 7913... lt ... String less than. 7914m/PATTERN/iogsmx 7915mkdir(FILENAME,MODE) 7916msgctl(ID,CMD,ARG) 7917msgget(KEY,FLAGS) 7918msgrcv(ID,VAR,SIZE,TYPE.FLAGS) 7919msgsnd(ID,MSG,FLAGS) 7920my VAR or my (VAR1,...) Introduces a lexical variable ($VAR, @ARR, or %HASH). 7921our VAR or our (VAR1,...) Lexically enable a global variable ($V, @A, or %H). 7922... ne ... String inequality. 7923next [LABEL] 7924oct(EXPR) 7925open(FILEHANDLE[,EXPR]) 7926opendir(DIRHANDLE,EXPR) 7927ord(EXPR) ASCII value of the first char of the string. 7928pack(TEMPLATE,LIST) 7929package NAME Introduces package context. 7930pipe(READHANDLE,WRITEHANDLE) Create a pair of filehandles on ends of a pipe. 7931pop(ARRAY) 7932print [FILEHANDLE] [(LIST)] 7933printf [FILEHANDLE] (FORMAT,LIST) 7934push(ARRAY,LIST) 7935q/STRING/ Synonym for 'STRING' 7936qq/STRING/ Synonym for \"STRING\" 7937qx/STRING/ Synonym for `STRING` 7938rand[(EXPR)] 7939read(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) 7940readdir(DIRHANDLE) 7941readlink(EXPR) 7942recv(SOCKET,SCALAR,LEN,FLAGS) 7943redo [LABEL] 7944rename(OLDNAME,NEWNAME) 7945require [FILENAME | PERL_VERSION] 7946reset[(EXPR)] 7947return(LIST) 7948reverse(LIST) 7949rewinddir(DIRHANDLE) 7950rindex(STR,SUBSTR[,OFFSET]) 7951rmdir(FILENAME) 7952s/PATTERN/REPLACEMENT/gieoxsm 7953scalar(EXPR) 7954seek(FILEHANDLE,POSITION,WHENCE) 7955seekdir(DIRHANDLE,POS) 7956select(FILEHANDLE | RBITS,WBITS,EBITS,TIMEOUT) 7957semctl(ID,SEMNUM,CMD,ARG) 7958semget(KEY,NSEMS,SIZE,FLAGS) 7959semop(KEY,...) 7960send(SOCKET,MSG,FLAGS[,TO]) 7961setgrent 7962sethostent(STAYOPEN) 7963setnetent(STAYOPEN) 7964setpgrp(PID,PGRP) 7965setpriority(WHICH,WHO,PRIORITY) 7966setprotoent(STAYOPEN) 7967setpwent 7968setservent(STAYOPEN) 7969setsockopt(SOCKET,LEVEL,OPTNAME,OPTVAL) 7970shift[(ARRAY)] 7971shmctl(ID,CMD,ARG) 7972shmget(KEY,SIZE,FLAGS) 7973shmread(ID,VAR,POS,SIZE) 7974shmwrite(ID,STRING,POS,SIZE) 7975shutdown(SOCKET,HOW) 7976sin(EXPR) 7977sleep[(EXPR)] 7978socket(SOCKET,DOMAIN,TYPE,PROTOCOL) 7979socketpair(SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL) 7980sort [SUBROUTINE] (LIST) 7981splice(ARRAY,OFFSET[,LENGTH[,LIST]]) 7982split[(/PATTERN/[,EXPR[,LIMIT]])] 7983sprintf(FORMAT,LIST) 7984sqrt(EXPR) 7985srand(EXPR) 7986stat(EXPR|FILEHANDLE|VAR) 7987study[(SCALAR)] 7988sub [NAME [(format)]] { BODY } sub NAME [(format)]; sub [(format)] {...} 7989substr(EXPR,OFFSET[,LEN]) 7990symlink(OLDFILE,NEWFILE) 7991syscall(LIST) 7992sysread(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) 7993system([TRUENAME] ARGV0 [,ARGV]) or system(SHELL_COMMAND_LINE) 7994syswrite(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) 7995tell[(FILEHANDLE)] 7996telldir(DIRHANDLE) 7997time 7998times 7999tr/SEARCHLIST/REPLACEMENTLIST/cds 8000truncate(FILE|EXPR,LENGTH) 8001umask[(EXPR)] 8002undef[(EXPR)] 8003unless (EXPR) { ... } [ else { ... } ] or EXPR unless EXPR 8004unlink(LIST) 8005unpack(TEMPLATE,EXPR) 8006unshift(ARRAY,LIST) 8007until (EXPR) { ... } EXPR until EXPR 8008utime(LIST) 8009values(%HASH) 8010vec(EXPR,OFFSET,BITS) 8011wait 8012waitpid(PID,FLAGS) 8013wantarray Returns true if the sub/eval is called in list context. 8014warn(LIST) 8015while (EXPR) { ... } EXPR while EXPR 8016write[(EXPR|FILEHANDLE)] 8017... x ... Repeat string or array. 8018x= ... Repetition assignment. 8019y/SEARCHLIST/REPLACEMENTLIST/ 8020... | ... Bitwise or. 8021... || ... Logical or. 8022~ ... Unary bitwise complement. 8023#! OS interpreter indicator. If contains `perl', used for options, and -x. 8024AUTOLOAD {...} Shorthand for `sub AUTOLOAD {...}'. 8025CORE:: Prefix to access builtin function if imported sub obscures it. 8026SUPER:: Prefix to lookup for a method in @ISA classes. 8027DESTROY Shorthand for `sub DESTROY {...}'. 8028... EQ ... Obsolete synonym of `eq'. 8029... GE ... Obsolete synonym of `ge'. 8030... GT ... Obsolete synonym of `gt'. 8031... LE ... Obsolete synonym of `le'. 8032... LT ... Obsolete synonym of `lt'. 8033... NE ... Obsolete synonym of `ne'. 8034abs [ EXPR ] absolute value 8035... and ... Low-precedence synonym for &&. 8036bless REFERENCE [, PACKAGE] Makes reference into an object of a package. 8037chomp [LIST] Strips $/ off LIST/$_. Returns count. Special if $/ eq ''! 8038chr Converts a number to char with the same ordinal. 8039else Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. 8040elsif Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. 8041exists $HASH{KEY} True if the key exists. 8042format [NAME] = Start of output format. Ended by a single dot (.) on a line. 8043formline PICTURE, LIST Backdoor into \"format\" processing. 8044glob EXPR Synonym of <EXPR>. 8045lc [ EXPR ] Returns lowercased EXPR. 8046lcfirst [ EXPR ] Returns EXPR with lower-cased first letter. 8047grep EXPR,LIST or grep {BLOCK} LIST Filters LIST via EXPR/BLOCK. 8048map EXPR, LIST or map {BLOCK} LIST Applies EXPR/BLOCK to elts of LIST. 8049no PACKAGE [SYMBOL1, ...] Partial reverse for `use'. Runs `unimport' method. 8050not ... Low-precedence synonym for ! - negation. 8051... or ... Low-precedence synonym for ||. 8052pos STRING Set/Get end-position of the last match over this string, see \\G. 8053quotemeta [ EXPR ] Quote regexp metacharacters. 8054qw/WORD1 .../ Synonym of split('', 'WORD1 ...') 8055readline FH Synonym of <FH>. 8056readpipe CMD Synonym of `CMD`. 8057ref [ EXPR ] Type of EXPR when dereferenced. 8058sysopen FH, FILENAME, MODE [, PERM] (MODE is numeric, see Fcntl.) 8059tie VAR, PACKAGE, LIST Hide an object behind a simple Perl variable. 8060tied Returns internal object for a tied data. 8061uc [ EXPR ] Returns upcased EXPR. 8062ucfirst [ EXPR ] Returns EXPR with upcased first letter. 8063untie VAR Unlink an object from a simple Perl variable. 8064use PACKAGE [SYMBOL1, ...] Compile-time `require' with consequent `import'. 8065... xor ... Low-precedence synonym for exclusive or. 8066prototype \\&SUB Returns prototype of the function given a reference. 8067=head1 Top-level heading. 8068=head2 Second-level heading. 8069=head3 Third-level heading (is there such?). 8070=over [ NUMBER ] Start list. 8071=item [ TITLE ] Start new item in the list. 8072=back End list. 8073=cut Switch from POD to Perl. 8074=pod Switch from Perl to POD. 8075") 8076 8077(defun cperl-switch-to-doc-buffer (&optional interactive) 8078 "Go to the perl documentation buffer and insert the documentation." 8079 (interactive "p") 8080 (let ((buf (get-buffer-create cperl-doc-buffer))) 8081 (if interactive 8082 (switch-to-buffer-other-window buf) 8083 (set-buffer buf)) 8084 (if (= (buffer-size) 0) 8085 (progn 8086 (insert (documentation-property 'cperl-short-docs 8087 'variable-documentation)) 8088 (setq buffer-read-only t))))) 8089 8090(defun cperl-beautify-regexp-piece (b e embed level) 8091 ;; b is before the starting delimiter, e before the ending 8092 ;; e should be a marker, may be changed, but remains "correct". 8093 ;; EMBED is nil iff we process the whole REx. 8094 ;; The REx is guaranteed to have //x 8095 ;; LEVEL shows how many levels deep to go 8096 ;; position at enter and at leave is not defined 8097 (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline code pos) 8098 (if (not embed) 8099 (goto-char (1+ b)) 8100 (goto-char b) 8101 (cond ((looking-at "(\\?\\\\#") ; (?#) wrongly commented when //x-ing 8102 (forward-char 2) 8103 (delete-char 1) 8104 (forward-char 1)) 8105 ((looking-at "(\\?[^a-zA-Z]") 8106 (forward-char 3)) 8107 ((looking-at "(\\?") ; (?i) 8108 (forward-char 2)) 8109 (t 8110 (forward-char 1)))) 8111 (setq c (if embed (current-indentation) (1- (current-column))) 8112 c1 (+ c (or cperl-regexp-indent-step cperl-indent-level))) 8113 (or (looking-at "[ \t]*[\n#]") 8114 (progn 8115 (insert "\n"))) 8116 (goto-char e) 8117 (beginning-of-line) 8118 (if (re-search-forward "[^ \t]" e t) 8119 (progn ; Something before the ending delimiter 8120 (goto-char e) 8121 (delete-horizontal-space) 8122 (insert "\n") 8123 (cperl-make-indent c) 8124 (set-marker e (point)))) 8125 (goto-char b) 8126 (end-of-line 2) 8127 (while (< (point) (marker-position e)) 8128 (beginning-of-line) 8129 (setq s (point) 8130 inline t) 8131 (skip-chars-forward " \t") 8132 (delete-region s (point)) 8133 (cperl-make-indent c1) 8134 (while (and 8135 inline 8136 (looking-at 8137 (concat "\\([a-zA-Z0-9]+[^*+{?]\\)" ; 1 word 8138 "\\|" ; Embedded variable 8139 "\\$\\([a-zA-Z0-9_]+\\([[{]\\)?\\|[^\n \t)|]\\)" ; 2 3 8140 "\\|" ; $ ^ 8141 "[$^]" 8142 "\\|" ; simple-code simple-code*? 8143 "\\(\\\\.\\|[^][()#|*+?\n]\\)\\([*+{?]\\??\\)?" ; 4 5 8144 "\\|" ; Class 8145 "\\(\\[\\)" ; 6 8146 "\\|" ; Grouping 8147 "\\((\\(\\?\\)?\\)" ; 7 8 8148 "\\|" ; | 8149 "\\(|\\)"))) ; 9 8150 (goto-char (match-end 0)) 8151 (setq spaces t) 8152 (cond ((match-beginning 1) ; Alphanum word + junk 8153 (forward-char -1)) 8154 ((or (match-beginning 3) ; $ab[12] 8155 (and (match-beginning 5) ; X* X+ X{2,3} 8156 (eq (preceding-char) ?\{))) 8157 (forward-char -1) 8158 (forward-sexp 1)) 8159 ((and ; [], already syntaxified 8160 (match-beginning 6) 8161 cperl-regexp-scan 8162 cperl-use-syntax-table-text-property) 8163 (forward-char -1) 8164 (forward-sexp 1) 8165 (or (eq (preceding-char) ?\]) 8166 (error "[]-group not terminated")) 8167 (re-search-forward 8168 "\\=\\([*+?]\\|{[0-9]+\\(,[0-9]*\\)?}\\)\\??" e t)) 8169 ((match-beginning 6) ; [] 8170 (setq tmp (point)) 8171 (if (looking-at "\\^?\\]") 8172 (goto-char (match-end 0))) 8173 ;; XXXX POSIX classes?! 8174 (while (and (not pos) 8175 (re-search-forward "\\[:\\|\\]" e t)) 8176 (if (eq (preceding-char) ?:) 8177 (or (re-search-forward ":\\]" e t) 8178 (error "[:POSIX:]-group in []-group not terminated")) 8179 (setq pos t))) 8180 (or (eq (preceding-char) ?\]) 8181 (error "[]-group not terminated")) 8182 (re-search-forward 8183 "\\=\\([*+?]\\|{[0-9]+\\(,[0-9]*\\)?}\\)\\??" e t)) 8184 ((match-beginning 7) ; () 8185 (goto-char (match-beginning 0)) 8186 (setq pos (current-column)) 8187 (or (eq pos c1) 8188 (progn 8189 (delete-horizontal-space) 8190 (insert "\n") 8191 (cperl-make-indent c1))) 8192 (setq tmp (point)) 8193 (forward-sexp 1) 8194 ;; (or (forward-sexp 1) 8195 ;; (progn 8196 ;; (goto-char tmp) 8197 ;; (error "()-group not terminated"))) 8198 (set-marker m (1- (point))) 8199 (set-marker m1 (point)) 8200 (if (= level 1) 8201 (if (progn ; indent rigidly if multiline 8202 ;; In fact does not make a lot of sense, since 8203 ;; the starting position can be already lost due 8204 ;; to insertion of "\n" and " " 8205 (goto-char tmp) 8206 (search-forward "\n" m1 t)) 8207 (indent-rigidly (point) m1 (- c1 pos))) 8208 (setq level (1- level)) 8209 (cond 8210 ((not (match-beginning 8)) 8211 (cperl-beautify-regexp-piece tmp m t level)) 8212 ((eq (char-after (+ 2 tmp)) ?\{) ; Code 8213 t) 8214 ((eq (char-after (+ 2 tmp)) ?\() ; Conditional 8215 (goto-char (+ 2 tmp)) 8216 (forward-sexp 1) 8217 (cperl-beautify-regexp-piece (point) m t level)) 8218 ((eq (char-after (+ 2 tmp)) ?<) ; Lookbehind 8219 (goto-char (+ 3 tmp)) 8220 (cperl-beautify-regexp-piece (point) m t level)) 8221 (t 8222 (cperl-beautify-regexp-piece tmp m t level)))) 8223 (goto-char m1) 8224 (cond ((looking-at "[*+?]\\??") 8225 (goto-char (match-end 0))) 8226 ((eq (following-char) ?\{) 8227 (forward-sexp 1) 8228 (if (eq (following-char) ?\?) 8229 (forward-char)))) 8230 (skip-chars-forward " \t") 8231 (setq spaces nil) 8232 (if (looking-at "[#\n]") 8233 (progn 8234 (or (eolp) (indent-for-comment)) 8235 (beginning-of-line 2)) 8236 (delete-horizontal-space) 8237 (insert "\n")) 8238 (end-of-line) 8239 (setq inline nil)) 8240 ((match-beginning 9) ; | 8241 (forward-char -1) 8242 (setq tmp (point)) 8243 (beginning-of-line) 8244 (if (re-search-forward "[^ \t]" tmp t) 8245 (progn 8246 (goto-char tmp) 8247 (delete-horizontal-space) 8248 (insert "\n")) 8249 ;; first at line 8250 (delete-region (point) tmp)) 8251 (cperl-make-indent c) 8252 (forward-char 1) 8253 (skip-chars-forward " \t") 8254 (setq spaces nil) 8255 (if (looking-at "[#\n]") 8256 (beginning-of-line 2) 8257 (delete-horizontal-space) 8258 (insert "\n")) 8259 (end-of-line) 8260 (setq inline nil))) 8261 (or (looking-at "[ \t\n]") 8262 (not spaces) 8263 (insert " ")) 8264 (skip-chars-forward " \t")) 8265 (or (looking-at "[#\n]") 8266 (error "Unknown code `%s' in a regexp" 8267 (buffer-substring (point) (1+ (point))))) 8268 (and inline (end-of-line 2))) 8269 ;; Special-case the last line of group 8270 (if (and (>= (point) (marker-position e)) 8271 (/= (current-indentation) c)) 8272 (progn 8273 (beginning-of-line) 8274 (cperl-make-indent c))))) 8275 8276(defun cperl-make-regexp-x () 8277 ;; Returns position of the start 8278 ;; XXX this is called too often! Need to cache the result! 8279 (save-excursion 8280 (or cperl-use-syntax-table-text-property 8281 (error "I need to have a regexp marked!")) 8282 ;; Find the start 8283 (if (looking-at "\\s|") 8284 nil ; good already 8285 (if (looking-at "\\([smy]\\|qr\\)\\s|") 8286 (forward-char 1) 8287 (re-search-backward "\\s|"))) ; Assume it is scanned already. 8288 ;;(forward-char 1) 8289 (let ((b (point)) (e (make-marker)) have-x delim (c (current-column)) 8290 (sub-p (eq (preceding-char) ?s)) s) 8291 (forward-sexp 1) 8292 (set-marker e (1- (point))) 8293 (setq delim (preceding-char)) 8294 (if (and sub-p (eq delim (char-after (- (point) 2)))) 8295 (error "Possible s/blah// - do not know how to deal with")) 8296 (if sub-p (forward-sexp 1)) 8297 (if (looking-at "\\sw*x") 8298 (setq have-x t) 8299 (insert "x")) 8300 ;; Protect fragile " ", "#" 8301 (if have-x nil 8302 (goto-char (1+ b)) 8303 (while (re-search-forward "\\(\\=\\|[^\\\\]\\)\\(\\\\\\\\\\)*[ \t\n#]" e t) ; Need to include (?#) too? 8304 (forward-char -1) 8305 (insert "\\") 8306 (forward-char 1))) 8307 b))) 8308 8309(defun cperl-beautify-regexp (&optional deep) 8310 "Do it. (Experimental, may change semantics, recheck the result.) 8311We suppose that the regexp is scanned already." 8312 (interactive "P") 8313 (setq deep (if deep (prefix-numeric-value deep) -1)) 8314 (save-excursion 8315 (goto-char (cperl-make-regexp-x)) 8316 (let ((b (point)) (e (make-marker))) 8317 (forward-sexp 1) 8318 (set-marker e (1- (point))) 8319 (cperl-beautify-regexp-piece b e nil deep)))) 8320 8321(defun cperl-regext-to-level-start () 8322 "Goto start of an enclosing group in regexp. 8323We suppose that the regexp is scanned already." 8324 (interactive) 8325 (let ((limit (cperl-make-regexp-x)) done) 8326 (while (not done) 8327 (or (eq (following-char) ?\() 8328 (search-backward "(" (1+ limit) t) 8329 (error "Cannot find `(' which starts a group")) 8330 (setq done 8331 (save-excursion 8332 (skip-chars-backward "\\") 8333 (looking-at "\\(\\\\\\\\\\)*("))) 8334 (or done (forward-char -1))))) 8335 8336(defun cperl-contract-level () 8337 "Find an enclosing group in regexp and contract it. 8338\(Experimental, may change semantics, recheck the result.) 8339We suppose that the regexp is scanned already." 8340 (interactive) 8341 ;; (save-excursion ; Can't, breaks `cperl-contract-levels' 8342 (cperl-regext-to-level-start) 8343 (let ((b (point)) (e (make-marker)) c) 8344 (forward-sexp 1) 8345 (set-marker e (1- (point))) 8346 (goto-char b) 8347 (while (re-search-forward "\\(#\\)\\|\n" e 'to-end) 8348 (cond 8349 ((match-beginning 1) ; #-comment 8350 (or c (setq c (current-indentation))) 8351 (beginning-of-line 2) ; Skip 8352 (cperl-make-indent c)) 8353 (t 8354 (delete-char -1) 8355 (just-one-space)))))) 8356 8357(defun cperl-contract-levels () 8358 "Find an enclosing group in regexp and contract all the kids. 8359\(Experimental, may change semantics, recheck the result.) 8360We suppose that the regexp is scanned already." 8361 (interactive) 8362 (save-excursion 8363 (condition-case nil 8364 (cperl-regext-to-level-start) 8365 (error ; We are outside outermost group 8366 (goto-char (cperl-make-regexp-x)))) 8367 (let ((b (point)) (e (make-marker)) s c) 8368 (forward-sexp 1) 8369 (set-marker e (1- (point))) 8370 (goto-char (1+ b)) 8371 (while (re-search-forward "\\(\\\\\\\\\\)\\|(" e t) 8372 (cond 8373 ((match-beginning 1) ; Skip 8374 nil) 8375 (t ; Group 8376 (cperl-contract-level))))))) 8377 8378(defun cperl-beautify-level (&optional deep) 8379 "Find an enclosing group in regexp and beautify it. 8380\(Experimental, may change semantics, recheck the result.) 8381We suppose that the regexp is scanned already." 8382 (interactive "P") 8383 (setq deep (if deep (prefix-numeric-value deep) -1)) 8384 (save-excursion 8385 (cperl-regext-to-level-start) 8386 (let ((b (point)) (e (make-marker))) 8387 (forward-sexp 1) 8388 (set-marker e (1- (point))) 8389 (cperl-beautify-regexp-piece b e nil deep)))) 8390 8391(defun cperl-invert-if-unless-modifiers () 8392 "Change `B if A;' into `if (A) {B}' etc if possible. 8393\(Unfinished.)" 8394 (interactive) ; 8395 (let (A B pre-B post-B pre-if post-if pre-A post-A if-string 8396 (w-rex "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>")) 8397 (and (= (char-syntax (preceding-char)) ?w) 8398 (forward-sexp -1)) 8399 (setq pre-if (point)) 8400 (cperl-backward-to-start-of-expr) 8401 (setq pre-B (point)) 8402 (forward-sexp 1) ; otherwise forward-to-end-of-expr is NOP 8403 (cperl-forward-to-end-of-expr) 8404 (setq post-A (point)) 8405 (goto-char pre-if) 8406 (or (looking-at w-rex) 8407 ;; Find the position 8408 (progn (goto-char post-A) 8409 (while (and 8410 (not (looking-at w-rex)) 8411 (> (point) pre-B)) 8412 (forward-sexp -1)) 8413 (setq pre-if (point)))) 8414 (or (looking-at w-rex) 8415 (error "Can't find `if', `unless', `while', `until', `for' or `foreach'")) 8416 ;; 1 B 2 ... 3 B-com ... 4 if 5 ... if-com 6 ... 7 A 8 8417 (setq if-string (buffer-substring (match-beginning 0) (match-end 0))) 8418 ;; First, simple part: find code boundaries 8419 (forward-sexp 1) 8420 (setq post-if (point)) 8421 (forward-sexp -2) 8422 (forward-sexp 1) 8423 (setq post-B (point)) 8424 (cperl-backward-to-start-of-expr) 8425 (setq pre-B (point)) 8426 (setq B (buffer-substring pre-B post-B)) 8427 (goto-char pre-if) 8428 (forward-sexp 2) 8429 (forward-sexp -1) 8430 ;; May be after $, @, $# etc of a variable 8431 (skip-chars-backward "$@%#") 8432 (setq pre-A (point)) 8433 (cperl-forward-to-end-of-expr) 8434 (setq post-A (point)) 8435 (setq A (buffer-substring pre-A post-A)) 8436 ;; Now modify (from end, to not break the stuff) 8437 (skip-chars-forward " \t;") 8438 (delete-region pre-A (point)) ; we move to pre-A 8439 (insert "\n" B ";\n}") 8440 (and (looking-at "[ \t]*#") (cperl-indent-for-comment)) 8441 (delete-region pre-if post-if) 8442 (delete-region pre-B post-B) 8443 (goto-char pre-B) 8444 (insert if-string " (" A ") {") 8445 (setq post-B (point)) 8446 (if (looking-at "[ \t]+$") 8447 (delete-horizontal-space) 8448 (if (looking-at "[ \t]*#") 8449 (cperl-indent-for-comment) 8450 (just-one-space))) 8451 (forward-line 1) 8452 (if (looking-at "[ \t]*$") 8453 (progn ; delete line 8454 (delete-horizontal-space) 8455 (delete-region (point) (1+ (point))))) 8456 (cperl-indent-line) 8457 (goto-char (1- post-B)) 8458 (forward-sexp 1) 8459 (cperl-indent-line) 8460 (goto-char pre-B))) 8461 8462(defun cperl-invert-if-unless () 8463 "Change `if (A) {B}' into `B if A;' etc (or visa versa) if possible. 8464If the cursor is not on the leading keyword of the BLOCK flavor of 8465construct, will assume it is the STATEMENT flavor, so will try to find 8466the appropriate statement modifier." 8467 (interactive) 8468 (and (= (char-syntax (preceding-char)) ?w) 8469 (forward-sexp -1)) 8470 (if (looking-at "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>") 8471 (let ((pre-if (point)) 8472 pre-A post-A pre-B post-B A B state p end-B-code is-block B-comment 8473 (if-string (buffer-substring (match-beginning 0) (match-end 0)))) 8474 (forward-sexp 2) 8475 (setq post-A (point)) 8476 (forward-sexp -1) 8477 (setq pre-A (point)) 8478 (setq is-block (and (eq (following-char) ?\( ) 8479 (save-excursion 8480 (condition-case nil 8481 (progn 8482 (forward-sexp 2) 8483 (forward-sexp -1) 8484 (eq (following-char) ?\{ )) 8485 (error nil))))) 8486 (if is-block 8487 (progn 8488 (goto-char post-A) 8489 (forward-sexp 1) 8490 (setq post-B (point)) 8491 (forward-sexp -1) 8492 (setq pre-B (point)) 8493 (if (and (eq (following-char) ?\{ ) 8494 (progn 8495 (cperl-backward-to-noncomment post-A) 8496 (eq (preceding-char) ?\) ))) 8497 (if (condition-case nil 8498 (progn 8499 (goto-char post-B) 8500 (forward-sexp 1) 8501 (forward-sexp -1) 8502 (looking-at "\\<els\\(e\\|if\\)\\>")) 8503 (error nil)) 8504 (error 8505 "`%s' (EXPR) {BLOCK} with `else'/`elsif'" if-string) 8506 (goto-char (1- post-B)) 8507 (cperl-backward-to-noncomment pre-B) 8508 (if (eq (preceding-char) ?\;) 8509 (forward-char -1)) 8510 (setq end-B-code (point)) 8511 (goto-char pre-B) 8512 (while (re-search-forward "\\<\\(for\\|foreach\\|if\\|unless\\|while\\|until\\)\\>\\|;" end-B-code t) 8513 (setq p (match-beginning 0) 8514 A (buffer-substring p (match-end 0)) 8515 state (parse-partial-sexp pre-B p)) 8516 (or (nth 3 state) 8517 (nth 4 state) 8518 (nth 5 state) 8519 (error "`%s' inside `%s' BLOCK" A if-string)) 8520 (goto-char (match-end 0))) 8521 ;; Finally got it 8522 (goto-char (1+ pre-B)) 8523 (skip-chars-forward " \t\n") 8524 (setq B (buffer-substring (point) end-B-code)) 8525 (goto-char end-B-code) 8526 (or (looking-at ";?[ \t\n]*}") 8527 (progn 8528 (skip-chars-forward "; \t\n") 8529 (setq B-comment 8530 (buffer-substring (point) (1- post-B))))) 8531 (and (equal B "") 8532 (setq B "1")) 8533 (goto-char (1- post-A)) 8534 (cperl-backward-to-noncomment pre-A) 8535 (or (looking-at "[ \t\n]*)") 8536 (goto-char (1- post-A))) 8537 (setq p (point)) 8538 (goto-char (1+ pre-A)) 8539 (skip-chars-forward " \t\n") 8540 (setq A (buffer-substring (point) p)) 8541 (delete-region pre-B post-B) 8542 (delete-region pre-A post-A) 8543 (goto-char pre-if) 8544 (insert B " ") 8545 (and B-comment (insert B-comment " ")) 8546 (just-one-space) 8547 (forward-word 1) 8548 (setq pre-A (point)) 8549 (insert " " A ";") 8550 (delete-horizontal-space) 8551 (setq post-B (point)) 8552 (if (looking-at "#") 8553 (indent-for-comment)) 8554 (goto-char post-B) 8555 (forward-char -1) 8556 (delete-horizontal-space) 8557 (goto-char pre-A) 8558 (just-one-space) 8559 (goto-char pre-if) 8560 (setq pre-A (set-marker (make-marker) pre-A)) 8561 (while (<= (point) (marker-position pre-A)) 8562 (cperl-indent-line) 8563 (forward-line 1)) 8564 (goto-char (marker-position pre-A)) 8565 (if B-comment 8566 (progn 8567 (forward-line -1) 8568 (indent-for-comment) 8569 (goto-char (marker-position pre-A))))) 8570 (error "`%s' (EXPR) not with an {BLOCK}" if-string))) 8571 ;; (error "`%s' not with an (EXPR)" if-string) 8572 (forward-sexp -1) 8573 (cperl-invert-if-unless-modifiers))) 8574 ;;(error "Not at `if', `unless', `while', `until', `for' or `foreach'") 8575 (cperl-invert-if-unless-modifiers))) 8576 8577;;; By Anthony Foiani <afoiani@uswest.com> 8578;;; Getting help on modules in C-h f ? 8579;;; This is a modified version of `man'. 8580;;; Need to teach it how to lookup functions 8581;;;###autoload 8582(defun cperl-perldoc (word) 8583 "Run `perldoc' on WORD." 8584 (interactive 8585 (list (let* ((default-entry (cperl-word-at-point)) 8586 (input (read-string 8587 (format "perldoc entry%s: " 8588 (if (string= default-entry "") 8589 "" 8590 (format " (default %s)" default-entry)))))) 8591 (if (string= input "") 8592 (if (string= default-entry "") 8593 (error "No perldoc args given") 8594 default-entry) 8595 input)))) 8596 (require 'man) 8597 (let* ((case-fold-search nil) 8598 (is-func (and 8599 (string-match "^[a-z]+$" word) 8600 (string-match (concat "^" word "\\>") 8601 (documentation-property 8602 'cperl-short-docs 8603 'variable-documentation)))) 8604 (manual-program (if is-func "perldoc -f" "perldoc"))) 8605 (cond 8606 (cperl-xemacs-p 8607 (let ((Manual-program "perldoc") 8608 (Manual-switches (if is-func (list "-f")))) 8609 (manual-entry word))) 8610 (t 8611 (Man-getpage-in-background word))))) 8612 8613;;;###autoload 8614(defun cperl-perldoc-at-point () 8615 "Run a `perldoc' on the word around point." 8616 (interactive) 8617 (cperl-perldoc (cperl-word-at-point))) 8618 8619(defcustom pod2man-program "pod2man" 8620 "*File name for `pod2man'." 8621 :type 'file 8622 :group 'cperl) 8623 8624;;; By Nick Roberts <Nick.Roberts@src.bae.co.uk> (with changes) 8625(defun cperl-pod-to-manpage () 8626 "Create a virtual manpage in Emacs from the Perl Online Documentation." 8627 (interactive) 8628 (require 'man) 8629 (let* ((pod2man-args (concat buffer-file-name " | nroff -man ")) 8630 (bufname (concat "Man " buffer-file-name)) 8631 (buffer (generate-new-buffer bufname))) 8632 (save-excursion 8633 (set-buffer buffer) 8634 (let ((process-environment (copy-sequence process-environment))) 8635 ;; Prevent any attempt to use display terminal fanciness. 8636 (setenv "TERM" "dumb") 8637 (set-process-sentinel 8638 (start-process pod2man-program buffer "sh" "-c" 8639 (format (cperl-pod2man-build-command) pod2man-args)) 8640 'Man-bgproc-sentinel))))) 8641 8642;;; Updated version by him too 8643(defun cperl-build-manpage () 8644 "Create a virtual manpage in Emacs from the POD in the file." 8645 (interactive) 8646 (require 'man) 8647 (cond 8648 (cperl-xemacs-p 8649 (let ((Manual-program "perldoc")) 8650 (manual-entry buffer-file-name))) 8651 (t 8652 (let* ((manual-program "perldoc")) 8653 (Man-getpage-in-background buffer-file-name))))) 8654 8655(defun cperl-pod2man-build-command () 8656 "Builds the entire background manpage and cleaning command." 8657 (let ((command (concat pod2man-program " %s 2>/dev/null")) 8658 (flist (and (boundp 'Man-filter-list) Man-filter-list))) 8659 (while (and flist (car flist)) 8660 (let ((pcom (car (car flist))) 8661 (pargs (cdr (car flist)))) 8662 (setq command 8663 (concat command " | " pcom " " 8664 (mapconcat '(lambda (phrase) 8665 (if (not (stringp phrase)) 8666 (error "Malformed Man-filter-list")) 8667 phrase) 8668 pargs " "))) 8669 (setq flist (cdr flist)))) 8670 command)) 8671 8672 8673(defun cperl-next-interpolated-REx-1 () 8674 "Move point to next REx which has interpolated parts without //o. 8675Skips RExes consisting of one interpolated variable. 8676 8677Note that skipped RExen are not performance hits." 8678 (interactive "") 8679 (cperl-next-interpolated-REx 1)) 8680 8681(defun cperl-next-interpolated-REx-0 () 8682 "Move point to next REx which has interpolated parts without //o." 8683 (interactive "") 8684 (cperl-next-interpolated-REx 0)) 8685 8686(defun cperl-next-interpolated-REx (&optional skip beg limit) 8687 "Move point to next REx which has interpolated parts. 8688SKIP is a list of possible types to skip, BEG and LIMIT are the starting 8689point and the limit of search (default to point and end of buffer). 8690 8691SKIP may be a number, then it behaves as list of numbers up to SKIP; this 8692semantic may be used as a numeric argument. 8693 8694Types are 0 for / $rex /o (interpolated once), 1 for /$rex/ (if $rex is 8695a result of qr//, this is not a performance hit), t for the rest." 8696 (interactive "P") 8697 (if (numberp skip) (setq skip (list 0 skip))) 8698 (or beg (setq beg (point))) 8699 (or limit (setq limit (point-max))) ; needed for n-s-p-c 8700 (let (pp) 8701 (and (eq (get-text-property beg 'syntax-type) 'string) 8702 (setq beg (next-single-property-change beg 'syntax-type nil limit))) 8703 (cperl-map-pods-heres 8704 (function (lambda (s e p) 8705 (if (memq (get-text-property s 'REx-interpolated) skip) 8706 t 8707 (setq pp s) 8708 nil))) ; nil stops 8709 'REx-interpolated beg limit) 8710 (if pp (goto-char pp) 8711 (message "No more interpolated REx")))) 8712 8713;;; Initial version contributed by Trey Belew 8714(defun cperl-here-doc-spell (&optional beg end) 8715 "Spell-check HERE-documents in the Perl buffer. 8716If a region is highlighted, restricts to the region." 8717 (interactive "") 8718 (cperl-pod-spell t beg end)) 8719 8720(defun cperl-pod-spell (&optional do-heres beg end) 8721 "Spell-check POD documentation. 8722If invoked with prefix argument, will do HERE-DOCs instead. 8723If a region is highlighted, restricts to the region." 8724 (interactive "P") 8725 (save-excursion 8726 (let (beg end) 8727 (if (cperl-mark-active) 8728 (setq beg (min (mark) (point)) 8729 end (max (mark) (point))) 8730 (setq beg (point-min) 8731 end (point-max))) 8732 (cperl-map-pods-heres (function 8733 (lambda (s e p) 8734 (if do-heres 8735 (setq e (save-excursion 8736 (goto-char e) 8737 (forward-line -1) 8738 (point)))) 8739 (ispell-region s e) 8740 t)) 8741 (if do-heres 'here-doc-group 'in-pod) 8742 beg end)))) 8743 8744(defun cperl-map-pods-heres (func &optional prop s end) 8745 "Executes a function over regions of pods or here-documents. 8746PROP is the text-property to search for; default to `in-pod'. Stop when 8747function returns nil." 8748 (let (pos posend has-prop (cont t)) 8749 (or prop (setq prop 'in-pod)) 8750 (or s (setq s (point-min))) 8751 (or end (setq end (point-max))) 8752 (cperl-update-syntaxification end end) 8753 (save-excursion 8754 (goto-char (setq pos s)) 8755 (while (and cont (< pos end)) 8756 (setq has-prop (get-text-property pos prop)) 8757 (setq posend (next-single-property-change pos prop nil end)) 8758 (and has-prop 8759 (setq cont (funcall func pos posend prop))) 8760 (setq pos posend))))) 8761 8762;;; Based on code by Masatake YAMATO: 8763(defun cperl-get-here-doc-region (&optional pos pod) 8764 "Return HERE document region around the point. 8765Return nil if the point is not in a HERE document region. If POD is non-nil, 8766will return a POD section if point is in a POD section." 8767 (or pos (setq pos (point))) 8768 (cperl-update-syntaxification pos pos) 8769 (if (or (eq 'here-doc (get-text-property pos 'syntax-type)) 8770 (and pod 8771 (eq 'pod (get-text-property pos 'syntax-type)))) 8772 (let ((b (cperl-beginning-of-property pos 'syntax-type)) 8773 (e (next-single-property-change pos 'syntax-type))) 8774 (cons b (or e (point-max)))))) 8775 8776(defun cperl-narrow-to-here-doc (&optional pos) 8777 "Narrows editing region to the HERE-DOC at POS. 8778POS defaults to the point." 8779 (interactive "d") 8780 (or pos (setq pos (point))) 8781 (let ((p (cperl-get-here-doc-region pos))) 8782 (or p (error "Not inside a HERE document")) 8783 (narrow-to-region (car p) (cdr p)) 8784 (message 8785 "When you are finished with narrow editing, type C-x n w"))) 8786 8787(defun cperl-select-this-pod-or-here-doc (&optional pos) 8788 "Select the HERE-DOC (or POD section) at POS. 8789POS defaults to the point." 8790 (interactive "d") 8791 (let ((p (cperl-get-here-doc-region pos t))) 8792 (if p 8793 (progn 8794 (goto-char (car p)) 8795 (push-mark (cdr p) nil t)) ; Message, activate in transient-mode 8796 (message "I do not think POS is in POD or a HERE-doc...")))) 8797 8798(defun cperl-facemenu-add-face-function (face end) 8799 "A callback to process user-initiated font-change requests. 8800Translates `bold', `italic', and `bold-italic' requests to insertion of 8801corresponding POD directives, and `underline' to C<> POD directive. 8802 8803Such requests are usually bound to M-o LETTER." 8804 (or (get-text-property (point) 'in-pod) 8805 (error "Faces can only be set within POD")) 8806 (setq facemenu-end-add-face (if (eq face 'bold-italic) ">>" ">")) 8807 (cdr (or (assq face '((bold . "B<") 8808 (italic . "I<") 8809 (bold-italic . "B<I<") 8810 (underline . "C<"))) 8811 (error "Face %s not configured for cperl-mode" 8812 face)))) 8813 8814(defun cperl-time-fontification (&optional l step lim) 8815 "Times how long it takes to do incremental fontification in a region. 8816L is the line to start at, STEP is the number of lines to skip when 8817doing next incremental fontification, LIM is the maximal number of 8818incremental fontification to perform. Messages are accumulated in 8819*Messages* buffer. 8820 8821May be used for pinpointing which construct slows down buffer fontification: 8822start with default arguments, then refine the slowdown regions." 8823 (interactive "nLine to start at: \nnStep to do incremental fontification: ") 8824 (or l (setq l 1)) 8825 (or step (setq step 500)) 8826 (or lim (setq lim 40)) 8827 (let* ((timems (function (lambda () 8828 (let ((tt (current-time))) 8829 (+ (* 1000 (nth 1 tt)) (/ (nth 2 tt) 1000)))))) 8830 (tt (funcall timems)) (c 0) delta tot) 8831 (goto-line l) 8832 (cperl-mode) 8833 (setq tot (- (- tt (setq tt (funcall timems))))) 8834 (message "cperl-mode at %s: %s" l tot) 8835 (while (and (< c lim) (not (eobp))) 8836 (forward-line step) 8837 (setq l (+ l step)) 8838 (setq c (1+ c)) 8839 (cperl-update-syntaxification (point) (point)) 8840 (setq delta (- (- tt (setq tt (funcall timems)))) tot (+ tot delta)) 8841 (message "to %s:%6s,%7s" l delta tot)) 8842 tot)) 8843 8844(defun cperl-emulate-lazy-lock (&optional window-size) 8845 "Emulate `lazy-lock' without `condition-case', so `debug-on-error' works. 8846Start fontifying the buffer from the start (or end) using the given 8847WINDOW-SIZE (units is lines). Negative WINDOW-SIZE starts at end, and 8848goes backwards; default is -50. This function is not CPerl-specific; it 8849may be used to debug problems with delayed incremental fontification." 8850 (interactive 8851 "nSize of window for incremental fontification, negative goes backwards: ") 8852 (or window-size (setq window-size -50)) 8853 (let ((pos (if (> window-size 0) 8854 (point-min) 8855 (point-max))) 8856 p) 8857 (goto-char pos) 8858 (normal-mode) 8859 ;; Why needed??? With older font-locks??? 8860 (set (make-local-variable 'font-lock-cache-position) (make-marker)) 8861 (while (if (> window-size 0) 8862 (< pos (point-max)) 8863 (> pos (point-min))) 8864 (setq p (progn 8865 (forward-line window-size) 8866 (point))) 8867 (font-lock-fontify-region (min p pos) (max p pos)) 8868 (setq pos p)))) 8869 8870 8871(defun cperl-lazy-install ()) ; Avoid a warning 8872(defun cperl-lazy-unstall ()) ; Avoid a warning 8873 8874(if (fboundp 'run-with-idle-timer) 8875 (progn 8876 (defvar cperl-help-shown nil 8877 "Non-nil means that the help was already shown now.") 8878 8879 (defvar cperl-lazy-installed nil 8880 "Non-nil means that the lazy-help handlers are installed now.") 8881 8882 (defun cperl-lazy-install () 8883 "Switches on Auto-Help on Perl constructs (put in the message area). 8884Delay of auto-help controlled by `cperl-lazy-help-time'." 8885 (interactive) 8886 (make-local-variable 'cperl-help-shown) 8887 (if (and (cperl-val 'cperl-lazy-help-time) 8888 (not cperl-lazy-installed)) 8889 (progn 8890 (add-hook 'post-command-hook 'cperl-lazy-hook) 8891 (run-with-idle-timer 8892 (cperl-val 'cperl-lazy-help-time 1000000 5) 8893 t 8894 'cperl-get-help-defer) 8895 (setq cperl-lazy-installed t)))) 8896 8897 (defun cperl-lazy-unstall () 8898 "Switches off Auto-Help on Perl constructs (put in the message area). 8899Delay of auto-help controlled by `cperl-lazy-help-time'." 8900 (interactive) 8901 (remove-hook 'post-command-hook 'cperl-lazy-hook) 8902 (cancel-function-timers 'cperl-get-help-defer) 8903 (setq cperl-lazy-installed nil)) 8904 8905 (defun cperl-lazy-hook () 8906 (setq cperl-help-shown nil)) 8907 8908 (defun cperl-get-help-defer () 8909 (if (not (memq major-mode '(perl-mode cperl-mode))) nil 8910 (let ((cperl-message-on-help-error nil) (cperl-help-from-timer t)) 8911 (cperl-get-help) 8912 (setq cperl-help-shown t)))) 8913 (cperl-lazy-install))) 8914 8915 8916;;; Plug for wrong font-lock: 8917 8918(defun cperl-font-lock-unfontify-region-function (beg end) 8919 (let* ((modified (buffer-modified-p)) (buffer-undo-list t) 8920 (inhibit-read-only t) (inhibit-point-motion-hooks t) 8921 before-change-functions after-change-functions 8922 deactivate-mark buffer-file-name buffer-file-truename) 8923 (remove-text-properties beg end '(face nil)) 8924 (if (and (not modified) (buffer-modified-p)) 8925 (set-buffer-modified-p nil)))) 8926 8927(defun cperl-font-lock-fontify-region-function (beg end loudly) 8928 "Extends the region to safe positions, then calls the default function. 8929Newer `font-lock's can do it themselves. 8930We unwind only as far as needed for fontification. Syntaxification may 8931do extra unwind via `cperl-unwind-to-safe'." 8932 (save-excursion 8933 (goto-char beg) 8934 (while (and beg 8935 (progn 8936 (beginning-of-line) 8937 (eq (get-text-property (setq beg (point)) 'syntax-type) 8938 'multiline))) 8939 (if (setq beg (cperl-beginning-of-property beg 'syntax-type)) 8940 (goto-char beg))) 8941 (setq beg (point)) 8942 (goto-char end) 8943 (while (and end 8944 (progn 8945 (or (bolp) (condition-case nil 8946 (forward-line 1) 8947 (error nil))) 8948 (eq (get-text-property (setq end (point)) 'syntax-type) 8949 'multiline))) 8950 (setq end (next-single-property-change end 'syntax-type nil (point-max))) 8951 (goto-char end)) 8952 (setq end (point))) 8953 (font-lock-default-fontify-region beg end loudly)) 8954 8955(defvar cperl-d-l nil) 8956(defun cperl-fontify-syntaxically (end) 8957 ;; Some vars for debugging only 8958 ;; (message "Syntaxifying...") 8959 (let ((dbg (point)) (iend end) (idone cperl-syntax-done-to) 8960 (istate (car cperl-syntax-state)) 8961 start from-start edebug-backtrace-buffer) 8962 (if (eq cperl-syntaxify-by-font-lock 'backtrace) 8963 (progn 8964 (require 'edebug) 8965 (let ((f 'edebug-backtrace)) 8966 (funcall f)))) ; Avoid compile-time warning 8967 (or cperl-syntax-done-to 8968 (setq cperl-syntax-done-to (point-min) 8969 from-start t)) 8970 (setq start (if (and cperl-hook-after-change 8971 (not from-start)) 8972 cperl-syntax-done-to ; Fontify without change; ignore start 8973 ;; Need to forget what is after `start' 8974 (min cperl-syntax-done-to (point)))) 8975 (goto-char start) 8976 (beginning-of-line) 8977 (setq start (point)) 8978 (and cperl-syntaxify-unwind 8979 (setq end (cperl-unwind-to-safe t end) 8980 start (point))) 8981 (and (> end start) 8982 (setq cperl-syntax-done-to start) ; In case what follows fails 8983 (cperl-find-pods-heres start end t nil t)) 8984 (if (memq cperl-syntaxify-by-font-lock '(backtrace message)) 8985 (message "Syxify req=%s..%s actual=%s..%s done-to: %s=>%s statepos: %s=>%s" 8986 dbg iend start end idone cperl-syntax-done-to 8987 istate (car cperl-syntax-state))) ; For debugging 8988 nil)) ; Do not iterate 8989 8990(defun cperl-fontify-update (end) 8991 (let ((pos (point-min)) prop posend) 8992 (setq end (point-max)) 8993 (while (< pos end) 8994 (setq prop (get-text-property pos 'cperl-postpone) 8995 posend (next-single-property-change pos 'cperl-postpone nil end)) 8996 (and prop (put-text-property pos posend (car prop) (cdr prop))) 8997 (setq pos posend))) 8998 nil) ; Do not iterate 8999 9000(defun cperl-fontify-update-bad (end) 9001 ;; Since fontification happens with different region than syntaxification, 9002 ;; do to the end of buffer, not to END;;; likewise, start earlier if needed 9003 (let* ((pos (point)) (prop (get-text-property pos 'cperl-postpone)) posend) 9004 (if prop 9005 (setq pos (or (cperl-beginning-of-property 9006 (cperl-1+ pos) 'cperl-postpone) 9007 (point-min)))) 9008 (while (< pos end) 9009 (setq posend (next-single-property-change pos 'cperl-postpone)) 9010 (and prop (put-text-property pos posend (car prop) (cdr prop))) 9011 (setq pos posend) 9012 (setq prop (get-text-property pos 'cperl-postpone)))) 9013 nil) ; Do not iterate 9014 9015;; Called when any modification is made to buffer text. 9016(defun cperl-after-change-function (beg end old-len) 9017 ;; We should have been informed about changes by `font-lock'. Since it 9018 ;; does not inform as which calls are defered, do it ourselves 9019 (if cperl-syntax-done-to 9020 (setq cperl-syntax-done-to (min cperl-syntax-done-to beg)))) 9021 9022(defun cperl-update-syntaxification (from to) 9023 (if (and cperl-use-syntax-table-text-property 9024 cperl-syntaxify-by-font-lock 9025 (or (null cperl-syntax-done-to) 9026 (< cperl-syntax-done-to to))) 9027 (progn 9028 (save-excursion 9029 (goto-char from) 9030 (cperl-fontify-syntaxically to))))) 9031 9032(defvar cperl-version 9033 (let ((v "Revision: 5.22")) 9034 (string-match ":\\s *\\([0-9.]+\\)" v) 9035 (substring v (match-beginning 1) (match-end 1))) 9036 "Version of IZ-supported CPerl package this file is based on.") 9037 9038(provide 'cperl-mode) 9039 9040;;; arch-tag: 42e5b19b-e187-4537-929f-1a7408980ce6 9041;;; cperl-mode.el ends here 9042