1;;; cperl-mode.el --- Perl code editing commands for Emacs -*- lexical-binding:t -*- 2 3;; Copyright (C) 1985-1987, 1991-2021 Free Software Foundation, Inc. 4 5;; Author: Ilya Zakharevich 6;; Bob Olson 7;; Jonathan Rockway <jon@jrock.us> 8;; Maintainer: emacs-devel@gnu.org 9;; Keywords: languages, Perl 10;; Package-Requires: ((emacs "26.1")) 11 12;; This file is part of GNU Emacs. 13 14;; GNU Emacs is free software: you can redistribute it and/or modify 15;; it under the terms of the GNU General Public License as published by 16;; the Free Software Foundation, either version 3 of the License, or 17;; (at your option) any later version. 18 19;; GNU Emacs is distributed in the hope that it will be useful, 20;; but WITHOUT ANY WARRANTY; without even the implied warranty of 21;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 22;; GNU General Public License for more details. 23 24;; You should have received a copy of the GNU General Public License 25;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. 26 27;; Corrections made by Ilya Zakharevich ilyaz@cpan.org 28 29;;; Commentary: 30 31;; This version of the file contains support for the syntax added by 32;; the MooseX::Declare CPAN module, as well as Perl 5.10 keyword 33;; support. 34 35;; The latest version is available from 36;; https://github.com/jrockway/cperl-mode 37;; 38;; (perhaps in the moosex-declare branch) 39 40;; You can either fine-tune the bells and whistles of this mode or 41;; bulk enable them by putting 42 43;; (setq cperl-hairy t) 44 45;; in your .emacs file. (Emacs rulers do not consider it politically 46;; correct to make whistles enabled by default.) 47 48;; DO NOT FORGET to read micro-docs (available from `Perl' menu) <<<<<< 49;; or as help on variables `cperl-tips', `cperl-problems', <<<<<< 50;; `cperl-praise', `cperl-speed'. <<<<<< 51;; 52;; Or search for "Short extra-docs" further down in this file for 53;; details on how to use `cperl-mode' instead of `perl-mode' and lots 54;; of other details. 55 56;; The mode information (on C-h m) provides some customization help. 57 58;; Faces used now: three faces for first-class and second-class keywords 59;; and control flow words, one for each: comments, string, labels, 60;; functions definitions and packages, arrays, hashes, and variable 61;; definitions. If you do not see all these faces, your font-lock does 62;; not define them, so you need to define them manually. 63 64;; This mode supports font-lock, imenu and mode-compile. In the 65;; hairy version font-lock is on, but you should activate imenu 66;; yourself (note that mode-compile is not standard yet). Well, you 67;; can use imenu from keyboard anyway (M-x imenu), but it is better 68;; to bind it like that: 69 70;; (define-key global-map [M-S-down-mouse-3] 'imenu) 71 72;;; Code: 73 74;;; Compatibility with older versions (for publishing on ELPA) 75;; The following helpers allow cperl-mode.el to work with older 76;; versions of Emacs. 77;; 78;; Whenever the minimum version is bumped (see "Package-Requires" 79;; above), please eliminate the corresponding compatibility-helpers. 80;; Whenever you create a new compatibility-helper, please add it here. 81 82;; Available in Emacs 27.1: time-convert 83(defalias 'cperl--time-convert 84 (if (fboundp 'time-convert) 'time-convert 85 'encode-time)) 86 87;; Available in Emacs 28: format-prompt 88(defalias 'cperl--format-prompt 89 (if (fboundp 'format-prompt) 'format-prompt 90 (lambda (msg default) 91 (if default (format "%s (default %s): " msg default) 92 (concat msg ": "))))) 93 94(eval-when-compile (require 'cl-lib)) 95(require 'facemenu) 96 97(defvar msb-menu-cond) 98(defvar gud-perldb-history) 99(defvar vc-rcs-header) 100(defvar vc-sccs-header) 101 102(defun cperl-choose-color (&rest list) 103 (let (answer) 104 (while list 105 (or answer 106 (if (or (x-color-defined-p (car list)) 107 (null (cdr list))) 108 (setq answer (car list)))) 109 (setq list (cdr list))) 110 answer)) 111 112(defgroup cperl nil 113 "Major mode for editing Perl code." 114 :prefix "cperl-" 115 :group 'languages 116 :version "20.3") 117 118(defgroup cperl-indentation-details nil 119 "Indentation." 120 :prefix "cperl-" 121 :group 'cperl) 122 123(defgroup cperl-affected-by-hairy nil 124 "Variables affected by `cperl-hairy'." 125 :prefix "cperl-" 126 :group 'cperl) 127 128(defgroup cperl-autoinsert-details nil 129 "Auto-insert tuneup." 130 :prefix "cperl-" 131 :group 'cperl) 132 133(defgroup cperl-faces nil 134 "Fontification colors." 135 :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces) 136 :prefix "cperl-" 137 :group 'cperl) 138 139(defgroup cperl-speed nil 140 "Speed vs. validity tuneup." 141 :prefix "cperl-" 142 :group 'cperl) 143 144(defgroup cperl-help-system nil 145 "Help system tuneup." 146 :prefix "cperl-" 147 :group 'cperl) 148 149 150(defcustom cperl-extra-newline-before-brace nil 151 "Non-nil means that if, elsif, while, until, else, for, foreach 152and do constructs look like: 153 154 if () 155 { 156 } 157 158instead of: 159 160 if () { 161 }" 162 :type 'boolean 163 :group 'cperl-autoinsert-details) 164 165(defcustom cperl-extra-newline-before-brace-multiline 166 cperl-extra-newline-before-brace 167 "Non-nil means the same as `cperl-extra-newline-before-brace', but 168for constructs with multiline if/unless/while/until/for/foreach condition." 169 :type 'boolean 170 :group 'cperl-autoinsert-details) 171 172(defcustom cperl-indent-level 2 173 "Indentation of CPerl statements with respect to containing block." 174 :type 'integer 175 :group 'cperl-indentation-details) 176 177;; It is not unusual to put both things like perl-indent-level and 178;; cperl-indent-level in the local variable section of a file. If only 179;; one of perl-mode and cperl-mode is in use, a warning will be issued 180;; about the variable. Autoload these here, so that no warning is 181;; issued when using either perl-mode or cperl-mode. 182;;;###autoload(put 'cperl-indent-level 'safe-local-variable 'integerp) 183;;;###autoload(put 'cperl-brace-offset 'safe-local-variable 'integerp) 184;;;###autoload(put 'cperl-continued-brace-offset 'safe-local-variable 'integerp) 185;;;###autoload(put 'cperl-label-offset 'safe-local-variable 'integerp) 186;;;###autoload(put 'cperl-continued-statement-offset 'safe-local-variable 'integerp) 187;;;###autoload(put 'cperl-extra-newline-before-brace 'safe-local-variable 'booleanp) 188;;;###autoload(put 'cperl-merge-trailing-else 'safe-local-variable 'booleanp) 189 190(defcustom cperl-lineup-step nil 191 "`cperl-lineup' will always lineup at multiple of this number. 192If nil, the value of `cperl-indent-level' will be used." 193 :type '(choice (const nil) integer) 194 :group 'cperl-indentation-details) 195 196(defcustom cperl-brace-imaginary-offset 0 197 "Imagined indentation of a Perl open brace that actually follows a statement. 198An open brace following other text is treated as if it were this far 199to the right of the start of its line." 200 :type 'integer 201 :group 'cperl-indentation-details) 202 203(defcustom cperl-brace-offset 0 204 "Extra indentation for braces, compared with other text in same context." 205 :type 'integer 206 :group 'cperl-indentation-details) 207(defcustom cperl-label-offset -2 208 "Offset of CPerl label lines relative to usual indentation." 209 :type 'integer 210 :group 'cperl-indentation-details) 211(defcustom cperl-min-label-indent 1 212 "Minimal offset of CPerl label lines." 213 :type 'integer 214 :group 'cperl-indentation-details) 215(defcustom cperl-continued-statement-offset 2 216 "Extra indent for lines not starting new statements." 217 :type 'integer 218 :group 'cperl-indentation-details) 219(defcustom cperl-continued-brace-offset 0 220 "Extra indent for substatements that start with open-braces. 221This is in addition to cperl-continued-statement-offset." 222 :type 'integer 223 :group 'cperl-indentation-details) 224(defcustom cperl-close-paren-offset -1 225 "Extra indent for substatements that start with close-parenthesis." 226 :type 'integer 227 :group 'cperl-indentation-details) 228 229(defcustom cperl-indent-wrt-brace t 230 "Non-nil means indent statements in if/etc block relative brace, not if/etc. 231Versions 5.2 ... 5.20 behaved as if this were nil." 232 :type 'boolean 233 :group 'cperl-indentation-details) 234 235(defcustom cperl-indent-subs-specially t 236 "If non-nil, indent subs inside other blocks relative to \"sub\" keyword. 237Otherwise, indent them relative to statement that contains the declaration. 238This applies to, for example, hash values." 239 :type 'boolean 240 :group 'cperl-indentation-details) 241 242(defcustom cperl-auto-newline nil 243 "Non-nil means automatically newline before and after braces, 244and after colons and semicolons, inserted in CPerl code. The following 245\\[cperl-electric-backspace] will remove the inserted whitespace. 246Insertion after colons requires both this variable and 247`cperl-auto-newline-after-colon' set." 248 :type 'boolean 249 :group 'cperl-autoinsert-details) 250 251(defcustom cperl-autoindent-on-semi nil 252 "Non-nil means automatically indent after insertion of (semi)colon. 253Active if `cperl-auto-newline' is false." 254 :type 'boolean 255 :group 'cperl-autoinsert-details) 256 257(defcustom cperl-auto-newline-after-colon nil 258 "Non-nil means automatically newline even after colons. 259Subject to `cperl-auto-newline' setting." 260 :type 'boolean 261 :group 'cperl-autoinsert-details) 262 263(defcustom cperl-tab-always-indent t 264 "Non-nil means TAB in CPerl mode should always reindent the current line, 265regardless of where in the line point is when the TAB command is used." 266 :type 'boolean 267 :group 'cperl-indentation-details) 268 269(defcustom cperl-font-lock nil 270 "Non-nil (and non-null) means CPerl buffers will use `font-lock-mode'. 271Can be overwritten by `cperl-hairy' if nil." 272 :type '(choice (const null) boolean) 273 :group 'cperl-affected-by-hairy) 274 275(defcustom cperl-electric-lbrace-space nil 276 "Non-nil (and non-null) means { after $ should be preceded by ` '. 277Can be overwritten by `cperl-hairy' if nil." 278 :type '(choice (const null) boolean) 279 :group 'cperl-affected-by-hairy) 280 281(defcustom cperl-electric-parens-string "({[]})<" 282 "String of parentheses that should be electric in CPerl. 283Closing ones are electric only if the region is highlighted." 284 :type 'string 285 :group 'cperl-affected-by-hairy) 286 287(defcustom cperl-electric-parens nil 288 "Non-nil (and non-null) means parentheses should be electric in CPerl. 289Can be overwritten by `cperl-hairy' if nil." 290 :type '(choice (const null) boolean) 291 :group 'cperl-affected-by-hairy) 292 293(defcustom cperl-electric-parens-mark window-system 294 "Not-nil means that electric parens look for active mark. 295Default is yes if there is visual feedback on mark." 296 :type 'boolean 297 :group 'cperl-autoinsert-details) 298 299(defcustom cperl-electric-linefeed nil 300 "If true, LFD should be hairy in CPerl, otherwise C-c LFD is hairy. 301In any case these two mean plain and hairy linefeeds together. 302Can be overwritten by `cperl-hairy' if nil." 303 :type '(choice (const null) boolean) 304 :group 'cperl-affected-by-hairy) 305 306(defcustom cperl-electric-keywords nil 307 "Not-nil (and non-null) means keywords are electric in CPerl. 308Can be overwritten by `cperl-hairy' if nil. 309 310Uses `abbrev-mode' to do the expansion. If you want to use your 311own abbrevs in `cperl-mode', but do not want keywords to be 312electric, you must redefine `cperl-mode-abbrev-table': do 313\\[edit-abbrevs], search for `cperl-mode-abbrev-table', and, in 314that paragraph, delete the words that appear at the ends of lines and 315that begin with \"cperl-electric\"." 316 :type '(choice (const null) boolean) 317 :group 'cperl-affected-by-hairy) 318 319(defcustom cperl-electric-backspace-untabify t 320 "Not-nil means electric-backspace will untabify in CPerl." 321 :type 'boolean 322 :group 'cperl-autoinsert-details) 323 324(defcustom cperl-hairy nil 325 "Not-nil means most of the bells and whistles are enabled in CPerl. 326Affects: `cperl-font-lock', `cperl-electric-lbrace-space', 327`cperl-electric-parens', `cperl-electric-linefeed', `cperl-electric-keywords', 328`cperl-info-on-command-no-prompt', `cperl-clobber-lisp-bindings', 329`cperl-lazy-help-time'." 330 :type 'boolean 331 :group 'cperl-affected-by-hairy) 332 333(defcustom cperl-comment-column 32 334 "Column to put comments in CPerl (use \\[cperl-indent] to lineup with code)." 335 :type 'integer 336 :group 'cperl-indentation-details) 337 338(defcustom cperl-indent-comment-at-column-0 nil 339 "Non-nil means that comment started at column 0 should be indentable." 340 :type 'boolean 341 :group 'cperl-indentation-details) 342 343(defcustom cperl-vc-sccs-header '("($sccs) = ('%W\ %' =~ /(\\d+(\\.\\d+)+)/) ;") 344 "Special version of `vc-sccs-header' that is used in CPerl mode buffers." 345 :type '(repeat string) 346 :group 'cperl) 347 348(defcustom cperl-vc-rcs-header '("($rcs) = (' $Id\ $ ' =~ /(\\d+(\\.\\d+)+)/);") 349 "Special version of `vc-rcs-header' that is used in CPerl mode buffers." 350 :type '(repeat string) 351 :group 'cperl) 352 353;; (defcustom cperl-clobber-mode-lists 354;; (not 355;; (and 356;; (boundp 'interpreter-mode-alist) 357;; (assoc "miniperl" interpreter-mode-alist) 358;; (assoc "\\.\\([pP][Llm]\\|al\\)$" auto-mode-alist))) 359;; "Whether to install us into `interpreter-' and `extension' mode lists." 360;; :type 'boolean 361;; :group 'cperl) 362 363(defcustom cperl-info-on-command-no-prompt nil 364 "Not-nil (and non-null) means not to prompt on \\[cperl-info-on-command]. 365The opposite behavior is always available if prefixed with C-c. 366Can be overwritten by `cperl-hairy' if nil." 367 :type '(choice (const null) boolean) 368 :group 'cperl-affected-by-hairy) 369 370(defcustom cperl-clobber-lisp-bindings nil 371 "Not-nil (and non-null) means not overwrite \\[describe-function]. 372The function is available on \\[cperl-info-on-command], \\[cperl-get-help]. 373Can be overwritten by `cperl-hairy' if nil." 374 :type '(choice (const null) boolean) 375 :group 'cperl-affected-by-hairy) 376 377(defcustom cperl-lazy-help-time nil 378 "Not-nil (and non-null) means to show lazy help after given idle time. 379Can be overwritten by `cperl-hairy' to be 5 sec if nil." 380 :type '(choice (const null) (const nil) integer) 381 :group 'cperl-affected-by-hairy) 382 383(defcustom cperl-pod-face 'font-lock-comment-face 384 "Face for POD highlighting." 385 :type 'face 386 :group 'cperl-faces) 387 388(defcustom cperl-pod-head-face 'font-lock-variable-name-face 389 "Face for POD highlighting. 390Font for POD headers." 391 :type 'face 392 :group 'cperl-faces) 393 394(defcustom cperl-here-face 'font-lock-string-face 395 "Face for here-docs highlighting." 396 :type 'face 397 :group 'cperl-faces) 398 399(defcustom cperl-invalid-face 'underline 400 "Face for highlighting trailing whitespace." 401 :type 'face 402 :version "21.1" 403 :group 'cperl-faces) 404 405(defcustom cperl-pod-here-fontify t 406 "Not-nil after evaluation means to highlight POD and here-docs sections." 407 :type 'boolean 408 :group 'cperl-faces) 409 410(defcustom cperl-fontify-m-as-s t 411 "Not-nil means highlight 1arg regular expressions operators same as 2arg." 412 :type 'boolean 413 :group 'cperl-faces) 414 415(defcustom cperl-highlight-variables-indiscriminately nil 416 "Non-nil means perform additional highlighting on variables. 417Currently only changes how scalar variables are highlighted. 418Note that the variable is only read at initialization time for 419the variable `cperl-font-lock-keywords-2', so changing it after you've 420entered CPerl mode the first time will have no effect." 421 :type 'boolean 422 :group 'cperl) 423 424(defcustom cperl-pod-here-scan t 425 "Not-nil means look for POD and here-docs sections during startup. 426You can always make lookup from menu or using \\[cperl-find-pods-heres]." 427 :type 'boolean 428 :group 'cperl-speed) 429 430(defcustom cperl-regexp-scan t 431 "Not-nil means make marking of regular expression more thorough. 432Effective only with `cperl-pod-here-scan'." 433 :type 'boolean 434 :group 'cperl-speed) 435 436(defcustom cperl-hook-after-change t 437 "Not-nil means install hook to know which regions of buffer are changed. 438May significantly speed up delayed fontification. Changes take effect 439after reload." 440 :type 'boolean 441 :group 'cperl-speed) 442 443(defcustom cperl-max-help-size 66 444 "Non-nil means shrink-wrapping of info-buffer allowed up to these percents." 445 :type '(choice integer (const nil)) 446 :group 'cperl-help-system) 447 448(defcustom cperl-shrink-wrap-info-frame t 449 "Non-nil means shrink-wrapping of info-buffer-frame allowed." 450 :type 'boolean 451 :group 'cperl-help-system) 452 453(defcustom cperl-info-page "perl" 454 "Name of the Info manual containing perl docs. 455Older version of this page was called `perl5', newer `perl'." 456 :type 'string 457 :group 'cperl-help-system) 458 459(defcustom cperl-use-syntax-table-text-property t 460 "Non-nil means CPerl sets up and uses `syntax-table' text property." 461 :type 'boolean 462 :group 'cperl-speed) 463 464(defcustom cperl-use-syntax-table-text-property-for-tags 465 cperl-use-syntax-table-text-property 466 "Non-nil means: set up and use `syntax-table' text property generating TAGS." 467 :type 'boolean 468 :group 'cperl-speed) 469 470(defcustom cperl-scan-files-regexp "\\.\\([pP][Llm]\\|xs\\)$" 471 "Regexp to match files to scan when generating TAGS." 472 :type 'regexp 473 :group 'cperl) 474 475(defcustom cperl-noscan-files-regexp 476 "/\\(\\.\\.?\\|SCCS\\|RCS\\|CVS\\|blib\\)$" 477 "Regexp to match files/dirs to skip when generating TAGS." 478 :type 'regexp 479 :group 'cperl) 480 481(defcustom cperl-regexp-indent-step nil 482 "Indentation used when beautifying regexps. 483If nil, the value of `cperl-indent-level' will be used." 484 :type '(choice integer (const nil)) 485 :group 'cperl-indentation-details) 486 487(defcustom cperl-indent-left-aligned-comments t 488 "Non-nil means that the comment starting in leftmost column should indent." 489 :type 'boolean 490 :group 'cperl-indentation-details) 491 492(defcustom cperl-under-as-char nil 493 "Non-nil means that the _ (underline) should be treated as word char." 494 :type 'boolean 495 :group 'cperl) 496(make-obsolete-variable 'cperl-under-as-char 'superword-mode "24.4") 497 498(defcustom cperl-extra-perl-args "" 499 "Extra arguments to use when starting Perl. 500Currently used with `cperl-check-syntax' only." 501 :type 'string 502 :group 'cperl) 503 504(defcustom cperl-message-electric-keyword t 505 "Non-nil means that the `cperl-electric-keyword' prints a help message." 506 :type 'boolean 507 :group 'cperl-help-system) 508 509(defcustom cperl-indent-region-fix-constructs 1 510 "Amount of space to insert between `}' and `else' or `elsif'. 511Used by `cperl-indent-region'. Set to nil to leave as is. 512Values other than 1 and nil will probably not work." 513 :type '(choice (const nil) (const 1)) 514 :group 'cperl-indentation-details) 515 516(defcustom cperl-break-one-line-blocks-when-indent t 517 "Non-nil means that one-line if/unless/while/until/for/foreach BLOCKs 518need to be reformatted into multiline ones when indenting a region." 519 :type 'boolean 520 :group 'cperl-indentation-details) 521 522(defcustom cperl-fix-hanging-brace-when-indent t 523 "Non-nil means that BLOCK-end `}' may be put on a separate line 524when indenting a region. 525Braces followed by else/elsif/while/until are excepted." 526 :type 'boolean 527 :group 'cperl-indentation-details) 528 529(defcustom cperl-merge-trailing-else t 530 "Non-nil means that BLOCK-end `}' followed by else/elsif/continue 531may be merged to be on the same line when indenting a region." 532 :type 'boolean 533 :group 'cperl-indentation-details) 534 535(defcustom cperl-indent-parens-as-block nil 536 "Non-nil means that non-block ()-, {}- and []-groups are indented as blocks, 537but for trailing \",\" inside the group, which won't increase indentation. 538One should tune up `cperl-close-paren-offset' as well." 539 :type 'boolean 540 :group 'cperl-indentation-details) 541 542(defcustom cperl-syntaxify-by-font-lock t 543 "Non-nil means that CPerl uses the `font-lock' routines for syntaxification." 544 :type '(choice (const message) boolean) 545 :group 'cperl-speed) 546 547(defcustom cperl-syntaxify-unwind 548 t 549 "Non-nil means that CPerl unwinds to a start of a long construction 550when syntaxifying a chunk of buffer." 551 :type 'boolean 552 :group 'cperl-speed) 553 554(defcustom cperl-syntaxify-for-menu 555 t 556 "Non-nil means that CPerl syntaxifies up to the point before showing menu. 557This way enabling/disabling of menu items is more correct." 558 :type 'boolean 559 :group 'cperl-speed) 560 561(defcustom cperl-ps-print-face-properties 562 '((font-lock-keyword-face nil nil bold shadow) 563 (font-lock-variable-name-face nil nil bold) 564 (font-lock-function-name-face nil nil bold italic box) 565 (font-lock-constant-face nil "LightGray" bold) 566 (cperl-array-face nil "LightGray" bold underline) 567 (cperl-hash-face nil "LightGray" bold italic underline) 568 (font-lock-comment-face nil "LightGray" italic) 569 (font-lock-string-face nil nil italic underline) 570 (cperl-nonoverridable-face nil nil italic underline) 571 (font-lock-type-face nil nil underline) 572 (font-lock-warning-face nil "LightGray" bold italic box) 573 (underline nil "LightGray" strikeout)) 574 "List given as an argument to `ps-extend-face-list' in `cperl-ps-print'." 575 :type '(repeat (cons symbol 576 (cons (choice (const nil) string) 577 (cons (choice (const nil) string) 578 (repeat symbol))))) 579 :group 'cperl-faces) 580 581(defvar cperl-dark-background 582 (cperl-choose-color "navy" "os2blue" "darkgreen")) 583(defvar cperl-dark-foreground 584 (cperl-choose-color "orchid1" "orange")) 585 586(defface cperl-nonoverridable-face 587 `((((class grayscale) (background light)) 588 (:background "Gray90" :slant italic :underline t)) 589 (((class grayscale) (background dark)) 590 (:foreground "Gray80" :slant italic :underline t :weight bold)) 591 (((class color) (background light)) 592 (:foreground "chartreuse3")) 593 (((class color) (background dark)) 594 (:foreground ,cperl-dark-foreground)) 595 (t (:weight bold :underline t))) 596 "Font Lock mode face used non-overridable keywords and modifiers of regexps." 597 :group 'cperl-faces) 598 599(defface cperl-array-face 600 `((((class grayscale) (background light)) 601 (:background "Gray90" :weight bold)) 602 (((class grayscale) (background dark)) 603 (:foreground "Gray80" :weight bold)) 604 (((class color) (background light)) 605 (:foreground "Blue" :background "lightyellow2" :weight bold)) 606 (((class color) (background dark)) 607 (:foreground "yellow" :background ,cperl-dark-background :weight bold)) 608 (t (:weight bold))) 609 "Font Lock mode face used to highlight array names." 610 :group 'cperl-faces) 611 612(defface cperl-hash-face 613 `((((class grayscale) (background light)) 614 (:background "Gray90" :weight bold :slant italic)) 615 (((class grayscale) (background dark)) 616 (:foreground "Gray80" :weight bold :slant italic)) 617 (((class color) (background light)) 618 (:foreground "Red" :background "lightyellow2" :weight bold :slant italic)) 619 (((class color) (background dark)) 620 (:foreground "Red" :background ,cperl-dark-background :weight bold :slant italic)) 621 (t (:weight bold :slant italic))) 622 "Font Lock mode face used to highlight hash names." 623 :group 'cperl-faces) 624 625 626 627;;; Short extra-docs. 628 629(defvar cperl-tips 'please-ignore-this-line 630 "Note that to enable Compile choices in the menu you need to install 631mode-compile.el. 632 633If your Emacs does not default to `cperl-mode' on Perl files, and you 634want it to: put the following into your .emacs file: 635 636 (defalias \\='perl-mode \\='cperl-mode) 637 638Get perl5-info from 639 $CPAN/doc/manual/info/perl5-old/perl5-info.tar.gz 640Also, one can generate a newer documentation running `pod2texi' converter 641 $CPAN/doc/manual/info/perl5/pod2texi-0.1.tar.gz 642 643If you use imenu-go, run imenu on perl5-info buffer (you can do it 644from Perl menu). If many files are related, generate TAGS files from 645Tools/Tags submenu in Perl menu. 646 647If some class structure is too complicated, use Tools/Hierarchy-view 648from Perl menu, or hierarchic view of imenu. The second one uses the 649current buffer only, the first one requires generation of TAGS from 650Perl/Tools/Tags menu beforehand. 651 652Run Perl/Tools/Insert-spaces-if-needed to fix your lazy typing. 653 654Switch auto-help on/off with Perl/Tools/Auto-help. 655 656Though CPerl mode should maintain the correct parsing of Perl even when 657editing, sometimes it may be lost. Fix this by 658 659 \\[normal-mode] 660 661In cases of more severe confusion sometimes it is helpful to do 662 663 \\[load-library] cperl-mode RET 664 \\[normal-mode] 665 666Before reporting (non-)problems look in the problem section of online 667micro-docs on what I know about CPerl problems.") 668 669(defvar cperl-problems 'please-ignore-this-line 670 "Description of problems in CPerl mode. 671`fill-paragraph' on a comment may leave the point behind the 672paragraph. It also triggers a bug in some versions of Emacs (CPerl tries 673to detect it and bulk out).") 674 675(defvar cperl-problems-old-emaxen 'please-ignore-this-line 676 "This used to contain a description of problems in CPerl mode 677specific for very old Emacs versions. This is no longer relevant 678and has been removed.") 679(make-obsolete-variable 'cperl-problems-old-emaxen nil "28.1") 680 681(defvar cperl-praise 'please-ignore-this-line 682 "Advantages of CPerl mode. 683 6840) It uses the newest `syntax-table' property ;-); 685 6861) It does 99% of Perl syntax correct. 687 688When using `syntax-table' property for syntax assist hints, it should 689handle 99.995% of lines correct - or somesuch. It automatically 690updates syntax assist hints when you edit your script. 691 6922) It is generally believed to be \"the most user-friendly Emacs 693package\" whatever it may mean (I doubt that the people who say similar 694things tried _all_ the rest of Emacs ;-), but this was not a lonely 695voice); 696 6973) Everything is customizable, one-by-one or in a big sweep; 698 6994) It has many easily-accessible \"tools\": 700 a) Can run program, check syntax, start debugger; 701 b) Can lineup vertically \"middles\" of rows, like `=' in 702 a = b; 703 cc = d; 704 c) Can insert spaces where this improves readability (in one 705 interactive sweep over the buffer); 706 d) Has support for imenu, including: 707 1) Separate unordered list of \"interesting places\"; 708 2) Separate TOC of POD sections; 709 3) Separate list of packages; 710 4) Hierarchical view of methods in (sub)packages; 711 5) and functions (by the full name - with package); 712 e) Has an interface to INFO docs for Perl; The interface is 713 very flexible, including shrink-wrapping of 714 documentation buffer/frame; 715 f) Has a builtin list of one-line explanations for perl constructs. 716 g) Can show these explanations if you stay long enough at the 717 corresponding place (or on demand); 718 h) Has an enhanced fontification (using 3 or 4 additional faces 719 comparing to font-lock - basically, different 720 namespaces in Perl have different colors); 721 i) Can construct TAGS basing on its knowledge of Perl syntax, 722 the standard menu has 6 different way to generate 723 TAGS (if \"by directory\", .xs files - with C-language 724 bindings - are included in the scan); 725 j) Can build a hierarchical view of classes (via imenu) basing 726 on generated TAGS file; 727 k) Has electric parentheses, electric newlines, uses Abbrev 728 for electric logical constructs 729 while () {} 730 with different styles of expansion (context sensitive 731 to be not so bothering). Electric parentheses behave 732 \"as they should\" in a presence of a visible region. 733 l) Changes msb.el \"on the fly\" to insert a group \"Perl files\"; 734 m) Can convert from 735 if (A) { B } 736 to 737 B if A; 738 739 n) Highlights (by user-choice) either 3-delimiters constructs 740 (such as tr/a/b/), or regular expressions and `y/tr'; 741 o) Highlights trailing whitespace; 742 p) Is able to manipulate Perl Regular Expressions to ease 743 conversion to a more readable form. 744 q) Can ispell POD sections and HERE-DOCs. 745 r) Understands comments and character classes inside regular 746 expressions; can find matching () and [] in a regular expression. 747 s) Allows indentation of //x-style regular expressions; 748 t) Highlights different symbols in regular expressions according 749 to their function; much less problems with backslashitis; 750 u) Allows to find regular expressions which contain interpolated parts. 751 7525) The indentation engine was very smart, but most of tricks may be 753not needed anymore with the support for `syntax-table' property. Has 754progress indicator for indentation (with `imenu' loaded). 755 7566) Indent-region improves inline-comments as well; also corrects 757whitespace *inside* the conditional/loop constructs. 758 7597) Fill-paragraph correctly handles multi-line comments; 760 7618) Can switch to different indentation styles by one command, and restore 762the settings present before the switch. 763 7649) When doing indentation of control constructs, may correct 765line-breaks/spacing between elements of the construct. 766 76710) Uses a linear-time algorithm for indentation of regions. 768 76911) Syntax-highlight, indentation, sexp-recognition inside regular expressions.") 770 771(defvar cperl-speed 'please-ignore-this-line 772 "This is an incomplete compendium of what is available in other parts 773of CPerl documentation. (Please inform me if I skipped anything.) 774 775There is a perception that CPerl is slower than alternatives. This part 776of documentation is designed to overcome this misconception. 777 778*By default* CPerl tries to enable the most comfortable settings. 779From most points of view, correctly working package is infinitely more 780comfortable than a non-correctly working one, thus by default CPerl 781prefers correctness over speed. Below is the guide how to change 782settings if your preferences are different. 783 784A) Speed of loading the file. When loading file, CPerl may perform a 785scan which indicates places which cannot be parsed by primitive Emacs 786syntax-parsing routines, and marks them up so that either 787 788 A1) CPerl may work around these deficiencies (for big chunks, mostly 789 PODs and HERE-documents), or 790 A2) CPerl will use improved syntax-handling which reads mark-up 791 hints directly. 792 793 The scan in case A2 is much more comprehensive, thus may be slower. 794 795 User can disable syntax-engine-helping scan of A2 by setting 796 `cperl-use-syntax-table-text-property' 797 variable to nil (if it is set to t). 798 799 One can disable the scan altogether (both A1 and A2) by setting 800 `cperl-pod-here-scan' 801 to nil. 802 803B) Speed of editing operations. 804 805 One can add a (minor) speedup to editing operations by setting 806 `cperl-use-syntax-table-text-property' 807 variable to nil (if it is set to t). This will disable 808 syntax-engine-helping scan, thus will make many more Perl 809 constructs be wrongly recognized by CPerl, thus may lead to 810 wrongly matched parentheses, wrong indentation, etc. 811 812 One can unset `cperl-syntaxify-unwind'. This might speed up editing 813 of, say, long POD sections.") 814 815(defvar cperl-tips-faces 'please-ignore-this-line 816 "CPerl mode uses following faces for highlighting: 817 818 `cperl-array-face' Array names 819 `cperl-hash-face' Hash names 820 `font-lock-comment-face' Comments, PODs and whatever is considered 821 syntactically to be not code 822 `font-lock-constant-face' HERE-doc delimiters, labels, delimiters of 823 2-arg operators s/y/tr/ or of RExen, 824 `font-lock-warning-face' Special-cased m// and s//foo/, 825 `font-lock-function-name-face' _ as a target of a file tests, file tests, 826 subroutine names at the moment of definition 827 (except those conflicting with Perl operators), 828 package names (when recognized), format names 829 `font-lock-keyword-face' Control flow switch constructs, declarators 830 `cperl-nonoverridable-face' Non-overridable keywords, modifiers of RExen 831 `font-lock-string-face' Strings, qw() constructs, RExen, POD sections, 832 literal parts and the terminator of formats 833 and whatever is syntactically considered 834 as string literals 835 `font-lock-type-face' Overridable keywords 836 `font-lock-variable-name-face' Variable declarations, indirect array and 837 hash names, POD headers/item names 838 `cperl-invalid-face' Trailing whitespace 839 840Note that in several situations the highlighting tries to inform about 841possible confusion, such as different colors for function names in 842declarations depending on what they (do not) override, or special cases 843m// and s/// which do not do what one would expect them to do. 844 845Help with best setup of these faces for printout requested (for each of 846the faces: please specify bold, italic, underline, shadow and box.) 847 848In regular expressions (including character classes): 849 `font-lock-string-face' \"Normal\" stuff and non-0-length constructs 850 `font-lock-constant-face': Delimiters 851 `font-lock-warning-face' Special-cased m// and s//foo/, 852 Mismatched closing delimiters, parens 853 we couldn't match, misplaced quantifiers, 854 unrecognized escape sequences 855 `cperl-nonoverridable-face' Modifiers, as gism in m/REx/gism 856 `font-lock-type-face' escape sequences with arguments (\\x \\23 \\p \\N) 857 and others match-a-char escape sequences 858 `font-lock-keyword-face' Capturing parens, and | 859 `font-lock-function-name-face' Special symbols: $ ^ . [ ] [^ ] (?{ }) (??{ }) 860 \"Range -\" in character classes 861 `font-lock-builtin-face' \"Remaining\" 0-length constructs, multipliers 862 ?+*{}, not-capturing parens, leading 863 backslashes of escape sequences 864 `font-lock-variable-name-face' Interpolated constructs, embedded code, 865 POSIX classes (inside charclasses) 866 `font-lock-comment-face' Embedded comments") 867 868 869 870;;; Portability stuff: 871 872(defvar cperl-del-back-ch 873 (car (append (where-is-internal 'delete-backward-char) 874 (where-is-internal 'backward-delete-char-untabify))) 875 "Character generated by key bound to `delete-backward-char'.") 876 877(and (vectorp cperl-del-back-ch) (= (length cperl-del-back-ch) 1) 878 (setq cperl-del-back-ch (aref cperl-del-back-ch 0))) 879 880(defun cperl-putback-char (c) ; Emacs 19 881 (push c unread-command-events)) ; Avoid undefined warning 882 883(defsubst cperl-put-do-not-fontify (from to &optional post) 884 ;; If POST, do not do it with postponed fontification 885 (if (and post cperl-syntaxify-by-font-lock) 886 nil 887 (put-text-property (max (point-min) (1- from)) 888 to 'fontified t))) 889 890(defcustom cperl-mode-hook nil 891 "Hook run by CPerl mode." 892 :type 'hook 893 :group 'cperl) 894 895(defvar cperl-syntax-state nil) 896(defvar cperl-syntax-done-to nil) 897 898;; Make customization possible "in reverse" 899(defsubst cperl-val (symbol &optional default hairy) 900 (cond 901 ((eq (symbol-value symbol) 'null) default) 902 (cperl-hairy (or hairy t)) 903 (t (symbol-value symbol)))) 904 905 906(defun cperl-make-indent (column &optional minimum keep) 907 "Indent from point with tabs and spaces until COLUMN is reached. 908MINIMUM is like in `indent-to', which see. 909Unless KEEP, removes the old indentation." 910 (or keep 911 (delete-horizontal-space)) 912 (indent-to column minimum)) 913 914;; Probably it is too late to set these guys already, but it can help later: 915 916;;(and cperl-clobber-mode-lists 917;;(setq auto-mode-alist 918;; (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist )) 919;;(and (boundp 'interpreter-mode-alist) 920;; (setq interpreter-mode-alist (append interpreter-mode-alist 921;; '(("miniperl" . perl-mode)))))) 922(eval-when-compile 923 (mapc #'require '(imenu easymenu etags timer man info))) 924 925(define-abbrev-table 'cperl-mode-electric-keywords-abbrev-table 926 (mapcar (lambda (x) 927 (let ((name (car x)) 928 (fun (cadr x))) 929 (list name name fun :system t))) 930 '(("if" cperl-electric-keyword) 931 ("elsif" cperl-electric-keyword) 932 ("while" cperl-electric-keyword) 933 ("until" cperl-electric-keyword) 934 ("unless" cperl-electric-keyword) 935 ("else" cperl-electric-else) 936 ("continue" cperl-electric-else) 937 ("for" cperl-electric-keyword) 938 ("foreach" cperl-electric-keyword) 939 ("formy" cperl-electric-keyword) 940 ("foreachmy" cperl-electric-keyword) 941 ("do" cperl-electric-keyword) 942 ("=pod" cperl-electric-pod) 943 ("=begin" cperl-electric-pod t) 944 ("=over" cperl-electric-pod) 945 ("=head1" cperl-electric-pod) 946 ("=head2" cperl-electric-pod) 947 ("pod" cperl-electric-pod) 948 ("over" cperl-electric-pod) 949 ("head1" cperl-electric-pod) 950 ("head2" cperl-electric-pod))) 951 "Abbrev table for electric keywords. Controlled by `cperl-electric-keywords'." 952 :case-fixed t 953 :enable-function (lambda () (cperl-val 'cperl-electric-keywords))) 954 955(define-abbrev-table 'cperl-mode-abbrev-table () 956 "Abbrev table in use in CPerl mode buffers." 957 :parents (list cperl-mode-electric-keywords-abbrev-table)) 958 959;; ;; TODO: Commented out as we don't know what it is used for. If 960;; ;; there are no bug reports about this for Emacs 28.1, this 961;; ;; can probably be removed. (Code search online reveals nothing.) 962;; (when (boundp 'edit-var-mode-alist) 963;; ;; FIXME: What package uses this? 964;; (add-to-list 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-")))) 965 966(defvar cperl-mode-map 967 (let ((map (make-sparse-keymap))) 968 (define-key map "{" 'cperl-electric-lbrace) 969 (define-key map "[" 'cperl-electric-paren) 970 (define-key map "(" 'cperl-electric-paren) 971 (define-key map "<" 'cperl-electric-paren) 972 (define-key map "}" 'cperl-electric-brace) 973 (define-key map "]" 'cperl-electric-rparen) 974 (define-key map ")" 'cperl-electric-rparen) 975 (define-key map ";" 'cperl-electric-semi) 976 (define-key map ":" 'cperl-electric-terminator) 977 (define-key map "\C-j" 'newline-and-indent) 978 (define-key map "\C-c\C-j" 'cperl-linefeed) 979 (define-key map "\C-c\C-t" 'cperl-invert-if-unless) 980 (define-key map "\C-c\C-a" 'cperl-toggle-auto-newline) 981 (define-key map "\C-c\C-k" 'cperl-toggle-abbrev) 982 (define-key map "\C-c\C-w" 'cperl-toggle-construct-fix) 983 (define-key map "\C-c\C-f" 'auto-fill-mode) 984 (define-key map "\C-c\C-e" 'cperl-toggle-electric) 985 (define-key map "\C-c\C-b" 'cperl-find-bad-style) 986 (define-key map "\C-c\C-p" 'cperl-pod-spell) 987 (define-key map "\C-c\C-d" 'cperl-here-doc-spell) 988 (define-key map "\C-c\C-n" 'cperl-narrow-to-here-doc) 989 (define-key map "\C-c\C-v" 'cperl-next-interpolated-REx) 990 (define-key map "\C-c\C-x" 'cperl-next-interpolated-REx-0) 991 (define-key map "\C-c\C-y" 'cperl-next-interpolated-REx-1) 992 (define-key map "\C-c\C-ha" 'cperl-toggle-autohelp) 993 (define-key map "\C-c\C-hp" 'cperl-perldoc) 994 (define-key map "\C-c\C-hP" 'cperl-perldoc-at-point) 995 (define-key map "\e\C-q" 'cperl-indent-exp) ; Usually not bound 996 (define-key map [(control meta ?|)] 'cperl-lineup) 997 ;;(define-key map "\M-q" 'cperl-fill-paragraph) 998 ;;(define-key map "\e;" 'cperl-indent-for-comment) 999 (define-key map "\177" 'cperl-electric-backspace) 1000 (define-key map "\t" 'cperl-indent-command) 1001 ;; don't clobber the backspace binding: 1002 (define-key map [(control ?c) (control ?h) ?F] 'cperl-info-on-command) 1003 (if (cperl-val 'cperl-clobber-lisp-bindings) 1004 (progn 1005 (define-key map [(control ?h) ?f] 1006 ;;(concat (char-to-string help-char) "f") ; does not work 1007 'cperl-info-on-command) 1008 (define-key map [(control ?h) ?v] 1009 ;;(concat (char-to-string help-char) "v") ; does not work 1010 'cperl-get-help) 1011 (define-key map [(control ?c) (control ?h) ?f] 1012 ;;(concat (char-to-string help-char) "f") ; does not work 1013 (key-binding "\C-hf")) 1014 (define-key map [(control ?c) (control ?h) ?v] 1015 ;;(concat (char-to-string help-char) "v") ; does not work 1016 (key-binding "\C-hv"))) 1017 (define-key map [(control ?c) (control ?h) ?f] 1018 'cperl-info-on-current-command) 1019 (define-key map [(control ?c) (control ?h) ?v] 1020 ;;(concat (char-to-string help-char) "v") ; does not work 1021 'cperl-get-help)) 1022 (define-key map [remap indent-sexp] #'cperl-indent-exp) 1023 (define-key map [remap indent-region] #'cperl-indent-region) 1024 (define-key map [remap indent-for-comment] #'cperl-indent-for-comment) 1025 map) 1026 "Keymap used in CPerl mode.") 1027 1028(defvar cperl-lazy-installed) 1029(defvar cperl-old-style nil) 1030(easy-menu-define cperl-menu cperl-mode-map 1031 "Menu for CPerl mode." 1032 '("Perl" 1033 ["Beginning of function" beginning-of-defun t] 1034 ["End of function" end-of-defun t] 1035 ["Mark function" mark-defun t] 1036 ["Indent expression" cperl-indent-exp t] 1037 ["Fill paragraph/comment" fill-paragraph t] 1038 "----" 1039 ["Line up a construction" cperl-lineup (use-region-p)] 1040 ["Invert if/unless/while etc" cperl-invert-if-unless t] 1041 ("Regexp" 1042 ["Beautify" cperl-beautify-regexp 1043 cperl-use-syntax-table-text-property] 1044 ["Beautify one level deep" (cperl-beautify-regexp 1) 1045 cperl-use-syntax-table-text-property] 1046 ["Beautify a group" cperl-beautify-level 1047 cperl-use-syntax-table-text-property] 1048 ["Beautify a group one level deep" (cperl-beautify-level 1) 1049 cperl-use-syntax-table-text-property] 1050 ["Contract a group" cperl-contract-level 1051 cperl-use-syntax-table-text-property] 1052 ["Contract groups" cperl-contract-levels 1053 cperl-use-syntax-table-text-property] 1054 "----" 1055 ["Find next interpolated" cperl-next-interpolated-REx 1056 (next-single-property-change (point-min) 'REx-interpolated)] 1057 ["Find next interpolated (no //o)" 1058 cperl-next-interpolated-REx-0 1059 (or (text-property-any (point-min) (point-max) 'REx-interpolated t) 1060 (text-property-any (point-min) (point-max) 'REx-interpolated 1))] 1061 ["Find next interpolated (neither //o nor whole-REx)" 1062 cperl-next-interpolated-REx-1 1063 (text-property-any (point-min) (point-max) 'REx-interpolated t)]) 1064 ["Insert spaces if needed to fix style" cperl-find-bad-style t] 1065 ["Refresh \"hard\" constructions" cperl-find-pods-heres t] 1066 "----" 1067 ["Indent region" cperl-indent-region (use-region-p)] 1068 ["Comment region" cperl-comment-region (use-region-p)] 1069 ["Uncomment region" cperl-uncomment-region (use-region-p)] 1070 "----" 1071 ["Run" mode-compile (fboundp 'mode-compile)] 1072 ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill) 1073 (get-buffer "*compilation*"))] 1074 ["Next error" next-error (get-buffer "*compilation*")] 1075 ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)] 1076 "----" 1077 ["Debugger" cperl-db t] 1078 "----" 1079 ("Tools" 1080 ["Imenu" imenu (fboundp 'imenu)] 1081 ["Imenu on Perl Info" cperl-imenu-on-info (featurep 'imenu)] 1082 "----" 1083 ["Ispell PODs" cperl-pod-spell 1084 ;; Better not to update syntaxification here: 1085 ;; debugging syntaxification can be broken by this??? 1086 (or 1087 (get-text-property (point-min) 'in-pod) 1088 (< (progn 1089 (and cperl-syntaxify-for-menu 1090 (cperl-update-syntaxification (point-max))) 1091 (next-single-property-change (point-min) 'in-pod nil (point-max))) 1092 (point-max)))] 1093 ["Ispell HERE-DOCs" cperl-here-doc-spell 1094 (< (progn 1095 (and cperl-syntaxify-for-menu 1096 (cperl-update-syntaxification (point-max))) 1097 (next-single-property-change (point-min) 'here-doc-group nil (point-max))) 1098 (point-max))] 1099 ["Narrow to this HERE-DOC" cperl-narrow-to-here-doc 1100 (eq 'here-doc (progn 1101 (and cperl-syntaxify-for-menu 1102 (cperl-update-syntaxification (point))) 1103 (get-text-property (point) 'syntax-type)))] 1104 ["Select this HERE-DOC or POD section" 1105 cperl-select-this-pod-or-here-doc 1106 (memq (progn 1107 (and cperl-syntaxify-for-menu 1108 (cperl-update-syntaxification (point))) 1109 (get-text-property (point) 'syntax-type)) 1110 '(here-doc pod))] 1111 "----" 1112 ["CPerl pretty print (experimental)" cperl-ps-print 1113 (fboundp 'ps-extend-face-list)] 1114 "----" 1115 ["Syntaxify region" cperl-find-pods-heres-region 1116 (use-region-p)] 1117 ["Profile syntaxification" cperl-time-fontification t] 1118 ["Debug errors in delayed fontification" cperl-emulate-lazy-lock t] 1119 ["Debug unwind for syntactic scan" cperl-toggle-set-debug-unwind t] 1120 ["Debug backtrace on syntactic scan (BEWARE!!!)" 1121 (cperl-toggle-set-debug-unwind nil t) t] 1122 "----" 1123 ["Class Hierarchy from TAGS" cperl-tags-hier-init t] 1124 ;;["Update classes" (cperl-tags-hier-init t) tags-table-list] 1125 ("Tags" 1126 ;; ["Create tags for current file" cperl-etags t] 1127 ;; ["Add tags for current file" (cperl-etags t) t] 1128 ;; ["Create tags for Perl files in directory" (cperl-etags nil t) t] 1129 ;; ["Add tags for Perl files in directory" (cperl-etags t t) t] 1130 ;; ["Create tags for Perl files in (sub)directories" 1131 ;; (cperl-etags nil 'recursive) t] 1132 ;; ["Add tags for Perl files in (sub)directories" 1133 ;; (cperl-etags t 'recursive) t]) 1134 ;; ;;? cperl-write-tags (&optional file erase recurse dir inbuffer) 1135 ["Create tags for current file" (cperl-write-tags nil t) t] 1136 ["Add tags for current file" (cperl-write-tags) t] 1137 ["Create tags for Perl files in directory" 1138 (cperl-write-tags nil t nil t) t] 1139 ["Add tags for Perl files in directory" 1140 (cperl-write-tags nil nil nil t) t] 1141 ["Create tags for Perl files in (sub)directories" 1142 (cperl-write-tags nil t t t) t] 1143 ["Add tags for Perl files in (sub)directories" 1144 (cperl-write-tags nil nil t t) t])) 1145 ("Perl docs" 1146 ["Define word at point" imenu-go-find-at-position 1147 (fboundp 'imenu-go-find-at-position)] 1148 ["Help on function" cperl-info-on-command t] 1149 ["Help on function at point" cperl-info-on-current-command t] 1150 ["Help on symbol at point" cperl-get-help t] 1151 ["Perldoc" cperl-perldoc t] 1152 ["Perldoc on word at point" cperl-perldoc-at-point t] 1153 ["View manpage of POD in this file" cperl-build-manpage t] 1154 ["Auto-help on" cperl-lazy-install 1155 (not cperl-lazy-installed)] 1156 ["Auto-help off" cperl-lazy-unstall 1157 cperl-lazy-installed]) 1158 ("Toggle..." 1159 ["Auto newline" cperl-toggle-auto-newline t] 1160 ["Electric parens" cperl-toggle-electric t] 1161 ["Electric keywords" cperl-toggle-abbrev t] 1162 ["Fix whitespace on indent" cperl-toggle-construct-fix t] 1163 ["Auto-help on Perl constructs" cperl-toggle-autohelp t] 1164 ["Auto fill" auto-fill-mode t]) 1165 ("Indent styles..." 1166 ["CPerl" (cperl-set-style "CPerl") t] 1167 ["PBP" (cperl-set-style "PBP") t] 1168 ["PerlStyle" (cperl-set-style "PerlStyle") t] 1169 ["GNU" (cperl-set-style "GNU") t] 1170 ["C++" (cperl-set-style "C++") t] 1171 ["K&R" (cperl-set-style "K&R") t] 1172 ["BSD" (cperl-set-style "BSD") t] 1173 ["Whitesmith" (cperl-set-style "Whitesmith") t] 1174 ["Memorize Current" (cperl-set-style "Current") t] 1175 ["Memorized" (cperl-set-style-back) cperl-old-style]) 1176 ("Micro-docs" 1177 ["Tips" (describe-variable 'cperl-tips) t] 1178 ["Problems" (describe-variable 'cperl-problems) t] 1179 ["Speed" (describe-variable 'cperl-speed) t] 1180 ["Praise" (describe-variable 'cperl-praise) t] 1181 ["Faces" (describe-variable 'cperl-tips-faces) t] 1182 ["CPerl mode" (describe-function 'cperl-mode) t]))) 1183 1184(autoload 'c-macro-expand "cmacexp" 1185 "Display the result of expanding all C macros occurring in the region. 1186The expansion is entirely correct because it uses the C preprocessor." 1187 t) 1188 1189 1190;;; Perl Grammar Components 1191;; 1192;; The following regular expressions are building blocks for a 1193;; minimalistic Perl grammar, to be used instead of individual (and 1194;; not always consistent) literal regular expressions. 1195 1196;; This is necessary to compile this file under Emacs 26.1 1197;; (there's no rx-define which would help) 1198(eval-and-compile 1199 1200 (defconst cperl--basic-identifier-rx 1201 '(sequence (or alpha "_") (* (or word "_"))) 1202 "A regular expression for the name of a \"basic\" Perl variable. 1203Neither namespace separators nor sigils are included. As is, 1204this regular expression applies to labels,subroutine calls where 1205the ampersand sigil is not required, and names of subroutine 1206attributes.") 1207 1208 (defconst cperl--label-rx 1209 `(sequence symbol-start 1210 ,cperl--basic-identifier-rx 1211 (0+ space) 1212 ":") 1213 "A regular expression for a Perl label. 1214By convention, labels are uppercase alphabetics, but this isn't 1215enforced.") 1216 1217 (defconst cperl--false-label-rx 1218 '(sequence (or (in "sym") "tr") (0+ space) ":") 1219 "A regular expression which is similar to a label, but might as 1220well be a quote-like operator with a colon as delimiter.") 1221 1222 (defconst cperl--normal-identifier-rx 1223 `(or (sequence (1+ (sequence 1224 (opt ,cperl--basic-identifier-rx) 1225 "::")) 1226 (opt ,cperl--basic-identifier-rx)) 1227 ,cperl--basic-identifier-rx) 1228 "A regular expression for a Perl variable name with optional namespace. 1229Examples are `foo`, `Some::Module::VERSION`, and `::` (yes, that 1230is a legal variable name).") 1231 1232 (defconst cperl--special-identifier-rx 1233 '(or 1234 (1+ digit) ; $0, $1, $2, ... 1235 (sequence "^" (any "A-Z" "]^_?\\")) ; $^V 1236 (sequence "{" (0+ space) ; ${^MATCH} 1237 "^" (any "A-Z" "]^_?\\") 1238 (0+ (any "A-Z" "_" digit)) 1239 (0+ space) "}") 1240 (in "!\"$%&'()+,-./:;<=>?@\\]^_`|~")) ; $., $|, $", ... but not $^ or ${ 1241 "The list of Perl \"punctuation\" variables, as listed in perlvar.") 1242 1243 (defconst cperl--ws-rx 1244 '(sequence (or space "\n")) 1245 "Regular expression for a single whitespace in Perl.") 1246 1247 (defconst cperl--eol-comment-rx 1248 '(sequence "#" (0+ (not (in "\n"))) "\n") 1249 "Regular expression for a single end-of-line comment in Perl") 1250 1251 (defconst cperl--ws-or-comment-rx 1252 `(or ,cperl--ws-rx 1253 ,cperl--eol-comment-rx) 1254 "A regular expression for either whitespace or comment") 1255 1256 (defconst cperl--ws*-rx 1257 `(0+ ,cperl--ws-or-comment-rx) 1258 "Regular expression for optional whitespaces or comments in Perl") 1259 1260 (defconst cperl--ws+-rx 1261 `(1+ ,cperl--ws-or-comment-rx) 1262 "Regular expression for a sequence of whitespace and comments in Perl.") 1263 1264 ;; This is left as a string regexp. There are many version schemes in 1265 ;; the wild, so people might want to fiddle with this variable. 1266 (defconst cperl--version-regexp 1267 (rx-to-string 1268 `(or 1269 (sequence (optional "v") 1270 (>= 2 (sequence (1+ digit) ".")) 1271 (1+ digit) 1272 (optional (sequence "_" (1+ word)))) 1273 (sequence (1+ digit) 1274 (optional (sequence "." (1+ digit))) 1275 (optional (sequence "_" (1+ word)))))) 1276 "A sequence for recommended version number schemes in Perl.") 1277 1278 (defconst cperl--package-rx 1279 `(sequence (group "package") 1280 ,cperl--ws+-rx 1281 (group ,cperl--normal-identifier-rx) 1282 (optional (sequence ,cperl--ws+-rx 1283 (group (regexp ,cperl--version-regexp))))) 1284 "A regular expression for package NAME VERSION in Perl. 1285Contains three groups for the keyword \"package\", for the 1286package name and for the version.") 1287 1288 (defconst cperl--package-for-imenu-rx 1289 `(sequence symbol-start 1290 (group-n 1 "package") 1291 ,cperl--ws*-rx 1292 (group-n 2 ,cperl--normal-identifier-rx) 1293 (optional (sequence ,cperl--ws+-rx 1294 (regexp ,cperl--version-regexp))) 1295 ,cperl--ws*-rx 1296 (group-n 3 (or ";" "{"))) 1297 "A regular expression to collect package names for `imenu'. 1298Catches \"package NAME;\", \"package NAME VERSION;\", \"package 1299NAME BLOCK\" and \"package NAME VERSION BLOCK.\" Contains three 1300groups: One for the keyword \"package\", one for the package 1301name, and one for the discovery of a following BLOCK.") 1302 1303 (defconst cperl--sub-name-for-imenu-rx 1304 `(sequence symbol-start 1305 (optional (sequence (group-n 3 (or "my" "state" "our")) 1306 ,cperl--ws+-rx)) 1307 (group-n 1 "sub") 1308 ,cperl--ws+-rx 1309 (group-n 2 ,cperl--normal-identifier-rx)) 1310 "A regular expression to detect a subroutine start. 1311Contains three groups: One one to distinguish lexical from 1312\"normal\" subroutines, for the keyword \"sub\", and one for the 1313subroutine name.") 1314 1315(defconst cperl--block-declaration-rx 1316 `(sequence 1317 (or "package" "sub") ; "class" and "method" coming soon 1318 (1+ ,cperl--ws-or-comment-rx) 1319 ,cperl--normal-identifier-rx) 1320 "A regular expression to find a declaration for a named block. 1321Used for indentation. These declarations introduce a block which 1322does not need a semicolon to terminate the statement.") 1323 1324(defconst cperl--pod-heading-rx 1325 `(sequence line-start 1326 (group-n 1 "=head") 1327 (group-n 3 (in "1-4")) 1328 (1+ (in " \t")) 1329 (group-n 2 (1+ (not (in "\n"))))) 1330 "A regular expression to detect a POD heading. 1331Contains two groups: One for the heading level, and one for the 1332heading text.") 1333 1334(defconst cperl--imenu-entries-rx 1335 `(or ,cperl--package-for-imenu-rx 1336 ,cperl--sub-name-for-imenu-rx 1337 ,cperl--pod-heading-rx) 1338 "A regular expression to collect stuff that goes into the `imenu' index. 1339Covers packages, subroutines, and POD headings.") 1340 1341;; end of eval-and-compiled stuff 1342) 1343 1344 1345(defun cperl-block-declaration-p () 1346 "Test whether the following ?\\{ opens a declaration block. 1347Returns the column where the declarating keyword is found, or nil 1348if this isn't a declaration block. Declaration blocks are named 1349subroutines, packages and the like. They start with a keyword 1350and a name, to be followed by various descriptive items which are 1351just skipped over for our purpose. Declaration blocks end a 1352statement, so there's no semicolon." 1353 ;; A scan error means that none of the declarators has been found 1354 (condition-case nil 1355 (let ((is-block-declaration nil) 1356 (continue-searching t)) 1357 (while (and continue-searching (not (bobp))) 1358 (forward-sexp -1) 1359 (cond 1360 ((looking-at (rx (eval cperl--block-declaration-rx))) 1361 (setq is-block-declaration (current-column) 1362 continue-searching nil)) 1363 ;; Another brace means this is no block declaration 1364 ((looking-at "{") 1365 (setq continue-searching nil)) 1366 (t 1367 (cperl-backward-to-noncomment (point-min)) 1368 ;; A semicolon or an opening brace prevent this block from 1369 ;; being a block declaration 1370 (when (or (eq (preceding-char) ?\;) 1371 (eq (preceding-char) ?{)) 1372 (setq continue-searching nil))))) 1373 is-block-declaration) 1374 (error nil))) 1375 1376 1377;; These two must be unwound, otherwise take exponential time 1378(defconst cperl-maybe-white-and-comment-rex 1379 (rx (group (eval cperl--ws*-rx))) 1380 ;; was: "[ \t\n]*\\(#[^\n]*\n[ \t\n]*\\)*" 1381"Regular expression to match optional whitespace with interspersed comments. 1382Should contain exactly one group.") 1383 1384;; This one is tricky to unwind; still very inefficient... 1385(defconst cperl-white-and-comment-rex 1386 (rx (group (eval cperl--ws+-rx))) 1387 ;; was: "\\([ \t\n]\\|#[^\n]*\n\\)+" 1388"Regular expression to match whitespace with interspersed comments. 1389Should contain exactly one group.") 1390 1391 1392;; Is incorporated in `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 (rx-to-string `(group ,cperl--normal-identifier-rx)) 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;; Tired of editing this in 8 places every time I remember that there 1431;; is another method-defining keyword 1432(defvar cperl-sub-keywords 1433 '("sub")) 1434 1435(defvar cperl-sub-regexp (regexp-opt cperl-sub-keywords)) 1436 1437(defun cperl-char-ends-sub-keyword-p (char) 1438 "Return t if CHAR is the last character of a perl sub keyword." 1439 (cl-loop for keyword in cperl-sub-keywords 1440 when (eq char (aref keyword (1- (length keyword)))) 1441 return t)) 1442 1443(defvar cperl-outline-regexp 1444 (rx (sequence line-start (0+ blank) (eval cperl--imenu-entries-rx))) 1445 "The regular expression used for `outline-minor-mode'.") 1446 1447(defvar cperl-mode-syntax-table nil 1448 "Syntax table in use in CPerl mode buffers.") 1449 1450(defvar cperl-string-syntax-table nil 1451 "Syntax table in use in CPerl mode string-like chunks.") 1452 1453(defsubst cperl-1- (p) 1454 (max (point-min) (1- p))) 1455 1456(defsubst cperl-1+ (p) 1457 (min (point-max) (1+ p))) 1458 1459(if cperl-mode-syntax-table 1460 () 1461 (setq cperl-mode-syntax-table (make-syntax-table)) 1462 (modify-syntax-entry ?\\ "\\" cperl-mode-syntax-table) 1463 (modify-syntax-entry ?/ "." cperl-mode-syntax-table) 1464 (modify-syntax-entry ?* "." cperl-mode-syntax-table) 1465 (modify-syntax-entry ?+ "." cperl-mode-syntax-table) 1466 (modify-syntax-entry ?- "." cperl-mode-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 ?\n ">" 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 (if cperl-under-as-char 1478 (modify-syntax-entry ?_ "w" cperl-mode-syntax-table)) 1479 (modify-syntax-entry ?: "_" cperl-mode-syntax-table) 1480 (modify-syntax-entry ?| "." cperl-mode-syntax-table) 1481 (setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table)) 1482 (modify-syntax-entry ?$ "." cperl-string-syntax-table) 1483 (modify-syntax-entry ?\{ "." cperl-string-syntax-table) 1484 (modify-syntax-entry ?\} "." cperl-string-syntax-table) 1485 (modify-syntax-entry ?\" "." cperl-string-syntax-table) 1486 (modify-syntax-entry ?' "." cperl-string-syntax-table) 1487 (modify-syntax-entry ?` "." cperl-string-syntax-table) 1488 (modify-syntax-entry ?# "." cperl-string-syntax-table)) ; (?# comment ) 1489 1490 1491 1492(defvar cperl-faces-init nil) 1493;; Fix for msb.el 1494(defvar cperl-msb-fixed nil) 1495(defvar cperl-use-major-mode 'cperl-mode) 1496(defvar cperl-font-lock-multiline-start nil) 1497(defvar cperl-font-lock-multiline nil) 1498(defvar cperl-font-locking nil) 1499 1500(defvar cperl-compilation-error-regexp-list 1501 ;; This look like a paranoiac regexp: could anybody find a better one? (which WORKS). 1502 '("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]" 1503 2 3) 1504 "List that specifies how to match errors in Perl output.") 1505 1506(defvar cperl-compilation-error-regexp-alist) 1507(make-obsolete-variable 'cperl-compilation-error-regexp-alist 1508 'cperl-compilation-error-regexp-list "28.1") 1509 1510(defvar compilation-error-regexp-alist) 1511 1512;;;###autoload 1513(define-derived-mode cperl-mode prog-mode "CPerl" 1514 "Major mode for editing Perl code. 1515Expression and list commands understand all C brackets. 1516Tab indents for Perl code. 1517Paragraphs are separated by blank lines only. 1518Delete converts tabs to spaces as it moves back. 1519 1520Various characters in Perl almost always come in pairs: {}, (), [], 1521sometimes <>. When the user types the first, she gets the second as 1522well, with optional special formatting done on {}. (Disabled by 1523default.) You can always quote (with \\[quoted-insert]) the left 1524\"paren\" to avoid the expansion. The processing of < is special, 1525since most the time you mean \"less\". CPerl mode tries to guess 1526whether you want to type pair <>, and inserts is if it 1527appropriate. You can set `cperl-electric-parens-string' to the string that 1528contains the parens from the above list you want to be electrical. 1529Electricity of parens is controlled by `cperl-electric-parens'. 1530You may also set `cperl-electric-parens-mark' to have electric parens 1531look for active mark and \"embrace\" a region if possible.' 1532 1533CPerl mode provides expansion of the Perl control constructs: 1534 1535 if, else, elsif, unless, while, until, continue, do, 1536 for, foreach, formy and foreachmy. 1537 1538and POD directives (Disabled by default, see `cperl-electric-keywords'.) 1539 1540The user types the keyword immediately followed by a space, which 1541causes the construct to be expanded, and the point is positioned where 1542she is most likely to want to be. E.g., when the user types a space 1543following \"if\" the following appears in the buffer: if () { or if () 1544} { } and the cursor is between the parentheses. The user can then 1545type some boolean expression within the parens. Having done that, 1546typing \\[cperl-linefeed] places you - appropriately indented - on a 1547new line between the braces (if you typed \\[cperl-linefeed] in a POD 1548directive line, then appropriate number of new lines is inserted). 1549 1550If CPerl decides that you want to insert \"English\" style construct like 1551 1552 bite if angry; 1553 1554it will not do any expansion. See also help on variable 1555`cperl-extra-newline-before-brace'. (Note that one can switch the 1556help message on expansion by setting `cperl-message-electric-keyword' 1557to nil.) 1558 1559\\[cperl-linefeed] is a convenience replacement for typing carriage 1560return. It places you in the next line with proper indentation, or if 1561you type it inside the inline block of control construct, like 1562 1563 foreach (@lines) {print; print} 1564 1565and you are on a boundary of a statement inside braces, it will 1566transform the construct into a multiline and will place you into an 1567appropriately indented blank line. If you need a usual 1568`newline-and-indent' behavior, it is on \\[newline-and-indent], 1569see documentation on `cperl-electric-linefeed'. 1570 1571Use \\[cperl-invert-if-unless] to change a construction of the form 1572 1573 if (A) { B } 1574 1575into 1576 1577 B if A; 1578 1579\\{cperl-mode-map} 1580 1581Setting the variable `cperl-font-lock' to t switches on `font-lock-mode' 1582\(even with older Emacsen), `cperl-electric-lbrace-space' to t switches 1583on electric space between $ and {, `cperl-electric-parens-string' is 1584the string that contains parentheses that should be electric in CPerl 1585\(see also `cperl-electric-parens-mark' and `cperl-electric-parens'), 1586setting `cperl-electric-keywords' enables electric expansion of 1587control structures in CPerl. `cperl-electric-linefeed' governs which 1588one of two linefeed behavior is preferable. You can enable all these 1589options simultaneously (recommended mode of use) by setting 1590`cperl-hairy' to t. In this case you can switch separate options off 1591by setting them to `null'. Note that one may undo the extra 1592whitespace inserted by semis and braces in `auto-newline'-mode by 1593consequent \\[cperl-electric-backspace]. 1594 1595If your site has perl5 documentation in info format, you can use commands 1596\\[cperl-info-on-current-command] and \\[cperl-info-on-command] to access it. 1597These keys run commands `cperl-info-on-current-command' and 1598`cperl-info-on-command', which one is which is controlled by variable 1599`cperl-info-on-command-no-prompt' and `cperl-clobber-lisp-bindings' 1600\(in turn affected by `cperl-hairy'). 1601 1602Even if you have no info-format documentation, short one-liner-style 1603help is available on \\[cperl-get-help], and one can run perldoc or 1604man via menu. 1605 1606It is possible to show this help automatically after some idle time. 1607This is regulated by variable `cperl-lazy-help-time'. Default with 1608`cperl-hairy' (if the value of `cperl-lazy-help-time' is nil) is 5 1609secs idle time . It is also possible to switch this on/off from the 1610menu, or via \\[cperl-toggle-autohelp]. 1611 1612Use \\[cperl-lineup] to vertically lineup some construction - put the 1613beginning of the region at the start of construction, and make region 1614span the needed amount of lines. 1615 1616Variables `cperl-pod-here-scan', `cperl-pod-here-fontify', 1617`cperl-pod-face', `cperl-pod-head-face' control processing of POD and 1618here-docs sections. Results of scan are used for indentation too. 1619 1620Variables controlling indentation style: 1621 `cperl-tab-always-indent' 1622 Non-nil means TAB in CPerl mode should always reindent the current line, 1623 regardless of where in the line point is when the TAB command is used. 1624 `cperl-indent-left-aligned-comments' 1625 Non-nil means that the comment starting in leftmost column should indent. 1626 `cperl-auto-newline' 1627 Non-nil means automatically newline before and after braces, 1628 and after colons and semicolons, inserted in Perl code. The following 1629 \\[cperl-electric-backspace] will remove the inserted whitespace. 1630 Insertion after colons requires both this variable and 1631 `cperl-auto-newline-after-colon' set. 1632 `cperl-auto-newline-after-colon' 1633 Non-nil means automatically newline even after colons. 1634 Subject to `cperl-auto-newline' setting. 1635 `cperl-indent-level' 1636 Indentation of Perl statements within surrounding block. 1637 The surrounding block's indentation is the indentation 1638 of the line on which the open-brace appears. 1639 `cperl-continued-statement-offset' 1640 Extra indentation given to a substatement, such as the 1641 then-clause of an if, or body of a while, or just a statement continuation. 1642 `cperl-continued-brace-offset' 1643 Extra indentation given to a brace that starts a substatement. 1644 This is in addition to `cperl-continued-statement-offset'. 1645 `cperl-brace-offset' 1646 Extra indentation for line if it starts with an open brace. 1647 `cperl-brace-imaginary-offset' 1648 An open brace following other text is treated as if it the line started 1649 this far to the right of the actual line indentation. 1650 `cperl-label-offset' 1651 Extra indentation for line that is a label. 1652 `cperl-min-label-indent' 1653 Minimal indentation for line that is a label. 1654 1655Settings for classic indent-styles: K&R BSD=C++ GNU PBP PerlStyle=Whitesmith 1656 `cperl-indent-level' 5 4 2 4 4 1657 `cperl-brace-offset' 0 0 0 0 0 1658 `cperl-continued-brace-offset' -5 -4 0 0 0 1659 `cperl-label-offset' -5 -4 -2 -2 -4 1660 `cperl-continued-statement-offset' 5 4 2 4 4 1661 1662CPerl knows several indentation styles, and may bulk set the 1663corresponding variables. Use \\[cperl-set-style] to do this. Use 1664\\[cperl-set-style-back] to restore the memorized preexisting values 1665\(both available from menu). See examples in `cperl-style-examples'. 1666 1667Part of the indentation style is how different parts of if/elsif/else 1668statements are broken into lines; in CPerl, this is reflected on how 1669templates for these constructs are created (controlled by 1670`cperl-extra-newline-before-brace'), and how reflow-logic should treat 1671\"continuation\" blocks of else/elsif/continue, controlled by the same 1672variable, and by `cperl-extra-newline-before-brace-multiline', 1673`cperl-merge-trailing-else', `cperl-indent-region-fix-constructs'. 1674 1675If `cperl-indent-level' is 0, the statement after opening brace in 1676column 0 is indented on 1677`cperl-brace-offset'+`cperl-continued-statement-offset'. 1678 1679Turning on CPerl mode calls the hooks in the variable `cperl-mode-hook' 1680with no args. 1681 1682DO NOT FORGET to read micro-docs (available from `Perl' menu) 1683or as help on variables `cperl-tips', `cperl-problems', 1684`cperl-praise', `cperl-speed'." 1685 (if (cperl-val 'cperl-electric-linefeed) 1686 (progn 1687 (local-set-key "\C-J" 'cperl-linefeed) 1688 (local-set-key "\C-C\C-J" 'newline-and-indent))) 1689 (if (and 1690 (cperl-val 'cperl-clobber-lisp-bindings) 1691 (cperl-val 'cperl-info-on-command-no-prompt)) 1692 (progn 1693 ;; don't clobber the backspace binding: 1694 (define-key cperl-mode-map "\C-hf" 'cperl-info-on-current-command) 1695 (define-key cperl-mode-map "\C-c\C-hf" 'cperl-info-on-command))) 1696 (setq local-abbrev-table cperl-mode-abbrev-table) 1697 (if (cperl-val 'cperl-electric-keywords) 1698 (abbrev-mode 1)) 1699 (set-syntax-table cperl-mode-syntax-table) 1700 ;; Workaround for Bug#30393, needed for Emacs 26. 1701 (when (< emacs-major-version 27) 1702 (setq-local open-paren-in-column-0-is-defun-start nil)) 1703 ;; Until Emacs is multi-threaded, we do not actually need it local: 1704 (make-local-variable 'cperl-font-lock-multiline-start) 1705 (make-local-variable 'cperl-font-locking) 1706 (setq-local outline-regexp cperl-outline-regexp) 1707 (setq-local outline-level 'cperl-outline-level) 1708 (setq-local add-log-current-defun-function 1709 (lambda () 1710 (save-excursion 1711 (if (re-search-backward "^sub[ \t]+\\([^({ \t\n]+\\)" nil t) 1712 (match-string-no-properties 1))))) 1713 1714 (setq-local paragraph-start (concat "^$\\|" page-delimiter)) 1715 (setq-local paragraph-separate paragraph-start) 1716 (setq-local paragraph-ignore-fill-prefix t) 1717 (setq-local indent-line-function #'cperl-indent-line) 1718 (setq-local require-final-newline mode-require-final-newline) 1719 (setq-local comment-start "# ") 1720 (setq-local comment-end "") 1721 (setq-local comment-column cperl-comment-column) 1722 (setq-local comment-start-skip "#+ *") 1723 1724;; "[ \t]*sub" 1725;; (cperl-after-sub-regexp 'named nil) ; 8=name 11=proto 14=attr-start 1726;; cperl-maybe-white-and-comment-rex ; 15=pre-block 1727 (setq-local defun-prompt-regexp 1728 (concat "^[ \t]*\\(" 1729 cperl-sub-regexp 1730 (cperl-after-sub-regexp 'named 'attr-groups) 1731 "\\|" ; per toke.c 1732 "\\(BEGIN\\|UNITCHECK\\|CHECK\\|INIT\\|END\\|AUTOLOAD\\|DESTROY\\)" 1733 "\\)" 1734 cperl-maybe-white-and-comment-rex)) 1735 (setq-local comment-indent-function #'cperl-comment-indent) 1736 (setq-local fill-paragraph-function #'cperl-fill-paragraph) 1737 (setq-local parse-sexp-ignore-comments t) 1738 (setq-local indent-region-function #'cperl-indent-region) 1739 ;;(setq auto-fill-function #'cperl-do-auto-fill) ; Need to switch on and off! 1740 (setq-local imenu-create-index-function #'cperl-imenu--create-perl-index) 1741 (setq-local imenu-sort-function nil) 1742 (setq-local vc-rcs-header cperl-vc-rcs-header) 1743 (setq-local vc-sccs-header cperl-vc-sccs-header) 1744 (when (boundp 'compilation-error-regexp-alist-alist) 1745 ;; The let here is just a compatibility kludge for the obsolete 1746 ;; variable `cperl-compilation-error-regexp-alist'. It can be removed 1747 ;; when that variable is removed. 1748 (let ((regexp (if (boundp 'cperl-compilation-error-regexp-alist) 1749 (car cperl-compilation-error-regexp-alist) 1750 cperl-compilation-error-regexp-list))) 1751 (setq-local compilation-error-regexp-alist-alist 1752 (cons (cons 'cperl regexp) 1753 compilation-error-regexp-alist-alist))) 1754 (make-local-variable 'compilation-error-regexp-alist) 1755 (push 'cperl compilation-error-regexp-alist)) 1756 (setq-local font-lock-defaults 1757 '((cperl-load-font-lock-keywords 1758 cperl-load-font-lock-keywords-1 1759 cperl-load-font-lock-keywords-2) 1760 nil nil ((?_ . "w")) nil 1761 (font-lock-syntactic-face-function 1762 . cperl-font-lock-syntactic-face-function))) 1763 ;; Reset syntaxification cache. 1764 (setq-local cperl-syntax-state nil) 1765 (when cperl-use-syntax-table-text-property 1766 ;; Reset syntaxification cache. 1767 (setq-local cperl-syntax-done-to nil) 1768 (setq-local syntax-propertize-function 1769 (lambda (start end) 1770 (goto-char start) 1771 ;; Even if cperl-fontify-syntactically has already gone 1772 ;; beyond `start', syntax-propertize has just removed 1773 ;; syntax-table properties between start and end, so we have 1774 ;; to re-apply them. 1775 (setq cperl-syntax-done-to start) 1776 (cperl-fontify-syntactically end)))) 1777 (setq cperl-font-lock-multiline t) ; Not localized... 1778 (setq-local font-lock-multiline t) 1779 (setq-local font-lock-fontify-region-function 1780 #'cperl-font-lock-fontify-region-function) 1781 (make-local-variable 'cperl-old-style) 1782 (setq-local normal-auto-fill-function 1783 #'cperl-do-auto-fill) 1784 (if (cperl-val 'cperl-font-lock) 1785 (progn (or cperl-faces-init (cperl-init-faces)) 1786 (font-lock-mode 1))) 1787 (setq-local facemenu-add-face-function 1788 #'cperl-facemenu-add-face-function) ; XXXX What this guy is for??? 1789 (and (boundp 'msb-menu-cond) 1790 (not cperl-msb-fixed) 1791 (cperl-msb-fix)) 1792 (if cperl-hook-after-change 1793 (add-hook 'after-change-functions #'cperl-after-change-function nil t)) 1794 ;; After hooks since fontification will break this 1795 (when (and cperl-pod-here-scan 1796 (not cperl-syntaxify-by-font-lock)) 1797 (cperl-find-pods-heres)) 1798 ;; Setup Flymake 1799 (add-hook 'flymake-diagnostic-functions #'perl-flymake nil t)) 1800 1801;; Fix for perldb - make default reasonable 1802(defun cperl-db () 1803 (interactive) 1804 (require 'gud) 1805 ;; FIXME: Use `read-string' or `read-shell-command'? 1806 (perldb (read-from-minibuffer "Run perldb (like this): " 1807 (if (consp gud-perldb-history) 1808 (car gud-perldb-history) 1809 (concat "perl -d " 1810 (buffer-file-name))) 1811 nil nil 1812 '(gud-perldb-history . 1)))) 1813 1814(defun cperl-msb-fix () 1815 ;; Adds perl files to msb menu, supposes that msb is already loaded 1816 (setq cperl-msb-fixed t) 1817 (let* ((l (length msb-menu-cond)) 1818 (last (nth (1- l) msb-menu-cond)) 1819 (precdr (nthcdr (- l 2) msb-menu-cond)) ; cdr of this is last 1820 (handle (1- (nth 1 last)))) 1821 (setcdr precdr (list 1822 (list 1823 '(memq major-mode '(cperl-mode perl-mode)) 1824 handle 1825 "Perl Files (%d)") 1826 last)))) 1827 1828;; This is used by indent-for-comment 1829;; to decide how much to indent a comment in CPerl code 1830;; based on its context. Do fallback if comment is found wrong. 1831 1832(defvar cperl-wrong-comment) 1833(defvar cperl-st-cfence '(14)) ; Comment-fence 1834(defvar cperl-st-sfence '(15)) ; String-fence 1835(defvar cperl-st-punct '(1)) 1836(defvar cperl-st-word '(2)) 1837(defvar cperl-st-bra '(4 . ?\>)) 1838(defvar cperl-st-ket '(5 . ?\<)) 1839 1840 1841(defun cperl-comment-indent () ; called at point at supposed comment 1842 (let ((p (point)) (c (current-column)) was phony) 1843 (if (and (not cperl-indent-comment-at-column-0) 1844 (looking-at "^#")) 1845 0 ; Existing comment at bol stays there. 1846 ;; Wrong comment found 1847 (save-excursion 1848 (setq was (cperl-to-comment-or-eol) 1849 phony (eq (get-text-property (point) 'syntax-table) 1850 cperl-st-cfence)) 1851 (if phony 1852 (progn ; Too naive??? 1853 (re-search-forward "#\\|$") ; Hmm, what about embedded #? 1854 (if (eq (preceding-char) ?\#) 1855 (forward-char -1)) 1856 (setq was nil))) 1857 (if (= (point) p) ; Our caller found a correct place 1858 (progn 1859 (skip-chars-backward " \t") 1860 (setq was (current-column)) 1861 (if (eq was 0) 1862 comment-column 1863 (max (1+ was) ; Else indent at comment column 1864 comment-column))) 1865 ;; No, the caller found a random place; we need to edit ourselves 1866 (if was nil 1867 (insert comment-start) 1868 (backward-char (length comment-start))) 1869 (setq cperl-wrong-comment t) 1870 (cperl-make-indent comment-column 1) ; Indent min 1 1871 c))))) 1872 1873;;(defun cperl-comment-indent-fallback () 1874;; "Is called if the standard comment-search procedure fails. 1875;;Point is at start of real comment." 1876;; (let ((c (current-column)) target cnt prevc) 1877;; (if (= c comment-column) nil 1878;; (setq cnt (skip-chars-backward " \t")) 1879;; (setq target (max (1+ (setq prevc 1880;; (current-column))) ; Else indent at comment column 1881;; comment-column)) 1882;; (if (= c comment-column) nil 1883;; (delete-backward-char cnt) 1884;; (while (< prevc target) 1885;; (insert "\t") 1886;; (setq prevc (current-column))) 1887;; (if (> prevc target) (progn (delete-char -1) (setq prevc (current-column)))) 1888;; (while (< prevc target) 1889;; (insert " ") 1890;; (setq prevc (current-column))))))) 1891 1892(defun cperl-indent-for-comment () 1893 "Substitute for `indent-for-comment' in CPerl." 1894 (interactive) 1895 (let (cperl-wrong-comment) 1896 (indent-for-comment) 1897 (if cperl-wrong-comment ; set by `cperl-comment-indent' 1898 (progn (cperl-to-comment-or-eol) 1899 (forward-char (length comment-start)))))) 1900 1901(defun cperl-comment-region (b e arg) 1902 "Comment or uncomment each line in the region in CPerl mode. 1903See `comment-region'." 1904 (interactive "r\np") 1905 (let ((comment-start "#")) 1906 (comment-region b e arg))) 1907 1908(defun cperl-uncomment-region (b e arg) 1909 "Uncomment or comment each line in the region in CPerl mode. 1910See `comment-region'." 1911 (interactive "r\np") 1912 (let ((comment-start "#")) 1913 (comment-region b e (- arg)))) 1914 1915(defvar cperl-brace-recursing nil) 1916 1917(defun cperl-electric-brace (arg &optional only-before) 1918 "Insert character and correct line's indentation. 1919If ONLY-BEFORE and `cperl-auto-newline', will insert newline before the 1920place (even in empty line), but not after. If after \")\" and the inserted 1921char is \"{\", insert extra newline before only if 1922`cperl-extra-newline-before-brace'." 1923 (interactive "P") 1924 (let (insertpos 1925 (other-end (if (and cperl-electric-parens-mark 1926 (region-active-p) 1927 (< (mark) (point))) 1928 (mark) 1929 nil))) 1930 (if (and other-end 1931 (not cperl-brace-recursing) 1932 (cperl-val 'cperl-electric-parens) 1933 (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))) 1934 ;; Need to insert a matching pair 1935 (progn 1936 (save-excursion 1937 (setq insertpos (point-marker)) 1938 (goto-char other-end) 1939 (setq last-command-event ?\{) 1940 (cperl-electric-lbrace arg insertpos)) 1941 (forward-char 1)) 1942 ;; Check whether we close something "usual" with `}' 1943 (if (and (eq last-command-event ?\}) 1944 (not 1945 (condition-case nil 1946 (save-excursion 1947 (up-list (- (prefix-numeric-value arg))) 1948 ;;(cperl-after-block-p (point-min)) 1949 (or (cperl-after-expr-p nil "{;)") 1950 ;; after sub, else, continue 1951 (cperl-after-block-p nil 'pre))) 1952 (error nil)))) 1953 ;; Just insert the guy 1954 (self-insert-command (prefix-numeric-value arg)) 1955 (if (and (not arg) ; No args, end (of empty line or auto) 1956 (eolp) 1957 (or (and (null only-before) 1958 (save-excursion 1959 (skip-chars-backward " \t") 1960 (bolp))) 1961 (and (eq last-command-event ?\{) ; Do not insert newline 1962 ;; if after ")" and `cperl-extra-newline-before-brace' 1963 ;; is nil, do not insert extra newline. 1964 (not cperl-extra-newline-before-brace) 1965 (save-excursion 1966 (skip-chars-backward " \t") 1967 (eq (preceding-char) ?\)))) 1968 (if cperl-auto-newline 1969 (progn (cperl-indent-line) (newline) t) nil))) 1970 (progn 1971 (self-insert-command (prefix-numeric-value arg)) 1972 (cperl-indent-line) 1973 (if cperl-auto-newline 1974 (setq insertpos (1- (point)))) 1975 (if (and cperl-auto-newline (null only-before)) 1976 (progn 1977 (newline) 1978 (cperl-indent-line))) 1979 (save-excursion 1980 (if insertpos (progn (goto-char insertpos) 1981 (search-forward (make-string 1982 1 last-command-event)) 1983 (setq insertpos (1- (point))))) 1984 (delete-char -1)))) 1985 (if insertpos 1986 (save-excursion 1987 (goto-char insertpos) 1988 (self-insert-command (prefix-numeric-value arg))) 1989 (self-insert-command (prefix-numeric-value arg))))))) 1990 1991(defun cperl-electric-lbrace (arg &optional end) 1992 "Insert character, correct line's indentation, correct quoting by space." 1993 (interactive "P") 1994 (let ((cperl-brace-recursing t) 1995 (cperl-auto-newline cperl-auto-newline) 1996 (other-end (or end 1997 (if (and cperl-electric-parens-mark 1998 (region-active-p) 1999 (> (mark) (point))) 2000 (save-excursion 2001 (goto-char (mark)) 2002 (point-marker)) 2003 nil))) 2004 pos) 2005 (and (cperl-val 'cperl-electric-lbrace-space) 2006 (eq (preceding-char) ?$) 2007 (save-excursion 2008 (skip-chars-backward "$") 2009 (looking-at "\\(\\$\\$\\)*\\$\\([^\\$]\\|$\\)")) 2010 (insert ?\s)) 2011 ;; Check whether we are in comment 2012 (if (and 2013 (save-excursion 2014 (beginning-of-line) 2015 (not (looking-at "[ \t]*#"))) 2016 (cperl-after-expr-p nil "{;)")) 2017 nil 2018 (setq cperl-auto-newline nil)) 2019 (cperl-electric-brace arg) 2020 (and (cperl-val 'cperl-electric-parens) 2021 (eq last-command-event ?{) 2022 (memq last-command-event 2023 (append cperl-electric-parens-string nil)) 2024 (or (if other-end (goto-char (marker-position other-end))) 2025 t) 2026 (setq last-command-event ?} pos (point)) 2027 (progn (cperl-electric-brace arg t) 2028 (goto-char pos))))) 2029 2030(defun cperl-electric-paren (arg) 2031 "Insert an opening parenthesis or a matching pair of parentheses. 2032See `cperl-electric-parens'." 2033 (interactive "P") 2034 (let ((other-end (if (and cperl-electric-parens-mark 2035 (region-active-p) 2036 (> (mark) (point))) 2037 (save-excursion 2038 (goto-char (mark)) 2039 (point-marker)) 2040 nil))) 2041 (if (and (cperl-val 'cperl-electric-parens) 2042 (memq last-command-event 2043 (append cperl-electric-parens-string nil)) 2044 (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)) 2045 (if (eq last-command-event ?<) 2046 (progn 2047 ;; This code is too electric, see Bug#3943. 2048 ;; (and abbrev-mode ; later it is too late, may be after `for' 2049 ;; (expand-abbrev)) 2050 (cperl-after-expr-p nil "{;(,:=")) 2051 1)) 2052 (progn 2053 (self-insert-command (prefix-numeric-value arg)) 2054 (if other-end (goto-char (marker-position other-end))) 2055 (insert (make-string 2056 (prefix-numeric-value arg) 2057 (cdr (assoc last-command-event '((?{ .?}) 2058 (?\[ . ?\]) 2059 (?\( . ?\)) 2060 (?< . ?>)))))) 2061 (forward-char (- (prefix-numeric-value arg)))) 2062 (self-insert-command (prefix-numeric-value arg))))) 2063 2064(defun cperl-electric-rparen (arg) 2065 "Insert a matching pair of parentheses if marking is active. 2066If not, or if we are not at the end of marking range, would self-insert. 2067Affected by `cperl-electric-parens'." 2068 (interactive "P") 2069 (let ((other-end (if (and cperl-electric-parens-mark 2070 (cperl-val 'cperl-electric-parens) 2071 (memq last-command-event 2072 (append cperl-electric-parens-string nil)) 2073 (region-active-p) 2074 (< (mark) (point))) 2075 (mark) 2076 nil)) 2077 p) 2078 (if (and other-end 2079 (cperl-val 'cperl-electric-parens) 2080 (memq last-command-event '( ?\) ?\] ?\} ?\> )) 2081 (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)) 2082 ) 2083 (progn 2084 (self-insert-command (prefix-numeric-value arg)) 2085 (setq p (point)) 2086 (if other-end (goto-char other-end)) 2087 (insert (make-string 2088 (prefix-numeric-value arg) 2089 (cdr (assoc last-command-event '((?\} . ?\{) 2090 (?\] . ?\[) 2091 (?\) . ?\() 2092 (?\> . ?\<)))))) 2093 (goto-char (1+ p))) 2094 (self-insert-command (prefix-numeric-value arg))))) 2095 2096(defun cperl-electric-keyword () 2097 "Insert a construction appropriate after a keyword. 2098Help message may be switched off by setting `cperl-message-electric-keyword' 2099to nil." 2100 (let ((beg (point-at-bol)) 2101 (dollar (and (eq last-command-event ?$) 2102 (eq this-command 'self-insert-command))) 2103 (delete (and (memq last-command-event '(?\s ?\n ?\t ?\f)) 2104 (memq this-command '(self-insert-command newline)))) 2105 my do) 2106 (and (save-excursion 2107 (condition-case nil 2108 (progn 2109 (backward-sexp 1) 2110 (setq do (looking-at "do\\>"))) 2111 (error nil)) 2112 (cperl-after-expr-p nil "{;:")) 2113 (save-excursion 2114 (not 2115 (re-search-backward 2116 "[#\"'`]\\|\\<q\\(\\|[wqxr]\\)\\>" 2117 beg t))) 2118 (save-excursion (or (not (re-search-backward "^=" nil t)) 2119 (or 2120 (looking-at "=cut") 2121 (looking-at "=end") 2122 (and cperl-use-syntax-table-text-property 2123 (not (eq (get-text-property (point) 2124 'syntax-type) 2125 'pod)))))) 2126 (save-excursion (forward-sexp -1) 2127 (not (memq (following-char) (append "$@%&*" nil)))) 2128 (progn 2129 (and (eq (preceding-char) ?y) 2130 (progn ; "foreachmy" 2131 (forward-char -2) 2132 (insert " ") 2133 (forward-char 2) 2134 (setq my t dollar t 2135 delete 2136 (memq this-command '(self-insert-command newline))))) 2137 (and dollar (insert " $")) 2138 (cperl-indent-line) 2139 ;;(insert " () {\n}") 2140 (cond 2141 (cperl-extra-newline-before-brace 2142 (insert (if do "\n" " ()\n")) 2143 (insert "{") 2144 (cperl-indent-line) 2145 (insert "\n") 2146 (cperl-indent-line) 2147 (insert "\n}") 2148 (and do (insert " while ();"))) 2149 (t 2150 (insert (if do " {\n} while ();" " () {\n}")))) 2151 (or (looking-at "[ \t]\\|$") (insert " ")) 2152 (cperl-indent-line) 2153 (if dollar (progn (search-backward "$") 2154 (if my 2155 (forward-char 1) 2156 (delete-char 1))) 2157 (search-backward ")") 2158 (if (eq last-command-event ?\() 2159 (progn ; Avoid "if (())" 2160 (delete-char -1) 2161 (delete-char 1)))) 2162 (if delete 2163 (cperl-putback-char cperl-del-back-ch)) 2164 (if cperl-message-electric-keyword 2165 (message "Precede char by C-q to avoid expansion")))))) 2166 2167(defun cperl-ensure-newlines (n &optional pos) 2168 "Make sure there are N newlines after the point." 2169 (or pos (setq pos (point))) 2170 (if (looking-at "\n") 2171 (forward-char 1) 2172 (insert "\n")) 2173 (if (> n 1) 2174 (cperl-ensure-newlines (1- n) pos) 2175 (goto-char pos))) 2176 2177(defun cperl-electric-pod () 2178 "Insert a POD chunk appropriate after a =POD directive." 2179 (let ((delete (and (memq last-command-event '(?\s ?\n ?\t ?\f)) 2180 (memq this-command '(self-insert-command newline)))) 2181 head1 notlast name p really-delete over) 2182 (and (save-excursion 2183 (forward-word-strictly -1) 2184 (and 2185 (eq (preceding-char) ?=) 2186 (progn 2187 (setq head1 (looking-at "head1\\>[ \t]*$")) 2188 (setq over (and (looking-at "over\\>[ \t]*$") 2189 (not (looking-at "over[ \t]*\n\n\n*=item\\>")))) 2190 (forward-char -1) 2191 (bolp)) 2192 (or 2193 (get-text-property (point) 'in-pod) 2194 (cperl-after-expr-p nil "{;:") 2195 (and (re-search-backward "\\(\\`\n?\\|^\n\\)=\\sw+" (point-min) t) 2196 (not (or (looking-at "\n*=cut") (looking-at "\n*=end"))) 2197 (or (not cperl-use-syntax-table-text-property) 2198 (eq (get-text-property (point) 'syntax-type) 'pod)))))) 2199 (progn 2200 (save-excursion 2201 (setq notlast (re-search-forward "^\n=" nil t))) 2202 (or notlast 2203 (progn 2204 (insert "\n\n=cut") 2205 (cperl-ensure-newlines 2) 2206 (forward-word-strictly -2) 2207 (if (and head1 2208 (not 2209 (save-excursion 2210 (forward-char -1) 2211 (re-search-backward "\\(\\`\n?\\|\n\n\\)=head1\\>" 2212 nil t)))) ; Only one 2213 (progn 2214 (forward-word-strictly 1) 2215 (setq name (file-name-base (buffer-file-name)) 2216 p (point)) 2217 (insert " NAME\n\n" name 2218 " - \n\n=head1 SYNOPSIS\n\n\n\n" 2219 "=head1 DESCRIPTION") 2220 (cperl-ensure-newlines 4) 2221 (goto-char p) 2222 (forward-word-strictly 2) 2223 (end-of-line) 2224 (setq really-delete t)) 2225 (forward-word-strictly 1)))) 2226 (if over 2227 (progn 2228 (setq p (point)) 2229 (insert "\n\n=item \n\n\n\n" 2230 "=back") 2231 (cperl-ensure-newlines 2) 2232 (goto-char p) 2233 (forward-word-strictly 1) 2234 (end-of-line) 2235 (setq really-delete t))) 2236 (if (and delete really-delete) 2237 (cperl-putback-char cperl-del-back-ch)))))) 2238 2239(defun cperl-electric-else () 2240 "Insert a construction appropriate after a keyword. 2241Help message may be switched off by setting `cperl-message-electric-keyword' 2242to nil." 2243 (let ((beg (point-at-bol))) 2244 (and (save-excursion 2245 (skip-chars-backward "[:alpha:]") 2246 (cperl-after-expr-p nil "{;:")) 2247 (save-excursion 2248 (not 2249 (re-search-backward 2250 "[#\"'`]\\|\\<q\\(\\|[wqxr]\\)\\>" 2251 beg t))) 2252 (save-excursion (or (not (re-search-backward "^=" nil t)) 2253 (looking-at "=cut") 2254 (looking-at "=end") 2255 (and cperl-use-syntax-table-text-property 2256 (not (eq (get-text-property (point) 2257 'syntax-type) 2258 'pod))))) 2259 (progn 2260 (cperl-indent-line) 2261 ;;(insert " {\n\n}") 2262 (cond 2263 (cperl-extra-newline-before-brace 2264 (insert "\n") 2265 (insert "{") 2266 (cperl-indent-line) 2267 (insert "\n\n}")) 2268 (t 2269 (insert " {\n\n}"))) 2270 (or (looking-at "[ \t]\\|$") (insert " ")) 2271 (cperl-indent-line) 2272 (forward-line -1) 2273 (cperl-indent-line) 2274 (cperl-putback-char cperl-del-back-ch) 2275 (setq this-command 'cperl-electric-else) 2276 (if cperl-message-electric-keyword 2277 (message "Precede char by C-q to avoid expansion")))))) 2278 2279(defun cperl-linefeed () 2280 "Go to end of line, open a new line and indent appropriately. 2281If in POD, insert appropriate lines." 2282 (interactive) 2283 (let ((beg (point-at-bol)) 2284 (end (point-at-eol)) 2285 (pos (point)) start over cut res) 2286 (if (and ; Check if we need to split: 2287 ; i.e., on a boundary and inside "{...}" 2288 (save-excursion (cperl-to-comment-or-eol) 2289 (>= (point) pos)) ; Not in a comment 2290 (or (save-excursion 2291 (skip-chars-backward " \t" beg) 2292 (forward-char -1) 2293 (looking-at "[;{]")) ; After { or ; + spaces 2294 (looking-at "[ \t]*}") ; Before } 2295 (re-search-forward "\\=[ \t]*;" end t)) ; Before spaces + ; 2296 (save-excursion 2297 (and 2298 (eq (car (parse-partial-sexp pos end -1)) -1) 2299 ; Leave the level of parens 2300 (looking-at "[,; \t]*\\($\\|#\\)") ; Comma to allow anon subr 2301 ; Are at end 2302 (cperl-after-block-p (point-min)) 2303 (progn 2304 (backward-sexp 1) 2305 (setq start (point-marker)) 2306 (<= start pos))))) ; Redundant? Are after the 2307 ; start of parens group. 2308 (progn 2309 (skip-chars-backward " \t") 2310 (or (memq (preceding-char) (append ";{" nil)) 2311 (insert ";")) 2312 (insert "\n") 2313 (forward-line -1) 2314 (cperl-indent-line) 2315 (goto-char start) 2316 (or (looking-at "{[ \t]*$") ; If there is a statement 2317 ; before, move it to separate line 2318 (progn 2319 (forward-char 1) 2320 (insert "\n") 2321 (cperl-indent-line))) 2322 (forward-line 1) ; We are on the target line 2323 (cperl-indent-line) 2324 (beginning-of-line) 2325 (or (looking-at "[ \t]*}[,; \t]*$") ; If there is a statement 2326 ; after, move it to separate line 2327 (progn 2328 (end-of-line) 2329 (search-backward "}" beg) 2330 (skip-chars-backward " \t") 2331 (or (memq (preceding-char) (append ";{" nil)) 2332 (insert ";")) 2333 (insert "\n") 2334 (cperl-indent-line) 2335 (forward-line -1))) 2336 (forward-line -1) ; We are on the line before target 2337 (end-of-line) 2338 (newline-and-indent)) 2339 (end-of-line) ; else - no splitting 2340 (cond 2341 ((and (looking-at "\n[ \t]*{$") 2342 (save-excursion 2343 (skip-chars-backward " \t") 2344 (eq (preceding-char) ?\)))) ; Probably if () {} group 2345 ; with an extra newline. 2346 (forward-line 2) 2347 (cperl-indent-line)) 2348 ((save-excursion ; In POD header 2349 (forward-paragraph -1) 2350 ;; (re-search-backward "\\(\\`\n?\\|\n\n\\)=head1\\b") 2351 ;; We are after \n now, so look for the rest 2352 (if (looking-at "\\(\\`\n?\\|\n\\)=\\sw+") 2353 (progn 2354 (setq cut (looking-at "\\(\\`\n?\\|\n\\)=\\(cut\\|end\\)\\>")) 2355 (setq over (looking-at "\\(\\`\n?\\|\n\\)=over\\>")) 2356 t))) 2357 (if (and over 2358 (progn 2359 (forward-paragraph -1) 2360 (forward-word-strictly 1) 2361 (setq pos (point)) 2362 (setq cut (buffer-substring (point) (point-at-eol))) 2363 (delete-char (- (point-at-eol) (point))) 2364 (setq res (expand-abbrev)) 2365 (save-excursion 2366 (goto-char pos) 2367 (insert cut)) 2368 res)) 2369 nil 2370 (cperl-ensure-newlines (if cut 2 4)) 2371 (forward-line 2))) 2372 ((get-text-property (point) 'in-pod) ; In POD section 2373 (cperl-ensure-newlines 4) 2374 (forward-line 2)) 2375 ((looking-at "\n[ \t]*$") ; Next line is empty - use it. 2376 (forward-line 1) 2377 (cperl-indent-line)) 2378 (t 2379 (newline-and-indent)))))) 2380 2381(defun cperl-electric-semi (arg) 2382 "Insert character and correct line's indentation." 2383 (interactive "P") 2384 (if cperl-auto-newline 2385 (cperl-electric-terminator arg) 2386 (self-insert-command (prefix-numeric-value arg)) 2387 (if cperl-autoindent-on-semi 2388 (cperl-indent-line)))) 2389 2390(defun cperl-electric-terminator (arg) 2391 "Insert character and correct line's indentation." 2392 (interactive "P") 2393 (let ((end (point)) 2394 (auto (and cperl-auto-newline 2395 (or (not (eq last-command-event ?:)) 2396 cperl-auto-newline-after-colon))) 2397 insertpos) 2398 (if (and ;;(not arg) 2399 (eolp) 2400 (not (save-excursion 2401 (beginning-of-line) 2402 (skip-chars-forward " \t") 2403 (or 2404 ;; Ignore in comment lines 2405 (= (following-char) ?#) 2406 ;; Colon is special only after a label 2407 ;; So quickly rule out most other uses of colon 2408 ;; and do no indentation for them. 2409 (and (eq last-command-event ?:) 2410 (save-excursion 2411 (forward-word-strictly 1) 2412 (skip-chars-forward " \t") 2413 (and (< (point) end) 2414 (progn (goto-char (- end 1)) 2415 (not (looking-at ":")))))) 2416 (progn 2417 (beginning-of-defun) 2418 (let ((pps (parse-partial-sexp (point) end))) 2419 (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))))) 2420 (progn 2421 (self-insert-command (prefix-numeric-value arg)) 2422 ;;(forward-char -1) 2423 (if auto (setq insertpos (point-marker))) 2424 ;;(forward-char 1) 2425 (cperl-indent-line) 2426 (if auto 2427 (progn 2428 (newline) 2429 (cperl-indent-line))) 2430 (save-excursion 2431 (if insertpos (goto-char (1- (marker-position insertpos))) 2432 (forward-char -1)) 2433 (delete-char 1)))) 2434 (if insertpos 2435 (save-excursion 2436 (goto-char insertpos) 2437 (self-insert-command (prefix-numeric-value arg))) 2438 (self-insert-command (prefix-numeric-value arg))))) 2439 2440(defun cperl-electric-backspace (arg) 2441 "Backspace, or remove whitespace around the point inserted by an electric key. 2442Will untabify if `cperl-electric-backspace-untabify' is non-nil." 2443 (interactive "p") 2444 (if (and cperl-auto-newline 2445 (memq last-command '(cperl-electric-semi 2446 cperl-electric-terminator 2447 cperl-electric-lbrace)) 2448 (memq (preceding-char) '(?\s ?\t ?\n))) 2449 (let (p) 2450 (if (eq last-command 'cperl-electric-lbrace) 2451 (skip-chars-forward " \t\n")) 2452 (setq p (point)) 2453 (skip-chars-backward " \t\n") 2454 (delete-region (point) p)) 2455 (and (eq last-command 'cperl-electric-else) 2456 ;; We are removing the whitespace *inside* cperl-electric-else 2457 (setq this-command 'cperl-electric-else-really)) 2458 (if (and cperl-auto-newline 2459 (eq last-command 'cperl-electric-else-really) 2460 (memq (preceding-char) '(?\s ?\t ?\n))) 2461 (let (p) 2462 (skip-chars-forward " \t\n") 2463 (setq p (point)) 2464 (skip-chars-backward " \t\n") 2465 (delete-region (point) p)) 2466 (if cperl-electric-backspace-untabify 2467 (backward-delete-char-untabify arg) 2468 (call-interactively 'delete-backward-char))))) 2469 2470(put 'cperl-electric-backspace 'delete-selection 'supersede) 2471 2472(defun cperl-inside-parens-p () 2473 (declare (obsolete nil "28.1")) ; not used 2474 (condition-case () 2475 (save-excursion 2476 (save-restriction 2477 (narrow-to-region (point) 2478 (progn (beginning-of-defun) (point))) 2479 (goto-char (point-max)) 2480 (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\())) 2481 (error nil))) 2482 2483(defun cperl-indent-command (&optional whole-exp) 2484 "Indent current line as Perl code, or in some cases insert a tab character. 2485If `cperl-tab-always-indent' is non-nil (the default), always indent current 2486line. Otherwise, indent the current line only if point is at the left margin 2487or in the line's indentation; otherwise insert a tab. 2488 2489A numeric argument, regardless of its value, 2490means indent rigidly all the lines of the expression starting after point 2491so that this line becomes properly indented. 2492The relative indentation among the lines of the expression are preserved." 2493 (interactive "P") 2494 (cperl-update-syntaxification (point)) 2495 (if whole-exp 2496 ;; If arg, always indent this line as Perl 2497 ;; and shift remaining lines of expression the same amount. 2498 (let ((shift-amt (cperl-indent-line)) 2499 beg end) 2500 (save-excursion 2501 (if cperl-tab-always-indent 2502 (beginning-of-line)) 2503 (setq beg (point)) 2504 (forward-sexp 1) 2505 (setq end (point)) 2506 (goto-char beg) 2507 (forward-line 1) 2508 (setq beg (point))) 2509 (if (and shift-amt (> end beg)) 2510 (indent-code-rigidly beg end shift-amt "#"))) 2511 (if (and (not cperl-tab-always-indent) 2512 (save-excursion 2513 (skip-chars-backward " \t") 2514 (not (bolp)))) 2515 (insert-tab) 2516 (cperl-indent-line)))) 2517 2518(defun cperl-indent-line (&optional parse-data) 2519 "Indent current line as Perl code. 2520Return the amount the indentation changed by." 2521 (let ((case-fold-search nil) 2522 (pos (- (point-max) (point))) 2523 indent i shift-amt) 2524 (setq indent (cperl-calculate-indent parse-data) 2525 i indent) 2526 (beginning-of-line) 2527 (cond ((or (eq indent nil) (eq indent t)) 2528 (setq indent (current-indentation) i nil)) 2529 ;;((eq indent t) ; Never? 2530 ;; (setq indent (cperl-calculate-indent-within-comment))) 2531 ;;((looking-at "[ \t]*#") 2532 ;; (setq indent 0)) 2533 (t 2534 (skip-chars-forward " \t") 2535 (if (listp indent) (setq indent (car indent))) 2536 (cond ((and (looking-at (rx (sequence (eval cperl--label-rx) 2537 (not (in ":"))))) 2538 (not (looking-at (rx (eval cperl--false-label-rx))))) 2539 (and (> indent 0) 2540 (setq indent (max cperl-min-label-indent 2541 (+ indent cperl-label-offset))))) 2542 ((= (following-char) ?}) 2543 (setq indent (- indent cperl-indent-level))) 2544 ((memq (following-char) '(?\) ?\])) ; To line up with opening paren. 2545 (setq indent (+ indent cperl-close-paren-offset))) 2546 ((= (following-char) ?{) 2547 (setq indent (+ indent cperl-brace-offset)))))) 2548 (skip-chars-forward " \t") 2549 (setq shift-amt (and i (- indent (current-column)))) 2550 (if (or (not shift-amt) 2551 (zerop shift-amt)) 2552 (if (> (- (point-max) pos) (point)) 2553 (goto-char (- (point-max) pos))) 2554 ;;(delete-region beg (point)) 2555 ;;(indent-to indent) 2556 (cperl-make-indent indent) 2557 ;; If initial point was within line's indentation, 2558 ;; position after the indentation. Else stay at same point in text. 2559 (if (> (- (point-max) pos) (point)) 2560 (goto-char (- (point-max) pos)))) 2561 shift-amt)) 2562 2563(defun cperl-after-label () 2564 ;; Returns true if the point is after label. Does not do save-excursion. 2565 (and (eq (preceding-char) ?:) 2566 (memq (char-syntax (char-after (- (point) 2))) 2567 '(?w ?_)) 2568 (progn 2569 (backward-sexp) 2570 (looking-at (rx (sequence (eval cperl--label-rx) 2571 (not (in ":")))))))) 2572 2573(defun cperl-get-state (&optional parse-start start-state) 2574 "Return list (START STATE DEPTH PRESTART). 2575START is a good place to start parsing, or equal to 2576PARSE-START if preset. 2577STATE is what is returned by `parse-partial-sexp'. 2578DEPTH is true is we are immediately after end of block 2579which contains START. 2580PRESTART is the position basing on which START was found." 2581 (save-excursion 2582 (let ((start-point (point)) depth state start prestart) 2583 (if (and parse-start 2584 (<= parse-start start-point)) 2585 (goto-char parse-start) 2586 (beginning-of-defun) 2587 (setq start-state nil)) 2588 (setq prestart (point)) 2589 (if start-state nil 2590 ;; Try to go out, if sub is not on the outermost level 2591 (while (< (point) start-point) 2592 (setq start (point) parse-start start depth nil 2593 state (parse-partial-sexp start start-point -1)) 2594 (if (> (car state) -1) nil 2595 ;; The current line could start like }}}, so the indentation 2596 ;; corresponds to a different level than what we reached 2597 (setq depth t) 2598 (beginning-of-line 2))) ; Go to the next line. 2599 (if start (goto-char start))) ; Not at the start of file 2600 (setq start (point)) 2601 (or state (setq state (parse-partial-sexp start start-point -1 nil start-state))) 2602 (list start state depth prestart)))) 2603 2604(defvar cperl-look-for-prop '((pod in-pod) (here-doc-delim here-doc-group))) 2605 2606(defun cperl-beginning-of-property (p prop &optional lim) 2607 "Given that P has a property PROP, find where the property starts. 2608Will not look before LIM." 2609;;; XXXX What to do at point-max??? 2610 (or (previous-single-property-change (cperl-1+ p) prop lim) 2611 (point-min)) 2612 ;; (cond ((eq p (point-min)) 2613 ;; p) 2614 ;; ((and lim (<= p lim)) 2615 ;; p) 2616 ;; ((not (get-text-property (1- p) prop)) 2617 ;; p) 2618 ;; (t (or (previous-single-property-change p look-prop lim) 2619 ;; (point-min)))) 2620 ) 2621 2622(defun cperl-sniff-for-indent (&optional parse-data) ; was parse-start 2623 ;; the sniffer logic to understand what the current line MEANS. 2624 (cperl-update-syntaxification (point)) 2625 (let ((res (get-text-property (point) 'syntax-type))) 2626 (save-excursion 2627 (cond 2628 ((and (memq res '(pod here-doc here-doc-delim format)) 2629 (not (get-text-property (point) 'indentable))) 2630 (vector res)) 2631 ;; before start of POD - whitespace found since do not have 'pod! 2632 ((looking-at "[ \t]*\n=") 2633 (error "Spaces before POD section!")) 2634 ((and (not cperl-indent-left-aligned-comments) 2635 (looking-at "^#")) 2636 [comment-special:at-beginning-of-line]) 2637 ((get-text-property (point) 'in-pod) 2638 [in-pod]) 2639 (t 2640 (beginning-of-line) 2641 (let* ((indent-point (point)) 2642 (char-after-pos (save-excursion 2643 (skip-chars-forward " \t") 2644 (point))) 2645 (char-after (char-after char-after-pos)) 2646 (pre-indent-point (point)) 2647 p prop look-prop is-block delim) 2648 (save-excursion ; Know we are not in POD, find appropriate pos before 2649 (cperl-backward-to-noncomment nil) 2650 (setq p (max (point-min) (1- (point))) 2651 prop (get-text-property p 'syntax-type) 2652 look-prop (or (nth 1 (assoc prop cperl-look-for-prop)) 2653 'syntax-type)) 2654 (if (memq prop '(pod here-doc format here-doc-delim)) 2655 (progn 2656 (goto-char (cperl-beginning-of-property p look-prop)) 2657 (beginning-of-line) 2658 (setq pre-indent-point (point))))) 2659 (goto-char pre-indent-point) ; Orig line skipping preceding pod/etc 2660 (let* ((case-fold-search nil) 2661 (s-s (cperl-get-state (car parse-data) (nth 1 parse-data))) 2662 (start (or (nth 2 parse-data) ; last complete sexp terminated 2663 (nth 0 s-s))) ; Good place to start parsing 2664 (state (nth 1 s-s)) 2665 (containing-sexp (car (cdr state))) 2666 old-indent) 2667 (if (and 2668 ;;containing-sexp ;; We are buggy at toplevel :-( 2669 parse-data) 2670 (progn 2671 (setcar parse-data pre-indent-point) 2672 (setcar (cdr parse-data) state) 2673 (or (nth 2 parse-data) 2674 (setcar (cddr parse-data) start)) 2675 ;; Before this point: end of statement 2676 (setq old-indent (nth 3 parse-data)))) 2677 (cond ((get-text-property (point) 'indentable) 2678 ;; indent to "after" the surrounding open 2679 ;; (same offset as `cperl-beautify-regexp-piece'), 2680 ;; skip blanks if we do not close the expression. 2681 (setq delim ; We do not close the expression 2682 (get-text-property 2683 (cperl-1+ char-after-pos) 'indentable) 2684 p (1+ (cperl-beginning-of-property 2685 (point) 'indentable)) 2686 is-block ; misused for: preceding line in REx 2687 (save-excursion ; Find preceding line 2688 (cperl-backward-to-noncomment p) 2689 (beginning-of-line) 2690 (if (<= (point) p) 2691 (progn ; get indent from the first line 2692 (goto-char p) 2693 (skip-chars-forward " \t") 2694 (if (memq (char-after (point)) 2695 (append "#\n" nil)) 2696 nil ; Can't use indentation of this line... 2697 (point))) 2698 (skip-chars-forward " \t") 2699 (point))) 2700 prop (parse-partial-sexp p char-after-pos)) 2701 (cond ((not delim) ; End the REx, ignore is-block 2702 (vector 'indentable 'terminator p is-block)) 2703 (is-block ; Indent w.r.t. preceding line 2704 (vector 'indentable 'cont-line char-after-pos 2705 is-block char-after p)) 2706 (t ; No preceding line... 2707 (vector 'indentable 'first-line p)))) 2708 ((get-text-property char-after-pos 'REx-part2) 2709 (vector 'REx-part2 (point))) 2710 ((nth 4 state) 2711 [comment]) 2712 ((nth 3 state) 2713 [string]) 2714 ;; XXXX Do we need to special-case this? 2715 ((null containing-sexp) 2716 ;; Line is at top level. May be data or function definition, 2717 ;; or may be function argument declaration. 2718 ;; Indent like the previous top level line 2719 ;; unless that ends in a closeparen without semicolon, 2720 ;; in which case this line is the first argument decl. 2721 (skip-chars-forward " \t") 2722 (cperl-backward-to-noncomment (or old-indent (point-min))) 2723 (setq state 2724 (or (bobp) 2725 (eq (point) old-indent) ; old-indent was at comment 2726 (eq (preceding-char) ?\;) 2727 ;; Had ?\) too 2728 (and (eq (preceding-char) ?\}) 2729 (cperl-after-block-and-statement-beg 2730 (point-min))) ; Was start - too close 2731 (and char-after (char-equal char-after ?{) 2732 (save-excursion (cperl-block-declaration-p))) 2733 (memq char-after (append ")]}" nil)) 2734 (and (eq (preceding-char) ?\:) ; label 2735 (progn 2736 (forward-sexp -1) 2737 (skip-chars-backward " \t") 2738 (looking-at 2739 (rx (sequence (0+ blank) 2740 (eval cperl--label-rx)))))) 2741 (get-text-property (point) 'first-format-line))) 2742 2743 ;; Look at previous line that's at column 0 2744 ;; to determine whether we are in top-level decls 2745 ;; or function's arg decls. Set basic-indent accordingly. 2746 ;; Now add a little if this is a continuation line. 2747 (and state 2748 parse-data 2749 (not (eq char-after ?\C-j)) 2750 (setcdr (cddr parse-data) 2751 (list pre-indent-point))) 2752 (vector 'toplevel start char-after state (nth 2 s-s))) 2753 ((not 2754 (or (setq is-block 2755 (and (setq delim (= (char-after containing-sexp) ?{)) 2756 (save-excursion ; Is it a hash? 2757 (goto-char containing-sexp) 2758 (cperl-block-p)))) 2759 cperl-indent-parens-as-block)) 2760 ;; group is an expression, not a block: 2761 ;; indent to just after the surrounding open parens, 2762 ;; skip blanks if we do not close the expression. 2763 (goto-char (1+ containing-sexp)) 2764 (or (memq char-after 2765 (append (if delim "}" ")]}") nil)) 2766 (looking-at "[ \t]*\\(#\\|$\\)") 2767 (skip-chars-forward " \t")) 2768 (setq old-indent (point)) ; delim=is-brace 2769 (vector 'in-parens char-after (point) delim containing-sexp)) 2770 (t 2771 ;; Statement level. Is it a continuation or a new statement? 2772 ;; Find previous non-comment character. 2773 (goto-char pre-indent-point) ; Skip one level of POD/etc 2774 (cperl-backward-to-noncomment containing-sexp) 2775 ;; Back up over label lines, since they don't 2776 ;; affect whether our line is a continuation. 2777 ;; (Had \, too) 2778 (while (and (eq (preceding-char) ?:) 2779 (re-search-backward 2780 (rx (sequence (eval cperl--label-rx) point)) 2781 nil t)) 2782 ;; This is always FALSE? 2783 (if (eq (preceding-char) ?\,) 2784 ;; Will go to beginning of line, essentially. 2785 ;; Will ignore embedded sexpr XXXX. 2786 (cperl-backward-to-start-of-continued-exp containing-sexp)) 2787 (beginning-of-line) 2788 (cperl-backward-to-noncomment containing-sexp)) 2789 ;; Now we get non-label preceding the indent point 2790 (if (not (or (eq (1- (point)) containing-sexp) 2791 (and cperl-indent-parens-as-block 2792 (not is-block)) 2793 (save-excursion (cperl-block-declaration-p)) 2794 (memq (preceding-char) 2795 (append (if is-block " ;{" " ,;{") '(nil))) 2796 (and (eq (preceding-char) ?\}) 2797 (cperl-after-block-and-statement-beg 2798 containing-sexp)) 2799 (get-text-property (point) 'first-format-line))) 2800 ;; This line is continuation of preceding line's statement; 2801 ;; indent `cperl-continued-statement-offset' more than the 2802 ;; previous line of the statement. 2803 ;; 2804 ;; There might be a label on this line, just 2805 ;; consider it bad style and ignore it. 2806 (progn 2807 (cperl-backward-to-start-of-continued-exp containing-sexp) 2808 (vector 'continuation (point) char-after is-block delim)) 2809 ;; This line starts a new statement. 2810 ;; Position following last unclosed open brace 2811 (goto-char containing-sexp) 2812 ;; Is line first statement after an open-brace? 2813 (or 2814 ;; If no, find that first statement and indent like 2815 ;; it. If the first statement begins with label, do 2816 ;; not believe when the indentation of the label is too 2817 ;; small. 2818 (save-excursion 2819 (forward-char 1) 2820 (let ((colon-line-end 0)) 2821 (while 2822 (progn 2823 (skip-chars-forward " \t\n") 2824 ;; s: foo : bar :x is NOT label 2825 (and (looking-at 2826 (rx 2827 (or "#" 2828 (sequence (eval cperl--label-rx) 2829 (not (in ":"))) 2830 (sequence "=" (in "a-zA-Z"))))) 2831 (not (looking-at 2832 (rx (eval cperl--false-label-rx)))))) 2833 ;; Skip over comments and labels following openbrace. 2834 (cond ((= (following-char) ?\#) 2835 (forward-line 1)) 2836 ((= (following-char) ?\=) 2837 (goto-char 2838 (or (next-single-property-change (point) 'in-pod) 2839 (point-max)))) ; do not loop if no syntaxification 2840 ;; label: 2841 (t 2842 (setq colon-line-end (point-at-eol)) 2843 (search-forward ":")))) 2844 ;; We are at beginning of code (NOT label or comment) 2845 ;; First, the following code counts 2846 ;; if it is before the line we want to indent. 2847 (and (< (point) indent-point) 2848 (vector 'have-prev-sibling (point) colon-line-end 2849 containing-sexp)))) 2850 (progn 2851 ;; If no previous statement, 2852 ;; indent it relative to line brace is on. 2853 2854 ;; For open-braces not the first thing in a line, 2855 ;; add in cperl-brace-imaginary-offset. 2856 2857 ;; If first thing on a line: ????? 2858 ;; Move back over whitespace before the openbrace. 2859 (setq ; brace first thing on a line 2860 old-indent (progn (skip-chars-backward " \t") (bolp))) 2861 ;; Should we indent w.r.t. earlier than start? 2862 ;; Move to start of control group, possibly on a different line 2863 (or cperl-indent-wrt-brace 2864 (cperl-backward-to-noncomment (point-min))) 2865 ;; If the openbrace is preceded by a parenthesized exp, 2866 ;; move to the beginning of that; 2867 (if (eq (preceding-char) ?\)) 2868 (progn 2869 (forward-sexp -1) 2870 (cperl-backward-to-noncomment (point-min)))) 2871 ;; In the case it starts a subroutine, indent with 2872 ;; respect to `sub', not with respect to the 2873 ;; first thing on the line, say in the case of 2874 ;; anonymous sub in a hash. 2875 (if (and;; Is it a sub in group starting on this line? 2876 cperl-indent-subs-specially 2877 (cond ((get-text-property (point) 'attrib-group) 2878 (goto-char (cperl-beginning-of-property 2879 (point) 'attrib-group))) 2880 ((eq (preceding-char) ?b) 2881 (forward-sexp -1) 2882 (looking-at (concat cperl-sub-regexp "\\>")))) 2883 (setq p (nth 1 ; start of innermost containing list 2884 (parse-partial-sexp 2885 (point-at-bol) 2886 (point))))) 2887 (progn 2888 (goto-char (1+ p)) ; enclosing block on the same line 2889 (skip-chars-forward " \t") 2890 (vector 'code-start-in-block containing-sexp char-after 2891 (and delim (not is-block)) ; is a HASH 2892 old-indent ; brace first thing on a line 2893 t (point) ; have something before... 2894 ) 2895 ;;(current-column) 2896 ) 2897 ;; Get initial indentation of the line we are on. 2898 ;; If line starts with label, calculate label indentation 2899 (vector 'code-start-in-block containing-sexp char-after 2900 (and delim (not is-block)) ; is a HASH 2901 old-indent ; brace first thing on a line 2902 nil (point))))))))))))))) ; nothing interesting before 2903 2904(defvar cperl-indent-rules-alist 2905 '((pod nil) ; via `syntax-type' property 2906 (here-doc nil) ; via `syntax-type' property 2907 (here-doc-delim nil) ; via `syntax-type' property 2908 (format nil) ; via `syntax-type' property 2909 (in-pod nil) ; via `in-pod' property 2910 (comment-special:at-beginning-of-line nil) 2911 (string t) 2912 (comment nil)) 2913 "Alist of indentation rules for CPerl mode. 2914The values mean: 2915 nil: do not indent; 2916 FUNCTION: a function to compute the indentation to use. 2917 Takes a single argument which provides the currently computed indentation 2918 context, and should return the column to which to indent. 2919 NUMBER: add this amount of indentation.") 2920 2921(defun cperl-calculate-indent (&optional parse-data) ; was parse-start 2922 "Return appropriate indentation for current line as Perl code. 2923In usual case returns an integer: the column to indent to. 2924Returns nil if line starts inside a string, t if in a comment. 2925 2926Will not correct the indentation for labels, but will correct it for braces 2927and closing parentheses and brackets." 2928 ;; This code is still a broken architecture: in some cases we need to 2929 ;; compensate for some modifications which `cperl-indent-line' will add later 2930 (save-excursion 2931 (let ((i (cperl-sniff-for-indent parse-data)) what p) 2932 (cond 2933 ;;((or (null i) (eq i t) (numberp i)) 2934 ;; i) 2935 ((vectorp i) 2936 (setq what (assoc (elt i 0) cperl-indent-rules-alist)) 2937 (cond 2938 (what 2939 (let ((action (cadr what))) 2940 (cond ((functionp action) (apply action (list i parse-data))) 2941 ((numberp action) (+ action (current-indentation))) 2942 (t action)))) 2943 ;; 2944 ;; Indenters for regular expressions with //x and qw() 2945 ;; 2946 ((eq 'REx-part2 (elt i 0)) ;; [self start] start of /REP in s//REP/x 2947 (goto-char (elt i 1)) 2948 (condition-case nil ; Use indentation of the 1st part 2949 (forward-sexp -1)) 2950 (current-column)) 2951 ((eq 'indentable (elt i 0)) ; Indenter for REGEXP qw() etc 2952 (cond ;;; [indentable terminator start-pos is-block] 2953 ((eq 'terminator (elt i 1)) ; Lone terminator of "indentable string" 2954 (goto-char (elt i 2)) ; After opening parens 2955 (1- (current-column))) 2956 ((eq 'first-line (elt i 1)); [indentable first-line start-pos] 2957 (goto-char (elt i 2)) 2958 (+ (or cperl-regexp-indent-step cperl-indent-level) 2959 -1 2960 (current-column))) 2961 ((eq 'cont-line (elt i 1)); [indentable cont-line pos prev-pos first-char start-pos] 2962 ;; Indent as the level after closing parens 2963 (goto-char (elt i 2)) ; indent line 2964 (skip-chars-forward " \t)") ; Skip closing parens 2965 (setq p (point)) 2966 (goto-char (elt i 3)) ; previous line 2967 (skip-chars-forward " \t)") ; Skip closing parens 2968 ;; Number of parens in between: 2969 (setq p (nth 0 (parse-partial-sexp (point) p)) 2970 what (elt i 4)) ; First char on current line 2971 (goto-char (elt i 3)) ; previous line 2972 (+ (* p (or cperl-regexp-indent-step cperl-indent-level)) 2973 (cond ((eq what ?\) ) 2974 (- cperl-close-paren-offset)) ; compensate 2975 ((eq what ?\| ) 2976 (- (or cperl-regexp-indent-step cperl-indent-level))) 2977 (t 0)) 2978 (if (eq (following-char) ?\| ) 2979 (or cperl-regexp-indent-step cperl-indent-level) 2980 0) 2981 (current-column))) 2982 (t 2983 (error "Unrecognized value of indent: %s" i)))) 2984 ;; 2985 ;; Indenter for stuff at toplevel 2986 ;; 2987 ((eq 'toplevel (elt i 0)) ;; [toplevel start char-after state immed-after-block] 2988 (+ (save-excursion ; To beg-of-defun, or end of last sexp 2989 (goto-char (elt i 1)) ; start = Good place to start parsing 2990 (- (current-indentation) ; 2991 (if (elt i 4) cperl-indent-level 0))) ; immed-after-block 2992 (if (eq (elt i 2) ?{) cperl-continued-brace-offset 0) ; char-after 2993 ;; Look at previous line that's at column 0 2994 ;; to determine whether we are in top-level decls 2995 ;; or function's arg decls. Set basic-indent accordingly. 2996 ;; Now add a little if this is a continuation line. 2997 (if (elt i 3) ; state (XXX What is the semantic???) 2998 0 2999 cperl-continued-statement-offset))) 3000 ;; 3001 ;; Indenter for stuff in "parentheses" (or brackets, braces-as-hash) 3002 ;; 3003 ((eq 'in-parens (elt i 0)) 3004 ;; in-parens char-after old-indent-point is-brace containing-sexp 3005 3006 ;; group is an expression, not a block: 3007 ;; indent to just after the surrounding open parens, 3008 ;; skip blanks if we do not close the expression. 3009 (+ (progn 3010 (goto-char (elt i 2)) ; old-indent-point 3011 (current-column)) 3012 (if (and (elt i 3) ; is-brace 3013 (eq (elt i 1) ?\})) ; char-after 3014 ;; Correct indentation of trailing ?\} 3015 (+ cperl-indent-level cperl-close-paren-offset) 3016 0))) 3017 ;; 3018 ;; Indenter for continuation lines 3019 ;; 3020 ((eq 'continuation (elt i 0)) 3021 ;; [continuation statement-start char-after is-block is-brace] 3022 (goto-char (elt i 1)) ; statement-start 3023 (+ (if (or (memq (elt i 2) (append "}])" nil)) ; char-after 3024 (eq 'continuation ; do not stagger continuations 3025 (elt (cperl-sniff-for-indent parse-data) 0))) 3026 0 ; Closing parenthesis or continuation of a continuation 3027 cperl-continued-statement-offset) 3028 (if (or (elt i 3) ; is-block 3029 (not (elt i 4)) ; is-brace 3030 (not (eq (elt i 2) ?\}))) ; char-after 3031 0 3032 ;; Now it is a hash reference 3033 (+ cperl-indent-level cperl-close-paren-offset)) 3034 ;; Labels do not take :: ... 3035 (if (looking-at "\\(\\w\\|_\\)+[ \t]*:") 3036 (if (> (current-indentation) cperl-min-label-indent) 3037 (- (current-indentation) cperl-label-offset) 3038 ;; Do not move `parse-data', this should 3039 ;; be quick anyway (this comment comes 3040 ;; from different location): 3041 (cperl-calculate-indent)) 3042 (current-column)) 3043 (if (eq (elt i 2) ?\{) ; char-after 3044 cperl-continued-brace-offset 0))) 3045 ;; 3046 ;; Indenter for lines in a block which are not leading lines 3047 ;; 3048 ((eq 'have-prev-sibling (elt i 0)) 3049 ;; [have-prev-sibling sibling-beg colon-line-end block-start] 3050 (goto-char (elt i 1)) ; sibling-beg 3051 (if (> (elt i 2) (point)) ; colon-line-end; have label before point 3052 (if (> (current-indentation) 3053 cperl-min-label-indent) 3054 (- (current-indentation) cperl-label-offset) 3055 ;; Do not believe: `max' was involved in calculation of indent 3056 (+ cperl-indent-level 3057 (save-excursion 3058 (goto-char (elt i 3)) ; block-start 3059 (current-indentation)))) 3060 (current-column))) 3061 ;; 3062 ;; Indenter for the first line in a block 3063 ;; 3064 ((eq 'code-start-in-block (elt i 0)) 3065 ;;[code-start-in-block before-brace char-after 3066 ;; is-a-HASH-ref brace-is-first-thing-on-a-line 3067 ;; group-starts-before-start-of-sub start-of-control-group] 3068 (goto-char (elt i 1)) 3069 ;; For open brace in column zero, don't let statement 3070 ;; start there too. If cperl-indent-level=0, 3071 ;; use cperl-brace-offset + cperl-continued-statement-offset instead. 3072 (+ (if (and (bolp) (zerop cperl-indent-level)) 3073 (+ cperl-brace-offset cperl-continued-statement-offset) 3074 cperl-indent-level) 3075 (if (and (elt i 3) ; is-a-HASH-ref 3076 (eq (elt i 2) ?\})) ; char-after: End of a hash reference 3077 (+ cperl-indent-level cperl-close-paren-offset) 3078 0) 3079 ;; Unless openbrace is the first nonwhite thing on the line, 3080 ;; add the cperl-brace-imaginary-offset. 3081 (if (elt i 4) 0 ; brace-is-first-thing-on-a-line 3082 cperl-brace-imaginary-offset) 3083 (progn 3084 (goto-char (elt i 6)) ; start-of-control-group 3085 (if (elt i 5) ; group-starts-before-start-of-sub 3086 (current-column) 3087 ;; Get initial indentation of the line we are on. 3088 ;; If line starts with label, calculate label indentation 3089 (if (save-excursion 3090 (beginning-of-line) 3091 (looking-at (rx 3092 (sequence (0+ space) 3093 (eval cperl--label-rx) 3094 (not (in ":")))))) 3095 (if (> (current-indentation) cperl-min-label-indent) 3096 (- (current-indentation) cperl-label-offset) 3097 ;; Do not move `parse-data', this should 3098 ;; be quick anyway: 3099 (cperl-calculate-indent)) 3100 (current-indentation)))))) 3101 (t 3102 (error "Unrecognized value of indent: %s" i)))) 3103 (t 3104 (error "Got strange value of indent: %s" i)))))) 3105 3106(defun cperl-calculate-indent-within-comment () 3107 "Return the indentation amount for line. 3108Assume that the current line is to be regarded as part of a block 3109comment." 3110 (let (end) 3111 (save-excursion 3112 (beginning-of-line) 3113 (skip-chars-forward " \t") 3114 (setq end (point)) 3115 (and (= (following-char) ?#) 3116 (forward-line -1) 3117 (cperl-to-comment-or-eol) 3118 (setq end (point))) 3119 (goto-char end) 3120 (current-column)))) 3121 3122 3123(defun cperl-to-comment-or-eol () 3124 "Go to position before comment on the current line, or to end of line. 3125Returns true if comment is found. In POD will not move the point." 3126 ;; If the line is inside other syntax groups (qq-style strings, HERE-docs) 3127 ;; then looks for literal # or end-of-line. 3128 (let (state stop-in cpoint (lim (point-at-eol)) pr e) 3129 (or cperl-font-locking 3130 (cperl-update-syntaxification lim)) 3131 (beginning-of-line) 3132 (if (setq pr (get-text-property (point) 'syntax-type)) 3133 (setq e (next-single-property-change (point) 'syntax-type nil (point-max)))) 3134 (if (or (eq pr 'pod) 3135 (if (or (not e) (> e lim)) ; deep inside a group 3136 (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t))) 3137 (if (eq (preceding-char) ?\#) (progn (backward-char 1) t)) 3138 ;; Else - need to do it the hard way 3139 (and (and e (<= e lim)) 3140 (goto-char e)) 3141 (while (not stop-in) 3142 (setq state (parse-partial-sexp (point) lim nil nil nil t)) 3143 ; stop at comment 3144 ;; If fails (beginning-of-line inside sexp), then contains not-comment 3145 (if (nth 4 state) ; After `#'; 3146 ; (nth 2 state) can be 3147 ; beginning of m,s,qq and so 3148 ; on 3149 (if (nth 2 state) 3150 (progn 3151 (setq cpoint (point)) 3152 (goto-char (nth 2 state)) 3153 (cond 3154 ((looking-at "\\(s\\|tr\\)\\>") 3155 (or (re-search-forward 3156 "\\=\\w+[ \t]*#\\([^\n\\#]\\|\\\\[\\#]\\)*#\\([^\n\\#]\\|\\\\[\\#]\\)*" 3157 lim 'move) 3158 (setq stop-in t))) 3159 ((looking-at "\\(m\\|q\\([qxwr]\\)?\\)\\>") 3160 (or (re-search-forward 3161 "\\=\\w+[ \t]*#\\([^\n\\#]\\|\\\\[\\#]\\)*#" 3162 lim 'move) 3163 (setq stop-in t))) 3164 (t ; It was fair comment 3165 (setq stop-in t) ; Finish 3166 (goto-char (1- cpoint))))) 3167 (setq stop-in t) ; Finish 3168 (forward-char -1)) 3169 (setq stop-in t))) ; Finish 3170 (nth 4 state)))) 3171 3172(defsubst cperl-modify-syntax-type (at how) 3173 (if (< at (point-max)) 3174 (progn 3175 (put-text-property at (1+ at) 'syntax-table how) 3176 (put-text-property at (1+ at) 'rear-nonsticky '(syntax-table))))) 3177 3178(defun cperl-protect-defun-start (s e) 3179 ;; C code looks for "^\\s(" to skip comment backward in "hard" situations 3180 (save-excursion 3181 (goto-char s) 3182 (while (re-search-forward "^\\s(" e 'to-end) 3183 (put-text-property (1- (point)) (point) 'syntax-table cperl-st-punct)))) 3184 3185(defun cperl-commentify (begin end string) 3186 "Mark text from BEGIN to END as generic string or comment. 3187Mark as generic string if STRING, as generic comment otherwise. 3188A single character is marked as punctuation and directly 3189fontified. Do nothing if BEGIN and END are equal. If 3190`cperl-use-syntax-text-property' is nil, just fontify." 3191 (if (and cperl-use-syntax-table-text-property 3192 (> end begin)) 3193 (progn 3194 (setq string (if string cperl-st-sfence cperl-st-cfence)) 3195 (if (> begin (- end 2)) 3196 ;; one-char string/comment?! 3197 (cperl-modify-syntax-type begin cperl-st-punct) 3198 (cperl-modify-syntax-type begin string) 3199 (cperl-modify-syntax-type (1- end) string)) 3200 (if (and (eq string cperl-st-sfence) (> (- end 2) begin)) 3201 (put-text-property (1+ begin) (1- end) 3202 'syntax-table cperl-string-syntax-table)) 3203 (cperl-protect-defun-start begin end)) 3204 ;; Fontify 3205 (when cperl-pod-here-fontify 3206 (put-text-property begin end 'face (if string 'font-lock-string-face 3207 'font-lock-comment-face))))) 3208 3209(defvar cperl-starters '(( ?\( . ?\) ) 3210 ( ?\[ . ?\] ) 3211 ( ?\{ . ?\} ) 3212 ( ?\< . ?\> ))) 3213 3214(defun cperl-cached-syntax-table (st) 3215 "Get a syntax table cached in ST, or create and cache into ST a syntax table. 3216All the entries of the syntax table are \".\", except for a backslash, which 3217is quoting." 3218 (if (car-safe st) 3219 (car st) 3220 (setcar st (make-syntax-table)) 3221 (setq st (car st)) 3222 (let ((i 0)) 3223 (while (< i 256) 3224 (modify-syntax-entry i "." st) 3225 (setq i (1+ i)))) 3226 (modify-syntax-entry ?\\ "\\" st) 3227 st)) 3228 3229(defun cperl-forward-re (lim end is-2arg st-l err-l argument 3230 &optional ostart oend) 3231"Find the end of a regular expression or a stringish construct (q[] etc). 3232The point should be before the starting delimiter. 3233 3234Goes to LIM if none is found. If IS-2ARG is non-nil, assumes that it 3235is s/// or tr/// like expression. If END is nil, generates an error 3236message if needed. If SET-ST is non-nil, will use (or generate) a 3237cached syntax table in ST-L. If ERR-L is non-nil, will store the 3238error message in its CAR (unless it already contains some error 3239message). ARGUMENT should be the name of the construct (used in error 3240messages). OSTART, OEND may be set in recursive calls when processing 3241the second argument of 2ARG construct. 3242 3243Works *before* syntax recognition is done. In IS-2ARG situation may 3244modify syntax-type text property if the situation is too hard." 3245 (let (b starter ender st i i2 go-forward reset-st set-st) 3246 (skip-chars-forward " \t") 3247 ;; ender means matching-char matcher. 3248 (setq b (point) 3249 starter (if (eobp) 0 (char-after b)) 3250 ender (cdr (assoc starter cperl-starters))) 3251 ;; What if starter == ?\\ ???? 3252 (setq st (cperl-cached-syntax-table st-l)) 3253 (setq set-st t) 3254 ;; Whether we have an intermediate point 3255 (setq i nil) 3256 ;; Prepare the syntax table: 3257 (if (not ender) ; m/blah/, s/x//, s/x/y/ 3258 (modify-syntax-entry starter "$" st) 3259 (modify-syntax-entry starter (concat "(" (list ender)) st) 3260 (modify-syntax-entry ender (concat ")" (list starter)) st)) 3261 (condition-case bb 3262 (progn 3263 ;; We use `$' syntax class to find matching stuff, but $$ 3264 ;; is recognized the same as $, so we need to check this manually. 3265 (if (and (eq starter (char-after (cperl-1+ b))) 3266 (not ender)) 3267 ;; $ has TeXish matching rules, so $$ equiv $... 3268 (forward-char 2) 3269 (setq reset-st (syntax-table)) 3270 (set-syntax-table st) 3271 (forward-sexp 1) 3272 (if (<= (point) (1+ b)) 3273 (error "Unfinished regular expression")) 3274 (set-syntax-table reset-st) 3275 (setq reset-st nil) 3276 ;; Now the problem is with m;blah;; 3277 (and (not ender) 3278 (eq (preceding-char) 3279 (char-after (- (point) 2))) 3280 (save-excursion 3281 (forward-char -2) 3282 (= 0 (% (skip-chars-backward "\\\\") 2))) 3283 (forward-char -1))) 3284 ;; Now we are after the first part. 3285 (and is-2arg ; Have trailing part 3286 (not ender) 3287 (eq (following-char) starter) ; Empty trailing part 3288 (progn 3289 (or (eq (char-syntax (following-char)) ?.) 3290 ;; Make trailing letter into punctuation 3291 (cperl-modify-syntax-type (point) cperl-st-punct)) 3292 (setq is-2arg nil go-forward t))) ; Ignore the tail 3293 (if is-2arg ; Not number => have second part 3294 (progn 3295 (setq i (point) i2 i) 3296 (if ender 3297 (if (memq (following-char) '(?\s ?\t ?\n ?\f)) 3298 (progn 3299 (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+") 3300 (goto-char (match-end 0)) 3301 (skip-chars-forward " \t\n\f")) 3302 (setq i2 (point)))) 3303 (forward-char -1)) 3304 (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st) 3305 (if ender (modify-syntax-entry ender "." st)) 3306 (setq set-st nil) 3307 (setq ender (cperl-forward-re lim end nil st-l err-l 3308 argument starter ender) 3309 ender (nth 2 ender))))) 3310 (error (goto-char lim) 3311 (setq set-st nil) 3312 (if reset-st 3313 (set-syntax-table reset-st)) 3314 (or end 3315 (and cperl-brace-recursing 3316 (or (eq ostart ?\{) 3317 (eq starter ?\{))) 3318 (message 3319 "End of `%s%s%c ... %c' string/RE not found: %s" 3320 argument 3321 (if ostart (format "%c ... %c" ostart (or oend ostart)) "") 3322 starter (or ender starter) bb) 3323 (or (car err-l) (setcar err-l b))))) 3324 (if set-st 3325 (progn 3326 (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st) 3327 (if ender (modify-syntax-entry ender "." st)))) 3328 ;; i: have 2 args, after end of the first arg 3329 ;; i2: start of the second arg, if any (before delim if `ender'). 3330 ;; ender: the last arg bounded by parens-like chars, the second one of them 3331 ;; starter: the starting delimiter of the first arg 3332 ;; go-forward: has 2 args, and the second part is empty 3333 (list i i2 ender starter go-forward))) 3334 3335(defun cperl-forward-group-in-re (&optional st-l) 3336 "Find the end of a group in a REx. 3337Return the error message (if any). Does not work if delimiter is `)'. 3338Works before syntax recognition is done." 3339 ;; Works *before* syntax recognition is done 3340 (or st-l (setq st-l (list nil))) ; Avoid overwriting '() 3341 (let (st result reset-st) 3342 (condition-case err 3343 (progn 3344 (setq st (cperl-cached-syntax-table st-l)) 3345 (modify-syntax-entry ?\( "()" st) 3346 (modify-syntax-entry ?\) ")(" st) 3347 (setq reset-st (syntax-table)) 3348 (set-syntax-table st) 3349 (forward-sexp 1)) 3350 (error (setq result err))) 3351 ;; now restore the initial state 3352 (if st 3353 (progn 3354 (modify-syntax-entry ?\( "." st) 3355 (modify-syntax-entry ?\) "." st))) 3356 (if reset-st 3357 (set-syntax-table reset-st)) 3358 result)) 3359 3360 3361(defsubst cperl-postpone-fontification (b e type val &optional now) 3362 ;; Do after syntactic fontification? 3363 (if cperl-syntaxify-by-font-lock 3364 (or now (put-text-property b e 'cperl-postpone (cons type val))) 3365 (put-text-property b e type val))) 3366 3367;; Here is how the global structures (those which cannot be 3368;; recognized locally) are marked: 3369;; a) PODs: 3370;; Start-to-end is marked `in-pod' ==> t 3371;; Each non-literal part is marked `syntax-type' ==> `pod' 3372;; Each literal part is marked `syntax-type' ==> `in-pod' 3373;; b) HEREs: 3374;; The point before start is marked `here-doc-start' 3375;; Start-to-end is marked `here-doc-group' ==> t 3376;; The body is marked `syntax-type' ==> `here-doc' 3377;; and is also marked as style 2 comment 3378;; The delimiter is marked `syntax-type' ==> `here-doc-delim' 3379;; c) FORMATs: 3380;; First line (to =) marked `first-format-line' ==> t 3381;; After-this--to-end is marked `syntax-type' ==> `format' 3382;; d) 'Q'uoted string: 3383;; part between markers inclusive is marked `syntax-type' ==> `string' 3384;; part between `q' and the first marker is marked `syntax-type' ==> `prestring' 3385;; second part of s///e is marked `syntax-type' ==> `multiline' 3386;; e) Attributes of subroutines: `attrib-group' ==> t 3387;; (or 0 if declaration); up to `{' or ';': `syntax-type' => `sub-decl'. 3388;; f) Multiline my/our declaration lists etc: `syntax-type' => `multiline' 3389 3390;; In addition, some parts of RExes may be marked as `REx-interpolated' 3391;; (value: 0 in //o, 1 if "interpolated variable" is whole-REx, t otherwise). 3392 3393(defun cperl-unwind-to-safe (before &optional end) 3394 "Move point back to a safe place, back up one extra line if BEFORE. 3395A place is \"safe\" if it is not within POD, a here-document, a 3396format, a quote-like expression, a subroutine attribute list or a 3397multiline declaration. These places all have special syntactical 3398rules and need to be parsed as a whole. If END, return the 3399position of the end of the unsafe construct." 3400 (let ((pos (point)) 3401 (state (syntax-ppss))) 3402 ;; Check edge cases for here-documents first 3403 (when before ; we need a safe start for parsing 3404 (cond 3405 ((or (equal (get-text-property (cperl-1- (point)) 'syntax-type) 3406 'here-doc-start) 3407 (equal (syntax-after (cperl-1- (point))) 3408 (string-to-syntax "> c"))) 3409 ;; point is either immediately after the start of a here-doc 3410 ;; (which may consist of nothing but one newline) or 3411 ;; immediately after the now-outdated end marker of the 3412 ;; here-doc. In both cases we need to back up to the line 3413 ;; where the here-doc delimiters are defined. 3414 (forward-char -1) 3415 (cperl-backward-to-noncomment (point-min)) 3416 (beginning-of-line)) 3417 ((eq 2 (nth 7 state)) 3418 ;; point is somewhere in a here-document. Back up to the line 3419 ;; where the here-doc delimiters are defined. 3420 (goto-char (nth 8 state)) ; beginning of this here-doc 3421 (cperl-backward-to-noncomment ; skip back over more 3422 (point-min)) ; here-documents (if any) 3423 (beginning-of-line)))) ; skip back over here-doc starters 3424 (while (and pos (progn 3425 (beginning-of-line) 3426 (get-text-property (setq pos (point)) 'syntax-type))) 3427 (setq pos (cperl-beginning-of-property pos 'syntax-type)) 3428 (if (eq pos (point-min)) 3429 (setq pos nil)) 3430 (if pos 3431 (if before 3432 (progn 3433 (goto-char (cperl-1- pos)) 3434 (beginning-of-line) 3435 (setq pos (point))) 3436 (goto-char (setq pos (cperl-1- pos)))) 3437 ;; Up to the start 3438 (goto-char (point-min)))) 3439 ;; Skip empty lines 3440 (and (looking-at "\n*=") 3441 (/= 0 (skip-chars-backward "\n")) 3442 (forward-char)) 3443 (setq pos (point)) 3444 (if end 3445 ;; Do the same for end, going small steps 3446 (save-excursion 3447 (while (and end (< end (point-max)) 3448 (get-text-property end 'syntax-type)) 3449 (setq pos end 3450 end (next-single-property-change end 'syntax-type nil (point-max))) 3451 (if end (progn (goto-char end) 3452 (or (bolp) (forward-line 1)) 3453 (setq end (point))))) 3454 (or end pos))))) 3455 3456(defun cperl-find-sub-attrs (&optional st-l b-fname e-fname pos) 3457 "Syntactically mark (and fontify) attributes of a subroutine. 3458Should be called with the point before leading colon of an attribute." 3459 ;; Works *before* syntax recognition is done 3460 (or st-l (setq st-l (list nil))) ; Avoid overwriting '() 3461 (let (st p reset-st after-first (start (point)) start1 end1) 3462 (condition-case b 3463 (while (looking-at 3464 (concat 3465 "\\(" ; 1=optional? colon 3466 ":" cperl-maybe-white-and-comment-rex ; 2=whitespace/comment? 3467 "\\)" 3468 (if after-first "?" "") 3469 ;; No space between name and paren allowed... 3470 "\\(\\sw+\\)" ; 3=name 3471 "\\((\\)?")) ; 4=optional paren 3472 (and (match-beginning 1) 3473 (cperl-postpone-fontification 3474 (match-beginning 0) (cperl-1+ (match-beginning 0)) 3475 'face font-lock-constant-face)) 3476 (setq start1 (match-beginning 3) end1 (match-end 3)) 3477 (cperl-postpone-fontification start1 end1 3478 'face font-lock-constant-face) 3479 (goto-char end1) ; end or before `(' 3480 (if (match-end 4) ; Have attribute arguments... 3481 (progn 3482 (if st nil 3483 (setq st (cperl-cached-syntax-table st-l)) 3484 (modify-syntax-entry ?\( "()" st) 3485 (modify-syntax-entry ?\) ")(" st)) 3486 (setq reset-st (syntax-table) p (point)) 3487 (set-syntax-table st) 3488 (forward-sexp 1) 3489 (set-syntax-table reset-st) 3490 (setq reset-st nil) 3491 (cperl-commentify p (point) t))) ; mark as string 3492 (forward-comment (buffer-size)) 3493 (setq after-first t)) 3494 (error (message 3495 "L%d: attribute `%s': %s" 3496 (count-lines (point-min) (point)) 3497 (and start1 end1 (buffer-substring start1 end1)) b) 3498 (setq start nil))) 3499 (and start 3500 (progn 3501 (put-text-property start (point) 3502 'attrib-group (if (looking-at "{") t 0)) 3503 (and pos 3504 (< 1 (count-lines (+ 3 pos) (point))) ; end of `sub' 3505 ;; Apparently, we do not need `multiline': faces added now 3506 (put-text-property (+ 3 pos) (cperl-1+ (point)) 3507 'syntax-type 'sub-decl)) 3508 (and b-fname ; Fontify here: the following condition 3509 (cperl-postpone-fontification ; is too hard to determine by 3510 b-fname e-fname 'face ; a REx, so do it here 3511 (if (looking-at "{") 3512 font-lock-function-name-face 3513 font-lock-variable-name-face))))) 3514 ;; now restore the initial state 3515 (if st 3516 (progn 3517 (modify-syntax-entry ?\( "." st) 3518 (modify-syntax-entry ?\) "." st))) 3519 (if reset-st 3520 (set-syntax-table reset-st)))) 3521 3522(defsubst cperl-look-at-leading-count (is-x-REx e) 3523 (if (and 3524 (< (point) e) 3525 (re-search-forward (concat "\\=" (if is-x-REx "[ \t\n]*" "") "[{?+*]") 3526 (1- e) t)) ; return nil on failure, no moving 3527 (if (eq ?\{ (preceding-char)) nil 3528 (cperl-postpone-fontification 3529 (1- (point)) (point) 3530 'face font-lock-warning-face)))) 3531 3532;; Do some smarter-highlighting 3533;; XXXX Currently ignores alphanum/dash delims, 3534(defsubst cperl-highlight-charclass (endbracket dashface bsface onec-space) 3535 (let ((l '(1 5 7)) ll lle lll 3536 ;; 2 groups, the first takes the whole match (include \[trnfabe]) 3537 (singleChar (concat "\\(" "[^\\]" "\\|" "\\\\[^cdg-mo-qsu-zA-Z0-9_]" "\\|" "\\\\c." "\\|" "\\\\x" "\\([[:xdigit:]][[:xdigit:]]?\\|\\={[[:xdigit:]]+}\\)" "\\|" "\\\\0?[0-7][0-7]?[0-7]?" "\\|" "\\\\N{[^{}]*}" "\\)"))) 3538 (while ; look for unescaped - between non-classes 3539 (re-search-forward 3540 ;; On 19.33, certain simplifications lead 3541 ;; to bugs (as in [^a-z] \\| [trnfabe] ) 3542 (concat ; 1: SingleChar (include \[trnfabe]) 3543 singleChar 3544 ;;"\\(" "[^\\]" "\\|" "\\\\[^cdg-mo-qsu-zA-Z0-9_]" "\\|" "\\\\c." "\\|" "\\\\x" "\\([[:xdigit:]][[:xdigit:]]?\\|\\={[[:xdigit:]]+}\\)" "\\|" "\\\\0?[0-7][0-7]?[0-7]?" "\\|" "\\\\N{[^{}]*}" "\\)" 3545 "\\(" ; 3: DASH SingleChar (match optionally) 3546 "\\(-\\)" ; 4: DASH 3547 singleChar ; 5: SingleChar 3548 ;;"\\(" "[^\\]" "\\|" "\\\\[^cdg-mo-qsu-zA-Z0-9_]" "\\|" "\\\\c." "\\|" "\\\\x" "\\([[:xdigit:]][[:xdigit:]]?\\|\\={[[:xdigit:]]+}\\)" "\\|" "\\\\0?[0-7][0-7]?[0-7]?" "\\|" "\\\\N{[^{}]*}" "\\)" 3549 "\\)?" 3550 "\\|" 3551 "\\(" ; 7: other escapes 3552 "\\\\[pP]" "\\([^{]\\|{[^{}]*}\\)" 3553 "\\|" "\\\\[^pP]" "\\)" 3554 ) 3555 endbracket 'toend) 3556 (if (match-beginning 4) 3557 (cperl-postpone-fontification 3558 (match-beginning 4) (match-end 4) 3559 'face dashface)) 3560 ;; save match data (for looking-at) 3561 (setq lll (mapcar (lambda (elt) (cons (match-beginning elt) 3562 (match-end elt))) 3563 l)) 3564 (while lll 3565 (setq ll (car lll)) 3566 (setq lle (cdr ll) 3567 ll (car ll)) 3568 ;; (message "Got %s of %s" ll l) 3569 (if (and ll (eq (char-after ll) ?\\ )) 3570 (save-excursion 3571 (goto-char ll) 3572 (cperl-postpone-fontification ll (1+ ll) 3573 'face bsface) 3574 (if (looking-at "\\\\[a-zA-Z0-9]") 3575 (cperl-postpone-fontification (1+ ll) lle 3576 'face onec-space)))) 3577 (setq lll (cdr lll)))) 3578 (goto-char endbracket) ; just in case something misbehaves??? 3579 t)) 3580 3581(defvar cperl-here-doc-functions 3582 (regexp-opt '("print" "printf" "say" ; print $handle <<EOF 3583 "system" "exec" ; system $progname <<EOF 3584 "sort") ; sort $subname <<EOF 3585 'symbols) ; avoid false positives 3586 "List of keywords after which `$var <<bareword' is a here-document. 3587After any other token `$var <<bareword' is treated as the variable `$var' 3588left-shifted by the return value of the function `bareword'.") 3589 3590(defun cperl-is-here-doc-p (start) 3591 "Find out whether a \"<<\" construct starting at START is a here-document. 3592The point is expected to be after the end of the delimiter. 3593Quoted delimiters after \"<<\" are unambiguously starting 3594here-documents and are not handled here. This function does not 3595move point but does change match data." 3596 ;; not a here-doc | here-doc 3597 ;; $foo << b; | $f .= <<B; 3598 ;; ($f+1) << b; | a($f) . <<B; 3599 ;; foo 1, <<B; | $x{a} <<b; 3600 ;; Limitations: 3601 ;; foo <<bar is statically undecidable. It could be either 3602 ;; foo() << bar # left shifting the return value or 3603 ;; foo(<<bar) # passing a here-doc to foo(). 3604 ;; We treat it as here-document and kindly ask programmers to 3605 ;; disambiguate by adding parens. 3606 (null 3607 (or (looking-at "[ \t]*(") ; << function_call() 3608 (looking-at ">>") ; <<>> operator 3609 (save-excursion ; 1 << func_name, or $foo << 10 3610 (condition-case nil 3611 (progn 3612 (goto-char start) 3613 (forward-sexp -1) ;; examine the part before "<<" 3614 (save-match-data 3615 (cond 3616 ((looking-at "[0-9$({]") 3617 (forward-sexp 1) 3618 (and 3619 (looking-at "[ \t]*<<") 3620 (condition-case nil 3621 ;; print $foo <<EOF 3622 (progn 3623 (forward-sexp -2) 3624 (not 3625 (looking-at cperl-here-doc-functions))) 3626 (error t))))))) 3627 (error nil)))))) ; func(<<EOF) 3628 3629(defun cperl-process-here-doc (min max end overshoot stop-point 3630 end-of-here-doc err-l 3631 indented-here-doc-p 3632 matched-pos todo-pos 3633 delim-begin delim-end) 3634 "Process a here-document's delimiters and body. 3635The parameters MIN, MAX, END, OVERSHOOT, STOP-POINT, ERR-L are 3636used for recursive calls to `cperl-find-pods-here' to handle the 3637rest of the line which contains the delimiter. MATCHED-POS and 3638TODO-POS are initial values for this function's result. 3639END-OF-HERE-DOC is the end of a previous here-doc in the same 3640line, or nil if this is the first. DELIM-BEGIN and DELIM-END are 3641the positions where the here-document's delimiter has been found. 3642This is part of `cperl-find-pods-heres' (below)." 3643 (let* ((my-cperl-delimiters-face font-lock-constant-face) 3644 (delimiter (buffer-substring-no-properties delim-begin delim-end)) 3645 (qtag (regexp-quote delimiter)) 3646 (use-syntax-state (and cperl-syntax-state 3647 (>= min (car cperl-syntax-state)))) 3648 (state-point (if use-syntax-state 3649 (car cperl-syntax-state) 3650 (point-min))) 3651 (state (if use-syntax-state 3652 (cdr cperl-syntax-state))) 3653 here-doc-start here-doc-end defs-eol 3654 warning-message) 3655 (when cperl-pod-here-fontify 3656 ;; Highlight the starting delimiter 3657 (cperl-postpone-fontification delim-begin delim-end 3658 'face my-cperl-delimiters-face) 3659 (cperl-put-do-not-fontify delim-begin delim-end t)) 3660 (forward-line) 3661 (setq here-doc-start (point) ; first char of (first) here-doc 3662 defs-eol (1- here-doc-start)) ; end of definitions line 3663 (if end-of-here-doc 3664 ;; skip to the end of the previous here-doc 3665 (goto-char end-of-here-doc) 3666 ;; otherwise treat the first (or only) here-doc: Check for 3667 ;; special cases if the line containing the delimiter(s) 3668 ;; ends in a regular comment or a solitary ?# 3669 (let* ((eol-state (save-excursion (syntax-ppss defs-eol)))) 3670 (when (nth 4 eol-state) ; EOL is in a comment 3671 (if (= (1- defs-eol) (nth 8 eol-state)) 3672 ;; line ends with a naked comment starter. 3673 ;; We let it start the here-doc. 3674 (progn 3675 (put-text-property (1- defs-eol) defs-eol 3676 'font-lock-face 3677 'font-lock-comment-face) 3678 (put-text-property (1- defs-eol) defs-eol 3679 'syntax-type 'here-doc) 3680 (put-text-property (1- defs-eol) defs-eol 3681 'syntax-type 'here-doc) 3682 (put-text-property (1- defs-eol) defs-eol 3683 'syntax-table 3684 (string-to-syntax "< c")) 3685 ) 3686 ;; line ends with a "regular" comment: make 3687 ;; the last character of the comment closing 3688 ;; it so that we can use the line feed to 3689 ;; start the here-doc 3690 (put-text-property (1- defs-eol) defs-eol 3691 'syntax-table 3692 (string-to-syntax ">")))))) 3693 (setq here-doc-start (point)) ; now points to current here-doc 3694 ;; Find the terminating delimiter. 3695 ;; We do not search to max, since we may be called from 3696 ;; some hook of fontification, and max is random 3697 (or (re-search-forward 3698 (concat "^" (when indented-here-doc-p "[ \t]*") 3699 qtag "$") 3700 stop-point 'toend) 3701 (progn ; Pretend we matched at the end 3702 (goto-char (point-max)) 3703 (re-search-forward "\\'") 3704 (setq warning-message 3705 (format "End of here-document `%s' not found." delimiter)) 3706 (or (car err-l) (setcar err-l here-doc-start)))) 3707 (when cperl-pod-here-fontify 3708 ;; Highlight the ending delimiter 3709 (cperl-postpone-fontification 3710 (match-beginning 0) (match-end 0) 3711 'face my-cperl-delimiters-face) 3712 (cperl-put-do-not-fontify here-doc-start (match-end 0) t)) 3713 (setq here-doc-end (cperl-1+ (match-end 0))) ; eol after delim 3714 (put-text-property here-doc-start (match-beginning 0) 3715 'syntax-type 'here-doc) 3716 (put-text-property (match-beginning 0) here-doc-end 3717 'syntax-type 'here-doc-delim) 3718 (put-text-property here-doc-start here-doc-end 'here-doc-group t) 3719 ;; This makes insertion at the start of HERE-DOC update 3720 ;; the whole construct: 3721 (put-text-property here-doc-start (cperl-1+ here-doc-start) 'front-sticky '(syntax-type)) 3722 (cperl-commentify (match-beginning 0) (1- here-doc-end) nil) 3723 (put-text-property (1- here-doc-start) here-doc-start 3724 'syntax-type 'here-doc-start) 3725 (when (> (match-beginning 0) here-doc-start) 3726 ;; here-document has non-zero length 3727 (cperl-modify-syntax-type (1- here-doc-start) (string-to-syntax "< c")) 3728 (cperl-modify-syntax-type (1- (match-beginning 0)) 3729 (string-to-syntax "> c"))) 3730 (cperl-put-do-not-fontify here-doc-start (match-end 0) t) 3731 ;; Cache the syntax info... 3732 (setq cperl-syntax-state (cons state-point state)) 3733 ;; ... and process the rest of the line... 3734 (setq overshoot 3735 (elt ; non-inter ignore-max 3736 (cperl-find-pods-heres todo-pos defs-eol 3737 t end t here-doc-end) 3738 1)) 3739 (if (and overshoot (> overshoot (point))) 3740 (goto-char overshoot) 3741 (setq overshoot here-doc-end)) 3742 (list (if (> here-doc-end max) matched-pos nil) 3743 overshoot 3744 warning-message))) 3745 3746;; Debugging this may require (setq max-specpdl-size 2000)... 3747(defun cperl-find-pods-heres (&optional min max non-inter end ignore-max end-of-here-doc) 3748 "Scan the buffer for hard-to-parse Perl constructions. 3749If `cperl-pod-here-fontify' is non-nil after evaluation, 3750fontify the sections using `cperl-pod-head-face', 3751`cperl-pod-face', `cperl-here-face'. The optional parameters are 3752for internal use: scan from MIN to MAX, or the whole buffer if 3753these are nil. If NON-INTER, don't write progress messages. If 3754IGNORE-MAX, scan to end of buffer. If END, we are after a 3755\"__END__\" or \"__DATA__\" token, so ignore unbalanced 3756constructs. END-OF-HERE-DOC points to the end of a here-document 3757which has already been processed. 3758Value is a two-element list of the position where an error 3759occurred (if any) and the \"overshoot\", which is used for 3760recursive calls in starting lines of here-documents." 3761 (interactive) 3762 (or min (setq min (point-min) 3763 cperl-syntax-state nil 3764 cperl-syntax-done-to min)) 3765 (or max (setq max (point-max))) 3766 (font-lock-flush min max) 3767 (let* (go tmpend 3768 face head-face b e bb tag qtag b1 e1 argument i c tail tb 3769 is-REx is-x-REx REx-subgr-start REx-subgr-end was-subgr i2 hairy-RE 3770 (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t) 3771 (modified (buffer-modified-p)) overshoot is-o-REx name 3772 (inhibit-modification-hooks t) 3773 (cperl-font-locking t) 3774 (use-syntax-state (and cperl-syntax-state 3775 (>= min (car cperl-syntax-state)))) 3776 (state-point (if use-syntax-state 3777 (car cperl-syntax-state) 3778 (point-min))) 3779 (state (if use-syntax-state 3780 (cdr cperl-syntax-state))) 3781 ;; (st-l '(nil)) (err-l '(nil)) ; Would overwrite - propagates from a function call to a function call! 3782 (st-l (list nil)) (err-l (list nil)) 3783 ;; Somehow font-lock may be not loaded yet... 3784 ;; (e.g., when building TAGS via command-line call) 3785 (font-lock-string-face (if (boundp 'font-lock-string-face) 3786 font-lock-string-face 3787 'font-lock-string-face)) 3788 (my-cperl-delimiters-face 3789 font-lock-constant-face) 3790 (my-cperl-REx-spec-char-face ; [] ^.$ and wrapper-of ({}) 3791 font-lock-function-name-face) 3792 (my-cperl-REx-0length-face ; 0-length, (?:)etc, non-literal \ 3793 font-lock-builtin-face) 3794 (my-cperl-REx-ctl-face ; (|) 3795 font-lock-keyword-face) 3796 (my-cperl-REx-modifiers-face ; //gims 3797 'cperl-nonoverridable-face) 3798 (my-cperl-REx-length1-face ; length=1 escaped chars, POSIX classes 3799 font-lock-type-face) 3800 (stop-point (if ignore-max 3801 (point-max) 3802 max)) 3803 (search 3804 (concat 3805 "\\(\\`\n?\\|^\n\\)=" ; POD 3806 "\\|" 3807 ;; One extra () before this: 3808 "<<\\(~?\\)" ; HERE-DOC, indented-p = capture 2 3809 "\\(" ; 2 + 1 3810 ;; First variant "BLAH" or just ``. 3811 "[ \t]*" ; Yes, whitespace is allowed! 3812 "\\([\"'`]\\)" ; 3 + 1 = 4 3813 "\\([^\"'`\n]*\\)" ; 4 + 1 3814 "\\4" 3815 "\\|" 3816 ;; Second variant: Identifier or \ID (same as 'ID') or empty 3817 "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 5 + 1, 6 + 1 3818 ;; Do not have <<= or << 30 or <<30 or << $blah. 3819 ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1 3820 "\\)" 3821 "\\|" 3822 ;; 1+6 extra () before this: 3823 "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" ;FRMAT 3824 (if cperl-use-syntax-table-text-property 3825 (concat 3826 "\\|" 3827 ;; 1+6+2=9 extra () before this: 3828 "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" ; QUOTED CONSTRUCT 3829 "\\|" 3830 ;; 1+6+2+1=10 extra () before this: 3831 "\\([/<]\\)" ; /blah/ or <file*glob> 3832 "\\|" 3833 ;; 1+6+2+1+1=11 extra () before this 3834 "\\<" cperl-sub-regexp "\\>" ; sub with proto/attr 3835 "\\(" 3836 cperl-white-and-comment-rex 3837 (rx (group (eval cperl--normal-identifier-rx))) 3838 "\\)" 3839 "\\(" 3840 cperl-maybe-white-and-comment-rex 3841 "\\(([^()]*)\\|:[^:]\\)\\)" ; prototype or attribute start 3842 "\\|" 3843 ;; 1+6+2+1+1+6=17 extra () before this: 3844 "\\$\\(['{]\\)" ; $' or ${foo} 3845 "\\|" 3846 ;; 1+6+2+1+1+6+1=18 extra () before this (old pack'var syntax; 3847 ;; we do not support intervening comments...): 3848 "\\(\\<" cperl-sub-regexp "[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'" 3849 ;; 1+6+2+1+1+6+1+1=19 extra () before this: 3850 "\\|" 3851 "__\\(END\\|DATA\\)__" ; __END__ or __DATA__ 3852 ;; 1+6+2+1+1+6+1+1+1=20 extra () before this: 3853 "\\|" 3854 "\\\\\\(['`\"($]\\)") ; BACKWACKED something-hairy 3855 ""))) 3856 warning-message) 3857 (unwind-protect 3858 (progn 3859 (save-excursion 3860 (or non-inter 3861 (message "Scanning for \"hard\" Perl constructions...")) 3862 ;;(message "find: %s --> %s" min max) 3863 (and cperl-pod-here-fontify 3864 ;; We had evals here, do not know why... 3865 (setq face cperl-pod-face 3866 head-face cperl-pod-head-face)) 3867 (unless end-of-here-doc 3868 (remove-text-properties min max 3869 '(syntax-type t in-pod t syntax-table t 3870 attrib-group t 3871 REx-interpolated t 3872 cperl-postpone t 3873 syntax-subtype t 3874 rear-nonsticky t 3875 front-sticky t 3876 here-doc-group t 3877 first-format-line t 3878 REx-part2 t 3879 indentable t))) 3880 ;; Need to remove face as well... 3881 (goto-char min) 3882 (while (and 3883 (< (point) max) 3884 (re-search-forward search max t)) 3885 (setq tmpend nil) ; Valid for most cases 3886 (setq b (match-beginning 0) 3887 state (save-excursion (parse-partial-sexp 3888 state-point b nil nil state)) 3889 state-point b) 3890 (cond 3891 ;; 1+6+2+1+1+6=17 extra () before this: 3892 ;; "\\$\\(['{]\\)" 3893 ((match-beginning 18) ; $' or ${foo} 3894 (if (eq (preceding-char) ?\') ; $' 3895 (progn 3896 (setq b (1- (point)) 3897 state (parse-partial-sexp 3898 state-point (1- b) nil nil state) 3899 state-point (1- b)) 3900 (if (nth 3 state) ; in string 3901 (cperl-modify-syntax-type (1- b) cperl-st-punct)) 3902 (goto-char (1+ b))) 3903 ;; else: ${ 3904 (setq bb (match-beginning 0)) 3905 (cperl-modify-syntax-type bb cperl-st-punct))) 3906 ;; No processing in strings/comments beyond this point: 3907 ((or (nth 3 state) (nth 4 state)) 3908 t) ; Do nothing in comment/string 3909 ((match-beginning 1) ; POD section 3910 ;; "\\(\\`\n?\\|^\n\\)=" 3911 (setq b (match-beginning 0) 3912 state (parse-partial-sexp 3913 state-point b nil nil state) 3914 state-point b) 3915 (if (or (nth 3 state) (nth 4 state) 3916 (looking-at "\\(cut\\|end\\)\\>")) 3917 (if (or (nth 3 state) (nth 4 state) ignore-max) 3918 nil ; Doing a chunk only 3919 (setq warning-message "=cut is not preceded by a POD section") 3920 (or (car err-l) (setcar err-l (point)))) 3921 (beginning-of-line) 3922 3923 (setq b (point) 3924 bb b 3925 tb (match-beginning 0) 3926 b1 nil) ; error condition 3927 ;; We do not search to max, since we may be called from 3928 ;; some hook of fontification, and max is random 3929 (or (re-search-forward "^\n=\\(cut\\|end\\)\\>" stop-point 'toend) 3930 (progn 3931 (goto-char b) 3932 (if (re-search-forward "\n=\\(cut\\|end\\)\\>" stop-point 'toend) 3933 (progn 3934 (setq warning-message "=cut is not preceded by an empty line") 3935 (setq b1 t) 3936 (or (car err-l) (setcar err-l b)))))) 3937 (beginning-of-line 2) ; An empty line after =cut is not POD! 3938 (setq e (point)) 3939 (and (> e max) 3940 (progn 3941 (remove-text-properties 3942 max e '(syntax-type t in-pod t syntax-table t 3943 attrib-group t 3944 REx-interpolated t 3945 cperl-postpone t 3946 syntax-subtype t 3947 here-doc-group t 3948 rear-nonsticky t 3949 front-sticky t 3950 first-format-line t 3951 REx-part2 t 3952 indentable t)) 3953 (setq tmpend tb))) 3954 (put-text-property b e 'in-pod t) 3955 (put-text-property b e 'syntax-type 'in-pod) 3956 (goto-char b) 3957 (while (re-search-forward "\n\n[ \t]" e t) 3958 ;; We start 'pod 1 char earlier to include the preceding line 3959 (beginning-of-line) 3960 (put-text-property (cperl-1- b) (point) 'syntax-type 'pod) 3961 (cperl-put-do-not-fontify b (point) t) 3962 ;; mark the non-literal parts as PODs 3963 (if cperl-pod-here-fontify 3964 (cperl-postpone-fontification b (point) 'face face t)) 3965 (re-search-forward "\n\n[^ \t\f\n]" e 'toend) 3966 (beginning-of-line) 3967 (setq b (point))) 3968 (put-text-property (cperl-1- (point)) e 'syntax-type 'pod) 3969 (cperl-put-do-not-fontify (point) e t) 3970 (if cperl-pod-here-fontify 3971 (progn 3972 ;; mark the non-literal parts as PODs 3973 (cperl-postpone-fontification (point) e 'face face t) 3974 (goto-char bb) 3975 (if (looking-at 3976 "=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$") 3977 ;; mark the headers 3978 (cperl-postpone-fontification 3979 (match-beginning 1) (match-end 1) 3980 'face head-face)) 3981 (while (re-search-forward 3982 ;; One paragraph 3983 "^\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$" 3984 e 'toend) 3985 ;; mark the headers 3986 (cperl-postpone-fontification 3987 (match-beginning 1) (match-end 1) 3988 'face head-face)))) 3989 (cperl-commentify bb e nil) 3990 (goto-char e) 3991 (or (eq e (point-max)) 3992 (forward-char -1)))) ; Prepare for immediate POD start. 3993 ;; Here document 3994 ;; We can do many here-per-line; 3995 ;; but multiline quote on the same line as <<HERE confuses us... 3996 ;; ;; One extra () before this: 3997 ;;"<<" 3998 ;; "<<\\(~?\\)" ; HERE-DOC, indented-p = capture 2 3999 ;; ;; First variant "BLAH" or just ``. 4000 ;; "[ \t]*" ; Yes, whitespace is allowed! 4001 ;; "\\([\"'`]\\)" ; 3 + 1 4002 ;; "\\([^\"'`\n]*\\)" ; 4 + 1 4003 ;; "\\4" 4004 ;; "\\|" 4005 ;; ;; Second variant: Identifier or \ID or empty 4006 ;; "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 5 + 1, 6 + 1 4007 ;; ;; Do not have <<= or << 30 or <<30 or << $blah. 4008 ;; ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1 4009 ;; "\\)" 4010 ((match-beginning 3) ; 2 + 1: found "<<", detect its type 4011 (let* ((matched-pos (match-beginning 0)) 4012 (quoted-delim-p (if (match-beginning 6) nil t)) 4013 (delim-capture (if quoted-delim-p 5 6))) 4014 (when (cperl-is-here-doc-p matched-pos) 4015 (let ((here-doc-results 4016 (cperl-process-here-doc 4017 min max end overshoot stop-point ; for recursion 4018 end-of-here-doc err-l ; for recursion 4019 (equal (match-string 2) "~") ; indented here-doc? 4020 matched-pos ; for recovery (?) 4021 (match-end 3) ; todo from here 4022 (match-beginning delim-capture) ; starting delimiter 4023 (match-end delim-capture)))) ; boundaries 4024 (setq tmpend (nth 0 here-doc-results) 4025 overshoot (nth 1 here-doc-results)) 4026 (and (nth 2 here-doc-results) 4027 (setq warning-message (nth 2 here-doc-results))))))) 4028 ;; format 4029 ((match-beginning 8) 4030 ;; 1+6=7 extra () before this: 4031 ;;"^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" 4032 (setq b (point) 4033 name (if (match-beginning 8) ; 7 + 1 4034 (buffer-substring (match-beginning 8) ; 7 + 1 4035 (match-end 8)) ; 7 + 1 4036 "") 4037 tb (match-beginning 0)) 4038 (setq argument nil) 4039 (put-text-property (point-at-bol) b 'first-format-line 't) 4040 (if cperl-pod-here-fontify 4041 (while (and (eq (forward-line) 0) 4042 (not (looking-at "^[.;]$"))) 4043 (cond 4044 ((looking-at "^#")) ; Skip comments 4045 ((and argument ; Skip argument multi-lines 4046 (looking-at "^[ \t]*{")) 4047 (forward-sexp 1) 4048 (setq argument nil)) 4049 (argument ; Skip argument lines 4050 (setq argument nil)) 4051 (t ; Format line 4052 (setq b1 (point)) 4053 (setq argument (looking-at "^[^\n]*[@^]")) 4054 (end-of-line) 4055 ;; Highlight the format line 4056 (cperl-postpone-fontification b1 (point) 4057 'face font-lock-string-face) 4058 (cperl-commentify b1 (point) nil) 4059 (cperl-put-do-not-fontify b1 (point) t)))) 4060 ;; We do not search to max, since we may be called from 4061 ;; some hook of fontification, and max is random 4062 (re-search-forward "^[.;]$" stop-point 'toend)) 4063 (beginning-of-line) 4064 (if (looking-at "^\\.$") ; ";" is not supported yet 4065 (progn 4066 ;; Highlight the ending delimiter 4067 (cperl-postpone-fontification (point) (+ (point) 2) 4068 'face font-lock-string-face) 4069 (cperl-commentify (point) (+ (point) 2) nil) 4070 (cperl-put-do-not-fontify (point) (+ (point) 2) t)) 4071 (setq warning-message 4072 (format "End of format `%s' not found." name)) 4073 (or (car err-l) (setcar err-l b))) 4074 (forward-line) 4075 (if (> (point) max) 4076 (setq tmpend tb)) 4077 (put-text-property b (point) 'syntax-type 'format)) 4078 ;; qq-like String or Regexp: 4079 ((or (match-beginning 10) (match-beginning 11)) 4080 ;; 1+6+2=9 extra () before this: 4081 ;; "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" 4082 ;; "\\|" 4083 ;; "\\([/<]\\)" ; /blah/ or <file*glob> 4084 (setq b1 (if (match-beginning 10) 10 11) 4085 argument (buffer-substring 4086 (match-beginning b1) (match-end b1)) 4087 b (point) ; end of qq etc 4088 i b 4089 c (char-after (match-beginning b1)) 4090 bb (char-after (1- (match-beginning b1))) ; tmp holder 4091 ;; bb == "Not a stringy" 4092 bb (if (eq b1 10) ; user variables/whatever 4093 (or 4094 ; false positive: "y_" has no word boundary 4095 (save-match-data (looking-at "_")) 4096 (and (memq bb (append "$@%*#_:-&>" nil)) ; $#y) 4097 (cond ((eq bb ?-) (eq c ?s)) ; -s file test 4098 ((eq bb ?\:) ; $opt::s 4099 (eq (char-after 4100 (- (match-beginning b1) 2)) 4101 ?\:)) 4102 ((eq bb ?\>) ; $foo->s 4103 (eq (char-after 4104 (- (match-beginning b1) 2)) 4105 ?\-)) 4106 ((eq bb ?\&) 4107 (not (eq (char-after ; &&m/blah/ 4108 (- (match-beginning b1) 2)) 4109 ?\&))) 4110 (t t)))) 4111 ;; <file> or <$file> 4112 (and (eq c ?\<) 4113 ;; Stringify what looks like a glob, but 4114 ;; do not stringify file handles <FH>, <$fh> : 4115 (save-match-data 4116 (looking-at 4117 (rx (sequence (opt "$") 4118 (eval cperl--normal-identifier-rx))))))) 4119 tb (match-beginning 0)) 4120 (goto-char (match-beginning b1)) 4121 (cperl-backward-to-noncomment (point-min)) 4122 (or bb 4123 (if (eq b1 11) ; bare /blah/ or <foo> 4124 (setq argument "" 4125 b1 nil 4126 bb ; Not a regexp? 4127 (not 4128 ;; What is below: regexp-p? 4129 (and 4130 (or (memq (preceding-char) 4131 (append (if (char-equal c ?\<) 4132 ;; $a++ ? 1 : 2 4133 "~{(=|&*!,;:[" 4134 "~{(=|&+-*!,;:[") nil)) 4135 (and (eq (preceding-char) ?\}) 4136 (cperl-after-block-p (point-min))) 4137 (and (eq (char-syntax (preceding-char)) ?w) 4138 (progn 4139 (forward-sexp -1) 4140;; After these keywords `/' starts a RE. One should add all the 4141;; functions/builtins which expect an argument, but ... 4142 (and 4143 (not (memq (preceding-char) 4144 '(?$ ?@ ?& ?%))) 4145 (looking-at 4146 "\\(while\\|if\\|unless\\|until\\|for\\(each\\)?\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\|say\\|return\\)\\>")))) 4147 (and (eq (preceding-char) ?.) 4148 (eq (char-after (- (point) 2)) ?.)) 4149 (bobp)) 4150 ;; { $a++ / $b } doesn't start a regex, nor does $a-- 4151 (not (and (memq (preceding-char) '(?+ ?-)) 4152 (eq (preceding-char) (char-before (1- (point)))))) 4153 ;; m|blah| ? foo : bar; 4154 (not 4155 (and (eq c ?\?) 4156 cperl-use-syntax-table-text-property 4157 (not (bobp)) 4158 (progn 4159 (forward-char -1) 4160 (looking-at "\\s|")))))) 4161 b (1- b)) 4162 ;; s y tr m 4163 ;; Check for $a -> y 4164 (setq b1 (preceding-char) 4165 go (point)) 4166 (if (and (eq b1 ?>) 4167 (eq (char-after (- go 2)) ?-)) 4168 ;; Not a regexp 4169 (setq bb t)))) 4170 (or bb 4171 (progn 4172 (goto-char b) 4173 (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+") 4174 (goto-char (match-end 0)) 4175 (skip-chars-forward " \t\n\f")) 4176 (cond ((and (eq (following-char) ?\}) 4177 (eq b1 ?\{)) 4178 ;; Check for $a[23]->{ s }, @{s} and *{s::foo} 4179 (goto-char (1- go)) 4180 (skip-chars-backward " \t\n\f") 4181 (if (memq (preceding-char) (append "$@%&*" nil)) 4182 (setq bb t) ; @{y} 4183 (condition-case nil 4184 (forward-sexp -1) 4185 (error nil))) 4186 (if (or bb 4187 (looking-at ; $foo -> {s} 4188 (rx 4189 (sequence 4190 (in "$@") (0+ "$") 4191 (or 4192 (eval cperl--normal-identifier-rx) 4193 (not (in "{"))) 4194 (opt (sequence (eval cperl--ws*-rx)) 4195 "->") 4196 (eval cperl--ws*-rx) 4197 "{"))) 4198 (and ; $foo[12] -> {s} 4199 (memq (following-char) '(?\{ ?\[)) 4200 (progn 4201 (forward-sexp 1) 4202 (looking-at "\\([ \t\n]*->\\)?[ \t\n]*{")))) 4203 (setq bb t) 4204 (goto-char b))) 4205 ((and (eq (following-char) ?=) 4206 (eq (char-after (1+ (point))) ?\>)) 4207 ;; Check for { foo => 1, s => 2 } 4208 ;; Apparently s=> is never a substitution... 4209 (setq bb t)) 4210 ((and (eq (following-char) ?:) 4211 (eq b1 ?\{) ; Check for $ { s::bar } 4212 ;; (looking-at "::[a-zA-Z0-9_:]*[ \t\n\f]*}") 4213 (looking-at 4214 (rx (sequence "::" 4215 (eval cperl--normal-identifier-rx) 4216 (eval cperl--ws*-rx) 4217 "}"))) 4218 (progn 4219 (goto-char (1- go)) 4220 (skip-chars-backward " \t\n\f") 4221 (memq (preceding-char) 4222 (append "$@%&*" nil)))) 4223 (setq bb t)) 4224 ((eobp) 4225 (setq bb t))))) 4226 (if bb 4227 (goto-char i) 4228 ;; Skip whitespace and comments... 4229 (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+") 4230 (goto-char (match-end 0)) 4231 (skip-chars-forward " \t\n\f")) 4232 (if (> (point) b) 4233 (put-text-property b (point) 'syntax-type 'prestring)) 4234 ;; qtag means two-arg matcher, may be reset to 4235 ;; 2 or 3 later if some special quoting is needed. 4236 ;; e1 means matching-char matcher. 4237 (setq b (point) ; before the first delimiter 4238 ;; has 2 args 4239 i2 (string-match "^\\([sy]\\|tr\\)$" argument) 4240 ;; We do not search to max, since we may be called from 4241 ;; some hook of fontification, and max is random 4242 i (cperl-forward-re stop-point end 4243 i2 4244 st-l err-l argument) 4245 ;; If `go', then it is considered as 1-arg, `b1' is nil 4246 ;; as in s/foo//x; the point is before final "slash" 4247 b1 (nth 1 i) ; start of the second part 4248 tag (nth 2 i) ; ender-char, true if second part 4249 ; is with matching chars [] 4250 go (nth 4 i) ; There is a 1-char part after the end 4251 i (car i) ; intermediate point 4252 e1 (point) ; end 4253 ;; Before end of the second part if non-matching: /// 4254 tail (if (and i (not tag)) 4255 (1- e1)) 4256 e (if i i e1) ; end of the first part 4257 qtag nil ; need to preserve backslashitis 4258 is-x-REx nil is-o-REx nil); REx has //x //o modifiers 4259 ;; If s{} (), then b/b1 are at "{", "(", e1/i after ")", "}" 4260 ;; Commenting \\ is dangerous, what about ( ? 4261 (and i tail 4262 (eq (char-after i) ?\\) 4263 (setq qtag t)) 4264 (and (if go (looking-at ".\\sw*x") 4265 (looking-at "\\sw*x")) ; qr//x 4266 (setq is-x-REx t)) 4267 (and (if go (looking-at ".\\sw*o") 4268 (looking-at "\\sw*o")) ; //o 4269 (setq is-o-REx t)) 4270 (if (null i) 4271 ;; Considered as 1arg form 4272 (progn 4273 (cperl-commentify b (point) t) 4274 (put-text-property b (point) 'syntax-type 'string) 4275 (if (or is-x-REx 4276 ;; ignore other text properties: 4277 (string-match "^qw$" argument)) 4278 (put-text-property b (point) 'indentable t)) 4279 (and go 4280 (setq e1 (cperl-1+ e1)) 4281 (or (eobp) 4282 (forward-char 1)))) 4283 (cperl-commentify b i t) 4284 (if (looking-at "\\sw*e") ; s///e 4285 (progn 4286 ;; Cache the syntax info... 4287 (setq cperl-syntax-state (cons state-point state)) 4288 (and 4289 ;; silent: 4290 (car (cperl-find-pods-heres b1 (1- (point)) t end)) 4291 ;; Error 4292 (goto-char (1+ max))) 4293 (if (and tag (eq (preceding-char) ?\>)) 4294 (progn 4295 (cperl-modify-syntax-type (1- (point)) cperl-st-ket) 4296 (cperl-modify-syntax-type i cperl-st-bra))) 4297 (put-text-property b i 'syntax-type 'string) 4298 (put-text-property i (point) 'syntax-type 'multiline) 4299 (if is-x-REx 4300 (put-text-property b i 'indentable t))) 4301 (cperl-commentify b1 (point) t) 4302 (put-text-property b (point) 'syntax-type 'string) 4303 (if is-x-REx 4304 (put-text-property b i 'indentable t)) 4305 (if qtag 4306 (cperl-modify-syntax-type (1+ i) cperl-st-punct)) 4307 (setq tail nil))) 4308 ;; Now: tail: if the second part is non-matching without ///e 4309 (if (eq (char-syntax (following-char)) ?w) 4310 (progn 4311 (forward-word-strictly 1) ; skip modifiers s///s 4312 (if tail (cperl-commentify tail (point) t)) 4313 (cperl-postpone-fontification 4314 e1 (point) 'face my-cperl-REx-modifiers-face))) 4315 ;; Check whether it is m// which means "previous match" 4316 ;; and highlight differently 4317 (setq is-REx 4318 (and (string-match "^\\([sm]?\\|qr\\)$" argument) 4319 (or (not (= (length argument) 0)) 4320 (not (eq c ?\<))))) 4321 (if (and is-REx 4322 (eq e (+ 2 b)) 4323 ;; split // *is* using zero-pattern 4324 (save-excursion 4325 (condition-case nil 4326 (progn 4327 (goto-char tb) 4328 (forward-sexp -1) 4329 (not (looking-at "split\\>"))) 4330 (error t)))) 4331 (cperl-postpone-fontification 4332 b e 'face font-lock-warning-face) 4333 (if (or i2 ; Has 2 args 4334 (and cperl-fontify-m-as-s 4335 (or 4336 (string-match "^\\(m\\|qr\\)$" argument) 4337 (and (eq 0 (length argument)) 4338 (not (eq ?\< (char-after b))))))) 4339 (progn 4340 (cperl-postpone-fontification 4341 b (cperl-1+ b) 'face my-cperl-delimiters-face) 4342 (cperl-postpone-fontification 4343 (1- e) e 'face my-cperl-delimiters-face))) 4344 (if (and is-REx cperl-regexp-scan) 4345 ;; Process RExen: embedded comments, charclasses and ] 4346;;;/\3333\xFg\x{FFF}a\ppp\PPP\qqq\C\99f(?{ foo })(??{ foo })/; 4347;;;/a\.b[^a[:ff:]b]x$ab->$[|$,$ab->[cd]->[ef]|$ab[xy].|^${a,b}{c,d}/; 4348;;;/(?<=foo)(?<!bar)(x)(?:$ab|\$\/)$|\\\b\x888\776\[\:$/xxx; 4349;;;m?(\?\?{b,a})? + m/(??{aa})(?(?=xx)aa|bb)(?#aac)/; 4350;;;m$(^ab[c]\$)$ + m+(^ab[c]\$\+)+ + m](^ab[c\]$|.+)] + m)(^ab[c]$|.+\)); 4351;;;m^a[\^b]c^ + m.a[^b]\.c.; 4352 (save-excursion 4353 (goto-char (1+ b)) 4354 ;; First 4355 (cperl-look-at-leading-count is-x-REx e) 4356 (setq hairy-RE 4357 (concat 4358 (if is-x-REx 4359 (if (eq (char-after b) ?\#) 4360 "\\((\\?\\\\#\\)\\|\\(\\\\#\\)" 4361 "\\((\\?#\\)\\|\\(#\\)") 4362 ;; keep the same count: add a fake group 4363 (if (eq (char-after b) ?\#) 4364 "\\((\\?\\\\#\\)\\(\\)" 4365 "\\((\\?#\\)\\(\\)")) 4366 "\\|" 4367 "\\(\\[\\)" ; 3=[ 4368 "\\|" 4369 "\\(]\\)" ; 4=] 4370 "\\|" 4371 ;; XXXX Will not be able to use it in s))) 4372 (if (eq (char-after b) ?\) ) 4373 "\\())))\\)" ; Will never match 4374 (if (eq (char-after b) ?? ) 4375 ;;"\\((\\\\\\?\\(\\\\\\?\\)?{\\)" 4376 "\\((\\\\\\?\\\\\\?{\\|()\\\\\\?{\\)" 4377 "\\((\\?\\??{\\)")) ; 5= (??{ (?{ 4378 "\\|" ; 6= 0-length, 7: name, 8,9:code, 10:group 4379 "\\(" ;; XXXX 1-char variables, exc. |()\s 4380 "[$@]" 4381 "\\(" 4382 (rx (eval cperl--normal-identifier-rx)) 4383 "\\|" 4384 "{[^{}]*}" ; only one-level allowed 4385 "\\|" 4386 "[^{(|) \t\r\n\f]" 4387 "\\)" 4388 "\\(" ;;8,9:code part of array/hash elt 4389 "\\(" "->" "\\)?" 4390 "\\[[^][]*\\]" 4391 "\\|" 4392 "{[^{}]*}" 4393 "\\)*" 4394 ;; XXXX: what if u is delim? 4395 "\\|" 4396 "[)^|$.*?+]" 4397 "\\|" 4398 "{[0-9]+}" 4399 "\\|" 4400 "{[0-9]+,[0-9]*}" 4401 "\\|" 4402 "\\\\[luLUEQbBAzZG]" 4403 "\\|" 4404 "(" ; Group opener 4405 "\\(" ; 10 group opener follower 4406 "\\?\\((\\?\\)" ; 11: in (?(?=C)A|B) 4407 "\\|" 4408 "\\?[:=!>?{]" ; "?" something 4409 "\\|" 4410 "\\?[-imsx]+[:)]" ; (?i) (?-s:.) 4411 "\\|" 4412 "\\?([0-9]+)" ; (?(1)foo|bar) 4413 "\\|" 4414 "\\?<[=!]" 4415 ;;;"\\|" 4416 ;;; "\\?" 4417 "\\)?" 4418 "\\)" 4419 "\\|" 4420 "\\\\\\(.\\)" ; 12=\SYMBOL 4421 )) 4422 (while 4423 (and (< (point) (1- e)) 4424 (re-search-forward hairy-RE (1- e) 'to-end)) 4425 (goto-char (match-beginning 0)) 4426 (setq REx-subgr-start (point) 4427 was-subgr (following-char)) 4428 (cond 4429 ((match-beginning 6) ; 0-length builtins, groups 4430 (goto-char (match-end 0)) 4431 (if (match-beginning 11) 4432 (goto-char (match-beginning 11))) 4433 (if (>= (point) e) 4434 (goto-char (1- e))) 4435 (cperl-postpone-fontification 4436 (match-beginning 0) (point) 4437 'face 4438 (cond 4439 ((eq was-subgr ?\) ) 4440 (condition-case nil 4441 (save-excursion 4442 (forward-sexp -1) 4443 (if (> (point) b) 4444 (if (if (eq (char-after b) ?? ) 4445 (looking-at "(\\\\\\?") 4446 (eq (char-after (1+ (point))) ?\?)) 4447 my-cperl-REx-0length-face 4448 my-cperl-REx-ctl-face) 4449 font-lock-warning-face)) 4450 (error font-lock-warning-face))) 4451 ((eq was-subgr ?\| ) 4452 my-cperl-REx-ctl-face) 4453 ((eq was-subgr ?\$ ) 4454 (if (> (point) (1+ REx-subgr-start)) 4455 (progn 4456 (put-text-property 4457 (match-beginning 0) (point) 4458 'REx-interpolated 4459 (if is-o-REx 0 4460 (if (and (eq (match-beginning 0) 4461 (1+ b)) 4462 (eq (point) 4463 (1- e))) 1 t))) 4464 font-lock-variable-name-face) 4465 my-cperl-REx-spec-char-face)) 4466 ((memq was-subgr (append "^." nil) ) 4467 my-cperl-REx-spec-char-face) 4468 ((eq was-subgr ?\( ) 4469 (if (not (match-beginning 10)) 4470 my-cperl-REx-ctl-face 4471 my-cperl-REx-0length-face)) 4472 (t my-cperl-REx-0length-face))) 4473 (if (and (memq was-subgr (append "(|" nil)) 4474 (not (string-match "(\\?[-imsx]+)" 4475 (match-string 0)))) 4476 (cperl-look-at-leading-count is-x-REx e)) 4477 (setq was-subgr nil)) ; We do stuff here 4478 ((match-beginning 12) ; \SYMBOL 4479 (forward-char 2) 4480 (if (>= (point) e) 4481 (goto-char (1- e)) 4482 ;; How many chars to not highlight: 4483 ;; 0-len special-alnums in other branch => 4484 ;; Generic: \non-alnum (1), \alnum (1+face) 4485 ;; Is-delim: \non-alnum (1/spec-2) alnum-1 (=what hai) 4486 (setq REx-subgr-start (point) 4487 qtag (preceding-char)) 4488 (cperl-postpone-fontification 4489 (- (point) 2) (- (point) 1) 'face 4490 (if (memq qtag 4491 (append "ghijkmoqvFHIJKMORTVY" nil)) 4492 font-lock-warning-face 4493 my-cperl-REx-0length-face)) 4494 (if (and (eq (char-after b) qtag) 4495 (memq qtag (append ".])^$|*?+" nil))) 4496 (progn 4497 (if (and cperl-use-syntax-table-text-property 4498 (eq qtag ?\) )) 4499 (put-text-property 4500 REx-subgr-start (1- (point)) 4501 'syntax-table cperl-st-punct)) 4502 (cperl-postpone-fontification 4503 (1- (point)) (point) 'face 4504 ; \] can't appear below 4505 (if (memq qtag (append ".]^$" nil)) 4506 'my-cperl-REx-spec-char-face 4507 (if (memq qtag (append "*?+" nil)) 4508 'my-cperl-REx-0length-face 4509 'my-cperl-REx-ctl-face))))) ; )| 4510 ;; Test for arguments: 4511 (cond 4512 ;; This is not pretty: the 5.8.7 logic: 4513 ;; \0numx -> octal (up to total 3 dig) 4514 ;; \DIGIT -> backref unless \0 4515 ;; \DIGITs -> backref if valid 4516 ;; otherwise up to 3 -> octal 4517 ;; Do not try to distinguish, we guess 4518 ((or (and (memq qtag (append "01234567" nil)) 4519 (re-search-forward 4520 "\\=[01234567]?[01234567]?" 4521 (1- e) 'to-end)) 4522 (and (memq qtag (append "89" nil)) 4523 (re-search-forward 4524 "\\=[0123456789]*" (1- e) 'to-end)) 4525 (and (eq qtag ?x) 4526 (re-search-forward 4527 "\\=[[:xdigit:]][[:xdigit:]]?\\|\\={[[:xdigit:]]+}" 4528 (1- e) 'to-end)) 4529 (and (memq qtag (append "pPN" nil)) 4530 (re-search-forward "\\={[^{}]+}\\|." 4531 (1- e) 'to-end)) 4532 (eq (char-syntax qtag) ?w)) 4533 (cperl-postpone-fontification 4534 (1- REx-subgr-start) (point) 4535 'face my-cperl-REx-length1-face)))) 4536 (setq was-subgr nil)) ; We do stuff here 4537 ((match-beginning 3) ; [charclass] 4538 ;; Highlight leader, trailer, POSIX classes 4539 (forward-char 1) 4540 (if (eq (char-after b) ?^ ) 4541 (and (eq (following-char) ?\\ ) 4542 (eq (char-after (cperl-1+ (point))) 4543 ?^ ) 4544 (forward-char 2)) 4545 (and (eq (following-char) ?^ ) 4546 (forward-char 1))) 4547 (setq argument b ; continue? & end of last POSIX 4548 tag nil ; list of POSIX classes 4549 qtag (point)) ; after leading ^ if present 4550 (if (eq (char-after b) ?\] ) 4551 (and (eq (following-char) ?\\ ) 4552 (eq (char-after (cperl-1+ (point))) 4553 ?\] ) 4554 (setq qtag (1+ qtag)) 4555 (forward-char 2)) 4556 (and (eq (following-char) ?\] ) 4557 (forward-char 1))) 4558 (setq REx-subgr-end qtag) ;End smart-highlighted 4559 ;; Apparently, I can't put \] into a charclass 4560 ;; in m]]: m][\\\]\]] produces [\\]] 4561;;; POSIX? [:word:] [:^word:] only inside [] 4562;;; "\\=\\(\\\\.\\|[^][\\]\\|\\[:\\^?\sw+:]\\|\\[[^:]\\)*]") 4563 (while ; look for unescaped ] 4564 (and argument 4565 (re-search-forward 4566 (if (eq (char-after b) ?\] ) 4567 "\\=\\(\\\\[^]]\\|[^]\\]\\)*\\\\]" 4568 "\\=\\(\\\\.\\|[^]\\]\\)*]") 4569 (1- e) 'toend)) 4570 ;; Is this ] an end of POSIX class? 4571 (if (save-excursion 4572 (and 4573 (search-backward "[" argument t) 4574 (< REx-subgr-start (point)) 4575 (setq argument (point)) ; POSIX-start 4576 (or ; Should work with delim = \ 4577 (not (eq (preceding-char) ?\\ )) 4578 ;; XXXX Double \\ is needed with 19.33 4579 (= (% (skip-chars-backward "\\\\") 2) 0)) 4580 (looking-at 4581 (cond 4582 ((eq (char-after b) ?\] ) 4583 "\\\\*\\[:\\^?\\sw+:\\\\\\]") 4584 ((eq (char-after b) ?\: ) 4585 "\\\\*\\[\\\\:\\^?\\sw+\\\\:]") 4586 ((eq (char-after b) ?^ ) 4587 "\\\\*\\[:\\(\\\\\\^\\)?\\sw+:]") 4588 ((eq (char-syntax (char-after b)) 4589 ?w) 4590 (concat 4591 "\\\\*\\[:\\(\\\\\\^\\)?\\(\\\\" 4592 (char-to-string (char-after b)) 4593 "\\|\\sw\\)+:]")) 4594 (t "\\\\*\\[:\\^?\\sw*:]"))) 4595 (goto-char REx-subgr-end) 4596 (cperl-highlight-charclass 4597 argument my-cperl-REx-spec-char-face 4598 my-cperl-REx-0length-face my-cperl-REx-length1-face))) 4599 (setq tag (cons (cons argument (point)) 4600 tag) 4601 argument (point) 4602 REx-subgr-end argument) ; continue 4603 (setq argument nil))) 4604 (and argument 4605 (setq warning-message 4606 (format "Couldn't find end of charclass in a REx, pos=%s" 4607 REx-subgr-start))) 4608 (setq argument (1- (point))) 4609 (goto-char REx-subgr-end) 4610 (cperl-highlight-charclass 4611 argument my-cperl-REx-spec-char-face 4612 my-cperl-REx-0length-face my-cperl-REx-length1-face) 4613 (forward-char 1) 4614 ;; Highlight starter, trailer, POSIX 4615 (if (and cperl-use-syntax-table-text-property 4616 (> (- (point) 2) REx-subgr-start)) 4617 (put-text-property 4618 (1+ REx-subgr-start) (1- (point)) 4619 'syntax-table cperl-st-punct)) 4620 (cperl-postpone-fontification 4621 REx-subgr-start qtag 4622 'face my-cperl-REx-spec-char-face) 4623 (cperl-postpone-fontification 4624 (1- (point)) (point) 'face 4625 my-cperl-REx-spec-char-face) 4626 (if (eq (char-after b) ?\] ) 4627 (cperl-postpone-fontification 4628 (- (point) 2) (1- (point)) 4629 'face my-cperl-REx-0length-face)) 4630 (while tag 4631 (cperl-postpone-fontification 4632 (car (car tag)) (cdr (car tag)) 4633 'face font-lock-variable-name-face) ;my-cperl-REx-length1-face 4634 (setq tag (cdr tag))) 4635 (setq was-subgr nil)) ; did facing already 4636 ;; Now rare stuff: 4637 ((and (match-beginning 2) ; #-comment 4638 (/= (match-beginning 2) (match-end 2))) 4639 (beginning-of-line 2) 4640 (if (> (point) e) 4641 (goto-char (1- e)))) 4642 ((match-beginning 4) ; character "]" 4643 (setq was-subgr nil) ; We do stuff here 4644 (goto-char (match-end 0)) 4645 (if cperl-use-syntax-table-text-property 4646 (put-text-property 4647 (1- (point)) (point) 4648 'syntax-table cperl-st-punct)) 4649 (cperl-postpone-fontification 4650 (1- (point)) (point) 4651 'face font-lock-warning-face)) 4652 ((match-beginning 5) ; before (?{}) (??{}) 4653 (setq tag (match-end 0)) 4654 (if (or (setq qtag 4655 (cperl-forward-group-in-re st-l)) 4656 (and (>= (point) e) 4657 (setq qtag "no matching `)' found")) 4658 (and (not (eq (char-after (- (point) 2)) 4659 ?\} )) 4660 (setq qtag "Can't find })"))) 4661 (progn 4662 (goto-char (1- e)) 4663 (setq warning-message 4664 (format "%s" qtag))) 4665 (cperl-postpone-fontification 4666 (1- tag) (1- (point)) 4667 'face font-lock-variable-name-face) 4668 (cperl-postpone-fontification 4669 REx-subgr-start (1- tag) 4670 'face my-cperl-REx-spec-char-face) 4671 (cperl-postpone-fontification 4672 (1- (point)) (point) 4673 'face my-cperl-REx-spec-char-face) 4674 (if cperl-use-syntax-table-text-property 4675 (progn 4676 (put-text-property 4677 (- (point) 2) (1- (point)) 4678 'syntax-table cperl-st-cfence) 4679 (put-text-property 4680 (+ REx-subgr-start 2) 4681 (+ REx-subgr-start 3) 4682 'syntax-table cperl-st-cfence)))) 4683 (setq was-subgr nil)) 4684 (t ; (?#)-comment 4685 ;; Inside "(" and "\" aren't special in any way 4686 ;; Works also if the outside delimiters are (). 4687 (or;;(if (eq (char-after b) ?\) ) 4688 ;;(re-search-forward 4689 ;; "[^\\]\\(\\\\\\\\\\)*\\\\)" 4690 ;; (1- e) 'toend) 4691 (search-forward ")" (1- e) 'toend) 4692 ;;) 4693 (setq warning-message 4694 (format "Couldn't find end of (?#...)-comment in a REx, pos=%s" 4695 REx-subgr-start))))) 4696 (if (>= (point) e) 4697 (goto-char (1- e))) 4698 (cond 4699 (was-subgr 4700 (setq REx-subgr-end (point)) 4701 (cperl-commentify 4702 REx-subgr-start REx-subgr-end nil) 4703 (cperl-postpone-fontification 4704 REx-subgr-start REx-subgr-end 4705 'face font-lock-comment-face)))))) 4706 (if (and is-REx is-x-REx) 4707 (put-text-property (1+ b) (1- e) 4708 'syntax-subtype 'x-REx))) 4709 (if (and i2 e1 (or (not b1) (> e1 b1))) 4710 (progn ; No errors finding the second part... 4711 (cperl-postpone-fontification 4712 (1- e1) e1 'face my-cperl-delimiters-face) 4713 (if (and (not (eobp)) 4714 (assoc (char-after b) cperl-starters)) 4715 (progn 4716 (cperl-postpone-fontification 4717 b1 (1+ b1) 'face my-cperl-delimiters-face) 4718 (put-text-property b1 (1+ b1) 4719 'REx-part2 t))))) 4720 (if (> (point) max) 4721 (setq tmpend tb)))) 4722 ((match-beginning 17) ; sub with prototype or attribute 4723 ;; 1+6+2+1+1=11 extra () before this (sub with proto/attr): 4724 ;;"\\<sub\\>\\(" ;12 4725 ;; cperl-white-and-comment-rex ;13 4726 ;; "\\([a-zA-Z_:'0-9]+\\)\\)?" ; name ;14 4727 ;;"\\(" cperl-maybe-white-and-comment-rex ;15,16 4728 ;; "\\(([^()]*)\\|:[^:]\\)\\)" ; 17:proto or attribute start 4729 (setq b1 (match-beginning 14) e1 (match-end 14)) 4730 (if (memq (char-after (1- b)) 4731 '(?\$ ?\@ ?\% ?\& ?\*)) 4732 nil 4733 (goto-char b) 4734 (if (eq (char-after (match-beginning 17)) ?\( ) 4735 (progn 4736 (cperl-commentify ; Prototypes; mark as string 4737 (match-beginning 17) (match-end 17) t) 4738 (goto-char (match-end 0)) 4739 ;; Now look for attributes after prototype: 4740 (forward-comment (buffer-size)) 4741 (and (looking-at ":[^:]") 4742 (cperl-find-sub-attrs st-l b1 e1 b))) 4743 ;; treat attributes without prototype 4744 (goto-char (match-beginning 17)) 4745 (cperl-find-sub-attrs st-l b1 e1 b)))) 4746 ;; 1+6+2+1+1+6+1=18 extra () before this: 4747 ;; "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'") 4748 ((match-beginning 19) ; old $abc'efg syntax 4749 (setq bb (match-end 0)) 4750 ;;;(if (nth 3 state) nil ; in string 4751 (put-text-property (1- bb) bb 'syntax-table cperl-st-word) 4752 (goto-char bb)) 4753 ;; 1+6+2+1+1+6+1+1=19 extra () before this: 4754 ;; "__\\(END\\|DATA\\)__" 4755 ((match-beginning 20) ; __END__, __DATA__ 4756 (setq bb (match-end 0)) 4757 ;; (put-text-property b (1+ bb) 'syntax-type 'pod) ; Cheat 4758 (cperl-commentify b bb nil) 4759 (setq end t)) 4760 ;; "\\\\\\(['`\"($]\\)" 4761 ((match-beginning 21) 4762 ;; Trailing backslash; make non-quoting outside string/comment 4763 (setq bb (match-end 0)) 4764 (goto-char b) 4765 (skip-chars-backward "\\\\") 4766 ;;;(setq i2 (= (% (skip-chars-backward "\\\\") 2) -1)) 4767 (cperl-modify-syntax-type b cperl-st-punct) 4768 (goto-char bb)) 4769 (t (error "Error in regexp of the sniffer"))) 4770 (if (> (point) stop-point) 4771 (progn 4772 (if end 4773 (setq warning-message "Garbage after __END__/__DATA__ ignored") 4774 (setq warning-message "Unbalanced syntax found while scanning") 4775 (or (car err-l) (setcar err-l b))) 4776 (goto-char stop-point)))) 4777 (setq cperl-syntax-state (cons state-point state) 4778 ;; Do not mark syntax as done past tmpend??? 4779 cperl-syntax-done-to (or tmpend (max (point) max))) 4780 ;;(message "state-at=%s, done-to=%s" state-point cperl-syntax-done-to) 4781 ) 4782 (if (car err-l) (goto-char (car err-l)) 4783 (or non-inter 4784 (message "Scanning for \"hard\" Perl constructions... done")))) 4785 (and (buffer-modified-p) 4786 (not modified) 4787 (set-buffer-modified-p nil)) 4788 ;; I do not understand what this is doing here. It breaks font-locking 4789 ;; because it resets the syntax-table from font-lock-syntax-table to 4790 ;; cperl-mode-syntax-table. 4791 ;; (set-syntax-table cperl-mode-syntax-table) 4792 ) 4793 (when warning-message (message warning-message)) 4794 (list (car err-l) overshoot))) 4795 4796(defun cperl-find-pods-heres-region (min max) 4797 (interactive "r") 4798 (cperl-find-pods-heres min max)) 4799 4800(defun cperl-backward-to-noncomment (lim) 4801 ;; Stops at lim or after non-whitespace that is not in comment 4802 ;; XXXX Wrongly understands end-of-multiline strings with # as comment 4803 (let (stop p pr) 4804 (while (and (not stop) (> (point) (or lim (point-min)))) 4805 (skip-chars-backward " \t\n\f" lim) 4806 (setq p (point)) 4807 (beginning-of-line) 4808 (if (memq (setq pr (get-text-property (point) 'syntax-type)) 4809 '(pod here-doc here-doc-delim)) 4810 (progn 4811 (cperl-unwind-to-safe nil) 4812 (setq pr (get-text-property (point) 'syntax-type)))) 4813 (or (and (looking-at "^[ \t]*\\(#\\|$\\)") 4814 (not (memq pr '(string prestring)))) 4815 (progn (cperl-to-comment-or-eol) (bolp)) 4816 (progn 4817 (skip-chars-backward " \t") 4818 (if (< p (point)) (goto-char p)) 4819 (setq stop t)))))) 4820 4821;; Used only in `cperl-sniff-for-indent'... 4822(defun cperl-block-p () 4823 "Point is before ?\\{. Return true if it starts a block." 4824 ;; No save-excursion! This is more a distinguisher of a block/hash ref... 4825 (cperl-backward-to-noncomment (point-min)) 4826 (or (memq (preceding-char) (append ";){}$@&%\C-@" nil)) ; Or label! \C-@ at bobp 4827 ; Label may be mixed up with `$blah :' 4828 (save-excursion (cperl-after-label)) 4829 ;; text with the 'attrib-group property is also covered by the 4830 ;; next clause. We keep it because it is faster (for 4831 ;; subroutines with attributes). 4832 (get-text-property (cperl-1- (point)) 'attrib-group) 4833 (save-excursion (cperl-block-declaration-p)) 4834 (and (memq (char-syntax (preceding-char)) '(?w ?_)) 4835 (progn 4836 (backward-sexp) 4837 ;; sub {BLK}, print {BLK} $data, but NOT `bless', `return', `tr', `constant' 4838 ;; a-zA-Z is fine here, these are Perl keywords 4839 (or (and (looking-at "[a-zA-Z0-9_:]+[ \t\n\f]*[{#]") ; Method call syntax 4840 (not (looking-at "\\(bless\\|return\\|q[wqrx]?\\|tr\\|[smy]\\|constant\\)\\>"))) 4841 ;; sub bless::foo {} 4842 (progn 4843 (cperl-backward-to-noncomment (point-min)) 4844 (and (eq (preceding-char) ?b) 4845 (progn 4846 (forward-sexp -1) 4847 (looking-at (concat cperl-sub-regexp "[ \t\n\f#]")))))))))) 4848 4849;; What is the difference of (cperl-after-block-p lim t) and (cperl-block-p)? 4850;; No save-excursion; condition-case ... In (cperl-block-p) the block 4851;; may be a part of an in-statement construct, such as 4852;; ${something()}, print {FH} $data. 4853;; Moreover, one takes positive approach (looks for else,grep etc) 4854;; another negative (looks for bless,tr etc) 4855(defun cperl-after-block-p (lim &optional pre-block) 4856 "Return non-nil if the preceding } (if PRE-BLOCK, following {) delimits a block. 4857Would not look before LIM. Assumes that LIM is a good place to begin a 4858statement. The kind of block we treat here is one after which a new 4859statement would start; thus the block in ${func()} does not count." 4860 (save-excursion 4861 (condition-case nil 4862 (progn 4863 (or pre-block (forward-sexp -1)) 4864 (cperl-backward-to-noncomment lim) 4865 (or (eq (point) lim) 4866 ;; if () {} // sub f () {} // sub f :a(') {} 4867 (eq (preceding-char) ?\) ) 4868 ;; label: {} 4869 (save-excursion (cperl-after-label)) 4870 ;; sub :attr {} 4871 (get-text-property (cperl-1- (point)) 'attrib-group) 4872 (save-excursion (cperl-block-declaration-p)) 4873 (if (memq (char-syntax (preceding-char)) '(?w ?_)) ; else {} 4874 (save-excursion 4875 (forward-sexp -1) 4876 ;; else {} but not else::func {} 4877 (or (and (looking-at "\\(else\\|catch\\|try\\|continue\\|grep\\|map\\|BEGIN\\|END\\|UNITCHECK\\|CHECK\\|INIT\\)\\>") 4878 (not (looking-at "\\(\\sw\\|_\\)+::"))) 4879 ;; sub f {} 4880 (progn 4881 (cperl-backward-to-noncomment lim) 4882 (and (cperl-char-ends-sub-keyword-p (preceding-char)) 4883 (progn 4884 (forward-sexp -1) 4885 (looking-at 4886 (concat cperl-sub-regexp "[ \t\n\f#]"))))))) 4887 ;; What precedes is not word... XXXX Last statement in sub??? 4888 (cperl-after-expr-p lim)))) 4889 (error nil)))) 4890 4891(defun cperl-after-expr-p (&optional lim chars test) 4892 "Return non-nil if the position is good for start of expression. 4893TEST is the expression to evaluate at the found position. If absent, 4894CHARS is a string that contains good characters to have before us (however, 4895`}' is treated \"smartly\" if it is not in the list)." 4896 (let ((lim (or lim (point-min))) 4897 stop p) 4898 (cperl-update-syntaxification (point)) 4899 (save-excursion 4900 (while (and (not stop) (> (point) lim)) 4901 (skip-chars-backward " \t\n\f" lim) 4902 (setq p (point)) 4903 (beginning-of-line) 4904 ;;(memq (setq pr (get-text-property (point) 'syntax-type)) 4905 ;; '(pod here-doc here-doc-delim)) 4906 (if (get-text-property (point) 'here-doc-group) 4907 (progn 4908 (goto-char 4909 (cperl-beginning-of-property (point) 'here-doc-group)) 4910 (beginning-of-line 0))) 4911 (if (get-text-property (point) 'in-pod) 4912 (progn 4913 (goto-char 4914 (cperl-beginning-of-property (point) 'in-pod)) 4915 (beginning-of-line 0))) 4916 (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip 4917 ;; Else: last iteration, or a label 4918 (cperl-to-comment-or-eol) ; Will not move past "." after a format 4919 (skip-chars-backward " \t") 4920 (if (< p (point)) (goto-char p)) 4921 (setq p (point)) 4922 (if (and (eq (preceding-char) ?:) 4923 (progn 4924 (forward-char -1) 4925 (skip-chars-backward " \t\n\f" lim) 4926 (memq (char-syntax (preceding-char)) '(?w ?_)))) 4927 (forward-sexp -1) ; Possibly label. Skip it 4928 (goto-char p) 4929 (setq stop t)))) 4930 (or (bobp) ; ???? Needed 4931 (eq (point) lim) 4932 (looking-at "[ \t]*__\\(END\\|DATA\\)__") ; After this anything goes 4933 (progn 4934 (if test (eval test) 4935 (or (memq (preceding-char) (append (or chars "{;") nil)) 4936 (and (eq (preceding-char) ?\}) 4937 (cperl-after-block-p lim)) 4938 (and (eq (following-char) ?.) ; in format: see comment above 4939 (eq (get-text-property (point) 'syntax-type) 4940 'format))))))))) 4941 4942(defun cperl-backward-to-start-of-expr (&optional lim) 4943 (condition-case nil 4944 (progn 4945 (while (and (or (not lim) 4946 (> (point) lim)) 4947 (not (cperl-after-expr-p lim))) 4948 (forward-sexp -1) 4949 ;; May be after $, @, $# etc of a variable 4950 (skip-chars-backward "$@%#"))) 4951 (error nil))) 4952 4953(defun cperl-at-end-of-expr (&optional lim) 4954 ;; Since the SEXP approach below is very fragile, do some overengineering 4955 (or (looking-at (concat cperl-maybe-white-and-comment-rex "[;}]")) 4956 (condition-case nil 4957 (save-excursion 4958 ;; If nothing interesting after, does as (forward-sexp -1); 4959 ;; otherwise fails, or ends at a start of following sexp. 4960 ;; XXXX PROBLEMS: if what follows (after ";") @FOO, or ${bar} 4961 ;; may be stuck after @ or $; just put some stupid workaround now: 4962 (let ((p (point))) 4963 (forward-sexp 1) 4964 (forward-sexp -1) 4965 (while (memq (preceding-char) (append "%&@$*" nil)) 4966 (forward-char -1)) 4967 (or (< (point) p) 4968 (cperl-after-expr-p lim)))) 4969 (error t)))) 4970 4971(defun cperl-forward-to-end-of-expr (&optional lim) 4972 (condition-case nil 4973 (progn 4974 (while (and (< (point) (or lim (point-max))) 4975 (not (cperl-at-end-of-expr))) 4976 (forward-sexp 1))) 4977 (error nil))) 4978 4979(defun cperl-backward-to-start-of-continued-exp (lim) 4980 (if (memq (preceding-char) (append ")]}\"'`" nil)) 4981 (forward-sexp -1)) 4982 (beginning-of-line) 4983 (if (<= (point) lim) 4984 (goto-char (1+ lim))) 4985 (skip-chars-forward " \t")) 4986 4987(defun cperl-after-block-and-statement-beg (lim) 4988 "Return non-nil if the preceding ?} ends the statement." 4989 ;; We assume that we are after ?\} 4990 (and 4991 (cperl-after-block-p lim) 4992 (save-excursion 4993 (forward-sexp -1) 4994 (cperl-backward-to-noncomment (point-min)) 4995 (or (bobp) 4996 (eq (point) lim) 4997 (not (= (char-syntax (preceding-char)) ?w)) 4998 (progn 4999 (forward-sexp -1) 5000 (not 5001 (looking-at 5002 "\\(map\\|grep\\|say\\|printf?\\|system\\|exec\\|tr\\|s\\)\\>"))))))) 5003 5004 5005(defun cperl-indent-exp () 5006 "Simple variant of indentation of continued-sexp. 5007 5008Will not indent comment if it starts at `comment-indent' or looks like 5009continuation of the comment on the previous line. 5010 5011If `cperl-indent-region-fix-constructs', will improve spacing on 5012conditional/loop constructs." 5013 (interactive) 5014 (save-excursion 5015 (let ((tmp-end (point-at-eol)) top done) 5016 (save-excursion 5017 (beginning-of-line) 5018 (while (null done) 5019 (setq top (point)) 5020 ;; Plan A: if line has an unfinished paren-group, go to end-of-group 5021 (while (= -1 (nth 0 (parse-partial-sexp (point) tmp-end -1))) 5022 (setq top (point))) ; Get the outermost parens in line 5023 (goto-char top) 5024 (while (< (point) tmp-end) 5025 (parse-partial-sexp (point) tmp-end nil t) ; To start-sexp or eol 5026 (or (eolp) (forward-sexp 1))) 5027 (if (> (point) tmp-end) ; Check for an unfinished block 5028 nil 5029 (if (eq ?\) (preceding-char)) 5030 ;; closing parens can be preceded by up to three sexps 5031 (progn ;; Plan B: find by REGEXP block followup this line 5032 (setq top (point)) 5033 (condition-case nil 5034 (progn 5035 (forward-sexp -2) 5036 (if (eq (following-char) ?$ ) ; for my $var (list) 5037 (progn 5038 (forward-sexp -1) 5039 (if (looking-at "\\(state\\|my\\|local\\|our\\)\\>") 5040 (forward-sexp -1)))) 5041 (if (looking-at 5042 (concat "\\(elsif\\|if\\|unless\\|while\\|until" 5043 "\\|for\\(each\\)?\\>\\(\\(" 5044 cperl-maybe-white-and-comment-rex 5045 "\\(state\\|my\\|local\\|our\\)\\)?" 5046 cperl-maybe-white-and-comment-rex 5047 (rx 5048 (sequence 5049 "$" 5050 (eval cperl--basic-identifier-rx))) 5051 "\\)?\\)\\>")) 5052 (progn 5053 (goto-char top) 5054 (forward-sexp 1) 5055 (setq top (point))) 5056 ;; no block to be processed: expression ends here 5057 (setq done t))) 5058 (error (setq done t))) 5059 (goto-char top)) 5060 (if (looking-at ; Try Plan C: continuation block 5061 (concat cperl-maybe-white-and-comment-rex 5062 "\\<\\(else\\|elsif\\|continue\\)\\>")) 5063 (progn 5064 (goto-char (match-end 0)) 5065 (setq tmp-end (point-at-eol))) 5066 (setq done t)))) 5067 (setq tmp-end (point-at-eol))) 5068 (goto-char tmp-end) 5069 (setq tmp-end (point-marker))) 5070 (if cperl-indent-region-fix-constructs 5071 (cperl-fix-line-spacing tmp-end)) 5072 (cperl-indent-region (point) tmp-end)))) 5073 5074(defun cperl-fix-line-spacing (&optional end parse-data) 5075 "Improve whitespace in a conditional/loop construct. 5076Returns some position at the last line." 5077 (interactive) 5078 (or end 5079 (setq end (point-max))) 5080 (let ((ee (point-at-eol)) 5081 (cperl-indent-region-fix-constructs 5082 (or cperl-indent-region-fix-constructs 1)) 5083 p pp ml have-brace ret) 5084 (save-excursion 5085 (beginning-of-line) 5086 (setq ret (point)) 5087 ;; }? continue 5088 ;; blah; } 5089 (if (not 5090 (or (looking-at "[ \t]*\\(els\\(e\\|if\\)\\|continue\\|if\\|while\\|for\\(each\\)?\\|unless\\|until\\)\\_>") 5091 (setq have-brace (save-excursion (search-forward "}" ee t))))) 5092 nil ; Do not need to do anything 5093 ;; Looking at: 5094 ;; } 5095 ;; else 5096 (if cperl-merge-trailing-else 5097 (if (looking-at 5098 "[ \t]*}[ \t]*\n[ \t\n]*\\(els\\(e\\|if\\)\\|continue\\)\\_>") 5099 (progn 5100 (search-forward "}") 5101 (setq p (point)) 5102 (skip-chars-forward " \t\n") 5103 (delete-region p (point)) 5104 (insert (make-string cperl-indent-region-fix-constructs ?\s)) 5105 (beginning-of-line))) 5106 (if (looking-at "[ \t]*}[ \t]*\\(els\\(e\\|if\\)\\|continue\\)\\_>") 5107 (save-excursion 5108 (search-forward "}") 5109 (delete-horizontal-space) 5110 (insert "\n") 5111 (setq ret (point)) 5112 (if (cperl-indent-line parse-data) 5113 (progn 5114 (cperl-fix-line-spacing end parse-data) 5115 (setq ret (point))))))) 5116 ;; Looking at: 5117 ;; } else 5118 (if (looking-at "[ \t]*}\\(\t*\\|[ \t][ \t]+\\)\\<\\(els\\(e\\|if\\)\\|continue\\)\\_>") 5119 (progn 5120 (search-forward "}") 5121 (delete-horizontal-space) 5122 (insert (make-string cperl-indent-region-fix-constructs ?\s)) 5123 (beginning-of-line))) 5124 ;; Looking at: 5125 ;; else { 5126 (if (looking-at 5127 "[ \t]*}?[ \t]*\\<\\(els\\(e\\|if\\)\\|continue\\|unless\\|if\\|while\\|for\\(each\\)?\\|until\\)\\>\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]") 5128 (progn 5129 (forward-word-strictly 1) 5130 (delete-horizontal-space) 5131 (insert (make-string cperl-indent-region-fix-constructs ?\s)) 5132 (beginning-of-line))) 5133 ;; Looking at: 5134 ;; foreach my $var 5135 (if (looking-at 5136 "[ \t]*\\<for\\(each\\)?[ \t]+\\(state\\|my\\|local\\|our\\)\\(\t*\\|[ \t][ \t]+\\)[^ \t\n]") 5137 (progn 5138 (forward-word-strictly 2) 5139 (delete-horizontal-space) 5140 (insert (make-string cperl-indent-region-fix-constructs ?\s)) 5141 (beginning-of-line))) 5142 ;; Looking at: 5143 ;; foreach my $var ( 5144 (if (looking-at 5145 (rx (sequence (0+ blank) symbol-start 5146 "for" (opt "each") 5147 (1+ blank) 5148 (or "state" "my" "local" "our") 5149 (0+ blank) 5150 "$" (eval cperl--basic-identifier-rx) 5151 (1+ blank) 5152 (not (in " \t\n#"))))) 5153 (progn 5154 (forward-sexp 3) 5155 (delete-horizontal-space) 5156 (insert 5157 (make-string cperl-indent-region-fix-constructs ?\s)) 5158 (beginning-of-line))) 5159 ;; Looking at (with or without "}" at start, ending after "({"): 5160 ;; } foreach my $var () OR { 5161 (if (looking-at 5162 (rx (sequence 5163 (0+ blank) 5164 (opt (sequence "}" (0+ blank) )) 5165 symbol-start 5166 (or "else" "elsif" "continue" "if" "unless" "while" "until" 5167 (sequence (or "for" "foreach") 5168 (opt 5169 (opt (sequence (1+ blank) 5170 (or "state" "my" "local" "our"))) 5171 (0+ blank) 5172 "$" (eval cperl--basic-identifier-rx)))) 5173 symbol-end 5174 (group-n 1 5175 (or 5176 (or (sequence (0+ blank) "(") 5177 (sequence (eval cperl--ws*-rx) "{")) 5178 (sequence (0+ blank) "{")))))) 5179 (progn 5180 (setq ml (match-beginning 1)) ; "(" or "{" after control word 5181 (re-search-forward "[({]") 5182 (forward-char -1) 5183 (setq p (point)) 5184 (if (eq (following-char) ?\( ) 5185 (progn 5186 (forward-sexp 1) 5187 (setq pp (point))) ; past parenthesis-group 5188 ;; after `else' or nothing 5189 (if ml ; after `else' 5190 (skip-chars-backward " \t\n") 5191 (beginning-of-line)) 5192 (setq pp nil)) 5193 ;; Now after the sexp before the brace 5194 ;; Multiline expr should be special 5195 (setq ml (and pp (save-excursion (goto-char p) 5196 (search-forward "\n" pp t)))) 5197 (if (and (or (not pp) (< pp end)) ; Do not go too far... 5198 (looking-at "[ \t\n]*{")) 5199 (progn 5200 (cond 5201 ((bolp) ; Were before `{', no if/else/etc 5202 nil) 5203 ((looking-at "\\(\t*\\| [ \t]+\\){") ; Not exactly 1 SPACE 5204 (delete-horizontal-space) 5205 (if (if ml 5206 cperl-extra-newline-before-brace-multiline 5207 cperl-extra-newline-before-brace) 5208 (progn 5209 (delete-horizontal-space) 5210 (insert "\n") 5211 (setq ret (point)) 5212 (if (cperl-indent-line parse-data) 5213 (progn 5214 (cperl-fix-line-spacing end parse-data) 5215 (setq ret (point))))) 5216 (insert 5217 (make-string cperl-indent-region-fix-constructs ?\s)))) 5218 ((and (looking-at "[ \t]*\n") 5219 (not (if ml 5220 cperl-extra-newline-before-brace-multiline 5221 cperl-extra-newline-before-brace))) 5222 (setq pp (point)) 5223 (skip-chars-forward " \t\n") 5224 (delete-region pp (point)) 5225 (insert 5226 (make-string cperl-indent-region-fix-constructs ?\ ))) 5227 ((and (looking-at "[\t ]*{") 5228 (if ml cperl-extra-newline-before-brace-multiline 5229 cperl-extra-newline-before-brace)) 5230 (delete-horizontal-space) 5231 (insert "\n") 5232 (setq ret (point)) 5233 (if (cperl-indent-line parse-data) 5234 (progn 5235 (cperl-fix-line-spacing end parse-data) 5236 (setq ret (point)))))) 5237 ;; Now we are before `{' 5238 (if (looking-at "[ \t\n]*{[ \t]*[^ \t\n#]") 5239 (progn 5240 (skip-chars-forward " \t\n") 5241 (setq pp (point)) 5242 (forward-sexp 1) 5243 (setq p (point)) 5244 (goto-char pp) 5245 (setq ml (search-forward "\n" p t)) 5246 (if (or cperl-break-one-line-blocks-when-indent ml) 5247 ;; not good: multi-line BLOCK 5248 (progn 5249 (goto-char (1+ pp)) 5250 (delete-horizontal-space) 5251 (insert "\n") 5252 (setq ret (point)) 5253 (if (cperl-indent-line parse-data) 5254 (setq ret (cperl-fix-line-spacing end parse-data))))))))))) 5255 (beginning-of-line) 5256 (setq p (point) pp (point-at-eol)) ; May be different from ee. 5257 ;; Now check whether there is a hanging `}' 5258 ;; Looking at: 5259 ;; } blah 5260 (if (and 5261 cperl-fix-hanging-brace-when-indent 5262 have-brace 5263 (not (looking-at "[ \t]*}[ \t]*\\(\\<\\(els\\(if\\|e\\)\\|continue\\|while\\|until\\)\\>\\|$\\|#\\)")) 5264 (condition-case nil 5265 (progn 5266 (up-list 1) 5267 (if (and (<= (point) pp) 5268 (eq (preceding-char) ?\} ) 5269 (cperl-after-block-and-statement-beg (point-min))) 5270 t 5271 (goto-char p) 5272 nil)) 5273 (error nil))) 5274 (progn 5275 (forward-char -1) 5276 (skip-chars-backward " \t") 5277 (if (bolp) 5278 ;; `}' was the first thing on the line, insert NL *after* it. 5279 (progn 5280 (cperl-indent-line parse-data) 5281 (search-forward "}") 5282 (delete-horizontal-space) 5283 (insert "\n")) 5284 (delete-horizontal-space) 5285 (or (eq (preceding-char) ?\;) 5286 (bolp) 5287 (and (eq (preceding-char) ?\} ) 5288 (cperl-after-block-p (point-min))) 5289 (insert ";")) 5290 (insert "\n") 5291 (setq ret (point))) 5292 (if (cperl-indent-line parse-data) 5293 (setq ret (cperl-fix-line-spacing end parse-data))) 5294 (beginning-of-line))))) 5295 ret)) 5296 5297(defvar cperl-update-start) ; Do not need to make them local 5298(defvar cperl-update-end) 5299(defun cperl-delay-update-hook (beg end _old-len) 5300 (setq cperl-update-start (min beg (or cperl-update-start (point-max)))) 5301 (setq cperl-update-end (max end (or cperl-update-end (point-min))))) 5302 5303(defun cperl-indent-region (start end) 5304 "Simple variant of indentation of region in CPerl mode. 5305Should be slow. Will not indent comment if it starts at `comment-indent' 5306or looks like continuation of the comment on the previous line. 5307Indents all the lines whose first character is between START and END 5308inclusive. 5309 5310If `cperl-indent-region-fix-constructs', will improve spacing on 5311conditional/loop constructs." 5312 (interactive "r") 5313 (cperl-update-syntaxification end) 5314 (save-excursion 5315 (let (cperl-update-start cperl-update-end (h-a-c after-change-functions)) 5316 (let ((indent-info (list nil nil nil) ; Cannot use '(), since will modify 5317 ) 5318 after-change-functions ; Speed it up! 5319 comm old-comm-indent new-comm-indent i empty) 5320 (if h-a-c (add-hook 'after-change-functions #'cperl-delay-update-hook)) 5321 (goto-char start) 5322 (setq old-comm-indent (and (cperl-to-comment-or-eol) 5323 (current-column)) 5324 new-comm-indent old-comm-indent) 5325 (goto-char start) 5326 (setq end (set-marker (make-marker) end)) ; indentation changes pos 5327 (or (bolp) (beginning-of-line 2)) 5328 (while (and (<= (point) end) (not (eobp))) ; bol to check start 5329 (if (or 5330 (setq empty (looking-at "[ \t]*\n")) 5331 (and (setq comm (looking-at "[ \t]*#")) 5332 (or (eq (current-indentation) (or old-comm-indent 5333 comment-column)) 5334 (setq old-comm-indent nil)))) 5335 (if (and old-comm-indent 5336 (not empty) 5337 (= (current-indentation) old-comm-indent) 5338 (not (eq (get-text-property (point) 'syntax-type) 'pod)) 5339 (not (eq (get-text-property (point) 'syntax-table) 5340 cperl-st-cfence))) 5341 (let ((comment-column new-comm-indent)) 5342 (indent-for-comment))) 5343 (progn 5344 (setq i (cperl-indent-line indent-info)) 5345 (or comm 5346 (not i) 5347 (progn 5348 (if cperl-indent-region-fix-constructs 5349 (goto-char (cperl-fix-line-spacing end indent-info))) 5350 (if (setq old-comm-indent 5351 (and (cperl-to-comment-or-eol) 5352 (not (memq (get-text-property (point) 5353 'syntax-type) 5354 '(pod here-doc))) 5355 (not (eq (get-text-property (point) 5356 'syntax-table) 5357 cperl-st-cfence)) 5358 (current-column))) 5359 (progn (indent-for-comment) 5360 (skip-chars-backward " \t") 5361 (skip-chars-backward "#") 5362 (setq new-comm-indent (current-column)))))))) 5363 (beginning-of-line 2))) 5364 ;; Now run the update hooks 5365 (and after-change-functions 5366 cperl-update-end 5367 (save-excursion 5368 (goto-char cperl-update-end) 5369 (insert " ") 5370 (delete-char -1) 5371 (goto-char cperl-update-start) 5372 (insert " ") 5373 (delete-char -1)))))) 5374 5375;; Stolen from lisp-mode with a lot of improvements 5376 5377(defun cperl-fill-paragraph (&optional justify iteration) 5378 "Like `fill-paragraph', but handle CPerl comments. 5379If any of the current line is a comment, fill the comment or the 5380block of it that point is in, preserving the comment's initial 5381indentation and initial hashes. Behaves usually outside of comment." 5382 ;; (interactive "P") ; Only works when called from fill-paragraph. -stef 5383 (let (;; Non-nil if the current line contains a comment. 5384 has-comment 5385 fill-paragraph-function ; do not recurse 5386 ;; If has-comment, the appropriate fill-prefix for the comment. 5387 comment-fill-prefix 5388 ;; Line that contains code and comment (or nil) 5389 start 5390 c spaces len dc (comment-column comment-column)) 5391 ;; Figure out what kind of comment we are looking at. 5392 (save-excursion 5393 (beginning-of-line) 5394 (cond 5395 5396 ;; A line with nothing but a comment on it? 5397 ((looking-at "[ \t]*#[# \t]*") 5398 (setq has-comment t 5399 comment-fill-prefix (buffer-substring (match-beginning 0) 5400 (match-end 0)))) 5401 5402 ;; A line with some code, followed by a comment? Remember that the 5403 ;; semi which starts the comment shouldn't be part of a string or 5404 ;; character. 5405 ((cperl-to-comment-or-eol) 5406 (setq has-comment t) 5407 (looking-at "#+[ \t]*") 5408 (setq start (point) c (current-column) 5409 comment-fill-prefix 5410 (concat (make-string (current-column) ?\s) 5411 (buffer-substring (match-beginning 0) (match-end 0))) 5412 spaces (progn (skip-chars-backward " \t") 5413 (buffer-substring (point) start)) 5414 dc (- c (current-column)) len (- start (point)) 5415 start (point-marker)) 5416 (delete-char len) 5417 (insert (make-string dc ?-))))) ; Placeholder (to avoid splitting???) 5418 (if (not has-comment) 5419 (fill-paragraph justify) ; Do the usual thing outside of comment 5420 ;; Narrow to include only the comment, and then fill the region. 5421 (save-restriction 5422 (narrow-to-region 5423 ;; Find the first line we should include in the region to fill. 5424 (if start (progn (beginning-of-line) (point)) 5425 (save-excursion 5426 (while (and (zerop (forward-line -1)) 5427 (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]"))) 5428 ;; We may have gone to far. Go forward again. 5429 (or (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]") 5430 (forward-line 1)) 5431 (point))) 5432 ;; Find the beginning of the first line past the region to fill. 5433 (save-excursion 5434 (while (progn (forward-line 1) 5435 (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]"))) 5436 (point))) 5437 ;; Remove existing hashes 5438 (goto-char (point-min)) 5439 (save-excursion 5440 (while (progn (forward-line 1) (< (point) (point-max))) 5441 (skip-chars-forward " \t") 5442 (if (looking-at "#+") 5443 (progn 5444 (if (and (eq (point) (match-beginning 0)) 5445 (not (eq (point) (match-end 0)))) nil 5446 (error 5447 "Bug in Emacs: `looking-at' in `narrow-to-region': match-data is garbage")) 5448 (delete-char (- (match-end 0) (match-beginning 0))))))) 5449 5450 ;; Lines with only hashes on them can be paragraph boundaries. 5451 (let ((paragraph-start (concat paragraph-start "\\|^[ \t#]*$")) 5452 (paragraph-separate (concat paragraph-start "\\|^[ \t#]*$")) 5453 (fill-prefix comment-fill-prefix)) 5454 (fill-paragraph justify))) 5455 (if (and start) 5456 (progn 5457 (goto-char start) 5458 (if (> dc 0) 5459 (progn (delete-char dc) (insert spaces))) 5460 (if (or (= (current-column) c) iteration) nil 5461 (setq comment-column c) 5462 (indent-for-comment) 5463 ;; Repeat once more, flagging as iteration 5464 (cperl-fill-paragraph justify t)))))) 5465 t) 5466 5467(defun cperl-do-auto-fill () 5468 ;; Break out if the line is short enough 5469 (if (> (save-excursion 5470 (end-of-line) 5471 (current-column)) 5472 fill-column) 5473 (let ((c (save-excursion (beginning-of-line) 5474 (cperl-to-comment-or-eol) (point))) 5475 (s (memq (following-char) '(?\s ?\t))) marker) 5476 (if (>= c (point)) 5477 ;; Don't break line inside code: only inside comment. 5478 nil 5479 (setq marker (point-marker)) 5480 (fill-paragraph nil) 5481 (goto-char marker) 5482 ;; Is not enough, sometimes marker is a start of line 5483 (if (bolp) (progn (re-search-forward "#+[ \t]*") 5484 (goto-char (match-end 0)))) 5485 ;; Following space could have gone: 5486 (if (or (not s) (memq (following-char) '(?\s ?\t))) nil 5487 (insert " ") 5488 (backward-char 1)) 5489 ;; Previous space could have gone: 5490 (or (memq (preceding-char) '(?\s ?\t)) (insert " ")))))) 5491 5492(defvar cperl-imenu-package-keywords '("package" "class" "role")) 5493(defvar cperl-imenu-sub-keywords '("sub" "method" "function" "fun")) 5494(defvar cperl-imenu-pod-keywords '("=head")) 5495 5496(defun cperl-imenu--create-perl-index () 5497 "Implement `imenu-create-index-function' for CPerl mode. 5498This function relies on syntaxification to exclude lines which 5499look like declarations but actually are part of a string, a 5500comment, or POD." 5501 (interactive) ; We'll remove that at some point 5502 (goto-char (point-min)) 5503 (cperl-update-syntaxification (point-max)) 5504 (let ((case-fold-search nil) 5505 (index-alist '()) 5506 (index-package-alist '()) 5507 (index-pod-alist '()) 5508 (index-sub-alist '()) 5509 (index-unsorted-alist '()) 5510 (package-stack '()) ; for package NAME BLOCK 5511 (current-package "(main)") 5512 (current-package-end (point-max))) ; end of package scope 5513 ;; collect index entries 5514 (while (re-search-forward (rx (eval cperl--imenu-entries-rx)) nil t) 5515 ;; First, check whether we have left the scope of previously 5516 ;; recorded packages, and if so, eliminate them from the stack. 5517 (while (< current-package-end (point)) 5518 (setq current-package (pop package-stack)) 5519 (setq current-package-end (pop package-stack))) 5520 (let ((state (syntax-ppss)) 5521 (entry-type (match-string 1)) 5522 name marker) ; for the "current" entry 5523 (cond 5524 ((nth 3 state) nil) ; matched in a string, so skip 5525 ((member entry-type cperl-imenu-package-keywords) ; package or class 5526 (unless (nth 4 state) ; skip if in a comment 5527 (setq name (match-string-no-properties 2) 5528 marker (copy-marker (match-end 2))) 5529 (if (string= (match-string 3) ";") 5530 (setq current-package name) ; package NAME; 5531 ;; No semicolon, therefore we have: package NAME BLOCK. 5532 ;; Stash the current package, because we need to restore 5533 ;; it after the end of BLOCK. 5534 (push current-package-end package-stack) 5535 (push current-package package-stack) 5536 ;; record the current name and its scope 5537 (setq current-package name) 5538 (setq current-package-end (save-excursion 5539 (goto-char (match-beginning 3)) 5540 (forward-sexp) 5541 (point)))) 5542 (push (cons name marker) index-package-alist) 5543 (push (cons (concat entry-type " " name) marker) index-unsorted-alist))) 5544 ((or (member entry-type cperl-imenu-sub-keywords) ; sub or method 5545 (string-equal entry-type "")) ; named blocks 5546 (unless (nth 4 state) ; skip if in a comment 5547 (setq name (match-string-no-properties 2) 5548 marker (copy-marker (match-end 2))) 5549 ;; Qualify the sub name with the package if it doesn't 5550 ;; already have one, and if it isn't lexically scoped. 5551 ;; "my" and "state" subs are lexically scoped, but "our" 5552 ;; are just lexical aliases to package subs. 5553 (if (and (null (string-match "::" name)) 5554 (or (null (match-string 3)) 5555 (string-equal (match-string 3) "our"))) 5556 (setq name (concat current-package "::" name))) 5557 (let ((index (cons name marker))) 5558 (push index index-alist) 5559 (push index index-sub-alist) 5560 (push index index-unsorted-alist)))) 5561 ((member entry-type cperl-imenu-pod-keywords) ; POD heading 5562 (when (get-text-property (match-beginning 2) 'in-pod) 5563 (setq name (concat (make-string 5564 (* 3 (- (char-after (match-beginning 3)) ?1)) 5565 ?\ ) 5566 (match-string-no-properties 2)) 5567 marker (copy-marker (match-beginning 2))) 5568 (push (cons name marker) index-pod-alist) 5569 (push (cons (concat "=" name) marker) index-unsorted-alist))) 5570 (t (error "Unidentified match: %s" (match-string 0)))))) 5571 ;; Now format the collected stuff 5572 (setq index-alist 5573 (if (default-value 'imenu-sort-function) 5574 (sort index-alist (default-value 'imenu-sort-function)) 5575 (nreverse index-alist))) 5576 (and index-pod-alist 5577 (push (cons "+POD headers+..." 5578 (nreverse index-pod-alist)) 5579 index-alist)) 5580 (and (or index-package-alist index-sub-alist) 5581 (let ((lst index-package-alist) hier-list pack elt group name) 5582 ;; reverse and uniquify. 5583 (while lst 5584 (setq elt (car lst) lst (cdr lst) name (car elt)) 5585 (if (assoc name hier-list) nil 5586 (setq hier-list (cons (cons name (cdr elt)) hier-list)))) 5587 (setq lst index-sub-alist) 5588 (while lst 5589 (setq elt (car lst) lst (cdr lst)) 5590 (cond ((string-match 5591 (rx (sequence (or "::" "'") 5592 (eval cperl--basic-identifier-rx) 5593 string-end)) 5594 (car elt)) 5595 (setq pack (substring (car elt) 0 (match-beginning 0))) 5596 (if (setq group (assoc pack hier-list)) 5597 (if (listp (cdr group)) 5598 ;; Have some functions already 5599 (setcdr group 5600 (cons (cons (substring 5601 (car elt) 5602 (+ 2 (match-beginning 0))) 5603 (cdr elt)) 5604 (cdr group))) 5605 (setcdr group (list (cons (substring 5606 (car elt) 5607 (+ 2 (match-beginning 0))) 5608 (cdr elt))))) 5609 (setq hier-list 5610 (cons (cons pack 5611 (list (cons (substring 5612 (car elt) 5613 (+ 2 (match-beginning 0))) 5614 (cdr elt)))) 5615 hier-list)))))) 5616 (push (cons "+Hierarchy+..." 5617 hier-list) 5618 index-alist))) 5619 (and index-package-alist 5620 (push (cons "+Packages+..." 5621 (nreverse index-package-alist)) 5622 index-alist)) 5623 (and (or index-package-alist index-pod-alist 5624 (default-value 'imenu-sort-function)) 5625 index-unsorted-alist 5626 (push (cons "+Unsorted List+..." 5627 (nreverse index-unsorted-alist)) 5628 index-alist)) 5629 ;; Finally, return the whole collection 5630 index-alist)) 5631 5632 5633;; Suggested by Mark A. Hershberger 5634(defun cperl-outline-level () 5635 (looking-at outline-regexp) 5636 (cond ((not (match-beginning 1)) 0) ; beginning-of-file 5637 ;; 2=package-group, 5=package-name 8=sub-name 16=head-level 5638 ((match-beginning 2) 0) ; package 5639 ((match-beginning 8) 1) ; sub 5640 ((match-beginning 16) 5641 (- (char-after (match-beginning 16)) ?0)) ; headN ==> N 5642 (t 5))) ; should not happen 5643 5644 5645(defun cperl-windowed-init () 5646 "Initialization under windowed version." 5647 (cond ((featurep 'ps-print) 5648 (or cperl-faces-init 5649 (progn 5650 (setq cperl-font-lock-multiline t) 5651 (cperl-init-faces)))) 5652 ((not cperl-faces-init) 5653 (add-hook 'font-lock-mode-hook 5654 (lambda () 5655 (if (memq major-mode '(perl-mode cperl-mode)) 5656 (progn 5657 (or cperl-faces-init (cperl-init-faces)))))) 5658 (eval-after-load 5659 "ps-print" 5660 '(or cperl-faces-init (cperl-init-faces)))))) 5661 5662(defvar cperl-font-lock-keywords-1 nil 5663 "Additional expressions to highlight in Perl mode. Minimal set.") 5664(defvar cperl-font-lock-keywords nil 5665 "Additional expressions to highlight in Perl mode. Default set.") 5666(defvar cperl-font-lock-keywords-2 nil 5667 "Additional expressions to highlight in Perl mode. Maximal set.") 5668 5669(defun cperl-load-font-lock-keywords () 5670 (or cperl-faces-init (cperl-init-faces)) 5671 cperl-font-lock-keywords) 5672 5673(defun cperl-load-font-lock-keywords-1 () 5674 (or cperl-faces-init (cperl-init-faces)) 5675 cperl-font-lock-keywords-1) 5676 5677(defun cperl-load-font-lock-keywords-2 () 5678 (or cperl-faces-init (cperl-init-faces)) 5679 cperl-font-lock-keywords-2) 5680 5681(defun cperl-font-lock-syntactic-face-function (state) 5682 "Apply faces according to their syntax type. 5683In CPerl mode, this is used for here-documents which have been 5684marked as c-style comments. For everything else, delegate to the 5685default function." 5686 (cond 5687 ;; A c-style comment is a HERE-document. Fontify if requested. 5688 ((and (eq 2 (nth 7 state)) 5689 cperl-pod-here-fontify) 5690 cperl-here-face) 5691 (t (funcall (default-value 'font-lock-syntactic-face-function) state)))) 5692 5693(defun cperl-init-faces () 5694 (condition-case errs 5695 (progn 5696 (let (t-font-lock-keywords t-font-lock-keywords-1) 5697 (setq 5698 t-font-lock-keywords 5699 (list 5700 `("[ \t]+$" 0 ',cperl-invalid-face t) 5701 (cons 5702 (concat 5703 "\\(^\\|[^$@%&\\]\\)\\<\\(" 5704 (regexp-opt 5705 (append 5706 cperl-sub-keywords 5707 '("if" "until" "while" "elsif" "else" 5708 "given" "when" "default" "break" 5709 "unless" "for" 5710 "try" "catch" "finally" 5711 "foreach" "continue" "exit" "die" "last" "goto" "next" 5712 "redo" "return" "local" "exec" 5713 "do" "dump" 5714 "use" "our" 5715 "require" "package" "eval" "evalbytes" "my" "state" 5716 "BEGIN" "END" "CHECK" "INIT" "UNITCHECK"))) ; Flow control 5717 "\\)\\>") 2) ; was "\\)[ \n\t;():,|&]" 5718 ; In what follows we use `type' style 5719 ; for overwritable builtins 5720 (list 5721 (concat 5722 "\\(^\\|[^$@%&\\]\\)\\<\\(" 5723 (regexp-opt 5724 '("CORE" "__FILE__" "__LINE__" "__SUB__" "__PACKAGE__" 5725 "abs" "accept" "alarm" "and" "atan2" 5726 "bind" "binmode" "bless" "caller" 5727 "chdir" "chmod" "chown" "chr" "chroot" "close" 5728 "closedir" "cmp" "connect" "continue" "cos" "crypt" 5729 "dbmclose" "dbmopen" "die" "dump" "endgrent" 5730 "endhostent" "endnetent" "endprotoent" "endpwent" 5731 "endservent" "eof" "eq" "exec" "exit" "exp" "fc" "fcntl" 5732 "fileno" "flock" "fork" "formline" "ge" "getc" 5733 "getgrent" "getgrgid" "getgrnam" "gethostbyaddr" 5734 "gethostbyname" "gethostent" "getlogin" 5735 "getnetbyaddr" "getnetbyname" "getnetent" 5736 "getpeername" "getpgrp" "getppid" "getpriority" 5737 "getprotobyname" "getprotobynumber" "getprotoent" 5738 "getpwent" "getpwnam" "getpwuid" "getservbyname" 5739 "getservbyport" "getservent" "getsockname" 5740 "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int" 5741 "ioctl" "join" "kill" "lc" "lcfirst" "le" "length" 5742 "link" "listen" "localtime" "lock" "log" "lstat" "lt" 5743 "mkdir" "msgctl" "msgget" "msgrcv" "msgsnd" "ne" 5744 "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe" 5745 "quotemeta" "rand" "read" "readdir" "readline" 5746 "readlink" "readpipe" "recv" "ref" "rename" "require" 5747 "reset" "reverse" "rewinddir" "rindex" "rmdir" "seek" 5748 "seekdir" "select" "semctl" "semget" "semop" "send" 5749 "setgrent" "sethostent" "setnetent" "setpgrp" 5750 "setpriority" "setprotoent" "setpwent" "setservent" 5751 "setsockopt" "shmctl" "shmget" "shmread" "shmwrite" 5752 "shutdown" "sin" "sleep" "socket" "socketpair" 5753 "sprintf" "sqrt" "srand" "stat" "substr" "symlink" 5754 "syscall" "sysopen" "sysread" "sysseek" "system" "syswrite" "tell" 5755 "telldir" "time" "times" "truncate" "uc" "ucfirst" 5756 "umask" "unlink" "unpack" "utime" "values" "vec" 5757 "wait" "waitpid" "wantarray" "warn" "write" "x" "xor")) 5758 "\\)\\>") 5759 2 'font-lock-type-face) 5760 ;; In what follows we use `other' style 5761 ;; for nonoverwritable builtins 5762 (list 5763 (concat 5764 "\\(^\\|[^$@%&\\]\\)\\<\\(" 5765 (regexp-opt 5766 '("AUTOLOAD" "BEGIN" "CHECK" "DESTROY" "END" "INIT" "UNITCHECK" 5767 "__END__" "__DATA__" "break" "catch" "chomp" "chop" "default" 5768 "defined" "delete" "do" "each" "else" "elsif" "eval" 5769 "evalbytes" "exists" "finally" "for" "foreach" "format" "given" 5770 "goto" "grep" "if" "keys" "last" "local" "m" "map" "my" "next" 5771 "no" "our" "package" "pop" "pos" "print" "printf" "prototype" 5772 "push" "q" "qq" "qr" "qw" "qx" "redo" "return" "s" "say" "scalar" 5773 "shift" "sort" "splice" "split" "state" "study" "sub" "tie" 5774 "tied" "tr" "try" "undef" "unless" "unshift" "untie" "until" 5775 "use" "when" "while" "y")) 5776 "\\)\\>") 5777 2 ''cperl-nonoverridable-face) ; unbound as var, so: doubly quoted 5778 ;; (mapconcat #'identity 5779 ;; '("#endif" "#else" "#ifdef" "#ifndef" "#if" 5780 ;; "#include" "#define" "#undef") 5781 ;; "\\|") 5782 '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0 5783 font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]" 5784 ;; This highlights declarations and definitions differently. 5785 ;; We do not try to highlight in the case of attributes: 5786 ;; it is already done by `cperl-find-pods-heres' 5787 (list (concat "\\<" cperl-sub-regexp 5788 cperl-white-and-comment-rex ; whitespace/comments 5789 "\\([^ \n\t{;()]+\\)" ; 2=name (assume non-anonymous) 5790 "\\(" 5791 cperl-maybe-white-and-comment-rex ;whitespace/comments? 5792 "([^()]*)\\)?" ; prototype 5793 cperl-maybe-white-and-comment-rex ; whitespace/comments? 5794 "[{;]") 5795 2 (if cperl-font-lock-multiline 5796 '(if (eq (char-after (cperl-1- (match-end 0))) ?\{ ) 5797 'font-lock-function-name-face 5798 'font-lock-variable-name-face) 5799 ;; need to manually set 'multiline' for older font-locks 5800 '(progn 5801 (if (< 1 (count-lines (match-beginning 0) 5802 (match-end 0))) 5803 (put-text-property 5804 (+ 3 (match-beginning 0)) (match-end 0) 5805 'syntax-type 'multiline)) 5806 (if (eq (char-after (cperl-1- (match-end 0))) ?\{ ) 5807 'font-lock-function-name-face 5808 'font-lock-variable-name-face)))) 5809 `(,(rx (sequence symbol-start 5810 (or "package" "require" "use" "import" 5811 "no" "bootstrap") 5812 (eval cperl--ws+-rx) 5813 (group-n 1 (eval cperl--normal-identifier-rx)) 5814 (any " \t;"))) ; require A if B; 5815 1 font-lock-function-name-face) 5816 '("^[ \t]*format[ \t]+\\([a-zA-Z_][a-zA-Z_0-9:]*\\)[ \t]*=[ \t]*$" 5817 1 font-lock-function-name-face) 5818 ;; bareword hash key: $foo{bar} 5819 `(,(rx (or (in "]}\\%@>*&") ; What Perl is this? 5820 (sequence "$" (eval cperl--normal-identifier-rx))) 5821 (0+ blank) "{" (0+ blank) 5822 (group-n 1 (sequence (opt "-") 5823 (eval cperl--basic-identifier-rx))) 5824 (0+ blank) "}") 5825;; '("\\([]}\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" 5826 (1 font-lock-string-face t) 5827 ;; anchored bareword hash key: $foo{bar}{baz} 5828 (,(rx point 5829 (0+ blank) "{" (0+ blank) 5830 (group-n 1 (sequence (opt "-") 5831 (eval cperl--basic-identifier-rx))) 5832 (0+ blank) "}") 5833 ;; ("\\=[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" 5834 nil nil 5835 (1 font-lock-string-face t))) 5836 ;; hash element assignments with bareword key => value 5837 `(,(rx (in "[ \t{,()") 5838 (group-n 1 (sequence (opt "-") 5839 (eval cperl--basic-identifier-rx))) 5840 (0+ blank) "=>") 5841 1 font-lock-string-face t) 5842;; '("[[ \t{,(]\\(-?[a-zA-Z0-9_:]+\\)[ \t]*=>" 1 5843;; font-lock-string-face t) 5844 ;; labels 5845 `(,(rx 5846 (sequence 5847 (0+ space) 5848 (group (eval cperl--label-rx)) 5849 (0+ space) 5850 (or line-end "#" "{" 5851 (sequence word-start 5852 (or "until" "while" "for" "foreach" "do") 5853 word-end)))) 5854 1 font-lock-constant-face) 5855 ;; labels as targets (no trailing colon!) 5856 `(,(rx 5857 (sequence 5858 symbol-start 5859 (or "continue" "next" "last" "redo" "break" "goto") 5860 (1+ space) 5861 (group (eval cperl--basic-identifier-rx)))) 5862 1 font-lock-constant-face) 5863 ;; Uncomment to get perl-mode-like vars 5864 ;;; '("[$*]{?\\(\\sw+\\)" 1 font-lock-variable-name-face) 5865 ;;; '("\\([@%]\\|\\$#\\)\\(\\sw+\\)" 5866 ;;; (2 (cons font-lock-variable-name-face '(underline)))) 5867 ;; 1=my_etc, 2=white? 3=(+white? 4=white? 5=var 5868 `(,(rx (sequence (or "state" "my" "local" "our")) 5869 (eval cperl--ws*-rx) 5870 (opt (sequence "(" (eval cperl--ws*-rx))) 5871 (group 5872 (in "$@%*") 5873 (or 5874 (eval cperl--normal-identifier-rx) 5875 (eval cperl--special-identifier-rx)) 5876 ) 5877 ) 5878 ;; (concat "\\<\\(state\\|my\\|local\\|our\\)" 5879 ;; cperl-maybe-white-and-comment-rex 5880 ;; "\\((" 5881 ;; cperl-maybe-white-and-comment-rex 5882 ;; "\\)?\\([$@%*]\\([a-zA-Z0-9_:]+\\|[^a-zA-Z0-9_]\\)\\)") 5883 ;; (5 ,(if cperl-font-lock-multiline 5884 (1 ,(if cperl-font-lock-multiline 5885 'font-lock-variable-name-face 5886 '(progn (setq cperl-font-lock-multiline-start 5887 (match-beginning 0)) 5888 'font-lock-variable-name-face))) 5889 (,(rx (sequence point 5890 (eval cperl--ws*-rx) 5891 "," 5892 (eval cperl--ws*-rx) 5893 (group 5894 (in "$@%*") 5895 (or 5896 (eval cperl--normal-identifier-rx) 5897 (eval cperl--special-identifier-rx)) 5898 ) 5899 ) 5900 ) 5901 ;; ,(concat "\\=" 5902 ;; cperl-maybe-white-and-comment-rex 5903 ;; "," 5904 ;; cperl-maybe-white-and-comment-rex 5905 ;; "\\([$@%*]\\([a-zA-Z0-9_:]+\\|[^a-zA-Z0-9_]\\)\\)") 5906 ;; Bug in font-lock: limit is used not only to limit 5907 ;; searches, but to set the "extend window for 5908 ;; facification" property. Thus we need to minimize. 5909 ,(if cperl-font-lock-multiline 5910 '(if (match-beginning 1) 5911 (save-excursion 5912 (goto-char (match-beginning 1)) 5913 (condition-case nil 5914 (forward-sexp 1) 5915 (error 5916 (condition-case nil 5917 (forward-char 200) 5918 (error nil)))) ; typeahead 5919 (1- (point))) ; report limit 5920 (forward-char -2)) ; disable continued expr 5921 '(if (match-beginning 1) 5922 (point-max) ; No limit for continuation 5923 (forward-char -2))) ; disable continued expr 5924 ,(if cperl-font-lock-multiline 5925 nil 5926 '(progn ; Do at end 5927 ;; "my" may be already fontified (POD), 5928 ;; so cperl-font-lock-multiline-start is nil 5929 (if (or (not cperl-font-lock-multiline-start) 5930 (> 2 (count-lines 5931 cperl-font-lock-multiline-start 5932 (point)))) 5933 nil 5934 (put-text-property 5935 (1+ cperl-font-lock-multiline-start) (point) 5936 'syntax-type 'multiline)) 5937 (setq cperl-font-lock-multiline-start nil))) 5938 (1 font-lock-variable-name-face))) 5939 ;; foreach my $foo ( 5940 `(,(rx symbol-start "for" (opt "each") 5941 (opt (sequence (1+ blank) 5942 (or "state" "my" "local" "our"))) 5943 (0+ blank) 5944 (group-n 1 (sequence "$" 5945 (eval cperl--basic-identifier-rx))) 5946 (0+ blank) "(") 5947;; '("\\<for\\(each\\)?\\([ \t]+\\(state\\|my\\|local\\|our\\)\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*(" 5948 1 font-lock-variable-name-face) 5949 ;; Avoid $!, and s!!, qq!! etc. when not fontifying syntactically 5950 '("\\(?:^\\|[^smywqrx$]\\)\\(!\\)" 1 font-lock-negation-char-face) 5951 '("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend))) 5952 (setq 5953 t-font-lock-keywords-1 5954 `( 5955 ;; arrays and hashes. Access to elements is fixed below 5956 (,(rx (group-n 1 (group-n 2 (or (in "@%") "$#")) 5957 (eval cperl--normal-identifier-rx))) 5958 1 5959;; ("\\(\\([@%]\\|\\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1 5960 (if (eq (char-after (match-beginning 2)) ?%) 5961 'cperl-hash-face 5962 'cperl-array-face) 5963 nil) ; arrays and hashes 5964 ;; access to array/hash elements 5965 (,(rx (group-n 1 (group-n 2 (in "$@%")) 5966 (eval cperl--normal-identifier-rx)) 5967 (0+ blank) 5968 (group-n 3 (in "[{"))) 5969;; ("\\(\\([$@%]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" 5970 1 5971 (if (= (- (match-end 2) (match-beginning 2)) 1) 5972 (if (eq (char-after (match-beginning 3)) ?{) 5973 'cperl-hash-face 5974 'cperl-array-face) ; arrays and hashes 5975 font-lock-variable-name-face) ; Just to put something 5976 t) ; override previous 5977 ;; @$ array dereferences, $#$ last array index 5978 (,(rx (group-n 1 (or "@" "$#")) 5979 (group-n 2 (sequence "$" 5980 (or (eval cperl--normal-identifier-rx) 5981 (not (in " \t\n")))))) 5982 ;; ("\\(@\\|\\$#\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)" 5983 (1 'cperl-array-face) 5984 (2 font-lock-variable-name-face)) 5985 ;; %$ hash dereferences 5986 (,(rx (group-n 1 "%") 5987 (group-n 2 (sequence "$" 5988 (or (eval cperl--normal-identifier-rx) 5989 (not (in " \t\n")))))) 5990 ;; ("\\(%\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)" 5991 (1 'cperl-hash-face) 5992 (2 font-lock-variable-name-face)) 5993;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2") 5994;;; Too much noise from \s* @s[ and friends 5995 ;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)" 5996 ;;(3 font-lock-function-name-face t t) 5997 ;;(4 5998 ;; (if (cperl-slash-is-regexp) 5999 ;; font-lock-function-name-face 'default) nil t)) 6000 )) 6001 (if cperl-highlight-variables-indiscriminately 6002 (setq t-font-lock-keywords-1 6003 (append t-font-lock-keywords-1 6004 (list '("\\([$*]{?\\(?:\\sw+\\|::\\)+\\)" 1 6005 font-lock-variable-name-face))))) 6006 (setq cperl-font-lock-keywords-1 6007 (if cperl-syntaxify-by-font-lock 6008 (cons 'cperl-fontify-update 6009 t-font-lock-keywords) 6010 t-font-lock-keywords) 6011 cperl-font-lock-keywords cperl-font-lock-keywords-1 6012 cperl-font-lock-keywords-2 (append 6013 t-font-lock-keywords-1 6014 cperl-font-lock-keywords-1))) 6015 (if (fboundp 'ps-print-buffer) (cperl-ps-print-init)) 6016 (setq cperl-faces-init t)) 6017 (error (message "cperl-init-faces (ignored): %s" errs)))) 6018 6019 6020(defvar ps-bold-faces) 6021(defvar ps-italic-faces) 6022(defvar ps-underlined-faces) 6023 6024(defun cperl-ps-print-init () 6025 "Initialization of `ps-print' components for faces used in CPerl." 6026 (eval-after-load "ps-print" 6027 '(setq ps-bold-faces 6028 ;; font-lock-variable-name-face 6029 ;; font-lock-constant-face 6030 (append '(cperl-array-face cperl-hash-face) 6031 ps-bold-faces) 6032 ps-italic-faces 6033 ;; font-lock-constant-face 6034 (append '(cperl-nonoverridable-face cperl-hash-face) 6035 ps-italic-faces) 6036 ps-underlined-faces 6037 ;; font-lock-type-face 6038 (append '(cperl-array-face cperl-hash-face underline cperl-nonoverridable-face) 6039 ps-underlined-faces)))) 6040 6041(defvar ps-print-face-extension-alist) 6042 6043(defun cperl-ps-print (&optional file) 6044 "Pretty-print in CPerl style. 6045If optional argument FILE is an empty string, prints to printer, otherwise 6046to the file FILE. If FILE is nil, prompts for a file name. 6047 6048Style of printout regulated by the variable `cperl-ps-print-face-properties'." 6049 (interactive) 6050 (or file 6051 (setq file (read-from-minibuffer 6052 "Print to file (if empty - to printer): " 6053 (concat (buffer-file-name) ".ps") 6054 nil nil 'file-name-history))) 6055 (or (> (length file) 0) 6056 (setq file nil)) 6057 (require 'ps-print) ; To get ps-print-face-extension-alist 6058 (let ((ps-print-color-p t) 6059 (ps-print-face-extension-alist ps-print-face-extension-alist)) 6060 (ps-extend-face-list cperl-ps-print-face-properties) 6061 (ps-print-buffer-with-faces file))) 6062 6063;; (defun cperl-ps-print-init () 6064;; "Initialization of `ps-print' components for faces used in CPerl." 6065;; ;; Guard against old versions 6066;; (defvar ps-underlined-faces nil) 6067;; (defvar ps-bold-faces nil) 6068;; (defvar ps-italic-faces nil) 6069;; (setq ps-bold-faces 6070;; (append '(font-lock-emphasized-face 6071;; cperl-array-face 6072;; font-lock-keyword-face 6073;; font-lock-variable-name-face 6074;; font-lock-constant-face 6075;; font-lock-reference-face 6076;; font-lock-other-emphasized-face 6077;; cperl-hash-face) 6078;; ps-bold-faces)) 6079;; (setq ps-italic-faces 6080;; (append '(cperl-nonoverridable-face 6081;; font-lock-constant-face 6082;; font-lock-reference-face 6083;; font-lock-other-emphasized-face 6084;; cperl-hash-face) 6085;; ps-italic-faces)) 6086;; (setq ps-underlined-faces 6087;; (append '(font-lock-emphasized-face 6088;; cperl-array-face 6089;; font-lock-other-emphasized-face 6090;; cperl-hash-face 6091;; cperl-nonoverridable-face font-lock-type-face) 6092;; ps-underlined-faces)) 6093;; (cons 'font-lock-type-face ps-underlined-faces)) 6094 6095 6096(cperl-windowed-init) 6097 6098(defconst cperl-styles-entries 6099 '(cperl-indent-level cperl-brace-offset cperl-continued-brace-offset 6100 cperl-label-offset cperl-extra-newline-before-brace 6101 cperl-extra-newline-before-brace-multiline 6102 cperl-merge-trailing-else 6103 cperl-continued-statement-offset)) 6104 6105(defconst cperl-style-examples 6106"##### Numbers etc are: cperl-indent-level cperl-brace-offset 6107##### cperl-continued-brace-offset cperl-label-offset 6108##### cperl-continued-statement-offset 6109##### cperl-merge-trailing-else cperl-extra-newline-before-brace 6110 6111########### (Do not forget cperl-extra-newline-before-brace-multiline) 6112 6113### CPerl (=GNU - extra-newline-before-brace + merge-trailing-else) 2/0/0/-2/2/t/nil 6114if (foo) { 6115 bar 6116 baz; 6117 label: 6118 { 6119 boon; 6120 } 6121} else { 6122 stop; 6123} 6124 6125### PBP (=Perl Best Practices) 4/0/0/-4/4/nil/nil 6126if (foo) { 6127 bar 6128 baz; 6129 label: 6130 { 6131 boon; 6132 } 6133} 6134else { 6135 stop; 6136} 6137### PerlStyle (=CPerl with 4 as indent) 4/0/0/-2/4/t/nil 6138if (foo) { 6139 bar 6140 baz; 6141 label: 6142 { 6143 boon; 6144 } 6145} else { 6146 stop; 6147} 6148 6149### GNU 2/0/0/-2/2/nil/t 6150if (foo) 6151 { 6152 bar 6153 baz; 6154 label: 6155 { 6156 boon; 6157 } 6158 } 6159else 6160 { 6161 stop; 6162 } 6163 6164### C++ (=PerlStyle with braces aligned with control words) 4/0/-4/-4/4/nil/t 6165if (foo) 6166{ 6167 bar 6168 baz; 6169 label: 6170 { 6171 boon; 6172 } 6173} 6174else 6175{ 6176 stop; 6177} 6178 6179### BSD (=C++, but will not change preexisting merge-trailing-else 6180### and extra-newline-before-brace ) 4/0/-4/-4/4 6181if (foo) 6182{ 6183 bar 6184 baz; 6185 label: 6186 { 6187 boon; 6188 } 6189} 6190else 6191{ 6192 stop; 6193} 6194 6195### K&R (=C++ with indent 5 - merge-trailing-else, but will not 6196### change preexisting extra-newline-before-brace) 5/0/-5/-5/5/nil 6197if (foo) 6198{ 6199 bar 6200 baz; 6201 label: 6202 { 6203 boon; 6204 } 6205} 6206else 6207{ 6208 stop; 6209} 6210 6211### Whitesmith (=PerlStyle, but will not change preexisting 6212### extra-newline-before-brace and merge-trailing-else) 4/0/0/-4/4 6213if (foo) 6214 { 6215 bar 6216 baz; 6217 label: 6218 { 6219 boon; 6220 } 6221 } 6222else 6223 { 6224 stop; 6225 } 6226" 6227"Examples of if/else with different indent styles (with v4.23).") 6228 6229(defconst cperl-style-alist 6230 '(("CPerl" ;; =GNU - extra-newline-before-brace + cperl-merge-trailing-else 6231 (cperl-indent-level . 2) 6232 (cperl-brace-offset . 0) 6233 (cperl-continued-brace-offset . 0) 6234 (cperl-label-offset . -2) 6235 (cperl-continued-statement-offset . 2) 6236 (cperl-extra-newline-before-brace . nil) 6237 (cperl-extra-newline-before-brace-multiline . nil) 6238 (cperl-merge-trailing-else . t)) 6239 6240 ("PBP" ;; Perl Best Practices by Damian Conway 6241 (cperl-indent-level . 4) 6242 (cperl-brace-offset . 0) 6243 (cperl-continued-brace-offset . 0) 6244 (cperl-label-offset . -2) 6245 (cperl-continued-statement-offset . 4) 6246 (cperl-close-paren-offset . -4) 6247 (cperl-extra-newline-before-brace . nil) 6248 (cperl-extra-newline-before-brace-multiline . nil) 6249 (cperl-merge-trailing-else . nil) 6250 (cperl-indent-parens-as-block . t) 6251 (cperl-tab-always-indent . t)) 6252 6253 ("PerlStyle" ; CPerl with 4 as indent 6254 (cperl-indent-level . 4) 6255 (cperl-brace-offset . 0) 6256 (cperl-continued-brace-offset . 0) 6257 (cperl-label-offset . -4) 6258 (cperl-continued-statement-offset . 4) 6259 (cperl-extra-newline-before-brace . nil) 6260 (cperl-extra-newline-before-brace-multiline . nil) 6261 (cperl-merge-trailing-else . t)) 6262 6263 ("GNU" 6264 (cperl-indent-level . 2) 6265 (cperl-brace-offset . 0) 6266 (cperl-continued-brace-offset . 0) 6267 (cperl-label-offset . -2) 6268 (cperl-continued-statement-offset . 2) 6269 (cperl-extra-newline-before-brace . t) 6270 (cperl-extra-newline-before-brace-multiline . t) 6271 (cperl-merge-trailing-else . nil)) 6272 6273 ("K&R" 6274 (cperl-indent-level . 5) 6275 (cperl-brace-offset . 0) 6276 (cperl-continued-brace-offset . -5) 6277 (cperl-label-offset . -5) 6278 (cperl-continued-statement-offset . 5) 6279 ;;(cperl-extra-newline-before-brace . nil) ; ??? 6280 ;;(cperl-extra-newline-before-brace-multiline . nil) 6281 (cperl-merge-trailing-else . nil)) 6282 6283 ("BSD" 6284 (cperl-indent-level . 4) 6285 (cperl-brace-offset . 0) 6286 (cperl-continued-brace-offset . -4) 6287 (cperl-label-offset . -4) 6288 (cperl-continued-statement-offset . 4) 6289 ;;(cperl-extra-newline-before-brace . nil) ; ??? 6290 ;;(cperl-extra-newline-before-brace-multiline . nil) 6291 ;;(cperl-merge-trailing-else . nil) ; ??? 6292 ) 6293 6294 ("C++" 6295 (cperl-indent-level . 4) 6296 (cperl-brace-offset . 0) 6297 (cperl-continued-brace-offset . -4) 6298 (cperl-label-offset . -4) 6299 (cperl-continued-statement-offset . 4) 6300 (cperl-extra-newline-before-brace . t) 6301 (cperl-extra-newline-before-brace-multiline . t) 6302 (cperl-merge-trailing-else . nil)) 6303 6304 ("Whitesmith" 6305 (cperl-indent-level . 4) 6306 (cperl-brace-offset . 0) 6307 (cperl-continued-brace-offset . 0) 6308 (cperl-label-offset . -4) 6309 (cperl-continued-statement-offset . 4) 6310 ;;(cperl-extra-newline-before-brace . nil) ; ??? 6311 ;;(cperl-extra-newline-before-brace-multiline . nil) 6312 ;;(cperl-merge-trailing-else . nil) ; ??? 6313 ) 6314 ("Current")) 6315 "List of variables to set to get a particular indentation style. 6316Should be used via `cperl-set-style' or via Perl menu. 6317 6318See examples in `cperl-style-examples'.") 6319 6320(defun cperl-set-style (style) 6321 "Set CPerl mode variables to use one of several different indentation styles. 6322The arguments are a string representing the desired style. 6323The list of styles is in `cperl-style-alist', available styles 6324are \"CPerl\", \"PBP\", \"PerlStyle\", \"GNU\", \"K&R\", \"BSD\", \"C++\" 6325and \"Whitesmith\". 6326 6327The current value of style is memorized (unless there is a memorized 6328data already), may be restored by `cperl-set-style-back'. 6329 6330Choosing \"Current\" style will not change style, so this may be used for 6331side-effect of memorizing only. Examples in `cperl-style-examples'." 6332 (interactive 6333 (list (completing-read "Enter style: " cperl-style-alist nil 'insist))) 6334 (or cperl-old-style 6335 (setq cperl-old-style 6336 (mapcar (lambda (name) 6337 (cons name (eval name))) 6338 cperl-styles-entries))) 6339 (let ((style (cdr (assoc style cperl-style-alist))) setting) 6340 (while style 6341 (setq setting (car style) style (cdr style)) 6342 (set (car setting) (cdr setting))))) 6343 6344(defun cperl-set-style-back () 6345 "Restore a style memorized by `cperl-set-style'." 6346 (interactive) 6347 (or cperl-old-style (error "The style was not changed")) 6348 (let (setting) 6349 (while cperl-old-style 6350 (setq setting (car cperl-old-style) 6351 cperl-old-style (cdr cperl-old-style)) 6352 (set (car setting) (cdr setting))))) 6353 6354(defvar perl-dbg-flags) 6355(defun cperl-check-syntax () 6356 (interactive) 6357 (require 'mode-compile) 6358 (let ((perl-dbg-flags (concat cperl-extra-perl-args " -wc"))) 6359 (eval '(mode-compile)))) ; Avoid a warning 6360 6361(declare-function Info-find-node "info" 6362 (filename nodename &optional no-going-back strict-case)) 6363 6364(defun cperl-info-buffer (type) 6365 ;; Return buffer with documentation. Creates if missing. 6366 ;; If TYPE, this vars buffer. 6367 ;; Special care is taken to not stomp over an existing info buffer 6368 (let* ((bname (if type "*info-perl-var*" "*info-perl*")) 6369 (info (get-buffer bname)) 6370 (oldbuf (get-buffer "*info*"))) 6371 (if info info 6372 (save-window-excursion 6373 ;; Get Info running 6374 (require 'info) 6375 (cond (oldbuf 6376 (set-buffer oldbuf) 6377 (rename-buffer "*info-perl-tmp*"))) 6378 (save-window-excursion 6379 (info)) 6380 (Info-find-node cperl-info-page (if type "perlvar" "perlfunc")) 6381 (set-buffer "*info*") 6382 (rename-buffer bname) 6383 (cond (oldbuf 6384 (set-buffer "*info-perl-tmp*") 6385 (rename-buffer "*info*") 6386 (set-buffer bname))) 6387 (setq-local window-min-height 2) 6388 (current-buffer))))) 6389 6390(defun cperl-word-at-point (&optional p) 6391 "Return the word at point or at P." 6392 (save-excursion 6393 (if p (goto-char p)) 6394 (or (cperl-word-at-point-hard) 6395 (progn 6396 (require 'etags) 6397 (funcall (or (and (boundp 'find-tag-default-function) 6398 find-tag-default-function) 6399 (get major-mode 'find-tag-default-function) 6400 'find-tag-default)))))) 6401 6402(defun cperl-info-on-command (command) 6403 "Show documentation for Perl command COMMAND in other window. 6404If perl-info buffer is shown in some frame, uses this frame. 6405Customized by setting variables `cperl-shrink-wrap-info-frame', 6406`cperl-max-help-size'." 6407 (interactive 6408 (let* ((default (cperl-word-at-point)) 6409 (read (read-string 6410 (cperl--format-prompt "Find doc for Perl function" default)))) 6411 (list (if (equal read "") 6412 default 6413 read)))) 6414 6415 (let ((cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///" 6416 pos isvar height iniheight frheight buf win fr1 fr2 iniwin not-loner 6417 max-height char-height buf-list) 6418 (if (string-match "^-[a-zA-Z]$" command) 6419 (setq cmd-desc "^-X[ \t\n]")) 6420 (setq isvar (string-match "^[$@%]" command) 6421 buf (cperl-info-buffer isvar) 6422 iniwin (selected-window) 6423 fr1 (window-frame iniwin)) 6424 (set-buffer buf) 6425 (goto-char (point-min)) 6426 (or isvar 6427 (progn (re-search-forward "^-X[ \t\n]") 6428 (forward-line -1))) 6429 (if (re-search-forward cmd-desc nil t) 6430 (progn 6431 ;; Go back to beginning of the group (ex, for qq) 6432 (if (re-search-backward "^[ \t\n\f]") 6433 (forward-line 1)) 6434 (beginning-of-line) 6435 ;; Get some of 6436 (setq pos (point) 6437 buf-list (list buf "*info-perl-var*" "*info-perl*")) 6438 (while (and (not win) buf-list) 6439 (setq win (get-buffer-window (car buf-list) t)) 6440 (setq buf-list (cdr buf-list))) 6441 (or (not win) 6442 (eq (window-buffer win) buf) 6443 (set-window-buffer win buf)) 6444 (and win (setq fr2 (window-frame win))) 6445 (if (or (not fr2) (eq fr1 fr2)) 6446 (pop-to-buffer buf) 6447 (special-display-popup-frame buf) ; Make it visible 6448 (select-window win)) 6449 (goto-char pos) ; Needed (?!). 6450 ;; Resize 6451 (setq iniheight (window-height) 6452 frheight (frame-height) 6453 not-loner (< iniheight (1- frheight))) ; Are not alone 6454 (cond ((if not-loner cperl-max-help-size 6455 cperl-shrink-wrap-info-frame) 6456 (setq height 6457 (+ 2 6458 (count-lines 6459 pos 6460 (save-excursion 6461 (if (re-search-forward 6462 "^[ \t][^\n]*\n+\\([^ \t\n\f]\\|\\'\\)" nil t) 6463 (match-beginning 0) (point-max))))) 6464 max-height 6465 (if not-loner 6466 (/ (* (- frheight 3) cperl-max-help-size) 100) 6467 (setq char-height (frame-char-height)) 6468 (if (eq char-height 1) (setq char-height 18)) 6469 ;; Title, menubar, + 2 for slack 6470 (- (/ (display-pixel-height) char-height) 4))) 6471 (if (> height max-height) (setq height max-height)) 6472 ;;(message "was %s doing %s" iniheight height) 6473 (if not-loner 6474 (enlarge-window (- height iniheight)) 6475 (set-frame-height (window-frame win) (1+ height))))) 6476 (set-window-start (selected-window) pos)) 6477 (message "No entry for %s found." command)) 6478 ;;(pop-to-buffer buffer) 6479 (select-window iniwin))) 6480 6481(defun cperl-info-on-current-command () 6482 "Show documentation for Perl command at point in other window." 6483 (interactive) 6484 (cperl-info-on-command (cperl-word-at-point))) 6485 6486(defun cperl-imenu-info-imenu-search () 6487 (if (looking-at "^-X[ \t\n]") nil 6488 (re-search-backward 6489 "^\n\\([-a-zA-Z_]+\\)[ \t\n]") 6490 (forward-line 1))) 6491 6492(defun cperl-imenu-info-imenu-name () 6493 (buffer-substring 6494 (match-beginning 1) (match-end 1))) 6495 6496(declare-function imenu-choose-buffer-index "imenu" (&optional prompt alist)) 6497 6498(defun cperl-imenu-on-info () 6499 "Show imenu for Perl Info Buffer. 6500Opens Perl Info buffer if needed." 6501 (interactive) 6502 (require 'imenu) 6503 (let* ((buffer (current-buffer)) 6504 imenu-create-index-function 6505 imenu-prev-index-position-function 6506 imenu-extract-index-name-function 6507 (index-item (save-restriction 6508 (save-window-excursion 6509 (set-buffer (cperl-info-buffer nil)) 6510 (setq imenu-create-index-function 6511 'imenu-default-create-index-function 6512 imenu-prev-index-position-function 6513 #'cperl-imenu-info-imenu-search 6514 imenu-extract-index-name-function 6515 #'cperl-imenu-info-imenu-name) 6516 (imenu-choose-buffer-index))))) 6517 (and index-item 6518 (progn 6519 (push-mark) 6520 (pop-to-buffer "*info-perl*") 6521 (cond 6522 ((markerp (cdr index-item)) 6523 (goto-char (marker-position (cdr index-item)))) 6524 (t 6525 (goto-char (cdr index-item)))) 6526 (set-window-start (selected-window) (point)) 6527 (pop-to-buffer buffer))))) 6528 6529(defun cperl-lineup (beg end &optional step minshift) 6530 "Lineup construction in a region. 6531Beginning of region should be at the start of a construction. 6532All first occurrences of this construction in the lines that are 6533partially contained in the region are lined up at the same column. 6534 6535MINSHIFT is the minimal amount of space to insert before the construction. 6536STEP is the tabwidth to position constructions. 6537If STEP is nil, `cperl-lineup-step' will be used 6538\(or `cperl-indent-level', if `cperl-lineup-step' is nil). 6539Will not move the position at the start to the left." 6540 (interactive "r") 6541 (let (search col tcol seen) 6542 (save-excursion 6543 (goto-char end) 6544 (end-of-line) 6545 (setq end (point-marker)) 6546 (goto-char beg) 6547 (skip-chars-forward " \t\f") 6548 (setq beg (point-marker)) 6549 (indent-region beg end nil) 6550 (goto-char beg) 6551 (setq col (current-column)) 6552 ;; Assuming that lineup is done on Perl syntax, this regexp 6553 ;; doesn't need to be unicode aware -- haj, 2021-09-10 6554 (if (looking-at "[a-zA-Z0-9_]") 6555 (if (looking-at "\\<[a-zA-Z0-9_]+\\>") 6556 (setq search 6557 (concat "\\<" 6558 (regexp-quote 6559 (buffer-substring (match-beginning 0) 6560 (match-end 0))) "\\>")) 6561 (error "Cannot line up in a middle of the word")) 6562 (if (looking-at "$") 6563 (error "Cannot line up end of line")) 6564 (setq search (regexp-quote (char-to-string (following-char))))) 6565 (setq step (or step cperl-lineup-step cperl-indent-level)) 6566 (or minshift (setq minshift 1)) 6567 (while (progn 6568 (beginning-of-line 2) 6569 (and (< (point) end) 6570 (re-search-forward search end t) 6571 (goto-char (match-beginning 0)))) 6572 (setq tcol (current-column) seen t) 6573 (if (> tcol col) (setq col tcol))) 6574 (or seen 6575 (error "The construction to line up occurred only once")) 6576 (goto-char beg) 6577 (setq col (+ col minshift)) 6578 (if (/= (% col step) 0) (setq step (* step (1+ (/ col step))))) 6579 (while 6580 (progn 6581 (cperl-make-indent col) 6582 (beginning-of-line 2) 6583 (and (< (point) end) 6584 (re-search-forward search end t) 6585 (goto-char (match-beginning 0)))))))) ; No body 6586 6587(defun cperl-etags (&optional add all files) ;; NOT USED??? 6588 "Run etags with appropriate options for Perl files. 6589If optional argument ALL is `recursive', will process Perl files 6590in subdirectories too." 6591 ;; Apparently etags doesn't support UTF-8 encoded sources, and usage 6592 ;; of etags has been commented out in the menu since ... well, 6593 ;; forever. So, let's just stick to ASCII here. -- haj, 2021-09-14 6594 (interactive) 6595 (let ((cmd "etags") 6596 (args `("-l" "none" "-r" 6597 ;; 1=fullname 2=package? 3=name 4=proto? 5=attrs? (VERY APPROX!) 6598 ,(concat 6599 "/\\<" cperl-sub-regexp "[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([ \t]*:[^#{;]*\\)?\\([{#]\\|$\\)/\\3/") 6600 "-r" 6601 "/\\<package[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\([#;]\\|$\\)/\\1/" 6602 "-r" 6603 "/\\<\\(package\\)[ \\t]*;/\\1;/")) 6604 res) 6605 (if add (setq args (cons "-a" args))) 6606 (or files (setq files (list buffer-file-name))) 6607 (cond 6608 ((eq all 'recursive) 6609 ;;(error "Not implemented: recursive") 6610 (setq args (append (list "-e" 6611 "sub wanted {push @ARGV, $File::Find::name if /\\.[pP][Llm]$/} 6612 use File::Find; 6613 find(\\&wanted, '.'); 6614 exec @ARGV;" 6615 cmd) args) 6616 cmd "perl")) 6617 (all 6618 ;;(error "Not implemented: all") 6619 (setq args (append (list "-e" 6620 "push @ARGV, <*.PL *.pl *.pm>; 6621 exec @ARGV;" 6622 cmd) args) 6623 cmd "perl")) 6624 (t 6625 (setq args (append args files)))) 6626 (setq res (apply 'call-process cmd nil nil nil args)) 6627 (or (eq res 0) 6628 (message "etags returned \"%s\"" res)))) 6629 6630(defun cperl-toggle-auto-newline () 6631 "Toggle the state of `cperl-auto-newline'." 6632 (interactive) 6633 (setq cperl-auto-newline (not cperl-auto-newline)) 6634 (message "Newlines will %sbe auto-inserted now." 6635 (if cperl-auto-newline "" "not "))) 6636 6637(defun cperl-toggle-abbrev () 6638 "Toggle the state of automatic keyword expansion in CPerl mode." 6639 (interactive) 6640 (abbrev-mode (if abbrev-mode 0 1)) 6641 (message "Perl control structure will %sbe auto-inserted now." 6642 (if abbrev-mode "" "not "))) 6643 6644 6645(defun cperl-toggle-electric () 6646 "Toggle the state of parentheses doubling in CPerl mode." 6647 (interactive) 6648 (setq cperl-electric-parens (if (cperl-val 'cperl-electric-parens) 'null t)) 6649 (message "Parentheses will %sbe auto-doubled now." 6650 (if (cperl-val 'cperl-electric-parens) "" "not "))) 6651 6652(defun cperl-toggle-autohelp () 6653 ;; FIXME: Turn me into a minor mode. Fix menu entries for "Auto-help on" as 6654 ;; well. 6655 "Toggle the state of Auto-Help on Perl constructs (put in the message area). 6656Delay of auto-help controlled by `cperl-lazy-help-time'." 6657 (interactive) 6658 (if cperl-lazy-installed 6659 (cperl-lazy-unstall) 6660 (cperl-lazy-install)) 6661 (message "Perl help messages will %sbe automatically shown now." 6662 (if cperl-lazy-installed "" "not "))) 6663 6664(defun cperl-toggle-construct-fix () 6665 "Toggle whether `indent-region'/`indent-sexp' fix whitespace too." 6666 (interactive) 6667 (setq cperl-indent-region-fix-constructs 6668 (if cperl-indent-region-fix-constructs 6669 nil 6670 1)) 6671 (message "indent-region/indent-sexp will %sbe automatically fix whitespace." 6672 (if cperl-indent-region-fix-constructs "" "not "))) 6673 6674(defun cperl-toggle-set-debug-unwind (arg &optional backtrace) 6675 "Toggle (or, with numeric argument, set) debugging state of syntaxification. 6676Nonpositive numeric argument disables debugging messages. The message 6677summarizes which regions it was decided to rescan for syntactic constructs. 6678 6679The message looks like this: 6680 6681 Syxify req=123..138 actual=101..146 done-to: 112=>146 statepos: 73=>117 6682 6683Numbers are character positions in the buffer. REQ provides the range to 6684rescan requested by `font-lock'. ACTUAL is the range actually resyntaxified; 6685for correct operation it should start and end outside any special syntactic 6686construct. DONE-TO and STATEPOS indicate changes to internal caches maintained 6687by CPerl." 6688 (interactive "P") 6689 (or arg 6690 (setq arg (if (eq cperl-syntaxify-by-font-lock 6691 (if backtrace 'backtrace 'message)) 6692 0 1))) 6693 (setq arg (if (> arg 0) (if backtrace 'backtrace 'message) t)) 6694 (setq cperl-syntaxify-by-font-lock arg) 6695 (message "Debugging messages of syntax unwind %sabled." 6696 (if (eq arg t) "dis" "en"))) 6697 6698;;;; Tags file creation. 6699 6700(defvar cperl-tmp-buffer " *cperl-tmp*") 6701 6702(defun cperl-setup-tmp-buf () 6703 (set-buffer (get-buffer-create cperl-tmp-buffer)) 6704 (set-syntax-table cperl-mode-syntax-table) 6705 (buffer-disable-undo) 6706 (auto-fill-mode 0) 6707 (if cperl-use-syntax-table-text-property-for-tags 6708 (progn 6709 ;; Do not introduce variable if not needed, we check it! 6710 (setq-local parse-sexp-lookup-properties t)))) 6711 6712;; Copied from imenu-example--name-and-position. 6713(defvar imenu-use-markers) 6714 6715(defun cperl-imenu-name-and-position () 6716 "Return the current/previous sexp and its (beginning) location. 6717Does not move point." 6718 (save-excursion 6719 (forward-sexp -1) 6720 (let ((beg (if imenu-use-markers (point-marker) (point))) 6721 (end (progn (forward-sexp) (point)))) 6722 (cons (buffer-substring beg end) 6723 beg)))) 6724 6725(defun cperl-xsub-scan () 6726 (require 'imenu) 6727 (let ((index-alist '()) 6728 index index1 name package prefix) 6729 (goto-char (point-min)) 6730 ;; Search for the function 6731 (progn ;;save-match-data 6732 (while (re-search-forward 6733 ;; FIXME: Should XS code be unicode aware? Recent C 6734 ;; compilers (Gcc 10+) are, but I guess this isn't used 6735 ;; much. -- haj, 2021-09-14 6736 "^\\([ \t]*MODULE\\>[^\n]*\\<PACKAGE[ \t]*=[ \t]*\\([a-zA-Z_][a-zA-Z_0-9:]*\\)\\>\\|\\([a-zA-Z_][a-zA-Z_0-9]*\\)(\\|[ \t]*BOOT:\\)" 6737 nil t) 6738 (cond 6739 ((match-beginning 2) ; SECTION 6740 (setq package (buffer-substring (match-beginning 2) (match-end 2))) 6741 (goto-char (match-beginning 0)) 6742 (skip-chars-forward " \t") 6743 (forward-char 1) 6744 (if (looking-at "[^\n]*\\<PREFIX[ \t]*=[ \t]*\\([a-zA-Z_][a-zA-Z_0-9]*\\)\\>") 6745 (setq prefix (buffer-substring (match-beginning 1) (match-end 1))) 6746 (setq prefix nil))) 6747 ((not package) nil) ; C language section 6748 ((match-beginning 3) ; XSUB 6749 (goto-char (1+ (match-beginning 3))) 6750 (setq index (cperl-imenu-name-and-position)) 6751 (setq name (buffer-substring (match-beginning 3) (match-end 3))) 6752 (if (and prefix (string-match (concat "^" prefix) name)) 6753 (setq name (substring name (length prefix)))) 6754 (cond ((string-match "::" name) nil) 6755 (t 6756 (setq index1 (cons (concat package "::" name) (cdr index))) 6757 (push index1 index-alist))) 6758 (setcar index name) 6759 (push index index-alist)) 6760 (t ; BOOT: section 6761 ;; (beginning-of-line) 6762 (setq index (cperl-imenu-name-and-position)) 6763 (setcar index (concat package "::BOOT:")) 6764 (push index index-alist))))) 6765 index-alist)) 6766 6767(defvar cperl-unreadable-ok nil) 6768 6769(defun cperl-find-tags (ifile xs topdir) 6770 (let ((b (get-buffer cperl-tmp-buffer)) ind lst elt pos ret rel 6771 (cperl-pod-here-fontify nil) file) 6772 (save-excursion 6773 (if b (set-buffer b) 6774 (cperl-setup-tmp-buf)) 6775 (erase-buffer) 6776 (condition-case nil 6777 (setq file (car (insert-file-contents ifile))) 6778 (error (if cperl-unreadable-ok nil 6779 (if (y-or-n-p 6780 (format "File %s unreadable. Continue? " ifile)) 6781 (setq cperl-unreadable-ok t) 6782 (error "Aborting: unreadable file %s" ifile))))) 6783 (if (not file) 6784 (message "Unreadable file %s" ifile) 6785 (message "Scanning file %s ..." file) 6786 (if (and cperl-use-syntax-table-text-property-for-tags 6787 (not xs)) 6788 (condition-case err ; after __END__ may have garbage 6789 (cperl-find-pods-heres nil nil noninteractive) 6790 (error (message "While scanning for syntax: %S" err)))) 6791 (if xs 6792 (setq lst (cperl-xsub-scan)) 6793 (setq ind (cperl-imenu--create-perl-index)) 6794 (setq lst (cdr (assoc "+Unsorted List+..." ind)))) 6795 (setq lst 6796 (mapcar 6797 (lambda (elt) 6798 (cond ((string-match (rx line-start (or alpha "_")) (car elt)) 6799 (goto-char (cdr elt)) 6800 (beginning-of-line) ; pos should be of the start of the line 6801 (list (car elt) 6802 (point) 6803 (1+ (count-lines 1 (point))) ; 1+ since at beg-o-l 6804 (buffer-substring (progn 6805 (goto-char (cdr elt)) 6806 ;; After name now... 6807 (or (eolp) (forward-char 1)) 6808 (point)) 6809 (progn 6810 (beginning-of-line) 6811 (point))))))) 6812 lst)) 6813 (erase-buffer) 6814 (while lst 6815 (setq elt (car lst) lst (cdr lst)) 6816 (if elt 6817 (progn 6818 (insert (elt elt 3) 6819 127 6820 (if (string-match "^package " (car elt)) 6821 (substring (car elt) 8) 6822 (car elt) ) 6823 1 6824 (number-to-string (elt elt 2)) ; Line 6825 "," 6826 (number-to-string (1- (elt elt 1))) ; Char pos 0-based 6827 "\n") 6828 (if (and (string-match (rx line-start 6829 (eval cperl--basic-identifier-rx) "++") 6830 (car elt)) 6831 (string-match (rx-to-string `(sequence line-start 6832 (regexp ,cperl-sub-regexp) 6833 (1+ (in " \t")) 6834 ,cperl--normal-identifier-rx)) 6835 (elt elt 3))) 6836 ;; Need to insert the name without package as well 6837 (setq lst (cons (cons (substring (elt elt 3) 6838 (match-beginning 1) 6839 (match-end 1)) 6840 (cdr elt)) 6841 lst)))))) 6842 (setq pos (point)) 6843 (goto-char 1) 6844 (setq rel file) 6845 ;; On case-preserving filesystems case might be encoded in properties 6846 (set-text-properties 0 (length rel) nil rel) 6847 (and (equal topdir (substring rel 0 (length topdir))) 6848 (setq rel (substring file (length topdir)))) 6849 (insert "\f\n" rel "," (number-to-string (1- pos)) "\n") 6850 (setq ret (buffer-substring 1 (point-max))) 6851 (erase-buffer) 6852 (or noninteractive 6853 (message "Scanning file %s finished" file)) 6854 ret)))) 6855 6856(defun cperl-add-tags-recurse-noxs () 6857 "Add to TAGS data for \"pure\" Perl files in the current directory and kids. 6858Use as 6859 emacs -batch -q -no-site-file -l emacs/cperl-mode.el \\ 6860 -f cperl-add-tags-recurse-noxs" 6861 (cperl-write-tags nil nil t t nil t)) 6862 6863(defun cperl-add-tags-recurse-noxs-fullpath () 6864 "Add to TAGS data for \"pure\" Perl in the current directory and kids. 6865Writes down fullpath, so TAGS is relocatable (but if the build directory 6866is relocated, the file TAGS inside it breaks). Use as 6867 emacs -batch -q -no-site-file -l emacs/cperl-mode.el \\ 6868 -f cperl-add-tags-recurse-noxs-fullpath" 6869 (cperl-write-tags nil nil t t nil t "")) 6870 6871(defun cperl-add-tags-recurse () 6872 "Add to TAGS file data for Perl files in the current directory and kids. 6873Use as 6874 emacs -batch -q -no-site-file -l emacs/cperl-mode.el \\ 6875 -f cperl-add-tags-recurse" 6876 (cperl-write-tags nil nil t t)) 6877 6878(defvar cperl-tags-file-name "TAGS" 6879 "TAGS file name to use in `cperl-write-tags'.") 6880 6881(defun cperl-write-tags (&optional file erase recurse dir inbuffer noxs topdir) 6882 ;; If INBUFFER, do not select buffer, and do not save 6883 ;; If ERASE is `ignore', do not erase, and do not try to delete old info. 6884 (require 'etags) 6885 (if file nil 6886 (setq file (if dir default-directory (buffer-file-name))) 6887 (if (and (not dir) (buffer-modified-p)) (error "Save buffer first!"))) 6888 (or topdir 6889 (setq topdir default-directory)) 6890 (let ((tags-file-name cperl-tags-file-name) 6891 (inhibit-read-only t) 6892 (case-fold-search nil) 6893 xs rel) 6894 (save-excursion 6895 (cond (inbuffer nil) ; Already there 6896 ((file-exists-p tags-file-name) 6897 (visit-tags-table-buffer tags-file-name)) 6898 (t 6899 (set-buffer (find-file-noselect tags-file-name)))) 6900 (cond 6901 (dir 6902 (cond ((eq erase 'ignore)) 6903 (erase 6904 (erase-buffer) 6905 (setq erase 'ignore))) 6906 (let ((files 6907 (condition-case nil 6908 (directory-files file t 6909 (if recurse nil cperl-scan-files-regexp) 6910 t) 6911 (error 6912 (if cperl-unreadable-ok nil 6913 (if (y-or-n-p 6914 (format "Directory %s unreadable. Continue? " file)) 6915 (progn 6916 (setq cperl-unreadable-ok t) 6917 nil) ; Return empty list 6918 (error "Aborting: unreadable directory %s" file))))))) 6919 (mapc (lambda (file) 6920 (cond 6921 ((string-match cperl-noscan-files-regexp file) 6922 nil) 6923 ((not (file-directory-p file)) 6924 (if (string-match cperl-scan-files-regexp file) 6925 (cperl-write-tags file erase recurse nil t noxs topdir))) 6926 ((not recurse) nil) 6927 (t (cperl-write-tags file erase recurse t t noxs topdir)))) 6928 files))) 6929 (t 6930 (setq xs (string-match "\\.xs$" file)) 6931 (if (not (and xs noxs)) 6932 (progn 6933 (cond ((eq erase 'ignore) (goto-char (point-max))) 6934 (erase (erase-buffer)) 6935 (t 6936 (goto-char 1) 6937 (setq rel file) 6938 ;; On case-preserving filesystems case might be encoded in properties 6939 (set-text-properties 0 (length rel) nil rel) 6940 (and (equal topdir (substring rel 0 (length topdir))) 6941 (setq rel (substring file (length topdir)))) 6942 (if (search-forward (concat "\f\n" rel ",") nil t) 6943 (progn 6944 (search-backward "\f\n") 6945 (delete-region (point) 6946 (save-excursion 6947 (forward-char 1) 6948 (if (search-forward "\f\n" 6949 nil 'toend) 6950 (- (point) 2) 6951 (point-max))))) 6952 (goto-char (point-max))))) 6953 (insert (cperl-find-tags file xs topdir)))))) 6954 (if inbuffer nil ; Delegate to the caller 6955 (save-buffer 0) ; No backup 6956 (if (fboundp 'initialize-new-tags-table) 6957 (initialize-new-tags-table)))))) 6958 6959(defvar cperl-tags-hier-regexp-list 6960 (concat 6961 "^\\(" 6962 "\\(package\\)\\>" 6963 "\\|" 6964 cperl-sub-regexp "\\>[^\n]+::" 6965 "\\|" 6966 "[a-zA-Z_][a-zA-Z_0-9:]*(\C-?[^\n]+::" ; XSUB? 6967 "\\|" 6968 "[ \t]*BOOT:\C-?[^\n]+::" ; BOOT section 6969 "\\)")) 6970 6971(defvar cperl-hierarchy '(() ()) 6972 "Global hierarchy of classes.") 6973 6974;; Follows call to (autoloaded) visit-tags-table. 6975(declare-function file-of-tag "etags" (&optional relative)) 6976(declare-function etags-snarf-tag "etags" (&optional use-explicit)) 6977 6978(defun cperl-tags-hier-fill () 6979 ;; Suppose we are in a tag table cooked by cperl. 6980 (goto-char 1) 6981 (let (pack name line ord cons1 file info fileind) 6982 (while (re-search-forward cperl-tags-hier-regexp-list nil t) 6983 (setq pack (match-beginning 2)) 6984 (beginning-of-line) 6985 (if (looking-at (concat 6986 "\\([^\n]+\\)" 6987 "\C-?" 6988 "\\([^\n]+\\)" 6989 "\C-a" 6990 "\\([0-9]+\\)" 6991 "," 6992 "\\([0-9]+\\)")) 6993 (progn 6994 (setq ;;str (buffer-substring (match-beginning 1) (match-end 1)) 6995 name (buffer-substring (match-beginning 2) (match-end 2)) 6996 ;;pos (buffer-substring (match-beginning 3) (match-end 3)) 6997 line (buffer-substring (match-beginning 3) (match-end 3)) 6998 ord (if pack 1 0) 6999 file (file-of-tag) 7000 fileind (format "%s:%s" file line) 7001 ;; Moves to beginning of the next line: 7002 info (etags-snarf-tag)) 7003 ;; Move back 7004 (forward-char -1) 7005 ;; Make new member of hierarchy name ==> file ==> pos if needed 7006 (if (setq cons1 (assoc name (nth ord cperl-hierarchy))) 7007 ;; Name known 7008 (setcdr cons1 (cons (cons fileind (vector file info)) 7009 (cdr cons1))) 7010 ;; First occurrence of the name, start alist 7011 (setq cons1 (cons name (list (cons fileind (vector file info))))) 7012 (if pack 7013 (setcar (cdr cperl-hierarchy) 7014 (cons cons1 (nth 1 cperl-hierarchy))) 7015 (setcar cperl-hierarchy 7016 (cons cons1 (car cperl-hierarchy))))))) 7017 (end-of-line)))) 7018 7019(declare-function x-popup-menu "menu.c" (position menu)) 7020(declare-function etags-goto-tag-location "etags" (tag-info)) 7021 7022(defun cperl-tags-hier-init (&optional update) 7023 "Show hierarchical menu of classes and methods. 7024Finds info about classes by a scan of loaded TAGS files. 7025Supposes that the TAGS files contain fully qualified function names. 7026One may build such TAGS files from CPerl mode menu." 7027 (interactive) 7028 (require 'etags) 7029 (require 'imenu) 7030 (if (or update (null (nth 2 cperl-hierarchy))) 7031 (let ((remover (lambda (elt) ; (name (file1...) (file2..)) 7032 (or (nthcdr 2 elt) 7033 ;; Only in one file 7034 (setcdr elt (cdr (nth 1 elt)))))) 7035 to) ;; l1 l2 l3 7036 ;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later! 7037 (setq cperl-hierarchy (list () () ())) ;; (list l1 l2 l3) 7038 (or tags-table-list 7039 (call-interactively 'visit-tags-table)) 7040 (mapc 7041 (lambda (tagsfile) 7042 (message "Updating list of classes... %s" tagsfile) 7043 (set-buffer (get-file-buffer tagsfile)) 7044 (cperl-tags-hier-fill)) 7045 tags-table-list) 7046 (message "Updating list of classes... postprocessing...") 7047 (mapc remover (car cperl-hierarchy)) 7048 (mapc remover (nth 1 cperl-hierarchy)) 7049 (setq to (list nil (cons "Packages: " (nth 1 cperl-hierarchy)) 7050 (cons "Methods: " (car cperl-hierarchy)))) 7051 (cperl-tags-treeify to 1) 7052 (setcar (nthcdr 2 cperl-hierarchy) 7053 (cperl-menu-to-keymap (cons '("+++UPDATE+++" . -999) (cdr to)))) 7054 (message "Updating list of classes: done, requesting display..."))) 7055 (or (nth 2 cperl-hierarchy) 7056 (error "No items found")) 7057 (setq update 7058 ;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy)) 7059 (if (if (fboundp 'display-popup-menus-p) 7060 (display-popup-menus-p) 7061 window-system) 7062 (x-popup-menu t (nth 2 cperl-hierarchy)) 7063 (require 'tmm) 7064 (tmm-prompt (nth 2 cperl-hierarchy)))) 7065 (if (and update (listp update)) 7066 (progn (while (cdr update) (setq update (cdr update))) 7067 (setq update (car update)))) ; Get the last from the list 7068 (if (vectorp update) 7069 (progn 7070 (find-file (elt update 0)) 7071 (etags-goto-tag-location (elt update 1)))) 7072 (if (eq update -999) (cperl-tags-hier-init t))) 7073 7074(defun cperl-tags-treeify (to level) 7075 ;; cadr of `to' is read-write. On start it is a cons 7076 (let* ((regexp (concat "^\\(" (mapconcat 7077 #'identity 7078 (make-list level "[_a-zA-Z0-9]+") 7079 "::") 7080 "\\)\\(::\\)?")) 7081 (packages (cdr (nth 1 to))) 7082 (methods (cdr (nth 2 to))) 7083 head cons1 cons2 ord writeto recurse ;; l1 7084 root-packages root-functions 7085 (move-deeper 7086 (lambda (elt) 7087 (cond ((and (string-match regexp (car elt)) 7088 (or (eq ord 1) (match-end 2))) 7089 (setq head (substring (car elt) 0 (match-end 1)) 7090 recurse t) 7091 (if (setq cons1 (assoc head writeto)) nil 7092 ;; Need to init new head 7093 (setcdr writeto (cons (list head (list "Packages: ") 7094 (list "Methods: ")) 7095 (cdr writeto))) 7096 (setq cons1 (nth 1 writeto))) 7097 (setq cons2 (nth ord cons1)) ; Either packs or meths 7098 (setcdr cons2 (cons elt (cdr cons2)))) 7099 ((eq ord 2) 7100 (setq root-functions (cons elt root-functions))) 7101 (t 7102 (setq root-packages (cons elt root-packages))))))) 7103 (setcdr to nil) ;; l1 ; Init to dynamic space 7104 (setq writeto to) 7105 (setq ord 1) 7106 (mapc move-deeper packages) 7107 (setq ord 2) 7108 (mapc move-deeper methods) 7109 (if recurse 7110 (mapc (lambda (elt) 7111 (cperl-tags-treeify elt (1+ level))) 7112 (cdr to))) 7113 ;;Now clean up leaders with one child only 7114 (mapc (lambda (elt) 7115 (if (not (and (listp (cdr elt)) 7116 (eq (length elt) 2))) 7117 nil 7118 (setcar elt (car (nth 1 elt))) 7119 (setcdr elt (cdr (nth 1 elt))))) 7120 (cdr to)) 7121 ;; Sort the roots of subtrees 7122 (if (default-value 'imenu-sort-function) 7123 (setcdr to 7124 (sort (cdr to) (default-value 'imenu-sort-function)))) 7125 ;; Now add back functions removed from display 7126 (mapc (lambda (elt) 7127 (setcdr to (cons elt (cdr to)))) 7128 (if (default-value 'imenu-sort-function) 7129 (nreverse 7130 (sort root-functions (default-value 'imenu-sort-function))) 7131 root-functions)) 7132 ;; Now add back packages removed from display 7133 (mapc (lambda (elt) 7134 (setcdr to (cons (cons (concat "package " (car elt)) 7135 (cdr elt)) 7136 (cdr to)))) 7137 (if (default-value 'imenu-sort-function) 7138 (nreverse 7139 (sort root-packages (default-value 'imenu-sort-function))) 7140 root-packages)))) 7141 7142;;(x-popup-menu t 7143;; '(keymap "Name1" 7144;; ("Ret1" "aa") 7145;; ("Head1" "ab" 7146;; keymap "Name2" 7147;; ("Tail1" "x") ("Tail2" "y")))) 7148 7149(defun cperl-list-fold (list name limit) 7150 (let (list1 list2 elt1 (num 0)) 7151 (if (<= (length list) limit) list 7152 (setq list1 nil list2 nil) 7153 (while list 7154 (setq num (1+ num) 7155 elt1 (car list) 7156 list (cdr list)) 7157 (if (<= num imenu-max-items) 7158 (setq list2 (cons elt1 list2)) 7159 (setq list1 (cons (cons name 7160 (nreverse list2)) 7161 list1) 7162 list2 (list elt1) 7163 num 1))) 7164 (nreverse (cons (cons name 7165 (nreverse list2)) 7166 list1))))) 7167 7168(defun cperl-menu-to-keymap (menu) 7169 (let (list) 7170 (cons 'keymap 7171 (mapcar 7172 (lambda (elt) 7173 (cond ((listp (cdr elt)) 7174 (setq list (cperl-list-fold 7175 (cdr elt) (car elt) imenu-max-items)) 7176 (cons nil 7177 (cons (car elt) 7178 (cperl-menu-to-keymap list)))) 7179 (t 7180 (list (cdr elt) (car elt) t)))) ; t is needed in 19.34 7181 (cperl-list-fold menu "Root" imenu-max-items))))) 7182 7183 7184(defvar cperl-bad-style-regexp 7185 (mapconcat #'identity 7186 '("[^-\n\t <>=+!.&|(*/'`\"#^][-=+<>!|&^]" ; char sign 7187 "[-<>=+^&|]+[^- \t\n=+<>~]") ; sign+ char 7188 "\\|") 7189 "Finds places such that insertion of a whitespace may help a lot.") 7190 7191(defvar cperl-not-bad-style-regexp 7192 (mapconcat 7193 #'identity 7194 '("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++ 7195 "[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used. 7196 "&[(a-zA-Z0-9_$]" ; &subroutine &(var->field) 7197 "<\\$?\\sw+\\(\\.\\(\\sw\\|_\\)+\\)?>" ; <IN> <stdin.h> 7198 "-[a-zA-Z][ \t]+[_$\"'`a-zA-Z]" ; -f file, -t STDIN 7199 "-[0-9]" ; -5 7200 "\\+\\+" ; ++var 7201 "--" ; --var 7202 ".->" ; a->b 7203 "->" ; a SPACE ->b 7204 "\\[-" ; a[-1] 7205 "\\\\[&$@*\\]" ; \&func 7206 "^=" ; =head 7207 "\\$." ; $| 7208 "<<[a-zA-Z_'\"`]" ; <<FOO, <<'FOO' 7209 "||" 7210 "//" 7211 "&&" 7212 "[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C<code like text> 7213 "-[a-zA-Z_0-9]+[ \t]*=>" ; -option => value 7214 ;; Unaddressed trouble spots: = -abc, f(56, -abc) --- specialcased below 7215 ;;"[*/+-|&<.]+=" 7216 ) 7217 "\\|") 7218 "If matches at the start of match found by `my-bad-c-style-regexp', 7219insertion of a whitespace will not help.") 7220 7221(defvar found-bad) 7222 7223(defun cperl-find-bad-style () 7224 "Find places in the buffer where insertion of a whitespace may help. 7225Prompts user for insertion of spaces. 7226Currently it is tuned to C and Perl syntax." 7227 (interactive) 7228 (let (found-bad (p (point))) 7229 (setq last-nonmenu-event 13) ; To disable popup 7230 (goto-char (point-min)) 7231 (map-y-or-n-p "Insert space here? " 7232 (lambda (_) (insert " ")) 7233 'cperl-next-bad-style 7234 '("location" "locations" "insert a space into") 7235 `((?\C-r ,(lambda (_) 7236 (let ((buffer-quit-function 7237 #'exit-recursive-edit)) 7238 (message "Exit with Esc Esc") 7239 (recursive-edit) 7240 t)) ; Consider acted upon 7241 "edit, exit with Esc Esc") 7242 (?e ,(lambda (_) 7243 (let ((buffer-quit-function 7244 #'exit-recursive-edit)) 7245 (message "Exit with Esc Esc") 7246 (recursive-edit) 7247 t)) ; Consider acted upon 7248 "edit, exit with Esc Esc")) 7249 t) 7250 (if found-bad (goto-char found-bad) 7251 (goto-char p) 7252 (message "No appropriate place found")))) 7253 7254(defun cperl-next-bad-style () 7255 (let (p (not-found t) found) 7256 (while (and not-found 7257 (re-search-forward cperl-bad-style-regexp nil 'to-end)) 7258 (setq p (point)) 7259 (goto-char (match-beginning 0)) 7260 (if (or 7261 (looking-at cperl-not-bad-style-regexp) 7262 ;; Check for a < -b and friends 7263 (and (eq (following-char) ?\-) 7264 (save-excursion 7265 (skip-chars-backward " \t\n") 7266 (memq (preceding-char) '(?\= ?\> ?\< ?\, ?\( ?\[ ?\{)))) 7267 ;; Now check for syntax type 7268 (save-match-data 7269 (setq found (point)) 7270 (beginning-of-defun) 7271 (let ((pps (parse-partial-sexp (point) found))) 7272 (or (nth 3 pps) (nth 4 pps) (nth 5 pps))))) 7273 (goto-char (match-end 0)) 7274 (goto-char (1- p)) 7275 (setq not-found nil 7276 found-bad found))) 7277 (not not-found))) 7278 7279 7280;;; Getting help 7281(defvar cperl-have-help-regexp 7282 ;;(concat "\\(" 7283 (mapconcat 7284 #'identity 7285 '("[$@%*&][[:alnum:]_:]+\\([ \t]*[[{]\\)?" ; Usual variable 7286 "[$@]\\^[a-zA-Z]" ; Special variable 7287 "[$@][^ \n\t]" ; Special variable 7288 "-[a-zA-Z]" ; File test 7289 "\\\\[a-zA-Z0]" ; Special chars 7290 "^=[a-z][a-zA-Z0-9_]*" ; POD sections 7291 "[-!&*+,./<=>?\\^|~]+" ; Operator 7292 "[[:alnum:]_:]+" ; symbol or number 7293 "x=" 7294 "#!") 7295 ;;"\\)\\|\\(" 7296 "\\|") 7297 ;;"\\)" 7298 ;;) 7299 "Matches places in the buffer we can find help for.") 7300 7301(defvar cperl-message-on-help-error t) 7302(defvar cperl-help-from-timer nil) 7303 7304(defun cperl-word-at-point-hard () 7305 ;; Does not save-excursion 7306 ;; Get to the something meaningful 7307 (or (eobp) (eolp) (forward-char 1)) 7308 (re-search-backward "[-[:alnum:]_:!&*+,./<=>?\\^|~$%@]" 7309 (point-at-bol) 7310 'to-beg) 7311 ;; (cond 7312 ;; ((or (eobp) (looking-at "[][ \t\n{}();,]")) ; Not at a symbol 7313 ;; (skip-chars-backward " \n\t\r({[]});,") 7314 ;; (or (bobp) (backward-char 1)))) 7315 ;; Try to backtrace 7316 (cond 7317 ((looking-at "[[:alnum:]_:]") ; symbol 7318 (skip-chars-backward "[:alnum:]_:") 7319 (cond 7320 ((and (eq (preceding-char) ?^) ; $^I 7321 (eq (char-after (- (point) 2)) ?\$)) 7322 (forward-char -2)) 7323 ((memq (preceding-char) (append "*$@%&\\" nil)) ; *glob 7324 (forward-char -1)) 7325 ((and (eq (preceding-char) ?\=) 7326 (eq (current-column) 1)) 7327 (forward-char -1))) ; =head1 7328 (if (and (eq (preceding-char) ?\<) 7329 (looking-at "\\$?[[:alnum:]_:]+>")) ; <FH> 7330 (forward-char -1))) 7331 ((and (looking-at "=") (eq (preceding-char) ?x)) ; x= 7332 (forward-char -1)) 7333 ((and (looking-at "\\^") (eq (preceding-char) ?\$)) ; $^I 7334 (forward-char -1)) 7335 ((looking-at "[-!&*+,./<=>?\\^|~]") 7336 (skip-chars-backward "-!&*+,./<=>?\\^|~") 7337 (cond 7338 ((and (eq (preceding-char) ?\$) 7339 (not (eq (char-after (- (point) 2)) ?\$))) ; $- 7340 (forward-char -1)) 7341 ((and (eq (following-char) ?\>) 7342 (string-match "[[:alnum:]_]" (char-to-string (preceding-char))) 7343 (save-excursion 7344 (forward-sexp -1) 7345 (and (eq (preceding-char) ?\<) 7346 (looking-at "\\$?[[:alnum:]_:]+>")))) ; <FH> 7347 (search-backward "<")))) 7348 ((and (eq (following-char) ?\$) 7349 (eq (preceding-char) ?\<) 7350 (looking-at "\\$?[[:alnum:]_:]+>")) ; <$fh> 7351 (forward-char -1))) 7352 (if (looking-at cperl-have-help-regexp) 7353 (buffer-substring (match-beginning 0) (match-end 0)))) 7354 7355(defun cperl-get-help () 7356 "Get one-line docs on the symbol at the point. 7357The data for these docs is a little bit obsolete and may be in fact longer 7358than a line. Your contribution to update/shorten it is appreciated." 7359 (interactive) 7360 (save-match-data ; May be called "inside" query-replace 7361 (save-excursion 7362 (let ((word (cperl-word-at-point-hard))) 7363 (if word 7364 (if (and cperl-help-from-timer ; Bail out if not in mainland 7365 (not (string-match "^#!\\|\\\\\\|^=" word)) ; Show help even in comments/strings. 7366 (or (memq (get-text-property (point) 'face) 7367 '(font-lock-comment-face font-lock-string-face)) 7368 (memq (get-text-property (point) 'syntax-type) 7369 '(pod here-doc format)))) 7370 nil 7371 (cperl-describe-perl-symbol word)) 7372 (if cperl-message-on-help-error 7373 (message "Nothing found for %s..." 7374 (buffer-substring (point) (min (+ 5 (point)) (point-max)))))))))) 7375 7376;;; Stolen from perl-descr.el by Johan Vromans: 7377 7378(defvar cperl-doc-buffer " *perl-doc*" 7379 "Where the documentation can be found.") 7380 7381(defun cperl-describe-perl-symbol (val) 7382 "Display the documentation of symbol at point, a Perl operator." 7383 (let ((enable-recursive-minibuffers t) 7384 regexp) 7385 (cond 7386 ((string-match "^[&*][a-zA-Z_]" val) 7387 (setq val (concat (substring val 0 1) "NAME"))) 7388 ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*\\[" val) 7389 (setq val (concat "@" (substring val 1 (match-end 1))))) 7390 ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*{" val) 7391 (setq val (concat "%" (substring val 1 (match-end 1))))) 7392 ((and (string= val "x") (string-match "^x=" val)) 7393 (setq val "x=")) 7394 ((string-match "^\\$[\C-a-\C-z]" val) 7395 (setq val (concat "$^" (char-to-string (+ ?A -1 (aref val 1)))))) 7396 ((string-match "^CORE::" val) 7397 (setq val "CORE::")) 7398 ((string-match "^SUPER::" val) 7399 (setq val "SUPER::")) 7400 ((and (string= "<" val) (string-match "^<\\$?[a-zA-Z0-9_:]+>" val)) 7401 (setq val "<NAME>"))) 7402 (setq regexp (concat "^" 7403 "\\([^a-zA-Z0-9_:]+[ \t]+\\)?" 7404 (regexp-quote val) 7405 "\\([ \t([/]\\|$\\)")) 7406 7407 ;; get the buffer with the documentation text 7408 (cperl-switch-to-doc-buffer) 7409 7410 ;; lookup in the doc 7411 (goto-char (point-min)) 7412 (let ((case-fold-search nil)) 7413 (list 7414 (if (re-search-forward regexp (point-max) t) 7415 (save-excursion 7416 (beginning-of-line 1) 7417 (let ((lnstart (point))) 7418 (end-of-line) 7419 (message "%s" (buffer-substring lnstart (point))))) 7420 (if cperl-message-on-help-error 7421 (message "No definition for %s" val))))))) 7422 7423(defvar cperl-short-docs 'please-ignore-this-line 7424 ;; Perl4 version was written by Johan Vromans (jvromans@squirrel.nl) 7425 "# based on \\='@(#)@ perl-descr.el 1.9 - describe-perl-symbol\\=' [Perl 5] 7426... Range (list context); flip/flop [no flop when flip] (scalar context). 7427! ... Logical negation. 7428... != ... Numeric inequality. 7429... !~ ... Search pattern, substitution, or translation (negated). 7430$! In numeric context: errno. In a string context: error string. 7431$\" The separator which joins elements of arrays interpolated in strings. 7432$# The output format for printed numbers. Default is %.15g or close. 7433$$ Process number of this script. Changes in the fork()ed child process. 7434$% The current page number of the currently selected output channel. 7435 7436 The following variables are always local to the current block: 7437 7438$1 Match of the 1st set of parentheses in the last match (auto-local). 7439$2 Match of the 2nd set of parentheses in the last match (auto-local). 7440$3 Match of the 3rd set of parentheses in the last match (auto-local). 7441$4 Match of the 4th set of parentheses in the last match (auto-local). 7442$5 Match of the 5th set of parentheses in the last match (auto-local). 7443$6 Match of the 6th set of parentheses in the last match (auto-local). 7444$7 Match of the 7th set of parentheses in the last match (auto-local). 7445$8 Match of the 8th set of parentheses in the last match (auto-local). 7446$9 Match of the 9th set of parentheses in the last match (auto-local). 7447$& The string matched by the last pattern match (auto-local). 7448$\\=' The string after what was matched by the last match (auto-local). 7449$\\=` The string before what was matched by the last match (auto-local). 7450 7451$( The real gid of this process. 7452$) The effective gid of this process. 7453$* Deprecated: Set to 1 to do multiline matching within a string. 7454$+ The last bracket matched by the last search pattern. 7455$, The output field separator for the print operator. 7456$- The number of lines left on the page. 7457$. The current input line number of the last filehandle that was read. 7458$/ The input record separator, newline by default. 7459$0 Name of the file containing the current perl script (read/write). 7460$: String may be broken after these characters to fill ^-lines in a format. 7461$; Subscript separator for multi-dim array emulation. Default \"\\034\". 7462$< The real uid of this process. 7463$= The page length of the current output channel. Default is 60 lines. 7464$> The effective uid of this process. 7465$? The status returned by the last \\=`\\=`, pipe close or `system'. 7466$@ The perl error message from the last eval or do @var{EXPR} command. 7467$ARGV The name of the current file used with <> . 7468$[ Deprecated: The index of the first element/char in an array/string. 7469$\\ The output record separator for the print operator. 7470$] The perl version string as displayed with perl -v. 7471$^ The name of the current top-of-page format. 7472$^A The current value of the write() accumulator for format() lines. 7473$^D The value of the perl debug (-D) flags. 7474$^E Information about the last system error other than that provided by $!. 7475$^F The highest system file descriptor, ordinarily 2. 7476$^H The current set of syntax checks enabled by `use strict'. 7477$^I The value of the in-place edit extension (perl -i option). 7478$^L What formats output to perform a formfeed. Default is \\f. 7479$^M A buffer for emergency memory allocation when running out of memory. 7480$^O The operating system name under which this copy of Perl was built. 7481$^P Internal debugging flag. 7482$^T The time the script was started. Used by -A/-M/-C file tests. 7483$^W True if warnings are requested (perl -w flag). 7484$^X The name under which perl was invoked (argv[0] in C-speech). 7485$_ The default input and pattern-searching space. 7486$| Auto-flush after write/print on current output channel? Default 0. 7487$~ The name of the current report format. 7488... % ... Modulo division. 7489... %= ... Modulo division assignment. 7490%ENV Contains the current environment. 7491%INC List of files that have been require-d or do-ne. 7492%SIG Used to set signal handlers for various signals. 7493... & ... Bitwise and. 7494... && ... Logical and. 7495... &&= ... Logical and assignment. 7496... &= ... Bitwise and assignment. 7497... * ... Multiplication. 7498... ** ... Exponentiation. 7499*NAME Glob: all objects referred by NAME. *NAM1 = *NAM2 aliases NAM1 to NAM2. 7500&NAME(arg0, ...) Subroutine call. Arguments go to @_. 7501... + ... Addition. +EXPR Makes EXPR into scalar context. 7502++ Auto-increment (magical on strings). ++EXPR EXPR++ 7503... += ... Addition assignment. 7504, Comma operator. 7505... - ... Subtraction. 7506-- Auto-decrement (NOT magical on strings). --EXPR EXPR-- 7507... -= ... Subtraction assignment. 7508-A Access time in days since script started. 7509-B File is a non-text (binary) file. 7510-C Inode change time in days since script started. 7511-M Age in days since script started. 7512-O File is owned by real uid. 7513-R File is readable by real uid. 7514-S File is a socket . 7515-T File is a text file. 7516-W File is writable by real uid. 7517-X File is executable by real uid. 7518-b File is a block special file. 7519-c File is a character special file. 7520-d File is a directory. 7521-e File exists . 7522-f File is a plain file. 7523-g File has setgid bit set. 7524-k File has sticky bit set. 7525-l File is a symbolic link. 7526-o File is owned by effective uid. 7527-p File is a named pipe (FIFO). 7528-r File is readable by effective uid. 7529-s File has non-zero size. 7530-t Tests if filehandle (STDIN by default) is opened to a tty. 7531-u File has setuid bit set. 7532-w File is writable by effective uid. 7533-x File is executable by effective uid. 7534-z File has zero size. 7535. Concatenate strings. 7536.. Range (list context); flip/flop (scalar context) operator. 7537.= Concatenate assignment strings 7538... / ... Division. /PATTERN/ioxsmg Pattern match 7539... /= ... Division assignment. 7540/PATTERN/ioxsmg Pattern match. 7541... < ... Numeric less than. <pattern> Glob. See <NAME>, <> as well. 7542<NAME> Reads line from filehandle NAME (a bareword or dollar-bareword). 7543<pattern> Glob (Unless pattern is bareword/dollar-bareword - see <NAME>). 7544<> Reads line from union of files in @ARGV (= command line) and STDIN. 7545... << ... Bitwise shift left. << start of HERE-DOCUMENT. 7546... <= ... Numeric less than or equal to. 7547... <=> ... Numeric compare. 7548... = ... Assignment. 7549... == ... Numeric equality. 7550... =~ ... Search pattern, substitution, or translation 7551... ~~ .. Smart match 7552... > ... Numeric greater than. 7553... >= ... Numeric greater than or equal to. 7554... >> ... Bitwise shift right. 7555... >>= ... Bitwise shift right assignment. 7556... ? ... : ... Condition=if-then-else operator. 7557@ARGV Command line arguments (not including the command name - see $0). 7558@INC List of places to look for perl scripts during do/include/use. 7559@_ Parameter array for subroutines; result of split() unless in list context. 7560\\ Creates reference to what follows, like \\$var, or quotes non-\\w in strings. 7561\\0 Octal char, e.g. \\033. 7562\\E Case modification terminator. See \\Q, \\L, and \\U. 7563\\L Lowercase until \\E . See also \\l, lc. 7564\\U Upcase until \\E . See also \\u, uc. 7565\\Q Quote metacharacters until \\E . See also quotemeta. 7566\\a Alarm character (octal 007). 7567\\b Backspace character (octal 010). 7568\\c Control character, e.g. \\c[ . 7569\\e Escape character (octal 033). 7570\\f Formfeed character (octal 014). 7571\\l Lowercase the next character. See also \\L and \\u, lcfirst. 7572\\n Newline character (octal 012 on most systems). 7573\\r Return character (octal 015 on most systems). 7574\\t Tab character (octal 011). 7575\\u Upcase the next character. See also \\U and \\l, ucfirst. 7576\\x Hex character, e.g. \\x1b. 7577... ^ ... Bitwise exclusive or. 7578__END__ Ends program source. 7579__DATA__ Ends program source. 7580__FILE__ Current (source) filename. 7581__LINE__ Current line in current source. 7582__PACKAGE__ Current package. 7583__SUB__ Current sub. 7584ARGV Default multi-file input filehandle. <ARGV> is a synonym for <>. 7585ARGVOUT Output filehandle with -i flag. 7586BEGIN { ... } Immediately executed (during compilation) piece of code. 7587END { ... } Pseudo-subroutine executed after the script finishes. 7588CHECK { ... } Pseudo-subroutine executed after the script is compiled. 7589UNITCHECK { ... } 7590INIT { ... } Pseudo-subroutine executed before the script starts running. 7591DATA Input filehandle for what follows after __END__ or __DATA__. 7592accept(NEWSOCKET,GENERICSOCKET) 7593alarm(SECONDS) 7594atan2(X,Y) 7595bind(SOCKET,NAME) 7596binmode(FILEHANDLE) 7597break Break out of a given/when statement 7598caller[(LEVEL)] 7599chdir(EXPR) 7600chmod(LIST) 7601chop[(LIST|VAR)] 7602chown(LIST) 7603chroot(FILENAME) 7604close(FILEHANDLE) 7605closedir(DIRHANDLE) 7606... cmp ... String compare. 7607connect(SOCKET,NAME) 7608continue of { block } continue { block }. Is executed after `next' or at end. 7609cos(EXPR) 7610crypt(PLAINTEXT,SALT) 7611dbmclose(%HASH) 7612dbmopen(%HASH,DBNAME,MODE) 7613default { ... } default case for given/when block 7614defined(EXPR) 7615delete($HASH{KEY}) 7616die(LIST) 7617do { ... }|SUBR while|until EXPR executes at least once 7618do(EXPR|SUBR([LIST])) (with while|until executes at least once) 7619dump LABEL 7620each(%HASH) 7621endgrent 7622endhostent 7623endnetent 7624endprotoent 7625endpwent 7626endservent 7627eof[([FILEHANDLE])] 7628... eq ... String equality. 7629eval(EXPR) or eval { BLOCK } 7630evalbytes See eval. 7631exec([TRUENAME] ARGV0, ARGVs) or exec(SHELL_COMMAND_LINE) 7632exit(EXPR) 7633exp(EXPR) 7634fcntl(FILEHANDLE,FUNCTION,SCALAR) 7635fileno(FILEHANDLE) 7636flock(FILEHANDLE,OPERATION) 7637for (EXPR;EXPR;EXPR) { ... } 7638foreach [VAR] (@ARRAY) { ... } 7639fork 7640... ge ... String greater than or equal. 7641getc[(FILEHANDLE)] 7642getgrent 7643getgrgid(GID) 7644getgrnam(NAME) 7645gethostbyaddr(ADDR,ADDRTYPE) 7646gethostbyname(NAME) 7647gethostent 7648getlogin 7649getnetbyaddr(ADDR,ADDRTYPE) 7650getnetbyname(NAME) 7651getnetent 7652getpeername(SOCKET) 7653getpgrp(PID) 7654getppid 7655getpriority(WHICH,WHO) 7656getprotobyname(NAME) 7657getprotobynumber(NUMBER) 7658getprotoent 7659getpwent 7660getpwnam(NAME) 7661getpwuid(UID) 7662getservbyname(NAME,PROTO) 7663getservbyport(PORT,PROTO) 7664getservent 7665getsockname(SOCKET) 7666getsockopt(SOCKET,LEVEL,OPTNAME) 7667given (EXPR) { [ when (EXPR) { ... } ]+ [ default { ... } ]? } 7668gmtime(EXPR) 7669goto LABEL 7670... gt ... String greater than. 7671hex(EXPR) 7672if (EXPR) { ... } [ elsif (EXPR) { ... } ... ] [ else { ... } ] or EXPR if EXPR 7673index(STR,SUBSTR[,OFFSET]) 7674int(EXPR) 7675ioctl(FILEHANDLE,FUNCTION,SCALAR) 7676join(EXPR,LIST) 7677keys(%HASH) 7678kill(LIST) 7679last [LABEL] 7680... le ... String less than or equal. 7681length(EXPR) 7682link(OLDFILE,NEWFILE) 7683listen(SOCKET,QUEUESIZE) 7684local(LIST) 7685localtime(EXPR) 7686log(EXPR) 7687lstat(EXPR|FILEHANDLE|VAR) 7688... lt ... String less than. 7689m/PATTERN/iogsmx 7690mkdir(FILENAME,MODE) 7691msgctl(ID,CMD,ARG) 7692msgget(KEY,FLAGS) 7693msgrcv(ID,VAR,SIZE,TYPE.FLAGS) 7694msgsnd(ID,MSG,FLAGS) 7695my VAR or my (VAR1,...) Introduces a lexical variable ($VAR, @ARR, or %HASH). 7696our VAR or our (VAR1,...) Lexically enable a global variable ($V, @A, or %H). 7697... ne ... String inequality. 7698next [LABEL] 7699oct(EXPR) 7700open(FILEHANDLE[,EXPR]) 7701opendir(DIRHANDLE,EXPR) 7702ord(EXPR) ASCII value of the first char of the string. 7703pack(TEMPLATE,LIST) 7704package NAME Introduces package context. 7705pipe(READHANDLE,WRITEHANDLE) Create a pair of filehandles on ends of a pipe. 7706pop(ARRAY) 7707print [FILEHANDLE] [(LIST)] 7708printf [FILEHANDLE] (FORMAT,LIST) 7709push(ARRAY,LIST) 7710q/STRING/ Synonym for \\='STRING\\=' 7711qq/STRING/ Synonym for \"STRING\" 7712qx/STRING/ Synonym for \\=`STRING\\=` 7713rand[(EXPR)] 7714read(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) 7715readdir(DIRHANDLE) 7716readlink(EXPR) 7717recv(SOCKET,SCALAR,LEN,FLAGS) 7718redo [LABEL] 7719rename(OLDNAME,NEWNAME) 7720require [FILENAME | PERL_VERSION] 7721reset[(EXPR)] 7722return(LIST) 7723reverse(LIST) 7724rewinddir(DIRHANDLE) 7725rindex(STR,SUBSTR[,OFFSET]) 7726rmdir(FILENAME) 7727s/PATTERN/REPLACEMENT/gieoxsm 7728say [FILEHANDLE] [(LIST)] 7729scalar(EXPR) 7730seek(FILEHANDLE,POSITION,WHENCE) 7731seekdir(DIRHANDLE,POS) 7732select(FILEHANDLE | RBITS,WBITS,EBITS,TIMEOUT) 7733semctl(ID,SEMNUM,CMD,ARG) 7734semget(KEY,NSEMS,SIZE,FLAGS) 7735semop(KEY,...) 7736send(SOCKET,MSG,FLAGS[,TO]) 7737setgrent 7738sethostent(STAYOPEN) 7739setnetent(STAYOPEN) 7740setpgrp(PID,PGRP) 7741setpriority(WHICH,WHO,PRIORITY) 7742setprotoent(STAYOPEN) 7743setpwent 7744setservent(STAYOPEN) 7745setsockopt(SOCKET,LEVEL,OPTNAME,OPTVAL) 7746shift[(ARRAY)] 7747shmctl(ID,CMD,ARG) 7748shmget(KEY,SIZE,FLAGS) 7749shmread(ID,VAR,POS,SIZE) 7750shmwrite(ID,STRING,POS,SIZE) 7751shutdown(SOCKET,HOW) 7752sin(EXPR) 7753sleep[(EXPR)] 7754socket(SOCKET,DOMAIN,TYPE,PROTOCOL) 7755socketpair(SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL) 7756sort [SUBROUTINE] (LIST) 7757splice(ARRAY,OFFSET[,LENGTH[,LIST]]) 7758split[(/PATTERN/[,EXPR[,LIMIT]])] 7759sprintf(FORMAT,LIST) 7760sqrt(EXPR) 7761srand(EXPR) 7762stat(EXPR|FILEHANDLE|VAR) 7763state VAR or state (VAR1,...) Introduces a static lexical variable 7764study[(SCALAR)] 7765sub [NAME [(format)]] { BODY } sub NAME [(format)]; sub [(format)] {...} 7766substr(EXPR,OFFSET[,LEN]) 7767symlink(OLDFILE,NEWFILE) 7768syscall(LIST) 7769sysread(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) 7770system([TRUENAME] ARGV0 [,ARGV]) or system(SHELL_COMMAND_LINE) 7771syswrite(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) 7772tell[(FILEHANDLE)] 7773telldir(DIRHANDLE) 7774time 7775times 7776tr/SEARCHLIST/REPLACEMENTLIST/cds 7777truncate(FILE|EXPR,LENGTH) 7778umask[(EXPR)] 7779undef[(EXPR)] 7780unless (EXPR) { ... } [ else { ... } ] or EXPR unless EXPR 7781unlink(LIST) 7782unpack(TEMPLATE,EXPR) 7783unshift(ARRAY,LIST) 7784until (EXPR) { ... } EXPR until EXPR 7785utime(LIST) 7786values(%HASH) 7787vec(EXPR,OFFSET,BITS) 7788wait 7789waitpid(PID,FLAGS) 7790wantarray Returns true if the sub/eval is called in list context. 7791warn(LIST) 7792while (EXPR) { ... } EXPR while EXPR 7793write[(EXPR|FILEHANDLE)] 7794... x ... Repeat string or array. 7795x= ... Repetition assignment. 7796y/SEARCHLIST/REPLACEMENTLIST/ 7797... | ... Bitwise or. 7798... || ... Logical or. 7799... // ... Defined-or. 7800~ ... Unary bitwise complement. 7801#! OS interpreter indicator. If contains `perl', used for options, and -x. 7802AUTOLOAD {...} Shorthand for `sub AUTOLOAD {...}'. 7803CORE:: Prefix to access builtin function if imported sub obscures it. 7804SUPER:: Prefix to lookup for a method in @ISA classes. 7805DESTROY Shorthand for `sub DESTROY {...}'. 7806... EQ ... Obsolete synonym of `eq'. 7807... GE ... Obsolete synonym of `ge'. 7808... GT ... Obsolete synonym of `gt'. 7809... LE ... Obsolete synonym of `le'. 7810... LT ... Obsolete synonym of `lt'. 7811... NE ... Obsolete synonym of `ne'. 7812abs [ EXPR ] absolute value 7813... and ... Low-precedence synonym for &&. 7814bless REFERENCE [, PACKAGE] Makes reference into an object of a package. 7815chomp [LIST] Strips $/ off LIST/$_. Returns count. Special if $/ eq \\='\\='! 7816chr Converts a number to char with the same ordinal. 7817else Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. 7818elsif Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. 7819exists $HASH{KEY} True if the key exists. 7820fc EXPR Returns the casefolded version of EXPR. 7821format [NAME] = Start of output format. Ended by a single dot (.) on a line. 7822formline PICTURE, LIST Backdoor into \"format\" processing. 7823glob EXPR Synonym of <EXPR>. 7824lc [ EXPR ] Returns lowercased EXPR. 7825lcfirst [ EXPR ] Returns EXPR with lower-cased first letter. 7826grep EXPR,LIST or grep {BLOCK} LIST Filters LIST via EXPR/BLOCK. 7827map EXPR, LIST or map {BLOCK} LIST Applies EXPR/BLOCK to elts of LIST. 7828no PACKAGE [SYMBOL1, ...] Partial reverse for `use'. Runs `unimport' method. 7829not ... Low-precedence synonym for ! - negation. 7830... or ... Low-precedence synonym for ||. 7831pos STRING Set/Get end-position of the last match over this string, see \\G. 7832prototype FUNC Returns the prototype of a function as a string, or undef. 7833quotemeta [ EXPR ] Quote regexp metacharacters. 7834qw/WORD1 .../ Synonym of split(\\='\\=', \\='WORD1 ...\\=') 7835readline FH Synonym of <FH>. 7836readpipe CMD Synonym of \\=`CMD\\=`. 7837ref [ EXPR ] Type of EXPR when dereferenced. 7838sysopen FH, FILENAME, MODE [, PERM] (MODE is numeric, see Fcntl.) 7839tie VAR, PACKAGE, LIST Hide an object behind a simple Perl variable. 7840tied Returns internal object for a tied data. 7841uc [ EXPR ] Returns upcased EXPR. 7842ucfirst [ EXPR ] Returns EXPR with upcased first letter. 7843untie VAR Unlink an object from a simple Perl variable. 7844use PACKAGE [SYMBOL1, ...] Compile-time `require' with consequent `import'. 7845... xor ... Low-precedence synonym for exclusive or. 7846prototype \\&SUB Returns prototype of the function given a reference. 7847=head1 Top-level heading. 7848=head2 Second-level heading. 7849=head3 Third-level heading. 7850=head4 Fourth-level heading. 7851=over [ NUMBER ] Start list. 7852=item [ TITLE ] Start new item in the list. 7853=back End list. 7854=cut Switch from POD to Perl. 7855=pod Switch from Perl to POD. 7856=begin formatname Start directly formatted region. 7857=end formatname End directly formatted region. 7858=for formatname text Paragraph in special format. 7859=encoding encodingname Encoding of the document.") 7860 7861(defun cperl-switch-to-doc-buffer (&optional interactive) 7862 "Go to the Perl documentation buffer and insert the documentation." 7863 (interactive "p") 7864 (let ((buf (get-buffer-create cperl-doc-buffer))) 7865 (if interactive 7866 (switch-to-buffer-other-window buf) 7867 (set-buffer buf)) 7868 (if (= (buffer-size) 0) 7869 (progn 7870 (insert (documentation-property 'cperl-short-docs 7871 'variable-documentation)) 7872 (setq buffer-read-only t))))) 7873 7874(defun cperl-beautify-regexp-piece (b e embed level) 7875 ;; b is before the starting delimiter, e before the ending 7876 ;; e should be a marker, may be changed, but remains "correct". 7877 ;; EMBED is nil if we process the whole REx. 7878 ;; The REx is guaranteed to have //x 7879 ;; LEVEL shows how many levels deep to go 7880 ;; position at enter and at leave is not defined 7881 (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline pos) 7882 (if embed 7883 (progn 7884 (goto-char b) 7885 (setq c (if (eq embed t) (current-indentation) (current-column))) 7886 (cond ((looking-at "(\\?\\\\#") ; (?#) wrongly commented when //x-ing 7887 (forward-char 2) 7888 (delete-char 1) 7889 (forward-char 1)) 7890 ((looking-at "(\\?[^a-zA-Z]") 7891 (forward-char 3)) 7892 ((looking-at "(\\?") ; (?i) 7893 (forward-char 2)) 7894 (t 7895 (forward-char 1)))) 7896 (goto-char (1+ b)) 7897 (setq c (1- (current-column)))) 7898 (setq c1 (+ c (or cperl-regexp-indent-step cperl-indent-level))) 7899 (or (looking-at "[ \t]*[\n#]") 7900 (progn 7901 (insert "\n"))) 7902 (goto-char e) 7903 (beginning-of-line) 7904 (if (re-search-forward "[^ \t]" e t) 7905 (progn ; Something before the ending delimiter 7906 (goto-char e) 7907 (delete-horizontal-space) 7908 (insert "\n") 7909 (cperl-make-indent c) 7910 (set-marker e (point)))) 7911 (goto-char b) 7912 (end-of-line 2) 7913 (while (< (point) (marker-position e)) 7914 (beginning-of-line) 7915 (setq s (point) 7916 inline t) 7917 (skip-chars-forward " \t") 7918 (delete-region s (point)) 7919 (cperl-make-indent c1) 7920 (while (and 7921 inline 7922 (looking-at 7923 (concat "\\([a-zA-Z0-9]+[^*+{?]\\)" ; 1 word 7924 "\\|" ; Embedded variable 7925 "\\$\\([a-zA-Z0-9_]+\\([[{]\\)?\\|[^\n \t)|]\\)" ; 2 3 7926 "\\|" ; $ ^ 7927 "[$^]" 7928 "\\|" ; simple-code simple-code*? 7929 "\\(\\\\.\\|[^][()#|*+?$^\n]\\)\\([*+{?]\\??\\)?" ; 4 5 7930 "\\|" ; Class 7931 "\\(\\[\\)" ; 6 7932 "\\|" ; Grouping 7933 "\\((\\(\\?\\)?\\)" ; 7 8 7934 "\\|" ; | 7935 "\\(|\\)"))) ; 9 7936 (goto-char (match-end 0)) 7937 (setq spaces t) 7938 (cond ((match-beginning 1) ; Alphanum word + junk 7939 (forward-char -1)) 7940 ((or (match-beginning 3) ; $ab[12] 7941 (and (match-beginning 5) ; X* X+ X{2,3} 7942 (eq (preceding-char) ?\{))) 7943 (forward-char -1) 7944 (forward-sexp 1)) 7945 ((and ; [], already syntaxified 7946 (match-beginning 6) 7947 cperl-regexp-scan 7948 cperl-use-syntax-table-text-property) 7949 (forward-char -1) 7950 (forward-sexp 1) 7951 (or (eq (preceding-char) ?\]) 7952 (error "[]-group not terminated")) 7953 (re-search-forward 7954 "\\=\\([*+?]\\|{[0-9]+\\(,[0-9]*\\)?}\\)\\??" e t)) 7955 ((match-beginning 6) ; [] 7956 (setq tmp (point)) 7957 (if (looking-at "\\^?\\]") 7958 (goto-char (match-end 0))) 7959 ;; XXXX POSIX classes?! 7960 (while (and (not pos) 7961 (re-search-forward "\\[:\\|\\]" e t)) 7962 (if (eq (preceding-char) ?:) 7963 (or (re-search-forward ":\\]" e t) 7964 (error "[:POSIX:]-group in []-group not terminated")) 7965 (setq pos t))) 7966 (or (eq (preceding-char) ?\]) 7967 (error "[]-group not terminated")) 7968 (re-search-forward 7969 "\\=\\([*+?]\\|{[0-9]+\\(,[0-9]*\\)?}\\)\\??" e t)) 7970 ((match-beginning 7) ; () 7971 (goto-char (match-beginning 0)) 7972 (setq pos (current-column)) 7973 (or (eq pos c1) 7974 (progn 7975 (delete-horizontal-space) 7976 (insert "\n") 7977 (cperl-make-indent c1))) 7978 (setq tmp (point)) 7979 (forward-sexp 1) 7980 ;; (or (forward-sexp 1) 7981 ;; (progn 7982 ;; (goto-char tmp) 7983 ;; (error "()-group not terminated"))) 7984 (set-marker m (1- (point))) 7985 (set-marker m1 (point)) 7986 (if (= level 1) 7987 (if (progn ; indent rigidly if multiline 7988 ;; In fact does not make a lot of sense, since 7989 ;; the starting position can be already lost due 7990 ;; to insertion of "\n" and " " 7991 (goto-char tmp) 7992 (search-forward "\n" m1 t)) 7993 (indent-rigidly (point) m1 (- c1 pos))) 7994 (setq level (1- level)) 7995 (cond 7996 ((not (match-beginning 8)) 7997 (cperl-beautify-regexp-piece tmp m t level)) 7998 ((eq (char-after (+ 2 tmp)) ?\{) ; Code 7999 t) 8000 ((eq (char-after (+ 2 tmp)) ?\() ; Conditional 8001 (goto-char (+ 2 tmp)) 8002 (forward-sexp 1) 8003 (cperl-beautify-regexp-piece (point) m t level)) 8004 ((eq (char-after (+ 2 tmp)) ?<) ; Lookbehind 8005 (goto-char (+ 3 tmp)) 8006 (cperl-beautify-regexp-piece (point) m t level)) 8007 (t 8008 (cperl-beautify-regexp-piece tmp m t level)))) 8009 (goto-char m1) 8010 (cond ((looking-at "[*+?]\\??") 8011 (goto-char (match-end 0))) 8012 ((eq (following-char) ?\{) 8013 (forward-sexp 1) 8014 (if (eq (following-char) ?\?) 8015 (forward-char)))) 8016 (skip-chars-forward " \t") 8017 (setq spaces nil) 8018 (if (looking-at "[#\n]") 8019 (progn 8020 (or (eolp) (indent-for-comment)) 8021 (beginning-of-line 2)) 8022 (delete-horizontal-space) 8023 (insert "\n")) 8024 (end-of-line) 8025 (setq inline nil)) 8026 ((match-beginning 9) ; | 8027 (forward-char -1) 8028 (setq tmp (point)) 8029 (beginning-of-line) 8030 (if (re-search-forward "[^ \t]" tmp t) 8031 (progn 8032 (goto-char tmp) 8033 (delete-horizontal-space) 8034 (insert "\n")) 8035 ;; first at line 8036 (delete-region (point) tmp)) 8037 (cperl-make-indent c) 8038 (forward-char 1) 8039 (skip-chars-forward " \t") 8040 (setq spaces nil) 8041 (if (looking-at "[#\n]") 8042 (beginning-of-line 2) 8043 (delete-horizontal-space) 8044 (insert "\n")) 8045 (end-of-line) 8046 (setq inline nil))) 8047 (or (looking-at "[ \t\n]") 8048 (not spaces) 8049 (insert " ")) 8050 (skip-chars-forward " \t")) 8051 (or (looking-at "[#\n]") 8052 (error "Unknown code `%s' in a regexp" 8053 (buffer-substring (point) (1+ (point))))) 8054 (and inline (end-of-line 2))) 8055 ;; Special-case the last line of group 8056 (if (and (>= (point) (marker-position e)) 8057 (/= (current-indentation) c)) 8058 (progn 8059 (beginning-of-line) 8060 (cperl-make-indent c))))) 8061 8062(defun cperl-make-regexp-x () 8063 ;; Returns position of the start 8064 ;; XXX this is called too often! Need to cache the result! 8065 (save-excursion 8066 (or cperl-use-syntax-table-text-property 8067 (error "I need to have a regexp marked!")) 8068 ;; Find the start 8069 (if (looking-at "\\s|") 8070 nil ; good already 8071 (if (or (looking-at "\\([smy]\\|qr\\)\\s|") 8072 (and (eq (preceding-char) ?q) 8073 (looking-at "\\(r\\)\\s|"))) 8074 (goto-char (match-end 1)) 8075 (re-search-backward "\\s|"))) ; Assume it is scanned already. 8076 ;;(forward-char 1) 8077 (let ((b (point)) (e (make-marker)) have-x delim 8078 (sub-p (eq (preceding-char) ?s))) 8079 (forward-sexp 1) 8080 (set-marker e (1- (point))) 8081 (setq delim (preceding-char)) 8082 (if (and sub-p (eq delim (char-after (- (point) 2)))) 8083 (error "Possible s/blah// - do not know how to deal with")) 8084 (if sub-p (forward-sexp 1)) 8085 (if (looking-at "\\sw*x") 8086 (setq have-x t) 8087 (insert "x")) 8088 ;; Protect fragile " ", "#" 8089 (if have-x nil 8090 (goto-char (1+ b)) 8091 (while (re-search-forward "\\(\\=\\|[^\\]\\)\\(\\\\\\\\\\)*[ \t\n#]" e t) ; Need to include (?#) too? 8092 (forward-char -1) 8093 (insert "\\") 8094 (forward-char 1))) 8095 b))) 8096 8097(defun cperl-beautify-regexp (&optional deep) 8098 "Do it. (Experimental, may change semantics, recheck the result.) 8099We suppose that the regexp is scanned already." 8100 (interactive "P") 8101 (setq deep (if deep (prefix-numeric-value deep) -1)) 8102 (save-excursion 8103 (goto-char (cperl-make-regexp-x)) 8104 (let ((b (point)) (e (make-marker))) 8105 (forward-sexp 1) 8106 (set-marker e (1- (point))) 8107 (cperl-beautify-regexp-piece b e nil deep)))) 8108 8109(defun cperl-regext-to-level-start () 8110 "Goto start of an enclosing group in regexp. 8111We suppose that the regexp is scanned already." 8112 (interactive) 8113 (let ((limit (cperl-make-regexp-x)) done) 8114 (while (not done) 8115 (or (eq (following-char) ?\() 8116 (search-backward "(" (1+ limit) t) 8117 (error "Cannot find `(' which starts a group")) 8118 (setq done 8119 (save-excursion 8120 (skip-chars-backward "\\\\") 8121 (looking-at "\\(\\\\\\\\\\)*("))) 8122 (or done (forward-char -1))))) 8123 8124(defun cperl-contract-level () 8125 "Find an enclosing group in regexp and contract it. 8126\(Experimental, may change semantics, recheck the result.) 8127We suppose that the regexp is scanned already." 8128 (interactive) 8129 ;; (save-excursion ; Can't, breaks `cperl-contract-levels' 8130 (cperl-regext-to-level-start) 8131 (let ((b (point)) (e (make-marker)) c) 8132 (forward-sexp 1) 8133 (set-marker e (1- (point))) 8134 (goto-char b) 8135 (while (re-search-forward "\\(#\\)\\|\n" e 'to-end) 8136 (cond 8137 ((match-beginning 1) ; #-comment 8138 (or c (setq c (current-indentation))) 8139 (beginning-of-line 2) ; Skip 8140 (cperl-make-indent c)) 8141 (t 8142 (delete-char -1) 8143 (just-one-space)))))) 8144 8145(defun cperl-contract-levels () 8146 "Find an enclosing group in regexp and contract all the kids. 8147\(Experimental, may change semantics, recheck the result.) 8148We suppose that the regexp is scanned already." 8149 (interactive) 8150 (save-excursion 8151 (condition-case nil 8152 (cperl-regext-to-level-start) 8153 (error ; We are outside outermost group 8154 (goto-char (cperl-make-regexp-x)))) 8155 (let ((b (point)) (e (make-marker))) 8156 (forward-sexp 1) 8157 (set-marker e (1- (point))) 8158 (goto-char (1+ b)) 8159 (while (re-search-forward "\\(\\\\\\\\\\)\\|(" e t) 8160 (cond 8161 ((match-beginning 1) ; Skip 8162 nil) 8163 (t ; Group 8164 (cperl-contract-level))))))) 8165 8166(defun cperl-beautify-level (&optional deep) 8167 "Find an enclosing group in regexp and beautify it. 8168\(Experimental, may change semantics, recheck the result.) 8169We suppose that the regexp is scanned already." 8170 (interactive "P") 8171 (setq deep (if deep (prefix-numeric-value deep) -1)) 8172 (save-excursion 8173 (cperl-regext-to-level-start) 8174 (let ((b (point)) (e (make-marker))) 8175 (forward-sexp 1) 8176 (set-marker e (1- (point))) 8177 (cperl-beautify-regexp-piece b e 'level deep)))) 8178 8179(defun cperl-invert-if-unless-modifiers () 8180 "Change `B if A;' into `if (A) {B}' etc if possible. 8181\(Unfinished.)" 8182 (interactive) 8183 (let (A B pre-B post-B pre-if post-if pre-A post-A if-string 8184 (w-rex "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>")) 8185 (and (= (char-syntax (preceding-char)) ?w) 8186 (forward-sexp -1)) 8187 (setq pre-if (point)) 8188 (cperl-backward-to-start-of-expr) 8189 (setq pre-B (point)) 8190 (forward-sexp 1) ; otherwise forward-to-end-of-expr is NOP 8191 (cperl-forward-to-end-of-expr) 8192 (setq post-A (point)) 8193 (goto-char pre-if) 8194 (or (looking-at w-rex) 8195 ;; Find the position 8196 (progn (goto-char post-A) 8197 (while (and 8198 (not (looking-at w-rex)) 8199 (> (point) pre-B)) 8200 (forward-sexp -1)) 8201 (setq pre-if (point)))) 8202 (or (looking-at w-rex) 8203 (error "Can't find `if', `unless', `while', `until', `for' or `foreach'")) 8204 ;; 1 B 2 ... 3 B-com ... 4 if 5 ... if-com 6 ... 7 A 8 8205 (setq if-string (buffer-substring (match-beginning 0) (match-end 0))) 8206 ;; First, simple part: find code boundaries 8207 (forward-sexp 1) 8208 (setq post-if (point)) 8209 (forward-sexp -2) 8210 (forward-sexp 1) 8211 (setq post-B (point)) 8212 (cperl-backward-to-start-of-expr) 8213 (setq pre-B (point)) 8214 (setq B (buffer-substring pre-B post-B)) 8215 (goto-char pre-if) 8216 (forward-sexp 2) 8217 (forward-sexp -1) 8218 ;; May be after $, @, $# etc of a variable 8219 (skip-chars-backward "$@%#") 8220 (setq pre-A (point)) 8221 (cperl-forward-to-end-of-expr) 8222 (setq post-A (point)) 8223 (setq A (buffer-substring pre-A post-A)) 8224 ;; Now modify (from end, to not break the stuff) 8225 (skip-chars-forward " \t;") 8226 (delete-region pre-A (point)) ; we move to pre-A 8227 (insert "\n" B ";\n}") 8228 (and (looking-at "[ \t]*#") (cperl-indent-for-comment)) 8229 (delete-region pre-if post-if) 8230 (delete-region pre-B post-B) 8231 (goto-char pre-B) 8232 (insert if-string " (" A ") {") 8233 (setq post-B (point)) 8234 (if (looking-at "[ \t]+$") 8235 (delete-horizontal-space) 8236 (if (looking-at "[ \t]*#") 8237 (cperl-indent-for-comment) 8238 (just-one-space))) 8239 (forward-line 1) 8240 (if (looking-at "[ \t]*$") 8241 (progn ; delete line 8242 (delete-horizontal-space) 8243 (delete-region (point) (1+ (point))))) 8244 (cperl-indent-line) 8245 (goto-char (1- post-B)) 8246 (forward-sexp 1) 8247 (cperl-indent-line) 8248 (goto-char pre-B))) 8249 8250(defun cperl-invert-if-unless () 8251 "Change `if (A) {B}' into `B if A;' etc (or visa versa) if possible. 8252If the cursor is not on the leading keyword of the BLOCK flavor of 8253construct, will assume it is the STATEMENT flavor, so will try to find 8254the appropriate statement modifier." 8255 (interactive) 8256 (and (= (char-syntax (preceding-char)) ?w) 8257 (forward-sexp -1)) 8258 (if (looking-at "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>") 8259 (let ((pre-if (point)) 8260 pre-A post-A pre-B post-B A B state p end-B-code is-block B-comment 8261 (if-string (buffer-substring (match-beginning 0) (match-end 0)))) 8262 (forward-sexp 2) 8263 (setq post-A (point)) 8264 (forward-sexp -1) 8265 (setq pre-A (point)) 8266 (setq is-block (and (eq (following-char) ?\( ) 8267 (save-excursion 8268 (condition-case nil 8269 (progn 8270 (forward-sexp 2) 8271 (forward-sexp -1) 8272 (eq (following-char) ?\{ )) 8273 (error nil))))) 8274 (if is-block 8275 (progn 8276 (goto-char post-A) 8277 (forward-sexp 1) 8278 (setq post-B (point)) 8279 (forward-sexp -1) 8280 (setq pre-B (point)) 8281 (if (and (eq (following-char) ?\{ ) 8282 (progn 8283 (cperl-backward-to-noncomment post-A) 8284 (eq (preceding-char) ?\) ))) 8285 (if (condition-case nil 8286 (progn 8287 (goto-char post-B) 8288 (forward-sexp 1) 8289 (forward-sexp -1) 8290 (looking-at "\\<els\\(e\\|if\\)\\>")) 8291 (error nil)) 8292 (error 8293 "`%s' (EXPR) {BLOCK} with `else'/`elsif'" if-string) 8294 (goto-char (1- post-B)) 8295 (cperl-backward-to-noncomment pre-B) 8296 (if (eq (preceding-char) ?\;) 8297 (forward-char -1)) 8298 (setq end-B-code (point)) 8299 (goto-char pre-B) 8300 (while (re-search-forward "\\<\\(for\\|foreach\\|if\\|unless\\|while\\|until\\)\\>\\|;" end-B-code t) 8301 (setq p (match-beginning 0) 8302 A (buffer-substring p (match-end 0)) 8303 state (parse-partial-sexp pre-B p)) 8304 (or (nth 3 state) 8305 (nth 4 state) 8306 (nth 5 state) 8307 (error "`%s' inside `%s' BLOCK" A if-string)) 8308 (goto-char (match-end 0))) 8309 ;; Finally got it 8310 (goto-char (1+ pre-B)) 8311 (skip-chars-forward " \t\n") 8312 (setq B (buffer-substring (point) end-B-code)) 8313 (goto-char end-B-code) 8314 (or (looking-at ";?[ \t\n]*}") 8315 (progn 8316 (skip-chars-forward "; \t\n") 8317 (setq B-comment 8318 (buffer-substring (point) (1- post-B))))) 8319 (and (equal B "") 8320 (setq B "1")) 8321 (goto-char (1- post-A)) 8322 (cperl-backward-to-noncomment pre-A) 8323 (or (looking-at "[ \t\n]*)") 8324 (goto-char (1- post-A))) 8325 (setq p (point)) 8326 (goto-char (1+ pre-A)) 8327 (skip-chars-forward " \t\n") 8328 (setq A (buffer-substring (point) p)) 8329 (delete-region pre-B post-B) 8330 (delete-region pre-A post-A) 8331 (goto-char pre-if) 8332 (insert B " ") 8333 (and B-comment (insert B-comment " ")) 8334 (just-one-space) 8335 (forward-word-strictly 1) 8336 (setq pre-A (point)) 8337 (insert " " A ";") 8338 (delete-horizontal-space) 8339 (setq post-B (point)) 8340 (if (looking-at "#") 8341 (indent-for-comment)) 8342 (goto-char post-B) 8343 (forward-char -1) 8344 (delete-horizontal-space) 8345 (goto-char pre-A) 8346 (just-one-space) 8347 (goto-char pre-if) 8348 (setq pre-A (set-marker (make-marker) pre-A)) 8349 (while (<= (point) (marker-position pre-A)) 8350 (cperl-indent-line) 8351 (forward-line 1)) 8352 (goto-char (marker-position pre-A)) 8353 (if B-comment 8354 (progn 8355 (forward-line -1) 8356 (indent-for-comment) 8357 (goto-char (marker-position pre-A))))) 8358 (error "`%s' (EXPR) not with an {BLOCK}" if-string))) 8359 ;; (error "`%s' not with an (EXPR)" if-string) 8360 (forward-sexp -1) 8361 (cperl-invert-if-unless-modifiers))) 8362 ;;(error "Not at `if', `unless', `while', `until', `for' or `foreach'") 8363 (cperl-invert-if-unless-modifiers))) 8364 8365(declare-function Man-getpage-in-background "man" (topic)) 8366 8367;; By Anthony Foiani <afoiani@uswest.com> 8368;; Getting help on modules in C-h f ? 8369;; This is a modified version of `man'. 8370;; Need to teach it how to lookup functions 8371;;;###autoload 8372(defun cperl-perldoc (word) 8373 "Run `perldoc' on WORD." 8374 (interactive 8375 (list (let* ((default-entry (cperl-word-at-point)) 8376 (input (read-string 8377 (cperl--format-prompt "perldoc entry" default-entry)))) 8378 (if (string= input "") 8379 (if (string= default-entry "") 8380 (error "No perldoc args given") 8381 default-entry) 8382 input)))) 8383 (require 'man) 8384 (let* ((case-fold-search nil) 8385 (is-func (and 8386 (string-match "^\\(-[A-Za-z]\\|[a-z]+\\)$" word) 8387 (string-match (concat "^" word "\\>") 8388 (documentation-property 8389 'cperl-short-docs 8390 'variable-documentation)))) 8391 (Man-switches "") 8392 (manual-program (if is-func "perldoc -f" "perldoc"))) 8393 (Man-getpage-in-background word))) 8394 8395;;;###autoload 8396(defun cperl-perldoc-at-point () 8397 "Run a `perldoc' on the word around point." 8398 (interactive) 8399 (cperl-perldoc (cperl-word-at-point))) 8400 8401(defcustom pod2man-program "pod2man" 8402 "File name for `pod2man'." 8403 :type 'file 8404 :group 'cperl) 8405 8406;; By Nick Roberts <Nick.Roberts@src.bae.co.uk> (with changes) 8407(defun cperl-pod-to-manpage () 8408 "Create a virtual manpage in Emacs from the Perl Online Documentation." 8409 (interactive) 8410 (require 'man) 8411 (let* ((pod2man-args (concat buffer-file-name " | nroff -man ")) 8412 (bufname (concat "Man " buffer-file-name)) 8413 (buffer (generate-new-buffer bufname))) 8414 (with-current-buffer buffer 8415 (let ((process-environment (copy-sequence process-environment))) 8416 ;; Prevent any attempt to use display terminal fanciness. 8417 (setenv "TERM" "dumb") 8418 (set-process-sentinel 8419 (start-process pod2man-program buffer "sh" "-c" 8420 (format (cperl-pod2man-build-command) pod2man-args)) 8421 'Man-bgproc-sentinel))))) 8422 8423;; Updated version by him too 8424(defun cperl-build-manpage () 8425 "Create a virtual manpage in Emacs from the POD in the file." 8426 (interactive) 8427 (require 'man) 8428 (let ((manual-program "perldoc") 8429 (Man-switches "")) 8430 (Man-getpage-in-background buffer-file-name))) 8431 8432(defun cperl-pod2man-build-command () 8433 "Builds the entire background manpage and cleaning command." 8434 (let ((command (concat pod2man-program " %s 2>" null-device)) 8435 (flist (and (boundp 'Man-filter-list) Man-filter-list))) 8436 (while (and flist (car flist)) 8437 (let ((pcom (car (car flist))) 8438 (pargs (cdr (car flist)))) 8439 (setq command 8440 (concat command " | " pcom " " 8441 (mapconcat (lambda (phrase) 8442 (if (not (stringp phrase)) 8443 (error "Malformed Man-filter-list")) 8444 phrase) 8445 pargs " "))) 8446 (setq flist (cdr flist)))) 8447 command)) 8448 8449 8450(defun cperl-next-interpolated-REx-1 () 8451 "Move point to next REx which has interpolated parts without //o. 8452Skips RExes consisting of one interpolated variable. 8453 8454Note that skipped RExen are not performance hits." 8455 (interactive "") 8456 (cperl-next-interpolated-REx 1)) 8457 8458(defun cperl-next-interpolated-REx-0 () 8459 "Move point to next REx which has interpolated parts without //o." 8460 (interactive "") 8461 (cperl-next-interpolated-REx 0)) 8462 8463(defun cperl-next-interpolated-REx (&optional skip beg limit) 8464 "Move point to next REx which has interpolated parts. 8465SKIP is a list of possible types to skip, BEG and LIMIT are the starting 8466point and the limit of search (default to point and end of buffer). 8467 8468SKIP may be a number, then it behaves as list of numbers up to SKIP; this 8469semantic may be used as a numeric argument. 8470 8471Types are 0 for / $rex /o (interpolated once), 1 for /$rex/ (if $rex is 8472a result of qr//, this is not a performance hit), t for the rest." 8473 (interactive "P") 8474 (if (numberp skip) (setq skip (list 0 skip))) 8475 (or beg (setq beg (point))) 8476 (or limit (setq limit (point-max))) ; needed for n-s-p-c 8477 (let (pp) 8478 (and (eq (get-text-property beg 'syntax-type) 'string) 8479 (setq beg (next-single-property-change beg 'syntax-type nil limit))) 8480 (cperl-map-pods-heres 8481 (lambda (s _e _p) 8482 (if (memq (get-text-property s 'REx-interpolated) skip) 8483 t 8484 (setq pp s) 8485 nil)) ; nil stops 8486 'REx-interpolated beg limit) 8487 (if pp (goto-char pp) 8488 (message "No more interpolated REx")))) 8489 8490;; Initial version contributed by Trey Belew 8491(defun cperl-here-doc-spell () 8492 "Spell-check HERE-documents in the Perl buffer. 8493If a region is highlighted, restricts to the region." 8494 (interactive) 8495 (cperl-pod-spell t)) 8496 8497(defun cperl-pod-spell (&optional do-heres) 8498 "Spell-check POD documentation. 8499If invoked with prefix argument, will do HERE-DOCs instead. 8500If a region is highlighted, restricts to the region." 8501 (interactive "P") 8502 (save-excursion 8503 (let (beg end) 8504 (if (region-active-p) 8505 (setq beg (min (mark) (point)) 8506 end (max (mark) (point))) 8507 (setq beg (point-min) 8508 end (point-max))) 8509 (cperl-map-pods-heres (lambda (s e _p) 8510 (if do-heres 8511 (setq e (save-excursion 8512 (goto-char e) 8513 (forward-line -1) 8514 (point)))) 8515 (ispell-region s e) 8516 t) 8517 (if do-heres 'here-doc-group 'in-pod) 8518 beg end)))) 8519 8520(defun cperl-map-pods-heres (func &optional prop s end) 8521 "Execute a function over regions of pods or here-documents. 8522PROP is the text-property to search for; default to `in-pod'. Stop when 8523function returns nil." 8524 (let (pos posend has-prop (cont t)) 8525 (or prop (setq prop 'in-pod)) 8526 (or s (setq s (point-min))) 8527 (or end (setq end (point-max))) 8528 (cperl-update-syntaxification end) 8529 (save-excursion 8530 (goto-char (setq pos s)) 8531 (while (and cont (< pos end)) 8532 (setq has-prop (get-text-property pos prop)) 8533 (setq posend (next-single-property-change pos prop nil end)) 8534 (and has-prop 8535 (setq cont (funcall func pos posend prop))) 8536 (setq pos posend))))) 8537 8538;; Based on code by Masatake YAMATO: 8539(defun cperl-get-here-doc-region (&optional pos pod) 8540 "Return HERE document region around the point. 8541Return nil if the point is not in a HERE document region. If POD is non-nil, 8542will return a POD section if point is in a POD section." 8543 (or pos (setq pos (point))) 8544 (cperl-update-syntaxification pos) 8545 (if (or (eq 'here-doc (get-text-property pos 'syntax-type)) 8546 (and pod 8547 (eq 'pod (get-text-property pos 'syntax-type)))) 8548 (let ((b (cperl-beginning-of-property pos 'syntax-type)) 8549 (e (next-single-property-change pos 'syntax-type))) 8550 (cons b (or e (point-max)))))) 8551 8552(defun cperl-narrow-to-here-doc (&optional pos) 8553 "Narrows editing region to the HERE-DOC at POS. 8554POS defaults to the point." 8555 (interactive "d") 8556 (or pos (setq pos (point))) 8557 (let ((p (cperl-get-here-doc-region pos))) 8558 (or p (error "Not inside a HERE document")) 8559 (narrow-to-region (car p) (cdr p)) 8560 (message 8561 "When you are finished with narrow editing, type C-x n w"))) 8562 8563(defun cperl-select-this-pod-or-here-doc (&optional pos) 8564 "Select the HERE-DOC (or POD section) at POS. 8565POS defaults to the point." 8566 (interactive "d") 8567 (let ((p (cperl-get-here-doc-region pos t))) 8568 (if p 8569 (progn 8570 (goto-char (car p)) 8571 (push-mark (cdr p) nil t)) ; Message, activate in transient-mode 8572 (message "I do not think POS is in POD or a HERE-doc...")))) 8573 8574(defun cperl-facemenu-add-face-function (face _end) 8575 "A callback to process user-initiated font-change requests. 8576Translates `bold', `italic', and `bold-italic' requests to insertion of 8577corresponding POD directives, and `underline' to C<> POD directive. 8578 8579Such requests are usually bound to M-o LETTER." 8580 (or (get-text-property (point) 'in-pod) 8581 (error "Faces can only be set within POD")) 8582 (setq facemenu-end-add-face (if (eq face 'bold-italic) ">>" ">")) 8583 (cdr (or (assq face '((bold . "B<") 8584 (italic . "I<") 8585 (bold-italic . "B<I<") 8586 (underline . "C<"))) 8587 (error "Face %S not configured for cperl-mode" 8588 face)))) 8589 8590(defun cperl-time-fontification (&optional l step lim) 8591 "Times how long it takes to do incremental fontification in a region. 8592L is the line to start at, STEP is the number of lines to skip when 8593doing next incremental fontification, LIM is the maximal number of 8594incremental fontification to perform. Messages are accumulated in 8595*Messages* buffer. 8596 8597May be used for pinpointing which construct slows down buffer fontification: 8598start with default arguments, then refine the slowdown regions." 8599 (interactive "nLine to start at: \nnStep to do incremental fontification: ") 8600 (or l (setq l 1)) 8601 (or step (setq step 500)) 8602 (or lim (setq lim 40)) 8603 (let* ((timems (lambda () (car (cperl--time-convert nil 1000)))) 8604 (tt (funcall timems)) (c 0) delta tot) 8605 (goto-char (point-min)) 8606 (forward-line (1- l)) 8607 (cperl-mode) 8608 (setq tot (- (- tt (setq tt (funcall timems))))) 8609 (message "cperl-mode at %s: %s" l tot) 8610 (while (and (< c lim) (not (eobp))) 8611 (forward-line step) 8612 (setq l (+ l step)) 8613 (setq c (1+ c)) 8614 (cperl-update-syntaxification (point)) 8615 (setq delta (- (- tt (setq tt (funcall timems)))) tot (+ tot delta)) 8616 (message "to %s:%6s,%7s" l delta tot)) 8617 tot)) 8618 8619(defvar font-lock-cache-position) 8620 8621(defun cperl-emulate-lazy-lock (&optional window-size) 8622 "Emulate `lazy-lock' without `condition-case', so `debug-on-error' works. 8623Start fontifying the buffer from the start (or end) using the given 8624WINDOW-SIZE (units is lines). Negative WINDOW-SIZE starts at end, and 8625goes backwards; default is -50. This function is not CPerl-specific; it 8626may be used to debug problems with delayed incremental fontification." 8627 (interactive 8628 "nSize of window for incremental fontification, negative goes backwards: ") 8629 (or window-size (setq window-size -50)) 8630 (let ((pos (if (> window-size 0) 8631 (point-min) 8632 (point-max))) 8633 p) 8634 (goto-char pos) 8635 (normal-mode) 8636 ;; Why needed??? With older font-locks??? 8637 (setq-local font-lock-cache-position (make-marker)) 8638 (while (if (> window-size 0) 8639 (< pos (point-max)) 8640 (> pos (point-min))) 8641 (setq p (progn 8642 (forward-line window-size) 8643 (point))) 8644 (font-lock-fontify-region (min p pos) (max p pos)) 8645 (setq pos p)))) 8646 8647 8648(defvar cperl-help-shown nil 8649 "Non-nil means that the help was already shown now.") 8650 8651(defvar cperl-lazy-installed nil 8652 "Non-nil means that the lazy-help handlers are installed now.") 8653 8654;; FIXME: Use eldoc? 8655(defun cperl-lazy-install () 8656 "Switch on Auto-Help on Perl constructs (put in the message area). 8657Delay of auto-help controlled by `cperl-lazy-help-time'." 8658 (interactive) 8659 (make-local-variable 'cperl-help-shown) 8660 (if (and (cperl-val 'cperl-lazy-help-time) 8661 (not cperl-lazy-installed)) 8662 (progn 8663 (add-hook 'post-command-hook #'cperl-lazy-hook) 8664 (run-with-idle-timer 8665 (cperl-val 'cperl-lazy-help-time 1000000 5) 8666 t 8667 #'cperl-get-help-defer) 8668 (setq cperl-lazy-installed t)))) 8669 8670(defun cperl-lazy-unstall () 8671 "Switch off Auto-Help on Perl constructs (put in the message area). 8672Delay of auto-help controlled by `cperl-lazy-help-time'." 8673 (interactive) 8674 (remove-hook 'post-command-hook #'cperl-lazy-hook) 8675 (cancel-function-timers #'cperl-get-help-defer) 8676 (setq cperl-lazy-installed nil)) 8677 8678(defun cperl-lazy-hook () 8679 (setq cperl-help-shown nil)) 8680 8681(defun cperl-get-help-defer () 8682 (if (not (memq major-mode '(perl-mode cperl-mode))) nil 8683 (let ((cperl-message-on-help-error nil) (cperl-help-from-timer t)) 8684 (cperl-get-help) 8685 (setq cperl-help-shown t)))) 8686(cperl-lazy-install) 8687 8688 8689;;; Plug for wrong font-lock: 8690 8691(defun cperl-font-lock-unfontify-region-function (beg end) 8692 (with-silent-modifications 8693 (remove-text-properties beg end '(face nil)))) 8694 8695(defun cperl-font-lock-fontify-region-function (beg end loudly) 8696 "Extend the region to safe positions, then call the default function. 8697Newer `font-lock's can do it themselves. 8698We unwind only as far as needed for fontification. Syntaxification may 8699do extra unwind via `cperl-unwind-to-safe'." 8700 (save-excursion 8701 (goto-char beg) 8702 (while (and beg 8703 (progn 8704 (beginning-of-line) 8705 (eq (get-text-property (setq beg (point)) 'syntax-type) 8706 'multiline))) 8707 (let ((new-beg (cperl-beginning-of-property beg 'syntax-type))) 8708 (setq beg (if (= new-beg beg) nil new-beg)) 8709 (goto-char new-beg))) 8710 (setq beg (point)) 8711 (goto-char end) 8712 (while (and end (< end (point-max)) 8713 (progn 8714 (or (bolp) (condition-case nil 8715 (forward-line 1) 8716 (error nil))) 8717 (eq (get-text-property (setq end (point)) 'syntax-type) 8718 'multiline))) 8719 (setq end (next-single-property-change end 'syntax-type nil (point-max))) 8720 (goto-char end)) 8721 (setq end (point))) 8722 (font-lock-default-fontify-region beg end loudly)) 8723 8724(defun cperl-fontify-syntactically (end) 8725 ;; Some vars for debugging only 8726 ;; (message "Syntaxifying...") 8727 (let ((dbg (point)) (iend end) (idone cperl-syntax-done-to) 8728 (istate (car cperl-syntax-state)) 8729 start from-start) 8730 (or cperl-syntax-done-to 8731 (setq cperl-syntax-done-to (point-min) 8732 from-start t)) 8733 (setq start (if (and cperl-hook-after-change 8734 (not from-start)) 8735 cperl-syntax-done-to ; Fontify without change; ignore start 8736 ;; Need to forget what is after `start' 8737 (min cperl-syntax-done-to (point)))) 8738 (goto-char start) 8739 (beginning-of-line) 8740 (setq start (point)) 8741 (and cperl-syntaxify-unwind 8742 (setq end (cperl-unwind-to-safe t end) 8743 start (point))) 8744 (and (> end start) 8745 (setq cperl-syntax-done-to start) ; In case what follows fails 8746 (cperl-find-pods-heres start end t nil t)) 8747 (if (memq cperl-syntaxify-by-font-lock '(backtrace message)) 8748 (message "Syxify req=%s..%s actual=%s..%s done-to: %s=>%s statepos: %s=>%s" 8749 dbg iend start end idone cperl-syntax-done-to 8750 istate (car cperl-syntax-state))) ; For debugging 8751 nil)) ; Do not iterate 8752 8753(defun cperl-fontify-update (end) 8754 (let ((pos (point-min)) prop posend) 8755 (setq end (point-max)) 8756 (while (< pos end) 8757 (setq prop (get-text-property pos 'cperl-postpone) 8758 posend (next-single-property-change pos 'cperl-postpone nil end)) 8759 (and prop (put-text-property pos posend (car prop) (cdr prop))) 8760 (setq pos posend))) 8761 nil) ; Do not iterate 8762 8763(defun cperl-fontify-update-bad (end) 8764 ;; Since fontification happens with different region than syntaxification, 8765 ;; do to the end of buffer, not to END;;; likewise, start earlier if needed 8766 (let* ((pos (point)) (prop (get-text-property pos 'cperl-postpone)) posend) 8767 (if prop 8768 (setq pos (or (cperl-beginning-of-property 8769 (cperl-1+ pos) 'cperl-postpone) 8770 (point-min)))) 8771 (while (< pos end) 8772 (setq posend (next-single-property-change pos 'cperl-postpone)) 8773 (and prop (put-text-property pos posend (car prop) (cdr prop))) 8774 (setq pos posend) 8775 (setq prop (get-text-property pos 'cperl-postpone)))) 8776 nil) ; Do not iterate 8777 8778;; Called when any modification is made to buffer text. 8779(defun cperl-after-change-function (beg _end _old-len) 8780 ;; We should have been informed about changes by `font-lock'. Since it 8781 ;; does not inform as which calls are deferred, do it ourselves 8782 (if cperl-syntax-done-to 8783 (setq cperl-syntax-done-to (min cperl-syntax-done-to beg)))) 8784 8785(defun cperl-update-syntaxification (to) 8786 (when cperl-use-syntax-table-text-property 8787 (syntax-propertize to))) 8788 8789(defvar cperl-version 8790 (let ((v "Revision: 6.2")) 8791 (string-match ":\\s *\\([0-9.]+\\)" v) 8792 (substring v (match-beginning 1) (match-end 1))) 8793 "Version of IZ-supported CPerl package this file is based on.") 8794(make-obsolete-variable 'cperl-version 'emacs-version "28.1") 8795 8796(defvar cperl-do-not-fontify 'fontified 8797 "Text property which inhibits refontification.") 8798(make-obsolete-variable 'cperl-do-not-fontify nil "28.1") 8799 8800(provide 'cperl-mode) 8801 8802;;; cperl-mode.el ends here 8803