aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorRichard M. Stallman1999-01-02 00:16:05 +0000
committerRichard M. Stallman1999-01-02 00:16:05 +0000
commit5bd52f0ea6ac8dcbfad5c6a816c236389a175c31 (patch)
tree91bc70bce11b07377f59393c55291d1ca26b8a77
parent75e4db343eedd95bc89dcbe06469295337c408eb (diff)
downloademacs-5bd52f0ea6ac8dcbfad5c6a816c236389a175c31.tar.gz
emacs-5bd52f0ea6ac8dcbfad5c6a816c236389a175c31.zip
Can use linear algorithm for indentation if Emacs supports it.
(cperl-after-expr-p): It is BLOCK if we reach lim when backup sexp. (cperl-after-block-p): Likewise. (cperl-after-block-and-statement-beg): Likewise. (cperl-after-block-p): After END/BEGIN we are a block. (cperl-after-expr-p): Skip labels when checking (cperl-indent-region): Make a marker for END - text added/removed. Disable hooks during the call (how to call them later?). Now indents 820-line-long function in 6.5 sec (including syntaxification) the first time (when buffer has few properties), 7.1 sec the second time. (cperl-indent-region): Do not indent whitespace lines (cperl-style-alist) Include `cperl-merge-trailing-else' where the value is clear. (cperl-styles-entries): Likewise. (cperl-problems): Improvements to docs. (cperl-tips): Likewise. (cperl-non-problems): Likewise. (cperl-mode): Make lazy syntaxification possible. Loads pseudo-faces for the sake of `cperl-find-pods-heres' (for 19.30). `font-lock-unfontify-region-function' was set to a wrong function. (cperl-find-pods-heres): Safe a position in buffer where it is safe to restart syntaxification. Changed so that -d ?foo? is a RE. Do not warn on `=cut' if doing a chunk only. 1 << 6 was OK, but 1<<6 was considered as HERE-doc. <file/glob> made into a string. Postpone addition of faces after syntactic step. Recognition of <FH> was wrong. Highlight `gem' in s///gem as a keyword. `qr' recognized. Knows that split// is null-RE. Highlights separators in 3-parts expressions as labels. <> was considered as a glob. Would err if the last line is `=head1'. $a-1 ? foo : bar; was a considered a regexp. `<< (' was considered a start of HERE-doc. mark qq[]-etc sections as syntax-type=string Was not processing sub protos after a comment ine. Was treating $a++ <= 5 as a glob. Tolerate unfinished REx at end-of-buffer. `unwind-protect' was left commented. / and ? after : start a REx. (cperl-syntaxify-by-font-lock): Set to t, should be safe now. Better default, customizes to `message' too, off in text-mode. (cperl-array-face): Renamed from `font-lock-emphasized-face', `defface'd. (cperl-hash-face): Renamed from `font-lock-other-emphasized-face'. `defface'd. (cperl-emacs-can-parse): New state variable. (cperl-indent-line): Corrected to use global state. (cperl-calculate-indent): Likewise. (cperl-fix-line-spacing): Likewise (not used yet). (cperl-calculate-indent): Did not consider `,' as continuation mark for statements. (cperl-calculate-indent): Avoid parse-data optimization at toplevel. Remove another parse-data optimization at toplevel: would indent correctly. Correct for labels when calculating indentation of continuations. Docstring updated. (cperl-choose-color): Converted to a function (to be compilable in text-mode). (cperl-dark-background): Disable without window-system. Do `defface' only if window-system. (cperl-fix-line-spacing): sped up to bail out early. (x-color-defined-p): was not compiling on XEmacs Was defmacro'ed with a tick. Remove another def. (cperl-clobber-lisp-bindings): if set, C-c variants are the old ones (cperl-unwind-to-safe): New function. (cperl-fontify-syntaxically): Use `cperl-unwind-to-safe' to start at reasonable position. (cperl-fontify-syntaxically): Unwinds start and end to go out of long strings (not very successful). (cperl-forward-re): Highlight the trailing / in s/foo// as string. Highlight the starting // in s//foo/ as function-name. Emit a meaningful error instead of a cryptic one for an uncomplete REx near end-of-buffer. (cperl-electric-keyword): `qr' recognized. (cperl-electric-else): Likewise (cperl-to-comment-or-eol): Likewise (cperl-make-regexp-x): Likewise (cperl-init-faces): Likewise, and `lock' (as overridable?). Corrected to use new macros; `if' for copying `reference-face' to `constant-face' was backward. remove init `font-lock-other-emphasized-face', `font-lock-emphasized-face', `font-lock-keyword-face'. Interpolate `cperl-invalid-face'. (cperl-make-regexp-x): Misprint in a message. (cperl-syntaxify-unwind): New configuration variable (cperl-fontify-m-as-s): New configuration variable (cperl-electric-pod): check for after-expr was performed inside of POD too. (cperl-backward-to-noncomment): better treatment of PODs and HEREs. (cperl-clobber-mode-lists): New configuration variable. (cperl-not-bad-style-regexp): Updated. Init: `cperl-is-face' was busted. (cperl-make-face): New macros. (cperl-force-face): New macros. (font-lock-other-type-face): Done via `defface' too. (cperl-nonoverridable-face): New face. Renamed from `font-lock-other-type-face'. (cperl-init-faces-weak): use `cperl-force-face'. (cperl-comment-indent): Commenting __END__ was not working. (cperl-indent-for-comment): Likewise. (cperl-write-tags): Correct for XEmacs's `visit-tags-table-buffer'. When removing old TAGS info was not relativizing filename. (cperl-tags-hier-init): Gross hack to pretend we work (are we?). Another try to work around XEmacs problems. Better progress messages. (toplevel): require custom unprotected => failure on 19.28. (cperl-xemacs-p): defined when compile too (cperl-find-tags): Was writing line/pos in a wrong order, pos off by 1 and not at beg-of-line. (cperl-etags-snarf-tag): New macro (cperl-etags-goto-tag-location): New macro (cperl-version): New variable. New menu entry random docstrings: References to "future" 20.3 removed. Menu was described as `CPerl' instead of `Perl' (perl-font-lock-keywords): Would not highlight `sub foo($$);'. (cperl-toggle-construct-fix): Was toggling to t instead of 1. (cperl-ps-print-init): Associate `cperl-array-face', `cperl-hash-face' Remove `font-lock-emphasized-face', `font-lock-other-emphasized-face', `font-lock-reference-face', `font-lock-keyword-face'. Use `eval-after-load'. Remove not-CPerl-related faces. (cperl-tips-faces): New variable and an entry into Mini-docs. (cperl-indent-exp): Was not processing else-blocks. (cperl-get-state): NOP line removed. (cperl-ps-print): New function and menu entry. (cperl-ps-print-face-properties): New configuration variable. (cperl-invalid-face): New configuration variable. (perl-font-lock-keywords): Highlight trailing whitespace (cperl-contract-levels): Documentation corrected. (cperl-contract-level): Likewise. (cperl-ps-extend-face-list): New macro. (cperl-invalid-face): Change to ''underline.
Diffstat
-rw-r--r--lisp/progmodes/cperl-mode.el1394
1 files changed, 1027 insertions, 367 deletions
diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el
index 0a35cfe175f..bd57c190291 100644
--- a/lisp/progmodes/cperl-mode.el
+++ b/lisp/progmodes/cperl-mode.el
@@ -62,6 +62,61 @@
62 62
63;;; Code: 63;;; Code:
64 64
65;; Some macros are needed for `defcustom'
66(if (fboundp 'eval-when-compile)
67 (eval-when-compile
68 (defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version))
69 (defmacro cperl-is-face (arg) ; Takes quoted arg
70 (cond ((fboundp 'find-face)
71 (` (find-face (, arg))))
72 (;;(and (fboundp 'face-list)
73 ;; (face-list))
74 (fboundp 'face-list)
75 (` (member (, arg) (and (fboundp 'face-list)
76 (face-list)))))
77 (t
78 (` (boundp (, arg))))))
79 (defmacro cperl-make-face (arg descr) ; Takes unquoted arg
80 (cond ((fboundp 'make-face)
81 (` (make-face (quote (, arg)))))
82 (t
83 (` (defconst (, arg) (quote (, arg)) (, descr))))))
84 (defmacro cperl-force-face (arg descr) ; Takes unquoted arg
85 (` (progn
86 (or (cperl-is-face (quote (, arg)))
87 (cperl-make-face (, arg) (, descr)))
88 (or (boundp (quote (, arg))) ; We use unquoted variants too
89 (defconst (, arg) (quote (, arg)) (, descr))))))
90 (if cperl-xemacs-p
91 (defmacro cperl-etags-snarf-tag (file line)
92 (` (progn
93 (beginning-of-line 2)
94 (list (, file) (, line)))))
95 (defmacro cperl-etags-snarf-tag (file line)
96 (` (etags-snarf-tag))))
97 (if cperl-xemacs-p
98 (defmacro cperl-etags-goto-tag-location (elt)
99 (` ;;(progn
100 ;; (switch-to-buffer (get-file-buffer (elt (, elt) 0)))
101 ;; (set-buffer (get-file-buffer (elt (, elt) 0)))
102 ;; Probably will not work due to some save-excursion???
103 ;; Or save-file-position?
104 ;; (message "Did I get to line %s?" (elt (, elt) 1))
105 (goto-line (string-to-int (elt (, elt) 1)))))
106 ;;)
107 (defmacro cperl-etags-goto-tag-location (elt)
108 (` (etags-goto-tag-location (, elt)))))))
109
110(defun cperl-choose-color (&rest list)
111 (let (answer)
112 (while list
113 (or answer
114 (if (or (x-color-defined-p (car list))
115 (null (cdr list)))
116 (setq answer (car list))))
117 (setq list (cdr list)))
118 answer))
119
65(defgroup cperl nil 120(defgroup cperl nil
66 "Major mode for editing Perl code." 121 "Major mode for editing Perl code."
67 :prefix "cperl-" 122 :prefix "cperl-"
@@ -257,6 +312,16 @@ Affects: `cperl-font-lock', `cperl-electric-lbrace-space',
257 :type '(repeat (list symbol string)) 312 :type '(repeat (list symbol string))
258 :group 'cperl) 313 :group 'cperl)
259 314
315(defcustom cperl-clobber-mode-lists
316 (not
317 (and
318 (boundp 'interpreter-mode-alist)
319 (assoc "miniperl" interpreter-mode-alist)
320 (assoc "\\.\\([pP][Llm]\\|al\\)$" auto-mode-alist)))
321 "*Whether to install us into `interpreter-' and `extension' mode lists."
322 :type 'boolean
323 :group 'cperl)
324
260(defcustom cperl-info-on-command-no-prompt nil 325(defcustom cperl-info-on-command-no-prompt nil
261 "*Not-nil (and non-null) means not to prompt on C-h f. 326 "*Not-nil (and non-null) means not to prompt on C-h f.
262The opposite behaviour is always available if prefixed with C-c. 327The opposite behaviour is always available if prefixed with C-c.
@@ -293,11 +358,21 @@ Font for POD headers."
293 :type 'face 358 :type 'face
294 :group 'cperl-faces) 359 :group 'cperl-faces)
295 360
361(defcustom cperl-invalid-face ''underline ; later evaluated by `font-lock'
362 "*The result of evaluation of this expression highlights trailing whitespace."
363 :type 'face
364 :group 'cperl-faces)
365
296(defcustom cperl-pod-here-fontify '(featurep 'font-lock) 366(defcustom cperl-pod-here-fontify '(featurep 'font-lock)
297 "*Not-nil after evaluation means to highlight pod and here-docs sections." 367 "*Not-nil after evaluation means to highlight pod and here-docs sections."
298 :type 'boolean 368 :type 'boolean
299 :group 'cperl-faces) 369 :group 'cperl-faces)
300 370
371(defcustom cperl-fontify-m-as-s t
372 "*Not-nil means highlight 1arg regular expressions operators same as 2arg."
373 :type 'boolean
374 :group 'cperl-faces)
375
301(defcustom cperl-pod-here-scan t 376(defcustom cperl-pod-here-scan t
302 "*Not-nil means look for pod and here-docs sections during startup. 377 "*Not-nil means look for pod and here-docs sections during startup.
303You can always make lookup from menu or using \\[cperl-find-pods-heres]." 378You can always make lookup from menu or using \\[cperl-find-pods-heres]."
@@ -401,12 +476,86 @@ may be merged to be on the same line when indenting a region."
401 :type 'boolean 476 :type 'boolean
402 :group 'cperl-indentation-details) 477 :group 'cperl-indentation-details)
403 478
404(defcustom cperl-syntaxify-by-font-lock nil 479(defcustom cperl-syntaxify-by-font-lock
480 (and window-system
481 (boundp 'parse-sexp-lookup-properties))
405 "*Non-nil means that CPerl uses `font-lock's routines for syntaxification. 482 "*Non-nil means that CPerl uses `font-lock's routines for syntaxification.
406Not debugged yet." 483Having it TRUE may be not completely debugged yet."
484 :type '(choice (const message) boolean)
485 :group 'cperl-speed)
486
487(defcustom cperl-syntaxify-unwind
488 t
489 "*Non-nil means that CPerl unwinds to a start of along construction
490when syntaxifying a chunk of buffer."
407 :type 'boolean 491 :type 'boolean
408 :group 'cperl-speed) 492 :group 'cperl-speed)
409 493
494(defcustom cperl-ps-print-face-properties
495 '((font-lock-keyword-face nil nil bold shadow)
496 (font-lock-variable-name-face nil nil bold)
497 (font-lock-function-name-face nil nil bold italic box)
498 (font-lock-constant-face nil "LightGray" bold)
499 (cperl-array-face nil "LightGray" bold underline)
500 (cperl-hash-face nil "LightGray" bold italic underline)
501 (font-lock-comment-face nil "LightGray" italic)
502 (font-lock-string-face nil nil italic underline)
503 (cperl-nonoverridable-face nil nil italic underline)
504 (font-lock-type-face nil nil underline)
505 (underline nil "LightGray" strikeout))
506 "List given as an argument to `ps-extend-face-list' in `cperl-ps-print'."
507 :type '(repeat (cons symbol
508 (cons (choice (const nil) string)
509 (cons (choice (const nil) string)
510 (repeat symbol)))))
511 :group 'cperl-faces)
512
513(if window-system
514 (progn
515 (defvar cperl-dark-background
516 (cperl-choose-color "navy" "os2blue" "darkgreen"))
517 (defvar cperl-dark-foreground
518 (cperl-choose-color "orchid1" "orange"))
519
520 (defface cperl-nonoverridable-face
521 (` ((((class grayscale) (background light))
522 (:background "Gray90" :italic t :underline t))
523 (((class grayscale) (background dark))
524 (:foreground "Gray80" :italic t :underline t :bold t))
525 (((class color) (background light))
526 (:foreground "chartreuse3"))
527 (((class color) (background dark))
528 (:foreground (, cperl-dark-foreground)))
529 (t (:bold t :underline t))))
530 "Font Lock mode face used to highlight array names."
531 :group 'cperl-faces)
532
533 (defface cperl-array-face
534 (` ((((class grayscale) (background light))
535 (:background "Gray90" :bold t))
536 (((class grayscale) (background dark))
537 (:foreground "Gray80" :bold t))
538 (((class color) (background light))
539 (:foreground "Blue" :background "lightyellow2" :bold t))
540 (((class color) (background dark))
541 (:foreground "yellow" :background (, cperl-dark-background) :bold t))
542 (t (:bold t))))
543 "Font Lock mode face used to highlight array names."
544 :group 'cperl-faces)
545
546 (defface cperl-hash-face
547 (` ((((class grayscale) (background light))
548 (:background "Gray90" :bold t :italic t))
549 (((class grayscale) (background dark))
550 (:foreground "Gray80" :bold t :italic t))
551 (((class color) (background light))
552 (:foreground "Red" :background "lightyellow2" :bold t :italic t))
553 (((class color) (background dark))
554 (:foreground "Red" :background (, cperl-dark-background) :bold t :italic t))
555 (t (:bold t :italic t))))
556 "Font Lock mode face used to highlight hash names."
557 :group 'cperl-faces)))
558
410 559
411 560
412;;; Short extra-docs. 561;;; Short extra-docs.
@@ -419,6 +568,13 @@ and/or
419Subdirectory `cperl-mode' may contain yet newer development releases and/or 568Subdirectory `cperl-mode' may contain yet newer development releases and/or
420patches to related files. 569patches to related files.
421 570
571For best results apply to an older Emacs the patches from
572 ftp://ftp.math.ohio-state.edu/pub/users/ilya/cperl-mode/patches
573\(this upgrades syntax-parsing abilities of RMS Emaxen v19.34 and
574v20.2 up to the level of RMS Emacs v20.3 - a must for a good Perl
575mode.) You will not get much from XEmacs, it's syntax abilities are
576too primitive.
577
422Get support packages choose-color.el (or font-lock-extra.el before 578Get support packages choose-color.el (or font-lock-extra.el before
42319.30), imenu-go.el from the same place. \(Look for other files there 57919.30), imenu-go.el from the same place. \(Look for other files there
424too... ;-). Get a patch for imenu.el in 19.29. Note that for 19.30 and 580too... ;-). Get a patch for imenu.el in 19.29. Note that for 19.30 and
@@ -434,27 +590,41 @@ older version was on
434 http://www.metronet.com:70/9/perlinfo/perl5/manual/perl5-info.tar.gz 590 http://www.metronet.com:70/9/perlinfo/perl5/manual/perl5-info.tar.gz
435 591
436If you use imenu-go, run imenu on perl5-info buffer (you can do it 592If you use imenu-go, run imenu on perl5-info buffer (you can do it
437from CPerl menu). If many files are related, generate TAGS files from 593from Perl menu). If many files are related, generate TAGS files from
438Tools/Tags submenu in CPerl menu. 594Tools/Tags submenu in Perl menu.
439 595
440If some class structure is too complicated, use Tools/Hierarchy-view 596If some class structure is too complicated, use Tools/Hierarchy-view
441from CPerl menu, or hierarchic view of imenu. The second one uses the 597from Perl menu, or hierarchic view of imenu. The second one uses the
442current buffer only, the first one requires generation of TAGS from 598current buffer only, the first one requires generation of TAGS from
443CPerl/Tools/Tags menu beforehand. 599Perl/Tools/Tags menu beforehand.
600
601Run Perl/Tools/Insert-spaces-if-needed to fix your lazy typing.
602
603Switch auto-help on/off with Perl/Tools/Auto-help.
604
605Though with contemporary Emaxen CPerl mode should maintain the correct
606parsing of Perl even when editing, sometimes it may be lost. Fix this by
607
608 M-x norm RET
444 609
445Run CPerl/Tools/Insert-spaces-if-needed to fix your lazy typing. 610In cases of more severe confusion sometimes it is helpful to do
446 611
447Switch auto-help on/off with CPerl/Tools/Auto-help. 612 M-x load-l RET cperl-mode RET
613 M-x norm RET
448 614
449Before reporting (non-)problems look in the problem section on what I 615Before reporting (non-)problems look in the problem section of online
450know about them.") 616micro-docs on what I know about CPerl problems.")
451 617
452(defvar cperl-problems 'please-ignore-this-line 618(defvar cperl-problems 'please-ignore-this-line
453"Some faces will not be shown on some versions of Emacs unless you 619"Some faces will not be shown on some versions of Emacs unless you
454install choose-color.el, available from 620install choose-color.el, available from
455 ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs/ 621 ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs/
456 622
457Even with newer Emacsen interaction of `font-lock' and 623Emacs had a _very_ restricted syntax parsing engine until RMS's Emacs
62420.1. Most problems below are corrected starting from this version of
625Emacs, and all of them should go with (future) RMS's version 20.3.
626
627Note that even with newer Emacsen interaction of `font-lock' and
458syntaxification is not cleaned up. You may get slightly different 628syntaxification is not cleaned up. You may get slightly different
459colors basing on the order of fontification and syntaxification. This 629colors basing on the order of fontification and syntaxification. This
460might be corrected by setting `cperl-syntaxify-by-font-lock' to t, but 630might be corrected by setting `cperl-syntaxify-by-font-lock' to t, but
@@ -480,9 +650,10 @@ to insert it as $ {aaa} (legal in perl5, not in perl4).
480Similar problems arise in regexps, when /(\\s|$)/ should be rewritten 650Similar problems arise in regexps, when /(\\s|$)/ should be rewritten
481as /($|\\s)/. Note that such a transposition is not always possible. 651as /($|\\s)/. Note that such a transposition is not always possible.
482 652
483The solution is to upgrade your Emacs. Note that Emacs 20.2 has some 653The solution is to upgrade your Emacs or patch an older one. Note
484bugs related to `syntax-table' text properties. Patches are available 654that RMS's 20.2 has some bugs related to `syntax-table' text
485on the main CPerl download site, and on CPAN. 655properties. Patches are available on the main CPerl download site,
656and on CPAN.
486 657
487If these bugs cannot be fixed on your machine (say, you have an inferior 658If these bugs cannot be fixed on your machine (say, you have an inferior
488environment and cannot recompile), you may still disable all the fancy stuff 659environment and cannot recompile), you may still disable all the fancy stuff
@@ -490,7 +661,9 @@ via `cperl-use-syntax-table-text-property'." )
490 661
491(defvar cperl-non-problems 'please-ignore-this-line 662(defvar cperl-non-problems 'please-ignore-this-line
492"As you know from `problems' section, Perl syntax is too hard for CPerl on 663"As you know from `problems' section, Perl syntax is too hard for CPerl on
493older Emacsen. 664older Emacsen. Here is what you can do if you cannot upgrade, or if
665you want to switch off these capabilities on RMS Emacs 20.2 (+patches) or 20.3
666or better. Please skip this docs if you run a capable Emacs already.
494 667
495Most of the time, if you write your own code, you may find an equivalent 668Most of the time, if you write your own code, you may find an equivalent
496\(and almost as readable) expression (what is discussed below is usually 669\(and almost as readable) expression (what is discussed below is usually
@@ -538,6 +711,7 @@ To speed up coloring the following compromises exist:
538Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove 711Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove
539`car' before `imenu-choose-buffer-index' in `imenu'. 712`car' before `imenu-choose-buffer-index' in `imenu'.
540`imenu-add-to-menubar' in 20.2 is broken. 713`imenu-add-to-menubar' in 20.2 is broken.
714
541A lot of things on XEmacs may be broken too, judging by bug reports I 715A lot of things on XEmacs may be broken too, judging by bug reports I
542recieve. Note that some releases of XEmacs are better than the others 716recieve. Note that some releases of XEmacs are better than the others
543as far as bugs reports I see are concerned.") 717as far as bugs reports I see are concerned.")
@@ -549,8 +723,11 @@ as far as bugs reports I see are concerned.")
549 723
5501) It does 99% of Perl syntax correct (as opposed to 80-90% in Perl 7241) It does 99% of Perl syntax correct (as opposed to 80-90% in Perl
551mode - but the latter number may have improved too in last years) even 725mode - but the latter number may have improved too in last years) even
552without `syntax-table' property; When using this property, it should 726with old Emaxen which do not support `syntax-table' property.
553handle 99.995% of lines correct - or somesuch. 727
728When using `syntax-table' property for syntax assist hints, it should
729handle 99.995% of lines correct - or somesuch. It automatically
730updates syntax assist hints when you edit your script.
554 731
5552) It is generally believed to be \"the most user-friendly Emacs 7322) It is generally believed to be \"the most user-friendly Emacs
556package\" whatever it may mean (I doubt that the people who say similar 733package\" whatever it may mean (I doubt that the people who say similar
@@ -599,6 +776,10 @@ voice);
599 to 776 to
600 B if A; 777 B if A;
601 778
779 n) Highlights (by user-choice) either 3-delimiters constructs
780 (such as tr/a/b/), or regular expressions and `y/tr'.
781 o) Highlights trailing whitespace.
782
6025) The indentation engine was very smart, but most of tricks may be 7835) The indentation engine was very smart, but most of tricks may be
603not needed anymore with the support for `syntax-table' property. Has 784not needed anymore with the support for `syntax-table' property. Has
604progress indicator for indentation (with `imenu' loaded). 785progress indicator for indentation (with `imenu' loaded).
@@ -655,8 +836,46 @@ B) Speed of editing operations.
655 syntax-engine-helping scan, thus will make many more Perl 836 syntax-engine-helping scan, thus will make many more Perl
656 constructs be wrongly recognized by CPerl, thus may lead to 837 constructs be wrongly recognized by CPerl, thus may lead to
657 wrongly matched parentheses, wrong indentation, etc. 838 wrongly matched parentheses, wrong indentation, etc.
839
840 One can unset `cperl-syntaxify-unwind'. This might speed up editing
841 of, say, long POD sections.
658") 842")
659 843
844(defvar cperl-tips-faces 'please-ignore-this-line
845 "CPerl mode uses following faces for highlighting:
846
847 cperl-array-face Array names
848 cperl-hash-face Hash names
849 font-lock-comment-face Comments, PODs and whatever is considered
850 syntaxically to be not code
851 font-lock-constant-face HERE-doc delimiters, labels, delimiters of
852 2-arg operators s/y/tr/ or of RExen,
853 font-lock-function-name-face Special-cased m// and s//foo/, _ as
854 a target of a file tests, file tests,
855 subroutine names at the moment of definition
856 (except those conflicting with Perl operators),
857 package names (when recognized), format names
858 font-lock-keyword-face Control flow switch constructs, declarators
859 cperl-nonoverridable-face Non-overridable keywords, modifiers of RExen
860 font-lock-string-face Strings, qw() constructs, RExen, POD sections,
861 literal parts and the terminator of formats
862 and whatever is syntaxically considered
863 as string literals
864 font-lock-type-face Overridable keywords
865 font-lock-variable-name-face Variable declarations, indirect array and
866 hash names, POD headers/item names
867 cperl-invalid-face Trailing whitespace
868
869Note that in several situations the highlighting tries to inform about
870possible confusion, such as different colors for function names in
871declarations depending on what they (do not) override, or special cases
872m// and s/// which do not do what one would expect them to do.
873
874Help with best setup of these faces for printout requested (for each of
875the faces: please specify bold, italic, underline, shadow and box.)
876
877\(Not finished.)")
878
660 879
661 880
662;;; Portability stuff: 881;;; Portability stuff:
@@ -713,9 +932,12 @@ B) Speed of editing operations.
713 'lazy-lock) 932 'lazy-lock)
714 "Text property which inhibits refontification.") 933 "Text property which inhibits refontification.")
715 934
716(defsubst cperl-put-do-not-fontify (from to) 935(defsubst cperl-put-do-not-fontify (from to &optional post)
936 ;; If POST, do not do it with postponed fontification
937 (if (and post cperl-syntaxify-by-font-lock)
938 nil
717 (put-text-property (max (point-min) (1- from)) 939 (put-text-property (max (point-min) (1- from))
718 to cperl-do-not-fontify t)) 940 to cperl-do-not-fontify t)))
719 941
720(defcustom cperl-mode-hook nil 942(defcustom cperl-mode-hook nil
721 "Hook run by `cperl-mode'." 943 "Hook run by `cperl-mode'."
@@ -724,6 +946,8 @@ B) Speed of editing operations.
724 946
725(defvar cperl-syntax-state nil) 947(defvar cperl-syntax-state nil)
726(defvar cperl-syntax-done-to nil) 948(defvar cperl-syntax-done-to nil)
949(defvar cperl-emacs-can-parse (> (length (save-excursion
950 (parse-partial-sexp 1 1))) 9))
727 951
728;; Make customization possible "in reverse" 952;; Make customization possible "in reverse"
729(defsubst cperl-val (symbol &optional default hairy) 953(defsubst cperl-val (symbol &optional default hairy)
@@ -734,11 +958,12 @@ B) Speed of editing operations.
734 958
735;;; Probably it is too late to set these guys already, but it can help later: 959;;; Probably it is too late to set these guys already, but it can help later:
736 960
961;;;(and cperl-clobber-mode-lists
737;;;(setq auto-mode-alist 962;;;(setq auto-mode-alist
738;;; (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist )) 963;;; (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist ))
739;;;(and (boundp 'interpreter-mode-alist) 964;;;(and (boundp 'interpreter-mode-alist)
740;;; (setq interpreter-mode-alist (append interpreter-mode-alist 965;;; (setq interpreter-mode-alist (append interpreter-mode-alist
741;;; '(("miniperl" . perl-mode))))) 966;;; '(("miniperl" . perl-mode))))))
742(if (fboundp 'eval-when-compile) 967(if (fboundp 'eval-when-compile)
743 (eval-when-compile 968 (eval-when-compile
744 (condition-case nil 969 (condition-case nil
@@ -759,31 +984,18 @@ B) Speed of editing operations.
759 (condition-case nil 984 (condition-case nil
760 (require 'info) 985 (require 'info)
761 (error nil)) 986 (error nil))
987 (if (fboundp 'ps-extend-face-list)
988 (defmacro cperl-ps-extend-face-list (arg)
989 (` (ps-extend-face-list (, arg))))
990 (defmacro cperl-ps-extend-face-list (arg)
991 (` (error "This version of Emacs has no `ps-extend-face-list'."))))
762 ;; Calling `cperl-enable-font-lock' below doesn't compile on XEmacs, 992 ;; Calling `cperl-enable-font-lock' below doesn't compile on XEmacs,
763 ;; macros instead of defsubsts don't work on Emacs, so we do the 993 ;; macros instead of defsubsts don't work on Emacs, so we do the
764 ;; expansion manually. Any other suggestions? 994 ;; expansion manually. Any other suggestions?
765 (if (or (string-match "XEmacs\\|Lucid" emacs-version) 995 (if (or (string-match "XEmacs\\|Lucid" emacs-version)
766 window-system) 996 window-system)
767 (require 'font-lock)) 997 (require 'font-lock))
768 (require 'cl) 998 (require 'cl)))
769 ;; Avoid warning (tmp definitions)
770 (or (fboundp 'x-color-defined-p)
771 (defalias 'x-color-defined-p
772 (cond ((fboundp 'color-defined-p) 'color-defined-p)
773 ;; XEmacs >= 19.12
774 ((fboundp 'valid-color-name-p) 'valid-color-name-p)
775 ;; XEmacs 19.11
776 (t 'x-valid-color-name-p))))
777 (fset 'cperl-is-face
778 (cond ((fboundp 'find-face)
779 (symbol-function 'find-face))
780 ((and (fboundp 'face-list)
781 (face-list))
782 (function (lambda (face)
783 (member face (and (fboundp 'face-list)
784 (face-list))))))
785 (t
786 (function (lambda (face) (boundp face))))))))
787 999
788(defvar cperl-mode-abbrev-table nil 1000(defvar cperl-mode-abbrev-table nil
789 "Abbrev table in use in Cperl-mode buffers.") 1001 "Abbrev table in use in Cperl-mode buffers.")
@@ -820,14 +1032,8 @@ B) Speed of editing operations.
820 (cperl-define-key "\177" 'cperl-electric-backspace) 1032 (cperl-define-key "\177" 'cperl-electric-backspace)
821 (cperl-define-key "\t" 'cperl-indent-command) 1033 (cperl-define-key "\t" 'cperl-indent-command)
822 ;; don't clobber the backspace binding: 1034 ;; don't clobber the backspace binding:
823 (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command
824 [(control c) (control h) f])
825 (cperl-define-key "\C-c\C-hF" 'cperl-info-on-command 1035 (cperl-define-key "\C-c\C-hF" 'cperl-info-on-command
826 [(control c) (control h) F]) 1036 [(control c) (control h) F])
827 (cperl-define-key "\C-c\C-hv"
828 ;;(concat (char-to-string help-char) "v") ; does not work
829 'cperl-get-help
830 [(control c) (control h) v])
831 (if (cperl-val 'cperl-clobber-lisp-bindings) 1037 (if (cperl-val 'cperl-clobber-lisp-bindings)
832 (progn 1038 (progn
833 (cperl-define-key "\C-hf" 1039 (cperl-define-key "\C-hf"
@@ -837,7 +1043,21 @@ B) Speed of editing operations.
837 (cperl-define-key "\C-hv" 1043 (cperl-define-key "\C-hv"
838 ;;(concat (char-to-string help-char) "v") ; does not work 1044 ;;(concat (char-to-string help-char) "v") ; does not work
839 'cperl-get-help 1045 'cperl-get-help
840 [(control h) v]))) 1046 [(control h) v])
1047 (cperl-define-key "\C-c\C-hf"
1048 ;;(concat (char-to-string help-char) "f") ; does not work
1049 (key-binding "\C-hf")
1050 [(control c) (control h) f])
1051 (cperl-define-key "\C-c\C-hv"
1052 ;;(concat (char-to-string help-char) "v") ; does not work
1053 (key-binding "\C-hv")
1054 [(control c) (control h) v]))
1055 (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command
1056 [(control c) (control h) f])
1057 (cperl-define-key "\C-c\C-hv"
1058 ;;(concat (char-to-string help-char) "v") ; does not work
1059 'cperl-get-help
1060 [(control c) (control h) v]))
841 (if (and cperl-xemacs-p 1061 (if (and cperl-xemacs-p
842 (<= emacs-minor-version 11) (<= emacs-major-version 19)) 1062 (<= emacs-minor-version 11) (<= emacs-major-version 19))
843 (progn 1063 (progn
@@ -902,6 +1122,8 @@ B) Speed of editing operations.
902 ["Insert spaces if needed" cperl-find-bad-style t] 1122 ["Insert spaces if needed" cperl-find-bad-style t]
903 ["Class Hierarchy from TAGS" cperl-tags-hier-init t] 1123 ["Class Hierarchy from TAGS" cperl-tags-hier-init t]
904 ;;["Update classes" (cperl-tags-hier-init t) tags-table-list] 1124 ;;["Update classes" (cperl-tags-hier-init t) tags-table-list]
1125 ["CPerl pretty print (exprmntl)" cperl-ps-print
1126 (fboundp 'ps-extend-face-list)]
905 ["Imenu on info" cperl-imenu-on-info (featurep 'imenu)] 1127 ["Imenu on info" cperl-imenu-on-info (featurep 'imenu)]
906 ("Tags" 1128 ("Tags"
907;;; ["Create tags for current file" cperl-etags t] 1129;;; ["Create tags for current file" cperl-etags t]
@@ -960,7 +1182,11 @@ B) Speed of editing operations.
960 ["Non-problems" (describe-variable 'cperl-non-problems) t] 1182 ["Non-problems" (describe-variable 'cperl-non-problems) t]
961 ["Speed" (describe-variable 'cperl-speed) t] 1183 ["Speed" (describe-variable 'cperl-speed) t]
962 ["Praise" (describe-variable 'cperl-praise) t] 1184 ["Praise" (describe-variable 'cperl-praise) t]
963 ["CPerl mode" (describe-function 'cperl-mode) t])))) 1185 ["Faces" (describe-variable 'cperl-tips-faces) t]
1186 ["CPerl mode" (describe-function 'cperl-mode) t]
1187 ["CPerl version"
1188 (message "The version of master-file for this CPerl is %s"
1189 cperl-version) t]))))
964 (error nil)) 1190 (error nil))
965 1191
966(autoload 'c-macro-expand "cmacexp" 1192(autoload 'c-macro-expand "cmacexp"
@@ -1271,7 +1497,7 @@ or as help on variables `cperl-tips', `cperl-problems',
1271 ;; Fix broken font-lock: 1497 ;; Fix broken font-lock:
1272 (or (boundp 'font-lock-unfontify-region-function) 1498 (or (boundp 'font-lock-unfontify-region-function)
1273 (set 'font-lock-unfontify-region-function 1499 (set 'font-lock-unfontify-region-function
1274 'font-lock-default-unfontify-buffer)) 1500 'font-lock-default-unfontify-region))
1275 (make-variable-buffer-local 'font-lock-unfontify-region-function) 1501 (make-variable-buffer-local 'font-lock-unfontify-region-function)
1276 (set 'font-lock-unfontify-region-function 1502 (set 'font-lock-unfontify-region-function
1277 'cperl-font-lock-unfontify-region-function) 1503 'cperl-font-lock-unfontify-region-function)
@@ -1306,11 +1532,12 @@ or as help on variables `cperl-tips', `cperl-problems',
1306 (run-hooks 'cperl-mode-hook) 1532 (run-hooks 'cperl-mode-hook)
1307 ;; After hooks since fontification will break this 1533 ;; After hooks since fontification will break this
1308 (if cperl-pod-here-scan 1534 (if cperl-pod-here-scan
1309 (or (and (boundp 'font-lock-mode) 1535 (or ;;(and (boundp 'font-lock-mode)
1310 (eval 'font-lock-mode) ; Avoid warning 1536 ;; (eval 'font-lock-mode) ; Avoid warning
1311 (boundp 'font-lock-hot-pass) ; Newer font-lock 1537 ;; (boundp 'font-lock-hot-pass) ; Newer font-lock
1312 cperl-syntaxify-by-font-lock) 1538 cperl-syntaxify-by-font-lock ;;)
1313 (cperl-find-pods-heres)))) 1539 (progn (or cperl-faces-init (cperl-init-faces-weak))
1540 (cperl-find-pods-heres)))))
1314 1541
1315;; Fix for perldb - make default reasonable 1542;; Fix for perldb - make default reasonable
1316(defvar gud-perldb-history) 1543(defvar gud-perldb-history)
@@ -1348,13 +1575,28 @@ or as help on variables `cperl-tips', `cperl-problems',
1348;; based on its context. Do fallback if comment is found wrong. 1575;; based on its context. Do fallback if comment is found wrong.
1349 1576
1350(defvar cperl-wrong-comment) 1577(defvar cperl-wrong-comment)
1578(defvar cperl-st-cfence '(14)) ; Comment-fence
1579(defvar cperl-st-sfence '(15)) ; String-fence
1580(defvar cperl-st-punct '(1))
1581(defvar cperl-st-word '(2))
1582(defvar cperl-st-bra '(4 . ?\>))
1583(defvar cperl-st-ket '(5 . ?\<))
1584
1351 1585
1352(defun cperl-comment-indent () 1586(defun cperl-comment-indent ()
1353 (let ((p (point)) (c (current-column)) was) 1587 (let ((p (point)) (c (current-column)) was phony)
1354 (if (looking-at "^#") 0 ; Existing comment at bol stays there. 1588 (if (looking-at "^#") 0 ; Existing comment at bol stays there.
1355 ;; Wrong comment found 1589 ;; Wrong comment found
1356 (save-excursion 1590 (save-excursion
1357 (setq was (cperl-to-comment-or-eol)) 1591 (setq was (cperl-to-comment-or-eol)
1592 phony (eq (get-text-property (point) 'syntax-table)
1593 cperl-st-cfence))
1594 (if phony
1595 (progn
1596 (re-search-forward "#\\|$") ; Hmm, what about embedded #?
1597 (if (eq (preceding-char) ?\#)
1598 (forward-char -1))
1599 (setq was nil)))
1358 (if (= (point) p) 1600 (if (= (point) p)
1359 (progn 1601 (progn
1360 (skip-chars-backward " \t") 1602 (skip-chars-backward " \t")
@@ -1609,7 +1851,7 @@ to nil."
1609 (save-excursion 1851 (save-excursion
1610 (not 1852 (not
1611 (re-search-backward 1853 (re-search-backward
1612 "[#\"'`]\\|\\<q\\(\\|[wqx]\\)\\>" 1854 "[#\"'`]\\|\\<q\\(\\|[wqxr]\\)\\>"
1613 beg t))) 1855 beg t)))
1614 (save-excursion (or (not (re-search-backward "^=" nil t)) 1856 (save-excursion (or (not (re-search-backward "^=" nil t))
1615 (or 1857 (or
@@ -1681,6 +1923,7 @@ to nil."
1681 (forward-char -1) 1923 (forward-char -1)
1682 (bolp)) 1924 (bolp))
1683 (or 1925 (or
1926 (get-text-property (point) 'in-pod)
1684 (cperl-after-expr-p nil "{;:") 1927 (cperl-after-expr-p nil "{;:")
1685 (and (re-search-backward 1928 (and (re-search-backward
1686 "\\(\\`\n?\\|\n\n\\)=\\sw+" (point-min) t) 1929 "\\(\\`\n?\\|\n\n\\)=\\sw+" (point-min) t)
@@ -1741,7 +1984,7 @@ to nil."
1741 (save-excursion 1984 (save-excursion
1742 (not 1985 (not
1743 (re-search-backward 1986 (re-search-backward
1744 "[#\"'`]\\|\\<q\\(\\|[wqx]\\)\\>" 1987 "[#\"'`]\\|\\<q\\(\\|[wqxr]\\)\\>"
1745 beg t))) 1988 beg t)))
1746 (save-excursion (or (not (re-search-backward "^=" nil t)) 1989 (save-excursion (or (not (re-search-backward "^=" nil t))
1747 (looking-at "=cut") 1990 (looking-at "=cut")
@@ -1980,6 +2223,7 @@ means indent rigidly all the lines of the expression starting after point
1980so that this line becomes properly indented. 2223so that this line becomes properly indented.
1981The relative indentation among the lines of the expression are preserved." 2224The relative indentation among the lines of the expression are preserved."
1982 (interactive "P") 2225 (interactive "P")
2226 (cperl-update-syntaxification (point) (point))
1983 (if whole-exp 2227 (if whole-exp
1984 ;; If arg, always indent this line as Perl 2228 ;; If arg, always indent this line as Perl
1985 ;; and shift remaining lines of expression the same amount. 2229 ;; and shift remaining lines of expression the same amount.
@@ -2003,13 +2247,13 @@ The relative indentation among the lines of the expression are preserved."
2003 (insert-tab) 2247 (insert-tab)
2004 (cperl-indent-line)))) 2248 (cperl-indent-line))))
2005 2249
2006(defun cperl-indent-line (&optional symbol) 2250(defun cperl-indent-line (&optional parse-data)
2007 "Indent current line as Perl code. 2251 "Indent current line as Perl code.
2008Return the amount the indentation changed by." 2252Return the amount the indentation changed by."
2009 (let (indent i beg shift-amt 2253 (let (indent i beg shift-amt
2010 (case-fold-search nil) 2254 (case-fold-search nil)
2011 (pos (- (point-max) (point)))) 2255 (pos (- (point-max) (point))))
2012 (setq indent (cperl-calculate-indent nil symbol) 2256 (setq indent (cperl-calculate-indent parse-data)
2013 i indent) 2257 i indent)
2014 (beginning-of-line) 2258 (beginning-of-line)
2015 (setq beg (point)) 2259 (setq beg (point))
@@ -2056,16 +2300,20 @@ Return the amount the indentation changed by."
2056 (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:[^:]")))) 2300 (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:[^:]"))))
2057 2301
2058(defun cperl-get-state (&optional parse-start start-state) 2302(defun cperl-get-state (&optional parse-start start-state)
2059 ;; returns list (START STATE DEPTH PRESTART), START is a good place 2303 ;; returns list (START STATE DEPTH PRESTART),
2060 ;; to start parsing, STATE is what is returned by 2304 ;; START is a good place to start parsing, or equal to
2061 ;; `parse-partial-sexp'. DEPTH is true is we are immediately after 2305 ;; PARSE-START if preset,
2062 ;; end of block which contains START. PRESTART is the position 2306 ;; STATE is what is returned by `parse-partial-sexp'.
2063 ;; basing on which START was found. 2307 ;; DEPTH is true is we are immediately after end of block
2308 ;; which contains START.
2309 ;; PRESTART is the position basing on which START was found.
2064 (save-excursion 2310 (save-excursion
2065 (let ((start-point (point)) depth state start prestart) 2311 (let ((start-point (point)) depth state start prestart)
2066 (if parse-start 2312 (if (and parse-start
2313 (<= parse-start start-point))
2067 (goto-char parse-start) 2314 (goto-char parse-start)
2068 (beginning-of-defun)) 2315 (beginning-of-defun)
2316 (setq start-state nil))
2069 (setq prestart (point)) 2317 (setq prestart (point))
2070 (if start-state nil 2318 (if start-state nil
2071 ;; Try to go out, if sub is not on the outermost level 2319 ;; Try to go out, if sub is not on the outermost level
@@ -2079,7 +2327,6 @@ Return the amount the indentation changed by."
2079 (beginning-of-line 2))) ; Go to the next line. 2327 (beginning-of-line 2))) ; Go to the next line.
2080 (if start (goto-char start))) ; Not at the start of file 2328 (if start (goto-char start))) ; Not at the start of file
2081 (setq start (point)) 2329 (setq start (point))
2082 (if (< start start-point) (setq parse-start start))
2083 (or state (setq state (parse-partial-sexp start start-point -1 nil start-state))) 2330 (or state (setq state (parse-partial-sexp start start-point -1 nil start-state)))
2084 (list start state depth prestart)))) 2331 (list start state depth prestart))))
2085 2332
@@ -2095,7 +2342,7 @@ Return the amount the indentation changed by."
2095 (backward-sexp) 2342 (backward-sexp)
2096 ;; Need take into account `bless', `return', `tr',... 2343 ;; Need take into account `bless', `return', `tr',...
2097 (or (and (looking-at "[a-zA-Z0-9_:]+[ \t\n\f]*[{#]") ; Method call syntax 2344 (or (and (looking-at "[a-zA-Z0-9_:]+[ \t\n\f]*[{#]") ; Method call syntax
2098 (not (looking-at "\\(bless\\|return\\|qw\\|tr\\|[smy]\\)\\>"))) 2345 (not (looking-at "\\(bless\\|return\\|q[wqrx]?\\|tr\\|[smy]\\)\\>")))
2099 (progn 2346 (progn
2100 (skip-chars-backward " \t\n\f") 2347 (skip-chars-backward " \t\n\f")
2101 (and (memq (char-syntax (preceding-char)) '(?w ?_)) 2348 (and (memq (char-syntax (preceding-char)) '(?w ?_))
@@ -2106,10 +2353,13 @@ Return the amount the indentation changed by."
2106 2353
2107(defvar cperl-look-for-prop '((pod in-pod) (here-doc-delim here-doc-group))) 2354(defvar cperl-look-for-prop '((pod in-pod) (here-doc-delim here-doc-group)))
2108 2355
2109(defun cperl-calculate-indent (&optional parse-start symbol) 2356(defun cperl-calculate-indent (&optional parse-data) ; was parse-start
2110 "Return appropriate indentation for current line as Perl code. 2357 "Return appropriate indentation for current line as Perl code.
2111In usual case returns an integer: the column to indent to. 2358In usual case returns an integer: the column to indent to.
2112Returns nil if line starts inside a string, t if in a comment." 2359Returns nil if line starts inside a string, t if in a comment.
2360
2361Will not correct the indentation for labels, but will correct it for braces
2362and closing parentheses and brackets.."
2113 (save-excursion 2363 (save-excursion
2114 (if (or 2364 (if (or
2115 (memq (get-text-property (point) 'syntax-type) 2365 (memq (get-text-property (point) 'syntax-type)
@@ -2148,15 +2398,22 @@ Returns nil if line starts inside a string, t if in a comment."
2148 (setq pre-indent-point (point))))))) 2398 (setq pre-indent-point (point)))))))
2149 (goto-char pre-indent-point) 2399 (goto-char pre-indent-point)
2150 (let* ((case-fold-search nil) 2400 (let* ((case-fold-search nil)
2151 (s-s (cperl-get-state)) 2401 (s-s (cperl-get-state (car parse-data) (nth 1 parse-data)))
2152 (start (nth 0 s-s)) 2402 (start (or (nth 2 parse-data)
2403 (nth 0 s-s)))
2153 (state (nth 1 s-s)) 2404 (state (nth 1 s-s))
2154 (containing-sexp (car (cdr state))) 2405 (containing-sexp (car (cdr state)))
2155 (start-indent (save-excursion
2156 (goto-char start)
2157 (- (current-indentation)
2158 (if (nth 2 s-s) cperl-indent-level 0))))
2159 old-indent) 2406 old-indent)
2407 (if (and
2408 ;;containing-sexp ;; We are buggy at toplevel :-(
2409 parse-data)
2410 (progn
2411 (setcar parse-data pre-indent-point)
2412 (setcar (cdr parse-data) state)
2413 (or (nth 2 parse-data)
2414 (setcar (cddr parse-data) start))
2415 ;; Before this point: end of statement
2416 (setq old-indent (nth 3 parse-data))))
2160 ;; (or parse-start (null symbol) 2417 ;; (or parse-start (null symbol)
2161 ;; (setq parse-start (symbol-value symbol) 2418 ;; (setq parse-start (symbol-value symbol)
2162 ;; start-indent (nth 2 parse-start) 2419 ;; start-indent (nth 2 parse-start)
@@ -2206,26 +2463,36 @@ Returns nil if line starts inside a string, t if in a comment."
2206 ;; unless that ends in a closeparen without semicolon, 2463 ;; unless that ends in a closeparen without semicolon,
2207 ;; in which case this line is the first argument decl. 2464 ;; in which case this line is the first argument decl.
2208 (skip-chars-forward " \t") 2465 (skip-chars-forward " \t")
2209 (+ start-indent 2466 (+ (save-excursion
2210 (if (= (following-char) ?{) cperl-continued-brace-offset 0) 2467 (goto-char start)
2468 (- (current-indentation)
2469 (if (nth 2 s-s) cperl-indent-level 0)))
2470 (if (= char-after ?{) cperl-continued-brace-offset 0)
2211 (progn 2471 (progn
2212 (cperl-backward-to-noncomment (or parse-start (point-min))) 2472 (cperl-backward-to-noncomment (or old-indent (point-min)))
2213 ;; Look at previous line that's at column 0 2473 ;; Look at previous line that's at column 0
2214 ;; to determine whether we are in top-level decls 2474 ;; to determine whether we are in top-level decls
2215 ;; or function's arg decls. Set basic-indent accordingly. 2475 ;; or function's arg decls. Set basic-indent accordingly.
2216 ;; Now add a little if this is a continuation line. 2476 ;; Now add a little if this is a continuation line.
2217 (if (or (bobp) 2477 (if (or (bobp)
2478 (eq (point) old-indent) ; old-indent was at comment
2218 (eq (preceding-char) ?\;) 2479 (eq (preceding-char) ?\;)
2219 ;; Had ?\) too 2480 ;; Had ?\) too
2220 (and (eq (preceding-char) ?\}) 2481 (and (eq (preceding-char) ?\})
2221 (cperl-after-block-and-statement-beg start)) 2482 (cperl-after-block-and-statement-beg
2483 (point-min))) ; Was start - too close
2222 (memq char-after (append ")]}" nil)) 2484 (memq char-after (append ")]}" nil))
2223 (and (eq (preceding-char) ?\:) ; label 2485 (and (eq (preceding-char) ?\:) ; label
2224 (progn 2486 (progn
2225 (forward-sexp -1) 2487 (forward-sexp -1)
2226 (skip-chars-backward " \t") 2488 (skip-chars-backward " \t")
2227 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:")))) 2489 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:"))))
2228 0 2490 (progn
2491 (if (and parse-data
2492 (not (eq char-after ?\C-j)))
2493 (setcdr (cddr parse-data)
2494 (list pre-indent-point)))
2495 0)
2229 cperl-continued-statement-offset)))) 2496 cperl-continued-statement-offset))))
2230 ((/= (char-after containing-sexp) ?{) 2497 ((/= (char-after containing-sexp) ?{)
2231 ;; line is expression, not statement: 2498 ;; line is expression, not statement:
@@ -2255,11 +2522,13 @@ Returns nil if line starts inside a string, t if in a comment."
2255 (cperl-backward-to-noncomment containing-sexp) 2522 (cperl-backward-to-noncomment containing-sexp)
2256 ;; Back up over label lines, since they don't 2523 ;; Back up over label lines, since they don't
2257 ;; affect whether our line is a continuation. 2524 ;; affect whether our line is a continuation.
2258 (while (or (eq (preceding-char) ?\,) 2525 ;; (Had \, too)
2526 (while ;;(or (eq (preceding-char) ?\,)
2259 (and (eq (preceding-char) ?:) 2527 (and (eq (preceding-char) ?:)
2260 (or;;(eq (char-after (- (point) 2)) ?\') ; ???? 2528 (or;;(eq (char-after (- (point) 2)) ?\') ; ????
2261 (memq (char-syntax (char-after (- (point) 2))) 2529 (memq (char-syntax (char-after (- (point) 2)))
2262 '(?w ?_))))) 2530 '(?w ?_))))
2531 ;;)
2263 (if (eq (preceding-char) ?\,) 2532 (if (eq (preceding-char) ?\,)
2264 ;; Will go to beginning of line, essentially. 2533 ;; Will go to beginning of line, essentially.
2265 ;; Will ignore embedded sexpr XXXX. 2534 ;; Will ignore embedded sexpr XXXX.
@@ -2275,12 +2544,22 @@ Returns nil if line starts inside a string, t if in a comment."
2275 ;; This line is continuation of preceding line's statement; 2544 ;; This line is continuation of preceding line's statement;
2276 ;; indent `cperl-continued-statement-offset' more than the 2545 ;; indent `cperl-continued-statement-offset' more than the
2277 ;; previous line of the statement. 2546 ;; previous line of the statement.
2547 ;;
2548 ;; There might be a label on this line, just
2549 ;; consider it bad style and ignore it.
2278 (progn 2550 (progn
2279 (cperl-backward-to-start-of-continued-exp containing-sexp) 2551 (cperl-backward-to-start-of-continued-exp containing-sexp)
2280 (+ (if (memq char-after (append "}])" nil)) 2552 (+ (if (memq char-after (append "}])" nil))
2281 0 ; Closing parenth 2553 0 ; Closing parenth
2282 cperl-continued-statement-offset) 2554 cperl-continued-statement-offset)
2283 (current-column) 2555 (if (looking-at "\\w+[ \t]*:")
2556 (if (> (current-indentation) cperl-min-label-indent)
2557 (- (current-indentation) cperl-label-offset)
2558 ;; Do not move `parse-data', this should
2559 ;; be quick anyway (this comment comes
2560 ;;from different location):
2561 (cperl-calculate-indent))
2562 (current-column))
2284 (if (eq char-after ?\{) 2563 (if (eq char-after ?\{)
2285 cperl-continued-brace-offset 0))) 2564 cperl-continued-brace-offset 0)))
2286 ;; This line starts a new statement. 2565 ;; This line starts a new statement.
@@ -2364,9 +2643,9 @@ Returns nil if line starts inside a string, t if in a comment."
2364 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]")) 2643 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]"))
2365 (if (> (current-indentation) cperl-min-label-indent) 2644 (if (> (current-indentation) cperl-min-label-indent)
2366 (- (current-indentation) cperl-label-offset) 2645 (- (current-indentation) cperl-label-offset)
2367 (cperl-calculate-indent 2646 ;; Do not move `parse-data', this should
2368 (if (and parse-start (<= parse-start (point))) 2647 ;; be quick anyway:
2369 parse-start))) 2648 (cperl-calculate-indent))
2370 (current-indentation)))))))))))))) 2649 (current-indentation))))))))))))))
2371 2650
2372(defvar cperl-indent-alist 2651(defvar cperl-indent-alist
@@ -2528,9 +2807,7 @@ Not finished, not used."
2528 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]")) 2807 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]"))
2529 (if (> (current-indentation) cperl-min-label-indent) 2808 (if (> (current-indentation) cperl-min-label-indent)
2530 (- (current-indentation) cperl-label-offset) 2809 (- (current-indentation) cperl-label-offset)
2531 (cperl-calculate-indent 2810 (cperl-calculate-indent))
2532 (if (and parse-start (<= parse-start (point)))
2533 parse-start)))
2534 (current-indentation)))))))) 2811 (current-indentation))))))))
2535 res))) 2812 res)))
2536 2813
@@ -2578,7 +2855,7 @@ Returns true if comment is found."
2578 "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*" 2855 "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*"
2579 lim 'move) 2856 lim 'move)
2580 (setq stop-in t))) 2857 (setq stop-in t)))
2581 ((looking-at "\\(m\\|q\\([qxw]\\)?\\)\\>") 2858 ((looking-at "\\(m\\|q\\([qxwr]\\)?\\)\\>")
2582 (or (re-search-forward 2859 (or (re-search-forward
2583 "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#" 2860 "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#"
2584 lim 'move) 2861 lim 'move)
@@ -2598,13 +2875,6 @@ Returns true if comment is found."
2598(defsubst cperl-1+ (p) 2875(defsubst cperl-1+ (p)
2599 (min (point-max) (1+ p))) 2876 (min (point-max) (1+ p)))
2600 2877
2601(defvar cperl-st-cfence '(14)) ; Comment-fence
2602(defvar cperl-st-sfence '(15)) ; String-fence
2603(defvar cperl-st-punct '(1))
2604(defvar cperl-st-word '(2))
2605(defvar cperl-st-bra '(4 . ?\>))
2606(defvar cperl-st-ket '(5 . ?\<))
2607
2608(defsubst cperl-modify-syntax-type (at how) 2878(defsubst cperl-modify-syntax-type (at how)
2609 (if (< at (point-max)) 2879 (if (< at (point-max))
2610 (progn 2880 (progn
@@ -2618,9 +2888,10 @@ Returns true if comment is found."
2618 (while (re-search-forward "^\\s(" e 'to-end) 2888 (while (re-search-forward "^\\s(" e 'to-end)
2619 (put-text-property (1- (point)) (point) 'syntax-table cperl-st-punct)))) 2889 (put-text-property (1- (point)) (point) 'syntax-table cperl-st-punct))))
2620 2890
2621(defun cperl-commentify (bb e string) 2891(defun cperl-commentify (bb e string &optional noface)
2622 (if cperl-use-syntax-table-text-property 2892 (if cperl-use-syntax-table-text-property
2623 (progn 2893 (if (eq noface 'n) ; Only immediate
2894 nil
2624 ;; We suppose that e is _after_ the end of construction, as after eol. 2895 ;; We suppose that e is _after_ the end of construction, as after eol.
2625 (setq string (if string cperl-st-sfence cperl-st-cfence)) 2896 (setq string (if string cperl-st-sfence cperl-st-cfence))
2626 (cperl-modify-syntax-type bb string) 2897 (cperl-modify-syntax-type bb string)
@@ -2628,7 +2899,16 @@ Returns true if comment is found."
2628 (if (and (eq string cperl-st-sfence) (> (- e 2) bb)) 2899 (if (and (eq string cperl-st-sfence) (> (- e 2) bb))
2629 (put-text-property (1+ bb) (1- e) 2900 (put-text-property (1+ bb) (1- e)
2630 'syntax-table cperl-string-syntax-table)) 2901 'syntax-table cperl-string-syntax-table))
2631 (cperl-protect-defun-start bb e)))) 2902 (cperl-protect-defun-start bb e))
2903 ;; Fontify
2904 (or noface
2905 (not cperl-pod-here-fontify)
2906 (put-text-property bb e 'face (if string 'font-lock-string-face
2907 'font-lock-comment-face)))))
2908(defvar cperl-starters '(( ?\( . ?\) )
2909 ( ?\[ . ?\] )
2910 ( ?\{ . ?\} )
2911 ( ?\< . ?\> )))
2632 2912
2633(defun cperl-forward-re (lim end is-2arg set-st st-l err-l argument 2913(defun cperl-forward-re (lim end is-2arg set-st st-l err-l argument
2634 &optional ostart oend) 2914 &optional ostart oend)
@@ -2638,13 +2918,8 @@ Returns true if comment is found."
2638 (skip-chars-forward " \t") 2918 (skip-chars-forward " \t")
2639 ;; ender means matching-char matcher. 2919 ;; ender means matching-char matcher.
2640 (setq b (point) 2920 (setq b (point)
2641 starter (char-after b) 2921 starter (if (eobp) 0 (char-after b))
2642 ;; ender: 2922 ender (cdr (assoc starter cperl-starters)))
2643 ender (cdr (assoc starter '(( ?\( . ?\) )
2644 ( ?\[ . ?\] )
2645 ( ?\{ . ?\} )
2646 ( ?\< . ?\> )
2647 ))))
2648 ;; What if starter == ?\\ ???? 2923 ;; What if starter == ?\\ ????
2649 (if set-st 2924 (if set-st
2650 (if (car st-l) 2925 (if (car st-l)
@@ -2666,6 +2941,8 @@ Returns true if comment is found."
2666 (modify-syntax-entry ender (concat ")" (list starter)) st))) 2941 (modify-syntax-entry ender (concat ")" (list starter)) st)))
2667 (condition-case bb 2942 (condition-case bb
2668 (progn 2943 (progn
2944 ;; We use `$' syntax class to find matching stuff, but $$
2945 ;; is recognized the same as $, so we need to check this manually.
2669 (if (and (eq starter (char-after (cperl-1+ b))) 2946 (if (and (eq starter (char-after (cperl-1+ b)))
2670 (not ender)) 2947 (not ender))
2671 ;; $ has TeXish matching rules, so $$ equiv $... 2948 ;; $ has TeXish matching rules, so $$ equiv $...
@@ -2681,6 +2958,7 @@ Returns true if comment is found."
2681 (forward-char -2) 2958 (forward-char -2)
2682 (= 0 (% (skip-chars-backward "\\\\") 2))) 2959 (= 0 (% (skip-chars-backward "\\\\") 2)))
2683 (forward-char -1))) 2960 (forward-char -1)))
2961 ;; Now we are after the first part.
2684 (and is-2arg ; Have trailing part 2962 (and is-2arg ; Have trailing part
2685 (not ender) 2963 (not ender)
2686 (eq (following-char) starter) ; Empty trailing part 2964 (eq (following-char) starter) ; Empty trailing part
@@ -2703,15 +2981,14 @@ Returns true if comment is found."
2703 (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st) 2981 (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st)
2704 (if ender (modify-syntax-entry ender "." st)) 2982 (if ender (modify-syntax-entry ender "." st))
2705 (setq set-st nil) 2983 (setq set-st nil)
2706 (setq 2984 (setq ender (cperl-forward-re lim end nil t st-l err-l
2707 ender 2985 argument starter ender)
2708 (cperl-forward-re lim end nil t st-l err-l argument starter ender)
2709 ender (nth 2 ender))))) 2986 ender (nth 2 ender)))))
2710 (error (goto-char lim) 2987 (error (goto-char lim)
2711 (setq set-st nil) 2988 (setq set-st nil)
2712 (or end 2989 (or end
2713 (message 2990 (message
2714 "End of `%s%s%c ... %c' string not found: %s" 2991 "End of `%s%s%c ... %c' string/RE not found: %s"
2715 argument 2992 argument
2716 (if ostart (format "%c ... %c" ostart (or oend ostart)) "") 2993 (if ostart (format "%c ... %c" ostart (or oend ostart)) "")
2717 starter (or ender starter) bb) 2994 starter (or ender starter) bb)
@@ -2720,11 +2997,60 @@ Returns true if comment is found."
2720 (progn 2997 (progn
2721 (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st) 2998 (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st)
2722 (if ender (modify-syntax-entry ender "." st)))) 2999 (if ender (modify-syntax-entry ender "." st))))
3000 ;; i: have 2 args, after end of the first arg
3001 ;; i2: start of the second arg, if any (before delim iff `ender').
3002 ;; ender: the last arg bounded by parens-like chars, the second one of them
3003 ;; starter: the starting delimiter of the first arg
3004 ;; go-forward: has 2 args, and the second part is empth
2723 (list i i2 ender starter go-forward))) 3005 (list i i2 ender starter go-forward)))
2724 3006
2725(defvar font-lock-string-face) 3007(defvar font-lock-string-face)
2726(defvar font-lock-reference-face) 3008;;(defvar font-lock-reference-face)
2727(defvar font-lock-constant-face) 3009(defvar font-lock-constant-face)
3010(defsubst cperl-postpone-fontification (b e type val &optional now)
3011 ;; Do after syntactic fontification?
3012 (if cperl-syntaxify-by-font-lock
3013 (or now (put-text-property b e 'cperl-postpone (cons type val)))
3014 (put-text-property b e type val)))
3015
3016;;; Here is how the global structures (those which cannot be
3017;;; recognized locally) are marked:
3018;; a) PODs:
3019;; Start-to-end is marked `in-pod' ==> t
3020;; Each non-literal part is marked `syntax-type' ==> `pod'
3021;; Each literal part is marked `syntax-type' ==> `in-pod'
3022;; b) HEREs:
3023;; Start-to-end is marked `here-doc-group' ==> t
3024;; The body is marked `syntax-type' ==> `here-doc'
3025;; The delimiter is marked `syntax-type' ==> `here-doc-delim'
3026;; c) FORMATs:
3027;; After-initial-line--to-end is marked `syntax-type' ==> `format'
3028;; d) 'Q'uoted string:
3029;; part between markers inclusive is marked `syntax-type' ==> `string'
3030
3031(defun cperl-unwind-to-safe (before &optional end)
3032 ;; if BEFORE, go to the previous start-of-line on each step of unwinding
3033 (let ((pos (point)) opos)
3034 (setq opos pos)
3035 (while (and pos (get-text-property pos 'syntax-type))
3036 (setq pos (previous-single-property-change pos 'syntax-type))
3037 (if pos
3038 (if before
3039 (progn
3040 (goto-char (cperl-1- pos))
3041 (beginning-of-line)
3042 (setq pos (point)))
3043 (goto-char (setq pos (cperl-1- pos))))
3044 ;; Up to the start
3045 (goto-char (point-min))))
3046 (if end
3047 ;; Do the same for end, going small steps
3048 (progn
3049 (while (and end (get-text-property end 'syntax-type))
3050 (setq pos end
3051 end (next-single-property-change end 'syntax-type)))
3052 (or end pos)))))
3053
2728(defun cperl-find-pods-heres (&optional min max non-inter end ignore-max) 3054(defun cperl-find-pods-heres (&optional min max non-inter end ignore-max)
2729 "Scans the buffer for hard-to-parse Perl constructions. 3055 "Scans the buffer for hard-to-parse Perl constructions.
2730If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify 3056If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify
@@ -2735,8 +3061,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
2735 cperl-syntax-state nil 3061 cperl-syntax-state nil
2736 cperl-syntax-done-to min)) 3062 cperl-syntax-done-to min))
2737 (or max (setq max (point-max))) 3063 (or max (setq max (point-max)))
2738 (let* (face head-face here-face b e bb tag qtag b1 e1 argument i c tail 3064 (let* (face head-face here-face b e bb tag qtag b1 e1 argument i c tail tb
2739 (cperl-pod-here-fontify (eval cperl-pod-here-fontify)) go 3065 (cperl-pod-here-fontify (eval cperl-pod-here-fontify)) go tmpend
2740 (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t) 3066 (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t)
2741 (modified (buffer-modified-p)) 3067 (modified (buffer-modified-p))
2742 (after-change-functions nil) 3068 (after-change-functions nil)
@@ -2752,6 +3078,17 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
2752 (font-lock-string-face (if (boundp 'font-lock-string-face) 3078 (font-lock-string-face (if (boundp 'font-lock-string-face)
2753 font-lock-string-face 3079 font-lock-string-face
2754 'font-lock-string-face)) 3080 'font-lock-string-face))
3081 (font-lock-constant-face (if (boundp 'font-lock-constant-face)
3082 font-lock-constant-face
3083 'font-lock-constant-face))
3084 (font-lock-function-name-face
3085 (if (boundp 'font-lock-function-name-face)
3086 font-lock-function-name-face
3087 'font-lock-function-name-face))
3088 (cperl-nonoverridable-face
3089 (if (boundp 'cperl-nonoverridable-face)
3090 cperl-nonoverridable-face
3091 'cperl-nonoverridable-face))
2755 (stop-point (if ignore-max 3092 (stop-point (if ignore-max
2756 (point-max) 3093 (point-max)
2757 max)) 3094 max))
@@ -2761,16 +3098,17 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
2761 "\\|" 3098 "\\|"
2762 ;; One extra () before this: 3099 ;; One extra () before this:
2763 "<<" 3100 "<<"
2764 "\\(" 3101 "\\(" ; 1 + 1
2765 ;; First variant "BLAH" or just ``. 3102 ;; First variant "BLAH" or just ``.
2766 "\\([\"'`]\\)" 3103 "\\([\"'`]\\)" ; 2 + 1
2767 "\\([^\"'`\n]*\\)" 3104 "\\([^\"'`\n]*\\)" ; 3 + 1
2768 "\\3" 3105 "\\3"
2769 "\\|" 3106 "\\|"
2770 ;; Second variant: Identifier or empty 3107 ;; Second variant: Identifier or \ID or empty
2771 "\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" 3108 "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1
2772 ;; Check that we do not have <<= or << 30 or << $blah. 3109 ;; Do not have <<= or << 30 or <<30 or << $blah.
2773 "\\([^= \t$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" 3110 ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1
3111 "\\(\\)" ; To preserve count of pars :-( 6 + 1
2774 "\\)" 3112 "\\)"
2775 "\\|" 3113 "\\|"
2776 ;; 1+6 extra () before this: 3114 ;; 1+6 extra () before this:
@@ -2779,10 +3117,10 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
2779 (concat 3117 (concat
2780 "\\|" 3118 "\\|"
2781 ;; 1+6+2=9 extra () before this: 3119 ;; 1+6+2=9 extra () before this:
2782 "\\<\\(q[wxq]?\\|[msy]\\|tr\\)\\>" 3120 "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>"
2783 "\\|" 3121 "\\|"
2784 ;; 1+6+2+1=10 extra () before this: 3122 ;; 1+6+2+1=10 extra () before this:
2785 "\\([?/]\\)" ; /blah/ or ?blah? 3123 "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob>
2786 "\\|" 3124 "\\|"
2787 ;; 1+6+2+1+1=11 extra () before this: 3125 ;; 1+6+2+1+1=11 extra () before this:
2788 "\\<sub\\>[ \t]*\\([a-zA-Z_:'0-9]+[ \t]*\\)?\\(([^()]*)\\)" 3126 "\\<sub\\>[ \t]*\\([a-zA-Z_:'0-9]+[ \t]*\\)?\\(([^()]*)\\)"
@@ -2808,7 +3146,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
2808 head-face cperl-pod-head-face 3146 head-face cperl-pod-head-face
2809 here-face cperl-here-face)) 3147 here-face cperl-here-face))
2810 (remove-text-properties min max 3148 (remove-text-properties min max
2811 '(syntax-type t in-pod t syntax-table t)) 3149 '(syntax-type t in-pod t syntax-table t
3150 cperl-postpone t))
2812 ;; Need to remove face as well... 3151 ;; Need to remove face as well...
2813 (goto-char min) 3152 (goto-char min)
2814 (and (eq system-type 'emx) 3153 (and (eq system-type 'emx)
@@ -2819,70 +3158,110 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
2819 (while (and 3158 (while (and
2820 (< (point) max) 3159 (< (point) max)
2821 (re-search-forward search max t)) 3160 (re-search-forward search max t))
3161 (setq tmpend nil) ; Valid for most cases
2822 (cond 3162 (cond
2823 ((match-beginning 1) ; POD section 3163 ((match-beginning 1) ; POD section
2824 ;; "\\(\\`\n?\\|\n\n\\)=" 3164 ;; "\\(\\`\n?\\|\n\n\\)="
2825 (if (looking-at "\n*cut\\>") 3165 (if (looking-at "\n*cut\\>")
2826 (progn 3166 (if ignore-max
3167 nil ; Doing a chunk only
2827 (message "=cut is not preceded by a POD section") 3168 (message "=cut is not preceded by a POD section")
2828 (or (car err-l) (setcar err-l (point)))) 3169 (or (car err-l) (setcar err-l (point))))
2829 (beginning-of-line) 3170 (beginning-of-line)
2830 3171
2831 (setq b (point) bb b) 3172 (setq b (point)
3173 bb b
3174 tb (match-beginning 0)
3175 b1 nil) ; error condition
2832 ;; We do not search to max, since we may be called from 3176 ;; We do not search to max, since we may be called from
2833 ;; some hook of fontification, and max is random 3177 ;; some hook of fontification, and max is random
2834 (or (re-search-forward "\n\n=cut\\>" stop-point 'toend) 3178 (or (re-search-forward "\n\n=cut\\>" stop-point 'toend)
2835 (progn 3179 (progn
2836 (message "End of a POD section not marked by =cut") 3180 (message "End of a POD section not marked by =cut")
3181 (setq b1 t)
2837 (or (car err-l) (setcar err-l b)))) 3182 (or (car err-l) (setcar err-l b))))
2838 (beginning-of-line 2) ; An empty line after =cut is not POD! 3183 (beginning-of-line 2) ; An empty line after =cut is not POD!
2839 (setq e (point)) 3184 (setq e (point))
3185 (if (and b1 (eobp))
3186 ;; Unrecoverable error
3187 nil
2840 (and (> e max) 3188 (and (> e max)
2841 (remove-text-properties max e 3189 (progn
2842 '(syntax-type t in-pod t syntax-table t))) 3190 (remove-text-properties
3191 max e '(syntax-type t in-pod t syntax-table t
3192 'cperl-postpone t))
3193 (setq tmpend tb)))
2843 (put-text-property b e 'in-pod t) 3194 (put-text-property b e 'in-pod t)
3195 (put-text-property b e 'syntax-type 'in-pod)
2844 (goto-char b) 3196 (goto-char b)
2845 (while (re-search-forward "\n\n[ \t]" e t) 3197 (while (re-search-forward "\n\n[ \t]" e t)
2846 ;; We start 'pod 1 char earlier to include the preceding line 3198 ;; We start 'pod 1 char earlier to include the preceding line
2847 (beginning-of-line) 3199 (beginning-of-line)
2848 (put-text-property (cperl-1- b) (point) 'syntax-type 'pod) 3200 (put-text-property (cperl-1- b) (point) 'syntax-type 'pod)
2849 (cperl-put-do-not-fontify b (point)) 3201 (cperl-put-do-not-fontify b (point) t)
2850 (if cperl-pod-here-fontify (put-text-property b (point) 'face face)) 3202 ;; mark the non-literal parts as PODs
3203 (if cperl-pod-here-fontify
3204 (cperl-postpone-fontification b (point) 'face face t))
2851 (re-search-forward "\n\n[^ \t\f\n]" e 'toend) 3205 (re-search-forward "\n\n[^ \t\f\n]" e 'toend)
2852 (beginning-of-line) 3206 (beginning-of-line)
2853 (setq b (point))) 3207 (setq b (point)))
2854 (put-text-property (cperl-1- (point)) e 'syntax-type 'pod) 3208 (put-text-property (cperl-1- (point)) e 'syntax-type 'pod)
2855 (cperl-put-do-not-fontify (point) e) 3209 (cperl-put-do-not-fontify (point) e t)
2856 (if cperl-pod-here-fontify 3210 (if cperl-pod-here-fontify
2857 (progn (put-text-property (point) e 'face face) 3211 (progn
3212 ;; mark the non-literal parts as PODs
3213 (cperl-postpone-fontification (point) e 'face face t)
2858 (goto-char bb) 3214 (goto-char bb)
2859 (if (looking-at 3215 (if (looking-at
2860 "=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$") 3216 "=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$")
2861 (put-text-property 3217 ;; mark the headers
3218 (cperl-postpone-fontification
2862 (match-beginning 1) (match-end 1) 3219 (match-beginning 1) (match-end 1)
2863 'face head-face)) 3220 'face head-face))
2864 (while (re-search-forward 3221 (while (re-search-forward
2865 ;; One paragraph 3222 ;; One paragraph
2866 "\n\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$" 3223 "\n\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$"
2867 e 'toend) 3224 e 'toend)
2868 (put-text-property 3225 ;; mark the headers
3226 (cperl-postpone-fontification
2869 (match-beginning 1) (match-end 1) 3227 (match-beginning 1) (match-end 1)
2870 'face head-face)))) 3228 'face head-face))))
2871 (cperl-commentify bb e nil) 3229 (cperl-commentify bb e nil)
2872 (goto-char e) 3230 (goto-char e)
2873 (or (eq e (point-max)) 3231 (or (eq e (point-max))
2874 (forward-char -1)))) ; Prepare for immediate pod start. 3232 (forward-char -1))))) ; Prepare for immediate pod start.
2875 ;; Here document 3233 ;; Here document
2876 ;; We do only one here-per-line 3234 ;; We do only one here-per-line
2877 ;; 1 () ahead 3235 ;; ;; One extra () before this:
2878 ;; "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\3\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)\\)" 3236 ;;"<<"
3237 ;; "\\(" ; 1 + 1
3238 ;; ;; First variant "BLAH" or just ``.
3239 ;; "\\([\"'`]\\)" ; 2 + 1
3240 ;; "\\([^\"'`\n]*\\)" ; 3 + 1
3241 ;; "\\3"
3242 ;; "\\|"
3243 ;; ;; Second variant: Identifier or \ID or empty
3244 ;; "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1
3245 ;; ;; Do not have <<= or << 30 or <<30 or << $blah.
3246 ;; ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1
3247 ;; "\\(\\)" ; To preserve count of pars :-( 6 + 1
3248 ;; "\\)"
2879 ((match-beginning 2) ; 1 + 1 3249 ((match-beginning 2) ; 1 + 1
2880 ;; Abort in comment: 3250 ;; Abort in comment:
2881 (setq b (point)) 3251 (setq b (point))
2882 (setq state (parse-partial-sexp state-point b nil nil state) 3252 (setq state (parse-partial-sexp state-point b nil nil state)
2883 state-point b) 3253 state-point b
2884 (if (or (nth 3 state) (nth 4 state)) 3254 tb (match-beginning 0)
2885 (goto-char (match-end 2)) 3255 i (or (nth 3 state) (nth 4 state)))
3256 (if i
3257 (setq c t)
3258 (setq c (and
3259 (match-beginning 5)
3260 (not (match-beginning 6)) ; Empty
3261 (looking-at
3262 "[ \t]*[=0-9$@%&(]"))))
3263 (if c ; Not here-doc
3264 nil ; Skip it.
2886 (if (match-beginning 5) ;4 + 1 3265 (if (match-beginning 5) ;4 + 1
2887 (setq b1 (match-beginning 5) ; 4 + 1 3266 (setq b1 (match-beginning 5) ; 4 + 1
2888 e1 (match-end 5)) ; 4 + 1 3267 e1 (match-end 5)) ; 4 + 1
@@ -2891,8 +3270,9 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
2891 (setq tag (buffer-substring b1 e1) 3270 (setq tag (buffer-substring b1 e1)
2892 qtag (regexp-quote tag)) 3271 qtag (regexp-quote tag))
2893 (cond (cperl-pod-here-fontify 3272 (cond (cperl-pod-here-fontify
2894 (put-text-property b1 e1 'face font-lock-constant-face) 3273 ;; Highlight the starting delimiter
2895 (cperl-put-do-not-fontify b1 e1))) 3274 (cperl-postpone-fontification b1 e1 'face font-lock-constant-face)
3275 (cperl-put-do-not-fontify b1 e1 t)))
2896 (forward-line) 3276 (forward-line)
2897 (setq b (point)) 3277 (setq b (point))
2898 ;; We do not search to max, since we may be called from 3278 ;; We do not search to max, since we may be called from
@@ -2901,10 +3281,12 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
2901 stop-point 'toend) 3281 stop-point 'toend)
2902 (if cperl-pod-here-fontify 3282 (if cperl-pod-here-fontify
2903 (progn 3283 (progn
2904 (put-text-property (match-beginning 0) (match-end 0) 3284 ;; Highlight the ending delimiter
3285 (cperl-postpone-fontification (match-beginning 0) (match-end 0)
2905 'face font-lock-constant-face) 3286 'face font-lock-constant-face)
2906 (cperl-put-do-not-fontify b (match-end 0)) 3287 (cperl-put-do-not-fontify b (match-end 0) t)
2907 (put-text-property b (match-beginning 0) 3288 ;; Highlight the HERE-DOC
3289 (cperl-postpone-fontification b (match-beginning 0)
2908 'face here-face))) 3290 'face here-face)))
2909 (setq e1 (cperl-1+ (match-end 0))) 3291 (setq e1 (cperl-1+ (match-end 0)))
2910 (put-text-property b (match-beginning 0) 3292 (put-text-property b (match-beginning 0)
@@ -2914,7 +3296,9 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
2914 (put-text-property b e1 3296 (put-text-property b e1
2915 'here-doc-group t) 3297 'here-doc-group t)
2916 (cperl-commentify b e1 nil) 3298 (cperl-commentify b e1 nil)
2917 (cperl-put-do-not-fontify b (match-end 0))) 3299 (cperl-put-do-not-fontify b (match-end 0) t)
3300 (if (> e1 max)
3301 (setq tmpend tb)))
2918 (t (message "End of here-document `%s' not found." tag) 3302 (t (message "End of here-document `%s' not found." tag)
2919 (or (car err-l) (setcar err-l b)))))) 3303 (or (car err-l) (setcar err-l b))))))
2920 ;; format 3304 ;; format
@@ -2925,7 +3309,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
2925 name (if (match-beginning 8) ; 7 + 1 3309 name (if (match-beginning 8) ; 7 + 1
2926 (buffer-substring (match-beginning 8) ; 7 + 1 3310 (buffer-substring (match-beginning 8) ; 7 + 1
2927 (match-end 8)) ; 7 + 1 3311 (match-end 8)) ; 7 + 1
2928 "")) 3312 "")
3313 tb (match-beginning 0))
2929 (setq argument nil) 3314 (setq argument nil)
2930 (if cperl-pod-here-fontify 3315 (if cperl-pod-here-fontify
2931 (while (and (eq (forward-line) 0) 3316 (while (and (eq (forward-line) 0)
@@ -2942,30 +3327,34 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
2942 (setq b1 (point)) 3327 (setq b1 (point))
2943 (setq argument (looking-at "^[^\n]*[@^]")) 3328 (setq argument (looking-at "^[^\n]*[@^]"))
2944 (end-of-line) 3329 (end-of-line)
2945 (put-text-property b1 (point) 3330 ;; Highlight the format line
3331 (cperl-postpone-fontification b1 (point)
2946 'face font-lock-string-face) 3332 'face font-lock-string-face)
2947 (cperl-commentify b1 (point) nil) 3333 (cperl-commentify b1 (point) nil)
2948 (cperl-put-do-not-fontify b1 (point))))) 3334 (cperl-put-do-not-fontify b1 (point) t))))
2949 ;; We do not search to max, since we may be called from 3335 ;; We do not search to max, since we may be called from
2950 ;; some hook of fontification, and max is random 3336 ;; some hook of fontification, and max is random
2951 (re-search-forward "^[.;]$" stop-point 'toend)) 3337 (re-search-forward "^[.;]$" stop-point 'toend))
2952 (beginning-of-line) 3338 (beginning-of-line)
2953 (if (looking-at "^[.;]$") 3339 (if (looking-at "^\\.$") ; ";" is not supported yet
2954 (progn 3340 (progn
2955 (put-text-property (point) (+ (point) 2) 3341 ;; Highlight the ending delimiter
3342 (cperl-postpone-fontification (point) (+ (point) 2)
2956 'face font-lock-string-face) 3343 'face font-lock-string-face)
2957 (cperl-commentify (point) (+ (point) 2) nil) 3344 (cperl-commentify (point) (+ (point) 2) nil)
2958 (cperl-put-do-not-fontify (point) (+ (point) 2))) 3345 (cperl-put-do-not-fontify (point) (+ (point) 2) t))
2959 (message "End of format `%s' not found." name) 3346 (message "End of format `%s' not found." name)
2960 (or (car err-l) (setcar err-l b))) 3347 (or (car err-l) (setcar err-l b)))
2961 (forward-line) 3348 (forward-line)
3349 (if (> (point) max)
3350 (setq tmpend tb))
2962 (put-text-property b (point) 'syntax-type 'format)) 3351 (put-text-property b (point) 'syntax-type 'format))
2963 ;; Regexp: 3352 ;; Regexp:
2964 ((or (match-beginning 10) (match-beginning 11)) 3353 ((or (match-beginning 10) (match-beginning 11))
2965 ;; 1+6+2=9 extra () before this: 3354 ;; 1+6+2=9 extra () before this:
2966 ;; "\\<\\(q[wxq]?\\|[msy]\\|tr\\)\\>" 3355 ;; "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>"
2967 ;; "\\|" 3356 ;; "\\|"
2968 ;; "\\([?/]\\)" ; /blah/ or ?blah? 3357 ;; "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob>
2969 (setq b1 (if (match-beginning 10) 10 11) 3358 (setq b1 (if (match-beginning 10) 10 11)
2970 argument (buffer-substring 3359 argument (buffer-substring
2971 (match-beginning b1) (match-end b1)) 3360 (match-beginning b1) (match-end b1))
@@ -2973,19 +3362,26 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
2973 i b 3362 i b
2974 c (char-after (match-beginning b1)) 3363 c (char-after (match-beginning b1))
2975 bb (char-after (1- (match-beginning b1))) ; tmp holder 3364 bb (char-after (1- (match-beginning b1))) ; tmp holder
2976 bb (and ; user variables/whatever 3365 ;; bb == "Not a stringy"
2977 (match-beginning 10) 3366 bb (if (eq b1 10) ; user variables/whatever
2978 (or 3367 (or
2979 (memq bb '(?\$ ?\@ ?\% ?\* ?\#)) ; $#y 3368 (memq bb '(?\$ ?\@ ?\% ?\* ?\#)) ; $#y
2980 (and (eq bb ?-) (eq c ?s)) ; -s file test 3369 (and (eq bb ?-) (eq c ?s)) ; -s file test
2981 (and (eq bb ?\&) ; &&m/blah/ 3370 (and (eq bb ?\&) ; &&m/blah/
2982 (not (eq (char-after 3371 (not (eq (char-after
2983 (- (match-beginning b1) 2)) 3372 (- (match-beginning b1) 2))
2984 ?\&)))))) 3373 ?\&))))
3374 ;; <file> or <$file>
3375 (and (eq c ?\<)
3376 ;; Do not stringify <FH> :
3377 (save-match-data
3378 (looking-at
3379 "\\s *\\$?\\([_a-zA-Z:][_a-zA-Z0-9:]*\\s *\\)?>"))))
3380 tb (match-beginning 0))
2985 (goto-char (match-beginning b1)) 3381 (goto-char (match-beginning b1))
2986 (cperl-backward-to-noncomment (point-min)) 3382 (cperl-backward-to-noncomment (point-min))
2987 (or bb 3383 (or bb
2988 (if (eq b1 11) ; bare /blah/ or ?blah? 3384 (if (eq b1 11) ; bare /blah/ or ?blah? or <foo>
2989 (setq argument "" 3385 (setq argument ""
2990 bb ; Not a regexp? 3386 bb ; Not a regexp?
2991 (progn 3387 (progn
@@ -2993,10 +3389,10 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
2993 ;; What is below: regexp-p? 3389 ;; What is below: regexp-p?
2994 (and 3390 (and
2995 (or (memq (preceding-char) 3391 (or (memq (preceding-char)
2996 (append (if (eq c ?\?) 3392 (append (if (memq c '(?\? ?\<))
2997 ;; $a++ ? 1 : 2 3393 ;; $a++ ? 1 : 2
2998 "~{(=|&*!,;" 3394 "~{(=|&*!,;:"
2999 "~{(=|&+-*!,;") nil)) 3395 "~{(=|&+-*!,;:") nil))
3000 (and (eq (preceding-char) ?\}) 3396 (and (eq (preceding-char) ?\})
3001 (cperl-after-block-p (point-min))) 3397 (cperl-after-block-p (point-min)))
3002 (and (eq (char-syntax (preceding-char)) ?w) 3398 (and (eq (char-syntax (preceding-char)) ?w)
@@ -3004,8 +3400,11 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3004 (forward-sexp -1) 3400 (forward-sexp -1)
3005;;; After these keywords `/' starts a RE. One should add all the 3401;;; After these keywords `/' starts a RE. One should add all the
3006;;; functions/builtins which expect an argument, but ... 3402;;; functions/builtins which expect an argument, but ...
3403 (if (eq (preceding-char) ?-)
3404 ;; -d ?foo? is a RE
3405 (looking-at "[a-zA-Z]\\>")
3007 (looking-at 3406 (looking-at
3008 "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>"))) 3407 "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>"))))
3009 (and (eq (preceding-char) ?.) 3408 (and (eq (preceding-char) ?.)
3010 (eq (char-after (- (point) 2)) ?.)) 3409 (eq (char-after (- (point) 2)) ?.))
3011 (bobp)) 3410 (bobp))
@@ -3037,53 +3436,106 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3037 ;; 2 or 3 later if some special quoting is needed. 3436 ;; 2 or 3 later if some special quoting is needed.
3038 ;; e1 means matching-char matcher. 3437 ;; e1 means matching-char matcher.
3039 (setq b (point) 3438 (setq b (point)
3439 ;; has 2 args
3440 i2 (string-match "^\\([sy]\\|tr\\)$" argument)
3040 ;; We do not search to max, since we may be called from 3441 ;; We do not search to max, since we may be called from
3041 ;; some hook of fontification, and max is random 3442 ;; some hook of fontification, and max is random
3042 i (cperl-forward-re stop-point end 3443 i (cperl-forward-re stop-point end
3043 (string-match "^\\([sy]\\|tr\\)$" argument) 3444 i2
3044 t st-l err-l argument) 3445 t st-l err-l argument)
3045 i2 (nth 1 i) ; start of the second part 3446 ;; Note that if `go', then it is considered as 1-arg
3046 e1 (nth 2 i) ; ender, true if matching second part 3447 b1 (nth 1 i) ; start of the second part
3448 tag (nth 2 i) ; ender-char, true if second part
3449 ; is with matching chars []
3047 go (nth 4 i) ; There is a 1-char part after the end 3450 go (nth 4 i) ; There is a 1-char part after the end
3048 i (car i) ; intermediate point 3451 i (car i) ; intermediate point
3049 tail (if (and i (not e1)) (1- (point))) 3452 e1 (point) ; end
3050 e nil) ; need to preserve backslashitis 3453 ;; Before end of the second part if non-matching: ///
3454 tail (if (and i (not tag))
3455 (1- e1))
3456 e (if i i e1) ; end of the first part
3457 qtag nil) ; need to preserve backslashitis
3051 ;; Commenting \\ is dangerous, what about ( ? 3458 ;; Commenting \\ is dangerous, what about ( ?
3052 (and i tail 3459 (and i tail
3053 (eq (char-after i) ?\\) 3460 (eq (char-after i) ?\\)
3054 (setq e t)) 3461 (setq qtag t))
3055 (if (null i) 3462 (if (null i)
3463 ;; Considered as 1arg form
3056 (progn 3464 (progn
3057 (cperl-commentify b (point) t) 3465 (cperl-commentify b (point) t)
3058 (if go (forward-char 1))) 3466 (put-text-property b (point) 'syntax-type 'string)
3467 (and go
3468 (setq e1 (cperl-1+ e1))
3469 (or (eobp)
3470 (forward-char 1))))
3059 (cperl-commentify b i t) 3471 (cperl-commentify b i t)
3060 (if (looking-at "\\sw*e") ; s///e 3472 (if (looking-at "\\sw*e") ; s///e
3061 (progn 3473 (progn
3062 (and 3474 (and
3063 ;; silent: 3475 ;; silent:
3064 (cperl-find-pods-heres i2 (1- (point)) t end) 3476 (cperl-find-pods-heres b1 (1- (point)) t end)
3065 ;; Error 3477 ;; Error
3066 (goto-char (1+ max))) 3478 (goto-char (1+ max)))
3067 (if (and e1 (eq (preceding-char) ?\>)) 3479 (if (and tag (eq (preceding-char) ?\>))
3068 (progn 3480 (progn
3069 (cperl-modify-syntax-type (1- (point)) cperl-st-ket) 3481 (cperl-modify-syntax-type (1- (point)) cperl-st-ket)
3070 (cperl-modify-syntax-type i cperl-st-bra)))) 3482 (cperl-modify-syntax-type i cperl-st-bra)))
3071 (cperl-commentify i2 (point) t) 3483 (put-text-property b i 'syntax-type 'string))
3072 (if e 3484 (cperl-commentify b1 (point) t)
3485 (put-text-property b (point) 'syntax-type 'string)
3486 (if qtag
3073 (cperl-modify-syntax-type (1+ i) cperl-st-punct)) 3487 (cperl-modify-syntax-type (1+ i) cperl-st-punct))
3074 (setq tail nil))) 3488 (setq tail nil)))
3489 ;; Now: tail: if the second part is non-matching without ///e
3075 (if (eq (char-syntax (following-char)) ?w) 3490 (if (eq (char-syntax (following-char)) ?w)
3076 (progn 3491 (progn
3077 (forward-word 1) ; skip modifiers s///s 3492 (forward-word 1) ; skip modifiers s///s
3078 (if tail (cperl-commentify tail (point) t)))))) 3493 (if tail (cperl-commentify tail (point) t))
3494 (cperl-postpone-fontification
3495 e1 (point) 'face cperl-nonoverridable-face)))
3496 ;; Check whether it is m// which means "previous match"
3497 ;; and highlight differently
3498 (if (and (eq e (+ 2 b))
3499 (string-match "^\\([sm]?\\|qr\\)$" argument)
3500 ;; <> is already filtered out
3501 ;; split // *is* using zero-pattern
3502 (save-excursion
3503 (condition-case nil
3504 (progn
3505 (goto-char tb)
3506 (forward-sexp -1)
3507 (not (looking-at "split\\>")))
3508 (error t))))
3509 (cperl-postpone-fontification
3510 b e 'face font-lock-function-name-face)
3511 (if (or i2 ; Has 2 args
3512 (and cperl-fontify-m-as-s
3513 (or
3514 (string-match "^\\(m\\|qr\\)$" argument)
3515 (and (eq 0 (length argument))
3516 (not (eq ?\< (char-after b)))))))
3517 (progn
3518 (cperl-postpone-fontification
3519 b (cperl-1+ b) 'face font-lock-constant-face)
3520 (cperl-postpone-fontification
3521 (1- e) e 'face font-lock-constant-face))))
3522 (if i2
3523 (progn
3524 (cperl-postpone-fontification
3525 (1- e1) e1 'face font-lock-constant-face)
3526 (if (assoc (char-after b) cperl-starters)
3527 (cperl-postpone-fontification
3528 b1 (1+ b1) 'face font-lock-constant-face))))
3529 (if (> (point) max)
3530 (setq tmpend tb))))
3079 ((match-beginning 13) ; sub with prototypes 3531 ((match-beginning 13) ; sub with prototypes
3080 (setq b (match-beginning 0)) 3532 (setq b (match-beginning 0))
3081 (if (memq (char-after (1- b)) 3533 (if (memq (char-after (1- b))
3082 '(?\$ ?\@ ?\% ?\& ?\*)) 3534 '(?\$ ?\@ ?\% ?\& ?\*))
3083 nil 3535 nil
3084 (setq state (parse-partial-sexp 3536 (setq state (parse-partial-sexp
3085 state-point (1- b) nil nil state) 3537 state-point b nil nil state)
3086 state-point (1- b)) 3538 state-point b)
3087 (if (or (nth 3 state) (nth 4 state)) 3539 (if (or (nth 3 state) (nth 4 state))
3088 nil 3540 nil
3089 ;; Mark as string 3541 ;; Mark as string
@@ -3139,7 +3591,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3139 (or (car err-l) (setcar err-l b))) 3591 (or (car err-l) (setcar err-l b)))
3140 (goto-char stop-point)))) 3592 (goto-char stop-point))))
3141 (setq cperl-syntax-state (cons state-point state) 3593 (setq cperl-syntax-state (cons state-point state)
3142 cperl-syntax-done-to (max (point) max))) 3594 cperl-syntax-done-to (or tmpend (max (point) max))))
3143 (if (car err-l) (goto-char (car err-l)) 3595 (if (car err-l) (goto-char (car err-l))
3144 (or non-inter 3596 (or non-inter
3145 (message "Scanning for \"hard\" Perl constructions... done")))) 3597 (message "Scanning for \"hard\" Perl constructions... done"))))
@@ -3151,18 +3603,21 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3151 3603
3152(defun cperl-backward-to-noncomment (lim) 3604(defun cperl-backward-to-noncomment (lim)
3153 ;; Stops at lim or after non-whitespace that is not in comment 3605 ;; Stops at lim or after non-whitespace that is not in comment
3154 (let (stop p) 3606 (let (stop p pr)
3155 (while (and (not stop) (> (point) (or lim 1))) 3607 (while (and (not stop) (> (point) (or lim 1)))
3156 (skip-chars-backward " \t\n\f" lim) 3608 (skip-chars-backward " \t\n\f" lim)
3157 (setq p (point)) 3609 (setq p (point))
3158 (beginning-of-line) 3610 (beginning-of-line)
3611 (if (memq (setq pr (get-text-property (point) 'syntax-type))
3612 '(pod here-doc here-doc-delim))
3613 (cperl-unwind-to-safe nil)
3159 (if (or (looking-at "^[ \t]*\\(#\\|$\\)") 3614 (if (or (looking-at "^[ \t]*\\(#\\|$\\)")
3160 (progn (cperl-to-comment-or-eol) (bolp))) 3615 (progn (cperl-to-comment-or-eol) (bolp)))
3161 nil ; Only comment, skip 3616 nil ; Only comment, skip
3162 ;; Else 3617 ;; Else
3163 (skip-chars-backward " \t") 3618 (skip-chars-backward " \t")
3164 (if (< p (point)) (goto-char p)) 3619 (if (< p (point)) (goto-char p))
3165 (setq stop t))))) 3620 (setq stop t))))))
3166 3621
3167(defun cperl-after-block-p (lim) 3622(defun cperl-after-block-p (lim)
3168 ;; We suppose that the preceding char is }. 3623 ;; We suppose that the preceding char is }.
@@ -3176,7 +3631,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3176 (if (eq (char-syntax (preceding-char)) ?w) ; else {} 3631 (if (eq (char-syntax (preceding-char)) ?w) ; else {}
3177 (save-excursion 3632 (save-excursion
3178 (forward-sexp -1) 3633 (forward-sexp -1)
3179 (or (looking-at "\\(else\\|grep\\|map\\)\\>") 3634 (or (looking-at "\\(else\\|grep\\|map\\|BEGIN\\|END\\)\\>")
3180 ;; sub f {} 3635 ;; sub f {}
3181 (progn 3636 (progn
3182 (cperl-backward-to-noncomment lim) 3637 (cperl-backward-to-noncomment lim)
@@ -3200,11 +3655,19 @@ CHARS is a string that contains good characters to have before us (however,
3200 (setq p (point)) 3655 (setq p (point))
3201 (beginning-of-line) 3656 (beginning-of-line)
3202 (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip 3657 (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip
3203 ;; Else: last iteration (What to do with labels?) 3658 ;; Else: last iteration, or a label
3204 (cperl-to-comment-or-eol) 3659 (cperl-to-comment-or-eol)
3205 (skip-chars-backward " \t") 3660 (skip-chars-backward " \t")
3206 (if (< p (point)) (goto-char p)) 3661 (if (< p (point)) (goto-char p))
3207 (setq stop t))) 3662 (setq p (point))
3663 (if (and (eq (preceding-char) ?:)
3664 (progn
3665 (forward-char -1)
3666 (skip-chars-backward " \t\n\f" lim)
3667 (eq (char-syntax (preceding-char)) ?w)))
3668 (forward-sexp -1) ; Possibly label. Skip it
3669 (goto-char p)
3670 (setq stop t))))
3208 (or (bobp) ; ???? Needed 3671 (or (bobp) ; ???? Needed
3209 (eq (point) lim) 3672 (eq (point) lim)
3210 (progn 3673 (progn
@@ -3243,8 +3706,9 @@ CHARS is a string that contains good characters to have before us (however,
3243 3706
3244(defun cperl-indent-exp () 3707(defun cperl-indent-exp ()
3245 "Simple variant of indentation of continued-sexp. 3708 "Simple variant of indentation of continued-sexp.
3246Should be slow. Will not indent comment if it starts at `comment-indent' 3709
3247or looks like continuation of the comment on the previous line. 3710Will not indent comment if it starts at `comment-indent' or looks like
3711continuation of the comment on the previous line.
3248 3712
3249If `cperl-indent-region-fix-constructs', will improve spacing on 3713If `cperl-indent-region-fix-constructs', will improve spacing on
3250conditional/loop constructs." 3714conditional/loop constructs."
@@ -3262,7 +3726,10 @@ conditional/loop constructs."
3262 (while (< (point) tmp-end) 3726 (while (< (point) tmp-end)
3263 (parse-partial-sexp (point) tmp-end nil t) ; To start-sexp or eol 3727 (parse-partial-sexp (point) tmp-end nil t) ; To start-sexp or eol
3264 (or (eolp) (forward-sexp 1))) 3728 (or (eolp) (forward-sexp 1)))
3265 (if (> (point) tmp-end) (progn (end-of-line) (setq tmp-end (point))) 3729 (if (> (point) tmp-end)
3730 (save-excursion
3731 (end-of-line)
3732 (setq tmp-end (point)))
3266 (setq done t))) 3733 (setq done t)))
3267 (goto-char tmp-end) 3734 (goto-char tmp-end)
3268 (setq tmp-end (point-marker))) 3735 (setq tmp-end (point-marker)))
@@ -3270,16 +3737,25 @@ conditional/loop constructs."
3270 (cperl-fix-line-spacing tmp-end)) 3737 (cperl-fix-line-spacing tmp-end))
3271 (cperl-indent-region (point) tmp-end)))) 3738 (cperl-indent-region (point) tmp-end))))
3272 3739
3273(defun cperl-fix-line-spacing (&optional end) 3740(defun cperl-fix-line-spacing (&optional end parse-data)
3274 "Improve whitespace in a conditional/loop construct." 3741 "Improve whitespace in a conditional/loop construct.
3742Returns some position at the last line."
3275 (interactive) 3743 (interactive)
3276 (or end 3744 (or end
3277 (setq end (point-max))) 3745 (setq end (point-max)))
3278 (let (p pp ml 3746 (let (p pp ml have-brace ret
3747 (ee (save-excursion (end-of-line) (point)))
3279 (cperl-indent-region-fix-constructs 3748 (cperl-indent-region-fix-constructs
3280 (or cperl-indent-region-fix-constructs 1))) 3749 (or cperl-indent-region-fix-constructs 1)))
3281 (save-excursion 3750 (save-excursion
3282 (beginning-of-line) 3751 (beginning-of-line)
3752 (setq ret (point))
3753 ;; }? continue
3754 ;; blah; }
3755 (if (not
3756 (or (looking-at "[ \t]*\\(els\\(e\\|if\\)\\|continue\\|if\\|while\\|for\\(each\\)?\\|until\\)")
3757 (setq have-brace (save-excursion (search-forward "}" ee t)))))
3758 nil ; Do not need to do anything
3283 ;; Looking at: 3759 ;; Looking at:
3284 ;; } 3760 ;; }
3285 ;; else 3761 ;; else
@@ -3304,7 +3780,7 @@ conditional/loop constructs."
3304 ;; Looking at: 3780 ;; Looking at:
3305 ;; else { 3781 ;; else {
3306 (if (looking-at 3782 (if (looking-at
3307 "[ \t]*}?[ \t]*\\<\\(\\els\\(e\\|if\\)\\|continue\\|if\\|while\\|for\\(each\\)?\\|until\\)\\>\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]") 3783 "[ \t]*}?[ \t]*\\<\\(\\els\\(e\\|if\\)\\|continue\\|unless\\|if\\|while\\|for\\(each\\)?\\|until\\)\\>\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]")
3308 (progn 3784 (progn
3309 (forward-word 1) 3785 (forward-word 1)
3310 (delete-horizontal-space) 3786 (delete-horizontal-space)
@@ -3332,7 +3808,7 @@ conditional/loop constructs."
3332 ;; Looking at: 3808 ;; Looking at:
3333 ;; } foreach my $var () { 3809 ;; } foreach my $var () {
3334 (if (looking-at 3810 (if (looking-at
3335 "[ \t]*\\(}[ \t]*\\)?\\<\\(\\els\\(e\\|if\\)\\|continue\\|if\\|while\\|for\\(each\\)?\\(\\([ t]+\\(my\\|local\\)\\)?[ \t]*\\$[_a-zA-Z0-9]+\\)?\\|until\\)\\>\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{") 3811 "[ \t]*\\(}[ \t]*\\)?\\<\\(\\els\\(e\\|if\\)\\|continue\\|if\\|unless\\|while\\|for\\(each\\)?\\(\\([ t]+\\(my\\|local\\)\\)?[ \t]*\\$[_a-zA-Z0-9]+\\)?\\|until\\)\\>\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{")
3336 (progn 3812 (progn
3337 (setq ml (match-beginning 8)) 3813 (setq ml (match-beginning 8))
3338 (re-search-forward "[({]") 3814 (re-search-forward "[({]")
@@ -3365,8 +3841,11 @@ conditional/loop constructs."
3365 (progn 3841 (progn
3366 (delete-horizontal-space) 3842 (delete-horizontal-space)
3367 (insert "\n") 3843 (insert "\n")
3368 (if (cperl-indent-line) 3844 (setq ret (point))
3369 (cperl-fix-line-spacing end))) 3845 (if (cperl-indent-line parse-data)
3846 (progn
3847 (cperl-fix-line-spacing end parse-data)
3848 (setq ret (point)))))
3370 (insert 3849 (insert
3371 (make-string cperl-indent-region-fix-constructs ?\ )))) 3850 (make-string cperl-indent-region-fix-constructs ?\ ))))
3372 ((and (looking-at "[ \t]*\n") 3851 ((and (looking-at "[ \t]*\n")
@@ -3393,15 +3872,17 @@ conditional/loop constructs."
3393 (goto-char (1+ pp)) 3872 (goto-char (1+ pp))
3394 (delete-horizontal-space) 3873 (delete-horizontal-space)
3395 (insert "\n") 3874 (insert "\n")
3396 (if (cperl-indent-line) 3875 (setq ret (point))
3397 (cperl-fix-line-spacing end)))))))))) 3876 (if (cperl-indent-line parse-data)
3877 (setq ret (cperl-fix-line-spacing end parse-data)))))))))))
3398 (beginning-of-line) 3878 (beginning-of-line)
3399 (setq p (point) pp (save-excursion (end-of-line) (point))) 3879 (setq p (point) pp (save-excursion (end-of-line) (point))) ; May be different from ee.
3400 ;; Now check whether there is a hanging `}' 3880 ;; Now check whether there is a hanging `}'
3401 ;; Looking at: 3881 ;; Looking at:
3402 ;; } blah 3882 ;; } blah
3403 (if (and 3883 (if (and
3404 cperl-fix-hanging-brace-when-indent 3884 cperl-fix-hanging-brace-when-indent
3885 have-brace
3405 (not (looking-at "[ \t]*}[ \t]*\\(\\<\\(els\\(if\\|e\\)\\|continue\\|while\\|until\\)\\>\\|$\\|#\\)")) 3886 (not (looking-at "[ \t]*}[ \t]*\\(\\<\\(els\\(if\\|e\\)\\|continue\\|while\\|until\\)\\>\\|$\\|#\\)"))
3406 (condition-case nil 3887 (condition-case nil
3407 (progn 3888 (progn
@@ -3419,7 +3900,7 @@ conditional/loop constructs."
3419 (if (bolp) 3900 (if (bolp)
3420 ;; `}' was the first thing on the line, insert NL *after* it. 3901 ;; `}' was the first thing on the line, insert NL *after* it.
3421 (progn 3902 (progn
3422 (cperl-indent-line) 3903 (cperl-indent-line parse-data)
3423 (search-forward "}") 3904 (search-forward "}")
3424 (delete-horizontal-space) 3905 (delete-horizontal-space)
3425 (insert "\n")) 3906 (insert "\n"))
@@ -3429,10 +3910,18 @@ conditional/loop constructs."
3429 (and (eq (preceding-char) ?\} ) 3910 (and (eq (preceding-char) ?\} )
3430 (cperl-after-block-p (point-min))) 3911 (cperl-after-block-p (point-min)))
3431 (insert ";")) 3912 (insert ";"))
3432 (insert "\n")) 3913 (insert "\n")
3433 (if (cperl-indent-line) 3914 (setq ret (point)))
3434 (cperl-fix-line-spacing end)) 3915 (if (cperl-indent-line parse-data)
3435 (beginning-of-line)))))) 3916 (setq ret (cperl-fix-line-spacing end parse-data)))
3917 (beginning-of-line)))))
3918 ret))
3919
3920(defvar cperl-update-start) ; Do not need to make them local
3921(defvar cperl-update-end)
3922(defun cperl-delay-update-hook (beg end old-len)
3923 (setq cperl-update-start (min beg (or cperl-update-start (point-max))))
3924 (setq cperl-update-end (max end (or cperl-update-end (point-min)))))
3436 3925
3437(defun cperl-indent-region (start end) 3926(defun cperl-indent-region (start end)
3438 "Simple variant of indentation of region in CPerl mode. 3927 "Simple variant of indentation of region in CPerl mode.
@@ -3444,9 +3933,16 @@ inclusive.
3444If `cperl-indent-region-fix-constructs', will improve spacing on 3933If `cperl-indent-region-fix-constructs', will improve spacing on
3445conditional/loop constructs." 3934conditional/loop constructs."
3446 (interactive "r") 3935 (interactive "r")
3936 (cperl-update-syntaxification end end)
3447 (save-excursion 3937 (save-excursion
3448 (let (st comm indent-info old-comm-indent new-comm-indent p pp i 3938 (let (cperl-update-start cperl-update-end (h-a-c after-change-functions))
3939 (let (st comm old-comm-indent new-comm-indent p pp i empty
3940 (indent-info (if cperl-emacs-can-parse
3941 (list nil nil nil) ; Cannot use '(), since will modify
3942 nil))
3943 after-change-functions ; Speed it up!
3449 (pm 0) (imenu-scanning-message "Indenting... (%3d%%)")) 3944 (pm 0) (imenu-scanning-message "Indenting... (%3d%%)"))
3945 (if h-a-c (add-hook 'after-change-functions 'cperl-delay-update-hook))
3450 (goto-char start) 3946 (goto-char start)
3451 (setq old-comm-indent (and (cperl-to-comment-or-eol) 3947 (setq old-comm-indent (and (cperl-to-comment-or-eol)
3452 (current-column)) 3948 (current-column))
@@ -3460,30 +3956,36 @@ conditional/loop constructs."
3460 (and (fboundp 'imenu-progress-message) 3956 (and (fboundp 'imenu-progress-message)
3461 (imenu-progress-message 3957 (imenu-progress-message
3462 pm (/ (* 100 (- (point) start)) (- end start -1)))) 3958 pm (/ (* 100 (- (point) start)) (- end start -1))))
3463 (setq st (point) 3959 (setq st (point))
3464 indent-info nil 3960 (if (or
3465 ) ; Believe indentation of the current 3961 (setq empty (looking-at "[ \t]*\n"))
3466 (if (and (setq comm (looking-at "[ \t]*#")) 3962 (and (setq comm (looking-at "[ \t]*#"))
3467 (or (eq (current-indentation) (or old-comm-indent 3963 (or (eq (current-indentation) (or old-comm-indent
3468 comment-column)) 3964 comment-column))
3469 (setq old-comm-indent nil))) 3965 (setq old-comm-indent nil))))
3470 (if (and old-comm-indent 3966 (if (and old-comm-indent
3967 (not empty)
3471 (= (current-indentation) old-comm-indent) 3968 (= (current-indentation) old-comm-indent)
3472 (not (eq (get-text-property (point) 'syntax-type) 'pod))) 3969 (not (eq (get-text-property (point) 'syntax-type) 'pod))
3970 (not (eq (get-text-property (point) 'syntax-table)
3971 cperl-st-cfence)))
3473 (let ((comment-column new-comm-indent)) 3972 (let ((comment-column new-comm-indent))
3474 (indent-for-comment))) 3973 (indent-for-comment)))
3475 (progn 3974 (progn
3476 (setq i (cperl-indent-line 'indent-info)) 3975 (setq i (cperl-indent-line indent-info))
3477 (or comm 3976 (or comm
3478 (not i) 3977 (not i)
3479 (progn 3978 (progn
3480 (if cperl-indent-region-fix-constructs 3979 (if cperl-indent-region-fix-constructs
3481 (cperl-fix-line-spacing end)) 3980 (goto-char (cperl-fix-line-spacing end indent-info)))
3482 (if (setq old-comm-indent 3981 (if (setq old-comm-indent
3483 (and (cperl-to-comment-or-eol) 3982 (and (cperl-to-comment-or-eol)
3484 (not (memq (get-text-property (point) 3983 (not (memq (get-text-property (point)
3485 'syntax-type) 3984 'syntax-type)
3486 '(pod here-doc))) 3985 '(pod here-doc)))
3986 (not (eq (get-text-property (point)
3987 'syntax-table)
3988 cperl-st-cfence))
3487 (current-column))) 3989 (current-column)))
3488 (progn (indent-for-comment) 3990 (progn (indent-for-comment)
3489 (skip-chars-backward " \t") 3991 (skip-chars-backward " \t")
@@ -3492,7 +3994,18 @@ conditional/loop constructs."
3492 (beginning-of-line 2)) 3994 (beginning-of-line 2))
3493 (if (fboundp 'imenu-progress-message) 3995 (if (fboundp 'imenu-progress-message)
3494 (imenu-progress-message pm 100) 3996 (imenu-progress-message pm 100)
3495 (message nil))))) 3997 (message nil)))
3998 ;; Now run the update hooks
3999 (if after-change-functions
4000 (save-excursion
4001 (if cperl-update-end
4002 (progn
4003 (goto-char cperl-update-end)
4004 (insert " ")
4005 (delete-char -1)
4006 (goto-char cperl-update-start)
4007 (insert " ")
4008 (delete-char -1))))))))
3496 4009
3497;; Stolen from lisp-mode with a lot of improvements 4010;; Stolen from lisp-mode with a lot of improvements
3498 4011
@@ -3827,8 +4340,16 @@ indentation and initial hashes. Behaves usually outside of comment."
3827 4340
3828(defvar font-lock-background-mode) 4341(defvar font-lock-background-mode)
3829(defvar font-lock-display-type) 4342(defvar font-lock-display-type)
4343(defun cperl-init-faces-weak ()
4344 ;; Allow `cperl-find-pods-heres' to run.
4345 (or (boundp 'font-lock-constant-face)
4346 (cperl-force-face font-lock-constant-face
4347 "Face for constant and label names")
4348 ;;(setq font-lock-constant-face 'font-lock-constant-face)
4349 ))
4350
3830(defun cperl-init-faces () 4351(defun cperl-init-faces ()
3831 (condition-case nil 4352 (condition-case errs
3832 (progn 4353 (progn
3833 (require 'font-lock) 4354 (require 'font-lock)
3834 (and (fboundp 'font-lock-fontify-anchored-keywords) 4355 (and (fboundp 'font-lock-fontify-anchored-keywords)
@@ -3840,6 +4361,7 @@ indentation and initial hashes. Behaves usually outside of comment."
3840 (setq 4361 (setq
3841 t-font-lock-keywords 4362 t-font-lock-keywords
3842 (list 4363 (list
4364 (list "[ \t]+$" 0 cperl-invalid-face t)
3843 (cons 4365 (cons
3844 (concat 4366 (concat
3845 "\\(^\\|[^$@%&\\]\\)\\<\\(" 4367 "\\(^\\|[^$@%&\\]\\)\\<\\("
@@ -3873,7 +4395,7 @@ indentation and initial hashes. Behaves usually outside of comment."
3873 ;; "getservbyport" "getservent" "getsockname" 4395 ;; "getservbyport" "getservent" "getsockname"
3874 ;; "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int" 4396 ;; "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int"
3875 ;; "ioctl" "join" "kill" "lc" "lcfirst" "le" "length" 4397 ;; "ioctl" "join" "kill" "lc" "lcfirst" "le" "length"
3876 ;; "link" "listen" "localtime" "log" "lstat" "lt" 4398 ;; "link" "listen" "localtime" "lock" "log" "lstat" "lt"
3877 ;; "mkdir" "msgctl" "msgget" "msgrcv" "msgsnd" "ne" 4399 ;; "mkdir" "msgctl" "msgget" "msgrcv" "msgsnd" "ne"
3878 ;; "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe" 4400 ;; "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe"
3879 ;; "quotemeta" "rand" "read" "readdir" "readline" 4401 ;; "quotemeta" "rand" "read" "readdir" "readline"
@@ -3905,7 +4427,7 @@ indentation and initial hashes. Behaves usually outside of comment."
3905 "ent\\)\\|gr\\(ent\\|nam\\|gid\\)\\)\\)\\)\\|" 4427 "ent\\)\\|gr\\(ent\\|nam\\|gid\\)\\)\\)\\)\\|"
3906 "hex\\|i\\(n\\(t\\|dex\\)\\|octl\\)\\|join\\|kill\\|" 4428 "hex\\|i\\(n\\(t\\|dex\\)\\|octl\\)\\|join\\|kill\\|"
3907 "l\\(i\\(sten\\|nk\\)\\|stat\\|c\\(\\|first\\)\\|t\\|e" 4429 "l\\(i\\(sten\\|nk\\)\\|stat\\|c\\(\\|first\\)\\|t\\|e"
3908 "\\(\\|ngth\\)\\|o\\(caltime\\|g\\)\\)\\|m\\(sg\\(rcv\\|snd\\|" 4430 "\\(\\|ngth\\)\\|o\\(c\\(altime\\|k\\)\\|g\\)\\)\\|m\\(sg\\(rcv\\|snd\\|"
3909 "ctl\\|get\\)\\|kdir\\)\\|n\\(e\\|ot\\)\\|o\\(pen\\(\\|dir\\)\\|" 4431 "ctl\\|get\\)\\|kdir\\)\\|n\\(e\\|ot\\)\\|o\\(pen\\(\\|dir\\)\\|"
3910 "r\\(\\|d\\)\\|ct\\)\\|p\\(ipe\\|ack\\)\\|quotemeta\\|" 4432 "r\\(\\|d\\)\\|ct\\)\\|p\\(ipe\\|ack\\)\\|quotemeta\\|"
3911 "r\\(index\\|and\\|mdir\\|e\\(quire\\|ad\\(pipe\\|\\|lin" 4433 "r\\(index\\|and\\|mdir\\|e\\(quire\\|ad\\(pipe\\|\\|lin"
@@ -3941,19 +4463,19 @@ indentation and initial hashes. Behaves usually outside of comment."
3941 "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|if\\|keys\\|" 4463 "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|if\\|keys\\|"
3942 "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|" 4464 "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|"
3943 "p\\(ackage\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|" 4465 "p\\(ackage\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|"
3944 "q\\(\\|q\\|w\\|x\\)\\|re\\(turn\\|do\\)\\|s\\(pli\\(ce\\|t\\)\\|" 4466 "q\\(\\|q\\|w\\|x\\|r\\)\\|re\\(turn\\|do\\)\\|s\\(pli\\(ce\\|t\\)\\|"
3945 "calar\\|tudy\\|ub\\|hift\\|ort\\)\\|t\\(r\\|ie\\)\\|" 4467 "calar\\|tudy\\|ub\\|hift\\|ort\\)\\|t\\(r\\|ie\\)\\|"
3946 "u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|" 4468 "u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|"
3947 "while\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually 4469 "while\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually
3948 "\\|[sm]" ; Added manually 4470 "\\|[sm]" ; Added manually
3949 "\\)\\>") 2 'font-lock-other-type-face) 4471 "\\)\\>") 2 'cperl-nonoverridable-face)
3950 ;; (mapconcat 'identity 4472 ;; (mapconcat 'identity
3951 ;; '("#endif" "#else" "#ifdef" "#ifndef" "#if" 4473 ;; '("#endif" "#else" "#ifdef" "#ifndef" "#if"
3952 ;; "#include" "#define" "#undef") 4474 ;; "#include" "#define" "#undef")
3953 ;; "\\|") 4475 ;; "\\|")
3954 '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0 4476 '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0
3955 font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]" 4477 font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]"
3956 '("\\<sub[ \t]+\\([^ \t{;]+\\)[ \t]*\\(([^()]*)[ \t]*\\)?[#{\n]" 1 4478 '("\\<sub[ \t]+\\([^ \t{;()]+\\)[ \t]*\\(([^()]*)[ \t]*\\)?[#{\n]" 1
3957 font-lock-function-name-face) 4479 font-lock-function-name-face)
3958 '("\\<\\(package\\|require\\|use\\|import\\|no\\|bootstrap\\)[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t;]" ; require A if B; 4480 '("\\<\\(package\\|require\\|use\\|import\\|no\\|bootstrap\\)[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t;]" ; require A if B;
3959 2 font-lock-function-name-face) 4481 2 font-lock-function-name-face)
@@ -4002,15 +4524,15 @@ indentation and initial hashes. Behaves usually outside of comment."
4002 '( 4524 '(
4003 ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1 4525 ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1
4004 (if (eq (char-after (match-beginning 2)) ?%) 4526 (if (eq (char-after (match-beginning 2)) ?%)
4005 font-lock-other-emphasized-face 4527 cperl-hash-face
4006 font-lock-emphasized-face) 4528 cperl-array-face)
4007 t) ; arrays and hashes 4529 t) ; arrays and hashes
4008 ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" 4530 ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)"
4009 1 4531 1
4010 (if (= (- (match-end 2) (match-beginning 2)) 1) 4532 (if (= (- (match-end 2) (match-beginning 2)) 1)
4011 (if (eq (char-after (match-beginning 3)) ?{) 4533 (if (eq (char-after (match-beginning 3)) ?{)
4012 font-lock-other-emphasized-face 4534 cperl-hash-face
4013 font-lock-emphasized-face) ; arrays and hashes 4535 cperl-array-face) ; arrays and hashes
4014 font-lock-variable-name-face) ; Just to put something 4536 font-lock-variable-name-face) ; Just to put something
4015 t) 4537 t)
4016 ;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2") 4538 ;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2")
@@ -4021,10 +4543,14 @@ indentation and initial hashes. Behaves usually outside of comment."
4021 ;; (if (cperl-slash-is-regexp) 4543 ;; (if (cperl-slash-is-regexp)
4022 ;; font-lock-function-name-face 'default) nil t)) 4544 ;; font-lock-function-name-face 'default) nil t))
4023 ))) 4545 )))
4024 (setq perl-font-lock-keywords-1 t-font-lock-keywords 4546 (setq perl-font-lock-keywords-1
4547 (if cperl-syntaxify-by-font-lock
4548 (cons 'cperl-fontify-update
4549 t-font-lock-keywords)
4550 t-font-lock-keywords)
4025 perl-font-lock-keywords perl-font-lock-keywords-1 4551 perl-font-lock-keywords perl-font-lock-keywords-1
4026 perl-font-lock-keywords-2 (append 4552 perl-font-lock-keywords-2 (append
4027 t-font-lock-keywords 4553 perl-font-lock-keywords-1
4028 t-font-lock-keywords-1))) 4554 t-font-lock-keywords-1)))
4029 (if (fboundp 'ps-print-buffer) (cperl-ps-print-init)) 4555 (if (fboundp 'ps-print-buffer) (cperl-ps-print-init))
4030 (if (or (featurep 'choose-color) (featurep 'font-lock-extra)) 4556 (if (or (featurep 'choose-color) (featurep 'font-lock-extra))
@@ -4044,12 +4570,6 @@ indentation and initial hashes. Behaves usually outside of comment."
4044 nil 4570 nil
4045 [nil nil t t t] 4571 [nil nil t t t]
4046 nil) 4572 nil)
4047 (list 'font-lock-keyword-face
4048 ["Purple" "LightSteelBlue" "DimGray" "Gray90"]
4049 nil
4050 [nil nil t t t]
4051 nil
4052 nil)
4053 (list 'font-lock-function-name-face 4573 (list 'font-lock-function-name-face
4054 (vector 4574 (vector
4055 "Blue" "LightSkyBlue" "Gray50" "LightGray" 4575 "Blue" "LightSkyBlue" "Gray50" "LightGray"
@@ -4082,7 +4602,7 @@ indentation and initial hashes. Behaves usually outside of comment."
4082 nil 4602 nil
4083 [nil nil t t t] 4603 [nil nil t t t]
4084 ) 4604 )
4085 (list 'font-lock-other-type-face 4605 (list 'cperl-nonoverridable-face
4086 ["chartreuse3" ("orchid1" "orange") 4606 ["chartreuse3" ("orchid1" "orange")
4087 nil "Gray80"] 4607 nil "Gray80"]
4088 [nil nil "gray90"] 4608 [nil nil "gray90"]
@@ -4090,74 +4610,106 @@ indentation and initial hashes. Behaves usually outside of comment."
4090 [nil nil t t] 4610 [nil nil t t]
4091 [nil nil t t t] 4611 [nil nil t t t]
4092 ) 4612 )
4093 (list 'font-lock-emphasized-face 4613 (list 'cperl-array-face
4094 ["blue" "yellow" nil "Gray80"] 4614 ["blue" "yellow" nil "Gray80"]
4095 ["lightyellow2" ("navy" "os2blue" "darkgreen") 4615 ["lightyellow2" ("navy" "os2blue" "darkgreen")
4096 "gray90"] 4616 "gray90"]
4097 t 4617 t
4098 nil 4618 nil
4099 nil) 4619 nil)
4100 (list 'font-lock-other-emphasized-face 4620 (list 'cperl-hash-face
4101 ["red" "red" nil "Gray80"] 4621 ["red" "red" nil "Gray80"]
4102 ["lightyellow2" ("navy" "os2blue" "darkgreen") 4622 ["lightyellow2" ("navy" "os2blue" "darkgreen")
4103 "gray90"] 4623 "gray90"]
4104 t 4624 t
4105 t 4625 t
4106 nil)))) 4626 nil))))
4627 ;; Do it the dull way, without choose-color
4107 (defvar cperl-guessed-background nil 4628 (defvar cperl-guessed-background nil
4108 "Display characteristics as guessed by cperl.") 4629 "Display characteristics as guessed by cperl.")
4109 (or (fboundp 'x-color-defined-p) 4630;; (or (fboundp 'x-color-defined-p)
4110 (defalias 'x-color-defined-p 4631;; (defalias 'x-color-defined-p
4111 (cond ((fboundp 'color-defined-p) 'color-defined-p) 4632;; (cond ((fboundp 'color-defined-p) 'color-defined-p)
4112 ;; XEmacs >= 19.12 4633;; ;; XEmacs >= 19.12
4113 ((fboundp 'valid-color-name-p) 'valid-color-name-p) 4634;; ((fboundp 'valid-color-name-p) 'valid-color-name-p)
4114 ;; XEmacs 19.11 4635;; ;; XEmacs 19.11
4115 (t 'x-valid-color-name-p)))) 4636;; (t 'x-valid-color-name-p))))
4116 (defvar font-lock-constant-face 'font-lock-constant-face) 4637 (cperl-force-face font-lock-constant-face
4117 (defvar font-lock-variable-name-face 'font-lock-variable-name-face) 4638 "Face for constant and label names")
4118 (or (boundp 'font-lock-type-face) 4639 (cperl-force-face font-lock-variable-name-face
4119 (defconst font-lock-type-face 4640 "Face for variable names")
4120 'font-lock-type-face 4641 (cperl-force-face font-lock-type-face
4121 "Face to use for data types.")) 4642 "Face for data types")
4122 (or (boundp 'font-lock-other-type-face) 4643 (cperl-force-face cperl-nonoverridable-face
4123 (defconst font-lock-other-type-face 4644 "Face for data types from another group")
4124 'font-lock-other-type-face 4645 (cperl-force-face font-lock-comment-face
4125 "Face to use for data types from another group.")) 4646 "Face for comments")
4126 (if (not cperl-xemacs-p) nil 4647 (cperl-force-face font-lock-function-name-face
4127 (or (boundp 'font-lock-comment-face) 4648 "Face for function names")
4128 (defconst font-lock-comment-face 4649 (cperl-force-face cperl-hash-face
4129 'font-lock-comment-face 4650 "Face for hashes")
4130 "Face to use for comments.")) 4651 (cperl-force-face cperl-array-face
4131 (or (boundp 'font-lock-keyword-face) 4652 "Face for arrays")
4132 (defconst font-lock-keyword-face 4653 ;;(defvar font-lock-constant-face 'font-lock-constant-face)
4133 'font-lock-keyword-face 4654 ;;(defvar font-lock-variable-name-face 'font-lock-variable-name-face)
4134 "Face to use for keywords.")) 4655 ;;(or (boundp 'font-lock-type-face)
4135 (or (boundp 'font-lock-function-name-face) 4656 ;; (defconst font-lock-type-face
4136 (defconst font-lock-function-name-face 4657 ;; 'font-lock-type-face
4137 'font-lock-function-name-face 4658 ;; "Face to use for data types."))
4138 "Face to use for function names."))) 4659 ;;(or (boundp 'cperl-nonoverridable-face)
4139 (or (boundp 'font-lock-other-emphasized-face) 4660 ;; (defconst cperl-nonoverridable-face
4140 (defconst font-lock-other-emphasized-face 4661 ;; 'cperl-nonoverridable-face
4141 'font-lock-other-emphasized-face 4662 ;; "Face to use for data types from another group."))
4142 "Face to use for another type of emphasizing.")) 4663 ;;(if (not cperl-xemacs-p) nil
4143 (or (boundp 'font-lock-emphasized-face) 4664 ;; (or (boundp 'font-lock-comment-face)
4144 (defconst font-lock-emphasized-face 4665 ;; (defconst font-lock-comment-face
4145 'font-lock-emphasized-face 4666 ;; 'font-lock-comment-face
4146 "Face to use for emphasizing.")) 4667 ;; "Face to use for comments."))
4668 ;; (or (boundp 'font-lock-keyword-face)
4669 ;; (defconst font-lock-keyword-face
4670 ;; 'font-lock-keyword-face
4671 ;; "Face to use for keywords."))
4672 ;; (or (boundp 'font-lock-function-name-face)
4673 ;; (defconst font-lock-function-name-face
4674 ;; 'font-lock-function-name-face
4675 ;; "Face to use for function names.")))
4676 (if (and
4677 (not (cperl-is-face 'cperl-array-face))
4678 (cperl-is-face 'font-lock-emphasized-face))
4679 (copy-face 'font-lock-emphasized-face 'cperl-array-face))
4680 (if (and
4681 (not (cperl-is-face 'cperl-hash-face))
4682 (cperl-is-face 'font-lock-other-emphasized-face))
4683 (copy-face 'font-lock-other-emphasized-face
4684 'cperl-hash-face))
4685 (if (and
4686 (not (cperl-is-face 'cperl-nonoverridable-face))
4687 (cperl-is-face 'font-lock-other-type-face))
4688 (copy-face 'font-lock-other-type-face
4689 'cperl-nonoverridable-face))
4690 ;;(or (boundp 'cperl-hash-face)
4691 ;; (defconst cperl-hash-face
4692 ;; 'cperl-hash-face
4693 ;; "Face to use for hashes."))
4694 ;;(or (boundp 'cperl-array-face)
4695 ;; (defconst cperl-array-face
4696 ;; 'cperl-array-face
4697 ;; "Face to use for arrays."))
4147 ;; Here we try to guess background 4698 ;; Here we try to guess background
4148 (let ((background 4699 (let ((background
4149 (if (boundp 'font-lock-background-mode) 4700 (if (boundp 'font-lock-background-mode)
4150 font-lock-background-mode 4701 font-lock-background-mode
4151 'light)) 4702 'light))
4152 (face-list (and (fboundp 'face-list) (face-list))) 4703 (face-list (and (fboundp 'face-list) (face-list)))
4153 cperl-is-face) 4704 ;; cperl-is-face
4154 (fset 'cperl-is-face 4705 )
4155 (cond ((fboundp 'find-face) 4706;;;; (fset 'cperl-is-face
4156 (symbol-function 'find-face)) 4707;;;; (cond ((fboundp 'find-face)
4157 (face-list 4708;;;; (symbol-function 'find-face))
4158 (function (lambda (face) (member face face-list)))) 4709;;;; (face-list
4159 (t 4710;;;; (function (lambda (face) (member face face-list))))
4160 (function (lambda (face) (boundp face)))))) 4711;;;; (t
4712;;;; (function (lambda (face) (boundp face))))))
4161 (defvar cperl-guessed-background 4713 (defvar cperl-guessed-background
4162 (if (and (boundp 'font-lock-display-type) 4714 (if (and (boundp 'font-lock-display-type)
4163 (eq font-lock-display-type 'grayscale)) 4715 (eq font-lock-display-type 'grayscale))
@@ -4167,7 +4719,6 @@ indentation and initial hashes. Behaves usually outside of comment."
4167 (if (and 4719 (if (and
4168 (not (cperl-is-face 'font-lock-constant-face)) 4720 (not (cperl-is-face 'font-lock-constant-face))
4169 (cperl-is-face 'font-lock-reference-face)) 4721 (cperl-is-face 'font-lock-reference-face))
4170 nil
4171 (copy-face 'font-lock-reference-face 'font-lock-constant-face)) 4722 (copy-face 'font-lock-reference-face 'font-lock-constant-face))
4172 (if (cperl-is-face 'font-lock-type-face) nil 4723 (if (cperl-is-face 'font-lock-type-face) nil
4173 (copy-face 'default 'font-lock-type-face) 4724 (copy-face 'default 'font-lock-type-face)
@@ -4184,88 +4735,137 @@ indentation and initial hashes. Behaves usually outside of comment."
4184 "pink"))) 4735 "pink")))
4185 (t 4736 (t
4186 (set-face-background 'font-lock-type-face "gray90")))) 4737 (set-face-background 'font-lock-type-face "gray90"))))
4187 (if (cperl-is-face 'font-lock-other-type-face) 4738 (if (cperl-is-face 'cperl-nonoverridable-face)
4188 nil 4739 nil
4189 (copy-face 'font-lock-type-face 'font-lock-other-type-face) 4740 (copy-face 'font-lock-type-face 'cperl-nonoverridable-face)
4190 (cond 4741 (cond
4191 ((eq background 'light) 4742 ((eq background 'light)
4192 (set-face-foreground 'font-lock-other-type-face 4743 (set-face-foreground 'cperl-nonoverridable-face
4193 (if (x-color-defined-p "chartreuse3") 4744 (if (x-color-defined-p "chartreuse3")
4194 "chartreuse3" 4745 "chartreuse3"
4195 "chartreuse"))) 4746 "chartreuse")))
4196 ((eq background 'dark) 4747 ((eq background 'dark)
4197 (set-face-foreground 'font-lock-other-type-face 4748 (set-face-foreground 'cperl-nonoverridable-face
4198 (if (x-color-defined-p "orchid1") 4749 (if (x-color-defined-p "orchid1")
4199 "orchid1" 4750 "orchid1"
4200 "orange"))))) 4751 "orange")))))
4201 (if (cperl-is-face 'font-lock-other-emphasized-face) nil 4752;;; (if (cperl-is-face 'font-lock-other-emphasized-face) nil
4202 (copy-face 'bold-italic 'font-lock-other-emphasized-face) 4753;;; (copy-face 'bold-italic 'font-lock-other-emphasized-face)
4203 (cond 4754;;; (cond
4204 ((eq background 'light) 4755;;; ((eq background 'light)
4205 (set-face-background 'font-lock-other-emphasized-face 4756;;; (set-face-background 'font-lock-other-emphasized-face
4206 (if (x-color-defined-p "lightyellow2") 4757;;; (if (x-color-defined-p "lightyellow2")
4207 "lightyellow2" 4758;;; "lightyellow2"
4208 (if (x-color-defined-p "lightyellow") 4759;;; (if (x-color-defined-p "lightyellow")
4209 "lightyellow" 4760;;; "lightyellow"
4210 "light yellow")))) 4761;;; "light yellow"))))
4211 ((eq background 'dark) 4762;;; ((eq background 'dark)
4212 (set-face-background 'font-lock-other-emphasized-face 4763;;; (set-face-background 'font-lock-other-emphasized-face
4213 (if (x-color-defined-p "navy") 4764;;; (if (x-color-defined-p "navy")
4214 "navy" 4765;;; "navy"
4215 (if (x-color-defined-p "darkgreen") 4766;;; (if (x-color-defined-p "darkgreen")
4216 "darkgreen" 4767;;; "darkgreen"
4217 "dark green")))) 4768;;; "dark green"))))
4218 (t (set-face-background 'font-lock-other-emphasized-face "gray90")))) 4769;;; (t (set-face-background 'font-lock-other-emphasized-face "gray90"))))
4219 (if (cperl-is-face 'font-lock-emphasized-face) nil 4770;;; (if (cperl-is-face 'font-lock-emphasized-face) nil
4220 (copy-face 'bold 'font-lock-emphasized-face) 4771;;; (copy-face 'bold 'font-lock-emphasized-face)
4221 (cond 4772;;; (cond
4222 ((eq background 'light) 4773;;; ((eq background 'light)
4223 (set-face-background 'font-lock-emphasized-face 4774;;; (set-face-background 'font-lock-emphasized-face
4224 (if (x-color-defined-p "lightyellow2") 4775;;; (if (x-color-defined-p "lightyellow2")
4225 "lightyellow2" 4776;;; "lightyellow2"
4226 "lightyellow"))) 4777;;; "lightyellow")))
4227 ((eq background 'dark) 4778;;; ((eq background 'dark)
4228 (set-face-background 'font-lock-emphasized-face 4779;;; (set-face-background 'font-lock-emphasized-face
4229 (if (x-color-defined-p "navy") 4780;;; (if (x-color-defined-p "navy")
4230 "navy" 4781;;; "navy"
4231 (if (x-color-defined-p "darkgreen") 4782;;; (if (x-color-defined-p "darkgreen")
4232 "darkgreen" 4783;;; "darkgreen"
4233 "dark green")))) 4784;;; "dark green"))))
4234 (t (set-face-background 'font-lock-emphasized-face "gray90")))) 4785;;; (t (set-face-background 'font-lock-emphasized-face "gray90"))))
4235 (if (cperl-is-face 'font-lock-variable-name-face) nil 4786 (if (cperl-is-face 'font-lock-variable-name-face) nil
4236 (copy-face 'italic 'font-lock-variable-name-face)) 4787 (copy-face 'italic 'font-lock-variable-name-face))
4237 (if (cperl-is-face 'font-lock-constant-face) nil 4788 (if (cperl-is-face 'font-lock-constant-face) nil
4238 (copy-face 'italic 'font-lock-constant-face)))) 4789 (copy-face 'italic 'font-lock-constant-face))))
4239 (setq cperl-faces-init t)) 4790 (setq cperl-faces-init t))
4240 (error nil))) 4791 (error (message "cperl-init-faces (ignored): %s" errs))))
4241 4792
4242 4793
4243(defun cperl-ps-print-init () 4794(defun cperl-ps-print-init ()
4244 "Initialization of `ps-print' components for faces used in CPerl." 4795 "Initialization of `ps-print' components for faces used in CPerl."
4245 ;; Guard against old versions 4796 (eval-after-load "ps-print"
4246 (defvar ps-underlined-faces nil) 4797 '(setq ps-bold-faces
4247 (defvar ps-bold-faces nil) 4798 ;; font-lock-variable-name-face
4248 (defvar ps-italic-faces nil) 4799 ;; font-lock-constant-face
4249 (setq ps-bold-faces 4800 (append '(cperl-array-face
4250 (append '(font-lock-emphasized-face 4801 cperl-hash-face)
4251 font-lock-keyword-face 4802 ps-bold-faces)
4252 font-lock-variable-name-face 4803 ps-italic-faces
4253 font-lock-constant-face 4804 ;; font-lock-constant-face
4254 font-lock-reference-face 4805 (append '(cperl-nonoverridable-face
4255 font-lock-other-emphasized-face) 4806 cperl-hash-face)
4256 ps-bold-faces)) 4807 ps-italic-faces)
4257 (setq ps-italic-faces 4808 ps-underlined-faces
4258 (append '(font-lock-other-type-face 4809 ;; font-lock-type-face
4259 font-lock-constant-face 4810 (append '(cperl-array-face
4260 font-lock-reference-face 4811 cperl-hash-face
4261 font-lock-other-emphasized-face) 4812 underline
4262 ps-italic-faces)) 4813 cperl-nonoverridable-face)
4263 (setq ps-underlined-faces 4814 ps-underlined-faces))))
4264 (append '(font-lock-emphasized-face 4815
4265 font-lock-other-emphasized-face 4816(defvar ps-print-face-extension-alist)
4266 font-lock-other-type-face font-lock-type-face) 4817
4267 ps-underlined-faces)) 4818(defun cperl-ps-print (&optional file)
4268 (cons 'font-lock-type-face ps-underlined-faces)) 4819 "Pretty-print in CPerl style.
4820If optional argument FILE is an empty string, prints to printer, otherwise
4821to the file FILE. If FILE is nil, prompts for a file name.
4822
4823Style of printout regulated by the variable `cperl-ps-print-face-properties'."
4824 (interactive)
4825 (or file
4826 (setq file (read-from-minibuffer
4827 "Print to file (if empty - to printer): "
4828 (concat (buffer-file-name) ".ps")
4829 nil nil 'file-name-history)))
4830 (or (> (length file) 0)
4831 (setq file nil))
4832 (require 'ps-print) ; To get ps-print-face-extension-alist
4833 (let ((ps-print-color-p t)
4834 (ps-print-face-extension-alist ps-print-face-extension-alist))
4835 (cperl-ps-extend-face-list cperl-ps-print-face-properties)
4836 (ps-print-buffer-with-faces file)))
4837
4838;;; (defun cperl-ps-print-init ()
4839;;; "Initialization of `ps-print' components for faces used in CPerl."
4840;;; ;; Guard against old versions
4841;;; (defvar ps-underlined-faces nil)
4842;;; (defvar ps-bold-faces nil)
4843;;; (defvar ps-italic-faces nil)
4844;;; (setq ps-bold-faces
4845;;; (append '(font-lock-emphasized-face
4846;;; cperl-array-face
4847;;; font-lock-keyword-face
4848;;; font-lock-variable-name-face
4849;;; font-lock-constant-face
4850;;; font-lock-reference-face
4851;;; font-lock-other-emphasized-face
4852;;; cperl-hash-face)
4853;;; ps-bold-faces))
4854;;; (setq ps-italic-faces
4855;;; (append '(cperl-nonoverridable-face
4856;;; font-lock-constant-face
4857;;; font-lock-reference-face
4858;;; font-lock-other-emphasized-face
4859;;; cperl-hash-face)
4860;;; ps-italic-faces))
4861;;; (setq ps-underlined-faces
4862;;; (append '(font-lock-emphasized-face
4863;;; cperl-array-face
4864;;; font-lock-other-emphasized-face
4865;;; cperl-hash-face
4866;;; cperl-nonoverridable-face font-lock-type-face)
4867;;; ps-underlined-faces))
4868;;; (cons 'font-lock-type-face ps-underlined-faces))
4269 4869
4270 4870
4271(if (cperl-enable-font-lock) (cperl-windowed-init)) 4871(if (cperl-enable-font-lock) (cperl-windowed-init))
@@ -4333,7 +4933,7 @@ indentation and initial hashes. Behaves usually outside of comment."
4333 ;;(cperl-extra-newline-before-brace . nil) ; ??? 4933 ;;(cperl-extra-newline-before-brace . nil) ; ???
4334 (cperl-continued-statement-offset . 4))) 4934 (cperl-continued-statement-offset . 4)))
4335 "(Experimental) list of variables to set to get a particular indentation style. 4935 "(Experimental) list of variables to set to get a particular indentation style.
4336Should be used via `cperl-set-style' or via CPerl menu.") 4936Should be used via `cperl-set-style' or via Perl menu.")
4337 4937
4338(defun cperl-set-style (style) 4938(defun cperl-set-style (style)
4339 "Set CPerl-mode variables to use one of several different indentation styles. 4939 "Set CPerl-mode variables to use one of several different indentation styles.
@@ -4675,7 +5275,9 @@ See `cperl-lazy-help-time' too."
4675 "Toggle whether `indent-region'/`indent-sexp' fix whitespace too." 5275 "Toggle whether `indent-region'/`indent-sexp' fix whitespace too."
4676 (interactive) 5276 (interactive)
4677 (setq cperl-indent-region-fix-constructs 5277 (setq cperl-indent-region-fix-constructs
4678 (not cperl-indent-region-fix-constructs)) 5278 (if cperl-indent-region-fix-constructs
5279 nil
5280 1))
4679 (message "indent-region/indent-sexp will %sbe automatically fix whitespace." 5281 (message "indent-region/indent-sexp will %sbe automatically fix whitespace."
4680 (if cperl-indent-region-fix-constructs "" "not "))) 5282 (if cperl-indent-region-fix-constructs "" "not ")))
4681 5283
@@ -4765,8 +5367,10 @@ See `cperl-lazy-help-time' too."
4765 (lambda (elt) 5367 (lambda (elt)
4766 (cond ((string-match "^[_a-zA-Z]" (car elt)) 5368 (cond ((string-match "^[_a-zA-Z]" (car elt))
4767 (goto-char (cdr elt)) 5369 (goto-char (cdr elt))
5370 (beginning-of-line) ; pos should be of the start of the line
4768 (list (car elt) 5371 (list (car elt)
4769 (point) (count-lines 1 (point)) 5372 (point)
5373 (1+ (count-lines 1 (point))) ; 1+ since at beg-o-l
4770 (buffer-substring (progn 5374 (buffer-substring (progn
4771 (skip-chars-forward 5375 (skip-chars-forward
4772 ":_a-zA-Z0-9") 5376 ":_a-zA-Z0-9")
@@ -4787,9 +5391,9 @@ See `cperl-lazy-help-time' too."
4787 (substring (car elt) 8) 5391 (substring (car elt) 8)
4788 (car elt) ) 5392 (car elt) )
4789 1 5393 1
4790 (number-to-string (elt elt 1)) 5394 (number-to-string (elt elt 2)) ; Line
4791 "," 5395 ","
4792 (number-to-string (elt elt 2)) 5396 (number-to-string (1- (elt elt 1))) ; Char pos 0-based
4793 "\n") 5397 "\n")
4794 (if (and (string-match "^[_a-zA-Z]+::" (car elt)) 5398 (if (and (string-match "^[_a-zA-Z]+::" (car elt))
4795 (string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]" 5399 (string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]"
@@ -4841,11 +5445,13 @@ Use as
4841 (setq topdir default-directory)) 5445 (setq topdir default-directory))
4842 (let ((tags-file-name "TAGS") 5446 (let ((tags-file-name "TAGS")
4843 (case-fold-search (eq system-type 'emx)) 5447 (case-fold-search (eq system-type 'emx))
4844 xs) 5448 xs rel)
4845 (save-excursion 5449 (save-excursion
4846 (cond (inbuffer nil) ; Already there 5450 (cond (inbuffer nil) ; Already there
4847 ((file-exists-p tags-file-name) 5451 ((file-exists-p tags-file-name)
4848 (visit-tags-table-buffer tags-file-name)) 5452 (if cperl-xemacs-p
5453 (visit-tags-table-buffer)
5454 (visit-tags-table-buffer tags-file-name)))
4849 (t (set-buffer (find-file-noselect tags-file-name)))) 5455 (t (set-buffer (find-file-noselect tags-file-name))))
4850 (cond 5456 (cond
4851 (dir 5457 (dir
@@ -4876,7 +5482,12 @@ Use as
4876 (erase (erase-buffer)) 5482 (erase (erase-buffer))
4877 (t 5483 (t
4878 (goto-char 1) 5484 (goto-char 1)
4879 (if (search-forward (concat "\f\n" file ",") nil t) 5485 (setq rel file)
5486 ;; On case-preserving filesystems (EMX on OS/2) case might be encoded in properties
5487 (set-text-properties 0 (length rel) nil rel)
5488 (and (equal topdir (substring rel 0 (length topdir)))
5489 (setq rel (substring file (length topdir))))
5490 (if (search-forward (concat "\f\n" rel ",") nil t)
4880 (progn 5491 (progn
4881 (search-backward "\f\n") 5492 (search-backward "\f\n")
4882 (delete-region (point) 5493 (delete-region (point)
@@ -4928,11 +5539,12 @@ Use as
4928 (setq ;;str (buffer-substring (match-beginning 1) (match-end 1)) 5539 (setq ;;str (buffer-substring (match-beginning 1) (match-end 1))
4929 name (buffer-substring (match-beginning 2) (match-end 2)) 5540 name (buffer-substring (match-beginning 2) (match-end 2))
4930 ;;pos (buffer-substring (match-beginning 3) (match-end 3)) 5541 ;;pos (buffer-substring (match-beginning 3) (match-end 3))
4931 line (buffer-substring (match-beginning 4) (match-end 4)) 5542 line (buffer-substring (match-beginning 3) (match-end 3))
4932 ord (if pack 1 0) 5543 ord (if pack 1 0)
4933 info (etags-snarf-tag) ; Moves to beginning of the next line
4934 file (file-of-tag) 5544 file (file-of-tag)
4935 fileind (format "%s:%s" file line)) 5545 fileind (format "%s:%s" file line)
5546 ;; Moves to beginning of the next line:
5547 info (cperl-etags-snarf-tag file line))
4936 ;; Move back 5548 ;; Move back
4937 (forward-char -1) 5549 (forward-char -1)
4938 ;; Make new member of hierarchy name ==> file ==> pos if needed 5550 ;; Make new member of hierarchy name ==> file ==> pos if needed
@@ -4958,22 +5570,31 @@ One may build such TAGS files from CPerl mode menu."
4958 (require 'etags) 5570 (require 'etags)
4959 (require 'imenu) 5571 (require 'imenu)
4960 (if (or update (null (nth 2 cperl-hierarchy))) 5572 (if (or update (null (nth 2 cperl-hierarchy)))
4961 (let (pack name cons1 to l1 l2 l3 l4 5573 (let (pack name cons1 to l1 l2 l3 l4 b
4962 (remover (function (lambda (elt) ; (name (file1...) (file2..)) 5574 (remover (function (lambda (elt) ; (name (file1...) (file2..))
4963 (or (nthcdr 2 elt) 5575 (or (nthcdr 2 elt)
4964 ;; Only in one file 5576 ;; Only in one file
4965 (setcdr elt (cdr (nth 1 elt)))))))) 5577 (setcdr elt (cdr (nth 1 elt))))))))
4966 ;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later! 5578 ;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later!
4967 (setq cperl-hierarchy (list l1 l2 l3)) 5579 (setq cperl-hierarchy (list l1 l2 l3))
4968 (or tags-table-list 5580 (if cperl-xemacs-p ; Not checked
5581 (progn
5582 (or tags-file-name
5583 ;; Does this work in XEmacs?
4969 (call-interactively 'visit-tags-table)) 5584 (call-interactively 'visit-tags-table))
4970 (message "Updating list of classes...") 5585 (message "Updating list of classes...")
5586 (set-buffer (get-file-buffer tags-file-name))
5587 (cperl-tags-hier-fill))
5588 (or tags-table-list
5589 (call-interactively 'visit-tags-table))
4971 (mapcar 5590 (mapcar
4972 (function 5591 (function
4973 (lambda (tagsfile) 5592 (lambda (tagsfile)
5593 (message "Updating list of classes... %s" tagsfile)
4974 (set-buffer (get-file-buffer tagsfile)) 5594 (set-buffer (get-file-buffer tagsfile))
4975 (cperl-tags-hier-fill))) 5595 (cperl-tags-hier-fill)))
4976 tags-table-list) 5596 tags-table-list)
5597 (message "Updating list of classes... postprocessing..."))
4977 (mapcar remover (car cperl-hierarchy)) 5598 (mapcar remover (car cperl-hierarchy))
4978 (mapcar remover (nth 1 cperl-hierarchy)) 5599 (mapcar remover (nth 1 cperl-hierarchy))
4979 (setq to (list nil (cons "Packages: " (nth 1 cperl-hierarchy)) 5600 (setq to (list nil (cons "Packages: " (nth 1 cperl-hierarchy))
@@ -4998,7 +5619,7 @@ One may build such TAGS files from CPerl mode menu."
4998 (if (vectorp update) 5619 (if (vectorp update)
4999 (progn 5620 (progn
5000 (find-file (elt update 0)) 5621 (find-file (elt update 0))
5001 (etags-goto-tag-location (elt update 1)))) 5622 (cperl-etags-goto-tag-location (elt update 1))))
5002 (if (eq update -999) (cperl-tags-hier-init t))) 5623 (if (eq update -999) (cperl-tags-hier-init t)))
5003 5624
5004(defun cperl-tags-treeify (to level) 5625(defun cperl-tags-treeify (to level)
@@ -5129,14 +5750,17 @@ One may build such TAGS files from CPerl mode menu."
5129 "[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used. 5750 "[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used.
5130 "&[(a-zA-Z0-9_$]" ; &subroutine &(var->field) 5751 "&[(a-zA-Z0-9_$]" ; &subroutine &(var->field)
5131 "<\\$?\\sw+\\(\\.\\sw+\\)?>" ; <IN> <stdin.h> 5752 "<\\$?\\sw+\\(\\.\\sw+\\)?>" ; <IN> <stdin.h>
5132 "-[a-zA-Z][ \t]+[_$\"'`]" ; -f file 5753 "-[a-zA-Z][ \t]+[_$\"'`a-zA-Z]" ; -f file, -t STDIN
5133 "-[0-9]" ; -5 5754 "-[0-9]" ; -5
5134 "\\+\\+" ; ++var 5755 "\\+\\+" ; ++var
5135 "--" ; --var 5756 "--" ; --var
5136 ".->" ; a->b 5757 ".->" ; a->b
5137 "->" ; a SPACE ->b 5758 "->" ; a SPACE ->b
5138 "\\[-" ; a[-1] 5759 "\\[-" ; a[-1]
5760 "\\\\[&$@*\\\\]" ; \&func
5139 "^=" ; =head 5761 "^=" ; =head
5762 "\\$." ; $|
5763 "<<[a-zA-Z_'\"`]" ; <<FOO, <<'FOO'
5140 "||" 5764 "||"
5141 "&&" 5765 "&&"
5142 "[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C<code like text> 5766 "[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C<code like text>
@@ -5407,6 +6031,7 @@ $^F The highest system file descriptor, ordinarily 2.
5407$^H The current set of syntax checks enabled by `use strict'. 6031$^H The current set of syntax checks enabled by `use strict'.
5408$^I The value of the in-place edit extension (perl -i option). 6032$^I The value of the in-place edit extension (perl -i option).
5409$^L What formats output to perform a formfeed. Default is \f. 6033$^L What formats output to perform a formfeed. Default is \f.
6034$^M A buffer for emergency memory allocation when running out of memory.
5410$^O The operating system name under which this copy of Perl was built. 6035$^O The operating system name under which this copy of Perl was built.
5411$^P Internal debugging flag. 6036$^P Internal debugging flag.
5412$^T The time the script was started. Used by -A/-M/-C file tests. 6037$^T The time the script was started. Used by -A/-M/-C file tests.
@@ -5945,11 +6570,11 @@ prototype \&SUB Returns prototype of the function given a reference.
5945 ;; Returns position of the start 6570 ;; Returns position of the start
5946 (save-excursion 6571 (save-excursion
5947 (or cperl-use-syntax-table-text-property 6572 (or cperl-use-syntax-table-text-property
5948 (error "I need to have regex marked!")) 6573 (error "I need to have a regexp marked!"))
5949 ;; Find the start 6574 ;; Find the start
5950 (if (looking-at "\\s|") 6575 (if (looking-at "\\s|")
5951 nil ; good already 6576 nil ; good already
5952 (if (looking-at "[smy]\\s|") 6577 (if (looking-at "\\([smy]\\|qr\\)\\s|")
5953 (forward-char 1) 6578 (forward-char 1)
5954 (re-search-backward "\\s|"))) ; Assume it is scanned already. 6579 (re-search-backward "\\s|"))) ; Assume it is scanned already.
5955 ;;(forward-char 1) 6580 ;;(forward-char 1)
@@ -5999,7 +6624,7 @@ We suppose that the regexp is scanned already."
5999 (or done (forward-char -1))))) 6624 (or done (forward-char -1)))))
6000 6625
6001(defun cperl-contract-level () 6626(defun cperl-contract-level ()
6002 "Find an enclosing group in regexp and contract it. Unfinished. 6627 "Find an enclosing group in regexp and contract it.
6003\(Experimental, may change semantics, recheck the result.) 6628\(Experimental, may change semantics, recheck the result.)
6004We suppose that the regexp is scanned already." 6629We suppose that the regexp is scanned already."
6005 (interactive) 6630 (interactive)
@@ -6022,7 +6647,7 @@ We suppose that the regexp is scanned already."
6022 (just-one-space)))))) 6647 (just-one-space))))))
6023 6648
6024(defun cperl-contract-levels () 6649(defun cperl-contract-levels ()
6025 "Find an enclosing group in regexp and contract all the kids. Unfinished. 6650 "Find an enclosing group in regexp and contract all the kids.
6026\(Experimental, may change semantics, recheck the result.) 6651\(Experimental, may change semantics, recheck the result.)
6027We suppose that the regexp is scanned already." 6652We suppose that the regexp is scanned already."
6028 (interactive) 6653 (interactive)
@@ -6137,6 +6762,7 @@ We suppose that the regexp is scanned already."
6137 (error "`%s' not with an (EXPR)" s0))) 6762 (error "`%s' not with an (EXPR)" s0)))
6138 (error "Not at `if', `unless', `while', or `unless'"))) 6763 (error "Not at `if', `unless', `while', or `unless'")))
6139 6764
6765;;; By Anthony Foiani <afoiani@uswest.com>
6140;;; Getting help on modules in C-h f ? 6766;;; Getting help on modules in C-h f ?
6141;;; This is a modified version of `man'. 6767;;; This is a modified version of `man'.
6142;;; Need to teach it how to lookup functions 6768;;; Need to teach it how to lookup functions
@@ -6174,6 +6800,7 @@ We suppose that the regexp is scanned already."
6174 :type 'file 6800 :type 'file
6175 :group 'cperl) 6801 :group 'cperl)
6176 6802
6803;;; By Nick Roberts <Nick.Roberts@src.bae.co.uk> (with changes)
6177(defun cperl-pod-to-manpage () 6804(defun cperl-pod-to-manpage ()
6178 "Create a virtual manpage in Emacs from the Perl Online Documentation." 6805 "Create a virtual manpage in Emacs from the Perl Online Documentation."
6179 (interactive) 6806 (interactive)
@@ -6261,11 +6888,17 @@ We suppose that the regexp is scanned already."
6261 6888
6262(defvar cperl-d-l nil) 6889(defvar cperl-d-l nil)
6263(defun cperl-fontify-syntaxically (end) 6890(defun cperl-fontify-syntaxically (end)
6264 (let ((start (point)) (dbg (point))) 6891 ;; Some vars for debugging only
6892 (let (start (dbg (point)) (iend end)
6893 (istate (car cperl-syntax-state)))
6894 (and cperl-syntaxify-unwind
6895 (setq end (cperl-unwind-to-safe t end)))
6896 (setq start (point))
6265 (or cperl-syntax-done-to 6897 (or cperl-syntax-done-to
6266 (setq cperl-syntax-done-to (point-min))) 6898 (setq cperl-syntax-done-to (point-min)))
6267 (if (or (not (boundp 'font-lock-hot-pass)) 6899 (if (or (not (boundp 'font-lock-hot-pass))
6268 (eval 'font-lock-hot-pass)) 6900 (eval 'font-lock-hot-pass)
6901 t) ; Not debugged otherwise
6269 ;; Need to forget what is after `start' 6902 ;; Need to forget what is after `start'
6270 (setq start (min cperl-syntax-done-to start)) 6903 (setq start (min cperl-syntax-done-to start))
6271 ;; Fontification without a change 6904 ;; Fontification without a change
@@ -6279,11 +6912,38 @@ We suppose that the regexp is scanned already."
6279 ;;(let ((standard-output (get-buffer "*Messages*"))) 6912 ;;(let ((standard-output (get-buffer "*Messages*")))
6280 ;;(princ (format "Syntaxifying %s..%s from %s to %s\n" 6913 ;;(princ (format "Syntaxifying %s..%s from %s to %s\n"
6281 ;; dbg end start cperl-syntax-done-to))) 6914 ;; dbg end start cperl-syntax-done-to)))
6282 (if (eq cperl-syntaxify-by-font-lock 1) 6915 (if (eq cperl-syntaxify-by-font-lock 'message)
6283 (message "Syntaxifying %s..%s from %s to %s" 6916 (message "Syntaxified %s..%s from %s to %s(%s), state %s-->%s"
6284 dbg end start cperl-syntax-done-to)) ; For debugging 6917 dbg iend
6918 start end cperl-syntax-done-to
6919 istate (car cperl-syntax-state))) ; For debugging
6285 nil)) ; Do not iterate 6920 nil)) ; Do not iterate
6286 6921
6922(defun cperl-fontify-update (end)
6923 (let ((pos (point)) prop posend)
6924 (while (< pos end)
6925 (setq prop (get-text-property pos 'cperl-postpone))
6926 (setq posend (next-single-property-change pos 'cperl-postpone nil end))
6927 (and prop (put-text-property pos posend (car prop) (cdr prop)))
6928 (setq pos posend)))
6929 nil) ; Do not iterate
6930
6931(defun cperl-update-syntaxification (from to)
6932 (if (and cperl-use-syntax-table-text-property
6933 cperl-syntaxify-by-font-lock
6934 (or (null cperl-syntax-done-to)
6935 (< cperl-syntax-done-to to)))
6936 (progn
6937 (save-excursion
6938 (goto-char from)
6939 (cperl-fontify-syntaxically to)))))
6940
6941(defvar cperl-version
6942 (let ((v "Revision: 4.21"))
6943 (string-match ":\\s *\\([0-9.]+\\)" v)
6944 (substring v (match-beginning 1) (match-end 1)))
6945 "Version of IZ-supported CPerl package this file is based on.")
6946
6287(provide 'cperl-mode) 6947(provide 'cperl-mode)
6288 6948
6289;;; cperl-mode.el ends here 6949;;; cperl-mode.el ends here
generated by cgit v1.2.1 (git 2.18.0) at 2026-02-04 18:57:30 +0000