comparison lisp/progmodes/cperl-mode.el @ 104310:2ecd57cadf51

* progmodes/cperl-mode.el: Merge upstream 6.2. (cperl-mode-syntax-table): Modify syntax entry for ["'`]. (cperl-forward-re): Check cperl-brace-recursing. (cperl-highlight-charclass): New function. (cperl-find-pods-heres): Use it. (cperl-fill-paragraph): Synch to save-excursion placement used upstream. (cperl-beautify-regexp-piece): Fix column calculation. (cperl-make-regexp-x): Handle case where point is between "q" and "rs". (cperl-beautify-level): Don't process entire regexp. (cperl-build-manpage, cperl-perldoc): Bind Man-switches before calling man. (cperl-tips-faces, cperl-mode, cperl-electric-backspace): Doc fix. (cperl-init-faces): Build a list in the normal way.

104309:d38c249bcfee

  '((font-lock-keyword-face		nil nil		bold shadow)
    (font-lock-variable-name-face	nil nil		bold)
    (font-lock-function-name-face	nil nil		bold italic box)
    (font-lock-constant-face		nil "LightGray"	bold)
    (cperl-array-face			nil "LightGray"	bold underline)
    (cperl-hash-face				nil "LightGray"	bold italic underline)
    (font-lock-comment-face		nil "LightGray"	italic)
    (font-lock-string-face		nil nil		italic underline)
    (cperl-nonoverridable-face		nil nil		italic underline)
    (font-lock-type-face		nil nil		underline)
    (font-lock-warning-face		nil "LightGray"	bold italic box)

				and whatever is syntaxically considered
				as string literals
  `font-lock-type-face'		Overridable keywords
  `font-lock-variable-name-face' Variable declarations, indirect array and
				hash names, POD headers/item names
  `cperl-invalid'		Trailing whitespace

Note that in several situations the highlighting tries to inform about
possible confusion, such as different colors for function names in
declarations depending on what they (do not) override, or special cases
m// and s/// which do not do what one would expect them to do.

Help with best setup of these faces for printout requested (for each of
the faces: please specify bold, italic, underline, shadow and box.)

In regular expressions (except character classes):
  `font-lock-string-face'	\"Normal\" stuff and non-0-length constructs
  `font-lock-constant-face':	Delimiters
  `font-lock-warning-face'	Special-cased m// and s//foo/,
				Mismatched closing delimiters, parens
				we couldn't match, misplaced quantifiers,
				unrecognized escape sequences
  `cperl-nonoverridable-face'	Modifiers, as gism in m/REx/gism
  `font-lock-type-face'		POSIX classes inside charclasses,
				escape sequences with arguments (\x \23 \p \N)
				and others match-a-char escape sequences
  `font-lock-keyword-face'	Capturing parens, and |
  `font-lock-function-name-face' Special symbols: $ ^ . [ ] [^ ] (?{ }) (??{ })
  `font-lock-builtin-face'	\"Remaining\" 0-length constructs, executable
				parts of a REx, not-capturing parens
  `font-lock-variable-name-face' Interpolated constructs, embedded code
  `font-lock-comment-face'	Embedded comments

")



(defsubst cperl-put-do-not-fontify (from to &optional post)
  ;; If POST, do not do it with postponed fontification
  (if (and post cperl-syntaxify-by-font-lock)
      nil
  (put-text-property (max (point-min) (1- from))
		       to cperl-do-not-fontify t)))

(defcustom cperl-mode-hook nil
  "Hook run by CPerl mode."
  :type 'hook

  (modify-syntax-entry ?| "." cperl-mode-syntax-table)
  (setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table))
  (modify-syntax-entry ?$ "." cperl-string-syntax-table)
  (modify-syntax-entry ?\{ "." cperl-string-syntax-table)
  (modify-syntax-entry ?\} "." cperl-string-syntax-table)
  (modify-syntax-entry ?# "." cperl-string-syntax-table)) ; (?# comment )



(defvar cperl-faces-init nil)

\(both available from menu).  See examples in `cperl-style-examples'.

Part of the indentation style is how different parts of if/elsif/else
statements are broken into lines; in CPerl, this is reflected on how
templates for these constructs are created (controlled by
`cperl-extra-newline-before-brace'), and how reflow-logic should treat \"continuation\" blocks of else/elsif/continue, controlled by the same variable,
and by `cperl-extra-newline-before-brace-multiline',
`cperl-merge-trailing-else', `cperl-indent-region-fix-constructs'.

If `cperl-indent-level' is 0, the statement after opening brace in
column 0 is indented on
`cperl-brace-offset'+`cperl-continued-statement-offset'.

  (cond ((boundp 'compilation-error-regexp-alist-alist);; xemacs 20.x
	 (make-local-variable 'compilation-error-regexp-alist-alist)
	 (set 'compilation-error-regexp-alist-alist
	      (cons (cons 'cperl (car cperl-compilation-error-regexp-alist))
		    (symbol-value 'compilation-error-regexp-alist-alist)))
         (if (fboundp 'compilation-build-compilation-error-regexp-alist)
             (let ((f 'compilation-build-compilation-error-regexp-alist))
               (funcall f))
           (make-local-variable 'compilation-error-regexp-alist)
           (push 'cperl compilation-error-regexp-alist)))
	((boundp 'compilation-error-regexp-alist);; xmeacs 19.x
	 (make-local-variable 'compilation-error-regexp-alist)
	 (set 'compilation-error-regexp-alist
	       (append cperl-compilation-error-regexp-alist
		       (symbol-value 'compilation-error-regexp-alist)))))

	  (goto-char insertpos)
	  (self-insert-command (prefix-numeric-value arg)))
      (self-insert-command (prefix-numeric-value arg)))))

(defun cperl-electric-backspace (arg)
  "Backspace, or remove the whitespace around the point inserted by an electric
key.  Will untabify if `cperl-electric-backspace-untabify' is non-nil."
  (interactive "p")
  (if (and cperl-auto-newline
	   (memq last-command '(cperl-electric-semi
				cperl-electric-terminator
				cperl-electric-lbrace))

;;;	(t (or (previous-single-property-change p look-prop lim)
;;;	       (point-min))))
  )

(defun cperl-sniff-for-indent (&optional parse-data) ; was parse-start
  ;; Old workhorse for calculation of indentation; the major problem
  ;; is that it mixes the sniffer logic to understand what the current line
  ;; MEANS with the logic to actually calculate where to indent it.
  ;; The latter part should be eventually moved to `cperl-calculate-indent';
  ;; actually, this is mostly done now...
  (cperl-update-syntaxification (point) (point))
  (let ((res (get-text-property (point) 'syntax-type)))
    (save-excursion
      (cond
       ((and (memq res '(pod here-doc here-doc-delim format))

		(modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st)
		(if ender (modify-syntax-entry ender "." st))
		(setq set-st nil)
		(setq ender (cperl-forward-re lim end nil st-l err-l
					      argument starter ender)
		 ender (nth 2 ender)))))
      (error (goto-char lim)
	     (setq set-st nil)
	     (if reset-st
		 (set-syntax-table reset-st))
	     (or end
		 (message
		  "End of `%s%s%c ... %c' string/RE not found: %s"
		  argument
		  (if ostart (format "%c ... %c" ostart (or oend ostart)) "")
		  starter (or ender starter) bb)

			  (1- e) t))	; return nil on failure, no moving
      (if (eq ?\{ (preceding-char)) nil
	(cperl-postpone-fontification
	 (1- (point)) (point)
	 'face font-lock-warning-face))))

;;; Debugging this may require (setq max-specpdl-size 2000)...
(defun cperl-find-pods-heres (&optional min max non-inter end ignore-max end-of-here-doc)
  "Scans the buffer for hard-to-parse Perl constructions.
If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify

				  (cperl-postpone-fontification
				   (1- REx-subgr-start) (point)
				   'face my-cperl-REx-length1-face))))
			      (setq was-subgr nil)) ; We do stuff here
			     ((match-beginning 3) ; [charclass]
			      (forward-char 1)
			      (if (eq (char-after b) ?^ )
				  (and (eq (following-char) ?\\ )
				       (eq (char-after (cperl-1+ (point)))
					   ?^ )
				       (forward-char 2))
				(and (eq (following-char) ?^ )
				     (forward-char 1)))
			      (setq argument b ; continue?
				    tag nil ; list of POSIX classes
				    qtag (point))
			      (if (eq (char-after b) ?\] )
				  (and (eq (following-char) ?\\ )
				       (eq (char-after (cperl-1+ (point)))
					   ?\] )
				       (setq qtag (1+ qtag))
				       (forward-char 2))
				(and (eq (following-char) ?\] )
				     (forward-char 1)))
			      ;; Apparently, I can't put \] into a charclass
			      ;; in m]]: m][\\\]\]] produces [\\]]
;;; POSIX?  [:word:] [:^word:] only inside []
;;;				       "\\=\\(\\\\.\\|[^][\\\\]\\|\\[:\\^?\sw+:]\\|\\[[^:]\\)*]")
			      (while
				  (and argument
				       (re-search-forward
					(if (eq (char-after b) ?\] )
					    "\\=\\(\\\\[^]]\\|[^]\\\\]\\)*\\\\]"
					  "\\=\\(\\\\.\\|[^]\\\\]\\)*]")

				;; Is this ] an end of POSIX class?
				(if (save-excursion
				      (and
				       (search-backward "[" argument t)
				       (< REx-subgr-start (point))
				       (not
					(and ; Should work with delim = \
					 (eq (preceding-char) ?\\ )
					 (= (% (skip-chars-backward
						"\\\\") 2) 0)))
				       (looking-at
					(cond
					 ((eq (char-after b) ?\] )
					  "\\\\*\\[:\\^?\\sw+:\\\\\\]")
					 ((eq (char-after b) ?\: )

					  (concat
					   "\\\\*\\[:\\(\\\\\\^\\)?\\(\\\\"
					   (char-to-string (char-after b))
					   "\\|\\sw\\)+:\]"))
					 (t "\\\\*\\[:\\^?\\sw*:]")))
				       (setq argument (point))))
				    (setq tag (cons (cons argument (point))
						    tag)
					  argument (point)) ; continue
				  (setq argument nil)))
			      (and argument
				   (message "Couldn't find end of charclass in a REx, pos=%s"
					    REx-subgr-start))
			      (if (and cperl-use-syntax-table-text-property
				       (> (- (point) 2) REx-subgr-start))
				  (put-text-property
				   (1+ REx-subgr-start) (1- (point))
				   'syntax-table cperl-st-punct))

				   (- (point) 2) (1- (point))
				   'face my-cperl-REx-0length-face))
			      (while tag
				(cperl-postpone-fontification
				 (car (car tag)) (cdr (car tag))
				 'face my-cperl-REx-length1-face)
				(setq tag (cdr tag)))
			      (setq was-subgr nil)) ; did facing already
			     ;; Now rare stuff:
			     ((and (match-beginning 2) ; #-comment
				   (/= (match-beginning 2) (match-end 2)))

			       REx-subgr-start REx-subgr-end
			       'face font-lock-comment-face))))))
		    (if (and is-REx is-x-REx)
			(put-text-property (1+ b) (1- e)
					   'syntax-subtype 'x-REx)))
		  (if (and i2 e1 b1 (> e1 b1))
		      (progn		; No errors finding the second part...
			(cperl-postpone-fontification
			 (1- e1) e1 'face my-cperl-delimiters-face)
			(if (and (not (eobp))
				 (assoc (char-after b) cperl-starters))

	       (setq empty (looking-at "[ \t]*\n"))
	       (and (setq comm (looking-at "[ \t]*#"))
		    (or (eq (current-indentation) (or old-comm-indent
						      comment-column))
			(setq old-comm-indent nil))))
	    (if (and old-comm-indent
		       (not empty)
		     (= (current-indentation) old-comm-indent)
		       (not (eq (get-text-property (point) 'syntax-type) 'pod))
		       (not (eq (get-text-property (point) 'syntax-table)
				cperl-st-cfence)))
		  (let ((comment-column new-comm-indent))
		    (indent-for-comment)))
	    (progn
	      (setq i (cperl-indent-line indent-info))
	    (or comm
		(not i)
		(progn
		  (if cperl-indent-region-fix-constructs
			(goto-char (cperl-fix-line-spacing end indent-info)))
		    (if (setq old-comm-indent
			      (and (cperl-to-comment-or-eol)
				   (not (memq (get-text-property (point)
								 'syntax-type)
					      '(pod here-doc)))
				   (not (eq (get-text-property (point)
							       'syntax-table)
					    cperl-st-cfence))
				 (current-column)))
		      (progn (indent-for-comment)
			     (skip-chars-backward " \t")
			     (skip-chars-backward "#")
			     (setq new-comm-indent (current-column))))))))
	(beginning-of-line 2)))
      ;; Now run the update hooks
      (and after-change-functions
	   cperl-update-end
	   (save-excursion
	     (goto-char cperl-update-end)

	 (save-excursion
	   (while (progn (forward-line 1)
			 (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]")))
	   (point)))
	;; Remove existing hashes
	(save-excursion
	(goto-char (point-min))
	(while (progn (forward-line 1) (< (point) (point-max)))
	  (skip-chars-forward " \t")
	  (if (looking-at "#+")
	      (progn
		(if (and (eq (point) (match-beginning 0))
			 (not (eq (point) (match-end 0)))) nil
		    (error
 "Bug in Emacs: `looking-at' in `narrow-to-region': match-data is garbage"))
		(delete-char (- (match-end 0) (match-beginning 0)))))))

	;; Lines with only hashes on them can be paragraph boundaries.

	  (if (fboundp 'font-lock-fontify-anchored-keywords)
	      (setq font-lock-anchored t))
	  (setq
	   t-font-lock-keywords
	   (list
	    `("[ \t]+$" 0 ',cperl-invalid-face t)
	    (cons
	     (concat
	      "\\(^\\|[^$@%&\\]\\)\\<\\("
	      (mapconcat
	       'identity

	(setq cperl-hierarchy (list l1 l2 l3))
	(if (featurep 'xemacs)		; Not checked
	    (progn
	      (or tags-file-name
		  ;; Does this work in XEmacs?
	    (call-interactively 'visit-tags-table))
	(message "Updating list of classes...")
	      (set-buffer (get-file-buffer tags-file-name))
	      (cperl-tags-hier-fill))
	  (or tags-table-list
	      (call-interactively 'visit-tags-table))
	  (mapc
	   (function
	    (lambda (tagsfile)
	      (message "Updating list of classes... %s" tagsfile)
	    (set-buffer (get-file-buffer tagsfile))
	    (cperl-tags-hier-fill)))
	   tags-table-list)
	  (message "Updating list of classes... postprocessing..."))
	(mapc remover (car cperl-hierarchy))
	(mapc remover (nth 1 cperl-hierarchy))
	(setq to (list nil (cons "Packages: " (nth 1 cperl-hierarchy))

  ;; EMBED is nil if we process the whole REx.
  ;; The REx is guaranteed to have //x
  ;; LEVEL shows how many levels deep to go
  ;; position at enter and at leave is not defined
  (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline code pos)
    (if (not embed)
	(goto-char (1+ b))
      (goto-char b)
      (cond ((looking-at "(\\?\\\\#")	;  (?#) wrongly commented when //x-ing
	     (forward-char 2)
	     (delete-char 1)
	     (forward-char 1))
	    ((looking-at "(\\?[^a-zA-Z]")
	     (forward-char 3))
	    ((looking-at "(\\?")	; (?i)
	     (forward-char 2))
	    (t
	     (forward-char 1))))
    (setq c (if embed (current-indentation) (1- (current-column)))
	  c1 (+ c (or cperl-regexp-indent-step cperl-indent-level)))
    (or (looking-at "[ \t]*[\n#]")
	(progn
	  (insert "\n")))
    (goto-char e)
    (beginning-of-line)

    (or cperl-use-syntax-table-text-property
	(error "I need to have a regexp marked!"))
    ;; Find the start
    (if (looking-at "\\s|")
	nil				; good already
      (if (looking-at "\\([smy]\\|qr\\)\\s|")
	  (forward-char 1)
	(re-search-backward "\\s|")))	; Assume it is scanned already.
    ;;(forward-char 1)
    (let ((b (point)) (e (make-marker)) have-x delim (c (current-column))
	  (sub-p (eq (preceding-char) ?s)) s)
      (forward-sexp 1)

  (save-excursion
    (cperl-regext-to-level-start)
    (let ((b (point)) (e (make-marker)))
      (forward-sexp 1)
      (set-marker e (1- (point)))
      (cperl-beautify-regexp-piece b e nil deep))))

(defun cperl-invert-if-unless-modifiers ()
  "Change `B if A;' into `if (A) {B}' etc if possible.
\(Unfinished.)"
  (interactive)				;
  (let (A B pre-B post-B pre-if post-if pre-A post-A if-string
	  (w-rex "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>"))
    (and (= (char-syntax (preceding-char)) ?w)
	 (forward-sexp -1))
    (setq pre-if (point))

		   (string-match "^[a-z]+$" word)
		   (string-match (concat "^" word "\\>")
				 (documentation-property
				  'cperl-short-docs
				  'variable-documentation))))
	 (manual-program (if is-func "perldoc -f" "perldoc")))
    (cond
     ((featurep 'xemacs)
      (let ((Manual-program "perldoc")
	    (Manual-switches (if is-func (list "-f"))))

  (cond
   ((featurep 'xemacs)
    (let ((Manual-program "perldoc"))
      (manual-entry buffer-file-name)))
   (t
    (let* ((manual-program "perldoc"))
      (Man-getpage-in-background buffer-file-name)))))

(defun cperl-pod2man-build-command ()
  "Builds the entire background manpage and cleaning command."
  (let ((command (concat pod2man-program " %s 2>/dev/null"))

	(save-excursion
	  (goto-char from)
	  (cperl-fontify-syntaxically to)))))

(defvar cperl-version
  (let ((v  "Revision: 5.23"))
    (string-match ":\\s *\\([0-9.]+\\)" v)
    (substring v (match-beginning 1) (match-end 1)))
  "Version of IZ-supported CPerl package this file is based on.")

(provide 'cperl-mode)

104310:2ecd57cadf51

  '((font-lock-keyword-face		nil nil		bold shadow)
    (font-lock-variable-name-face	nil nil		bold)
    (font-lock-function-name-face	nil nil		bold italic box)
    (font-lock-constant-face		nil "LightGray"	bold)
    (cperl-array-face			nil "LightGray"	bold underline)
    (cperl-hash-face			nil "LightGray"	bold italic underline)
    (font-lock-comment-face		nil "LightGray"	italic)
    (font-lock-string-face		nil nil		italic underline)
    (cperl-nonoverridable-face		nil nil		italic underline)
    (font-lock-type-face		nil nil		underline)
    (font-lock-warning-face		nil "LightGray"	bold italic box)

				and whatever is syntaxically considered
				as string literals
  `font-lock-type-face'		Overridable keywords
  `font-lock-variable-name-face' Variable declarations, indirect array and
				hash names, POD headers/item names
  `cperl-invalid-face'		Trailing whitespace

Note that in several situations the highlighting tries to inform about
possible confusion, such as different colors for function names in
declarations depending on what they (do not) override, or special cases
m// and s/// which do not do what one would expect them to do.

Help with best setup of these faces for printout requested (for each of
the faces: please specify bold, italic, underline, shadow and box.)

In regular expressions (including character classes):
  `font-lock-string-face'	\"Normal\" stuff and non-0-length constructs
  `font-lock-constant-face':	Delimiters
  `font-lock-warning-face'	Special-cased m// and s//foo/,
				Mismatched closing delimiters, parens
				we couldn't match, misplaced quantifiers,
				unrecognized escape sequences
  `cperl-nonoverridable-face'	Modifiers, as gism in m/REx/gism
  `font-lock-type-face'		escape sequences with arguments (\\x \\23 \\p \\N)
				and others match-a-char escape sequences
  `font-lock-keyword-face'	Capturing parens, and |
  `font-lock-function-name-face' Special symbols: $ ^ . [ ] [^ ] (?{ }) (??{ })
				\"Range -\" in character classes
  `font-lock-builtin-face'	\"Remaining\" 0-length constructs, multipliers
				?+*{}, not-capturing parens, leading
				backslashes of escape sequences
  `font-lock-variable-name-face' Interpolated constructs, embedded code,
				POSIX classes (inside charclasses)
  `font-lock-comment-face'	Embedded comments

")



(defsubst cperl-put-do-not-fontify (from to &optional post)
  ;; If POST, do not do it with postponed fontification
  (if (and post cperl-syntaxify-by-font-lock)
      nil
    (put-text-property (max (point-min) (1- from))
		       to cperl-do-not-fontify t)))

(defcustom cperl-mode-hook nil
  "Hook run by CPerl mode."
  :type 'hook

  (modify-syntax-entry ?| "." cperl-mode-syntax-table)
  (setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table))
  (modify-syntax-entry ?$ "." cperl-string-syntax-table)
  (modify-syntax-entry ?\{ "." cperl-string-syntax-table)
  (modify-syntax-entry ?\} "." cperl-string-syntax-table)
  (modify-syntax-entry ?\" "." cperl-string-syntax-table)
  (modify-syntax-entry ?' "." cperl-string-syntax-table)
  (modify-syntax-entry ?` "." cperl-string-syntax-table)
  (modify-syntax-entry ?# "." cperl-string-syntax-table)) ; (?# comment )



(defvar cperl-faces-init nil)

\(both available from menu).  See examples in `cperl-style-examples'.

Part of the indentation style is how different parts of if/elsif/else
statements are broken into lines; in CPerl, this is reflected on how
templates for these constructs are created (controlled by
`cperl-extra-newline-before-brace'), and how reflow-logic should treat
\"continuation\" blocks of else/elsif/continue, controlled by the same
variable, and by `cperl-extra-newline-before-brace-multiline',
`cperl-merge-trailing-else', `cperl-indent-region-fix-constructs'.

If `cperl-indent-level' is 0, the statement after opening brace in
column 0 is indented on
`cperl-brace-offset'+`cperl-continued-statement-offset'.

  (cond ((boundp 'compilation-error-regexp-alist-alist);; xemacs 20.x
	 (make-local-variable 'compilation-error-regexp-alist-alist)
	 (set 'compilation-error-regexp-alist-alist
	      (cons (cons 'cperl (car cperl-compilation-error-regexp-alist))
		    (symbol-value 'compilation-error-regexp-alist-alist)))
	 (if (fboundp 'compilation-build-compilation-error-regexp-alist)
	     (let ((f 'compilation-build-compilation-error-regexp-alist))
	       (funcall f))
	   (make-local-variable 'compilation-error-regexp-alist)
	   (push 'cperl compilation-error-regexp-alist)))
	((boundp 'compilation-error-regexp-alist);; xmeacs 19.x
	 (make-local-variable 'compilation-error-regexp-alist)
	 (set 'compilation-error-regexp-alist
	       (append cperl-compilation-error-regexp-alist
		       (symbol-value 'compilation-error-regexp-alist)))))

	  (goto-char insertpos)
	  (self-insert-command (prefix-numeric-value arg)))
      (self-insert-command (prefix-numeric-value arg)))))

(defun cperl-electric-backspace (arg)
  "Backspace, or remove whitespace around the point inserted by an electric key.
Will untabify if `cperl-electric-backspace-untabify' is non-nil."
  (interactive "p")
  (if (and cperl-auto-newline
	   (memq last-command '(cperl-electric-semi
				cperl-electric-terminator
				cperl-electric-lbrace))

;;;	(t (or (previous-single-property-change p look-prop lim)
;;;	       (point-min))))
  )

(defun cperl-sniff-for-indent (&optional parse-data) ; was parse-start
  ;; the sniffer logic to understand what the current line MEANS.
  (cperl-update-syntaxification (point) (point))
  (let ((res (get-text-property (point) 'syntax-type)))
    (save-excursion
      (cond
       ((and (memq res '(pod here-doc here-doc-delim format))

		(modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st)
		(if ender (modify-syntax-entry ender "." st))
		(setq set-st nil)
		(setq ender (cperl-forward-re lim end nil st-l err-l
					      argument starter ender)
		      ender (nth 2 ender)))))
      (error (goto-char lim)
	     (setq set-st nil)
	     (if reset-st
		 (set-syntax-table reset-st))
	     (or end
		 (and cperl-brace-recursing
		      (or (eq ostart  ?\{)
			  (eq starter ?\{)))
		 (message
		  "End of `%s%s%c ... %c' string/RE not found: %s"
		  argument
		  (if ostart (format "%c ... %c" ostart (or oend ostart)) "")
		  starter (or ender starter) bb)

			  (1- e) t))	; return nil on failure, no moving
      (if (eq ?\{ (preceding-char)) nil
	(cperl-postpone-fontification
	 (1- (point)) (point)
	 'face font-lock-warning-face))))

;; Do some smarter-highlighting
;; XXXX Currently ignores alphanum/dash delims,
(defsubst cperl-highlight-charclass (endbracket dashface bsface onec-space)
  (let ((l '(1 5 7)) ll lle lll
	;; 2 groups, the first takes the whole match (include \[trnfabe])
	(singleChar (concat "\\(" "[^\\\\]" "\\|" "\\\\[^cdg-mo-qsu-zA-Z0-9_]" "\\|" "\\\\c." "\\|" "\\\\x" "\\([0-9a-fA-F][0-9a-fA-F]?\\|\\={[0-9a-fA-F]+}\\)" "\\|" "\\\\0?[0-7][0-7]?[0-7]?" "\\|" "\\\\N{[^{}]*}" "\\)")))
    (while				; look for unescaped - between non-classes
	(re-search-forward
	 ;; On 19.33, certain simplifications lead
	 ;; to bugs (as in  [^a-z] \\| [trnfabe]  )
	 (concat	       		; 1: SingleChar (include \[trnfabe])
	  singleChar
	  ;;"\\(" "[^\\\\]" "\\|" "\\\\[^cdg-mo-qsu-zA-Z0-9_]" "\\|" "\\\\c." "\\|" "\\\\x" "\\([0-9a-fA-F][0-9a-fA-F]?\\|\\={[0-9a-fA-F]+}\\)" "\\|" "\\\\0?[0-7][0-7]?[0-7]?" "\\|" "\\\\N{[^{}]*}" "\\)"
	  "\\("				; 3: DASH SingleChar (match optionally)
	    "\\(-\\)"			; 4: DASH
	    singleChar			; 5: SingleChar
	    ;;"\\(" "[^\\\\]" "\\|" "\\\\[^cdg-mo-qsu-zA-Z0-9_]" "\\|" "\\\\c." "\\|" "\\\\x" "\\([0-9a-fA-F][0-9a-fA-F]?\\|\\={[0-9a-fA-F]+}\\)" "\\|" "\\\\0?[0-7][0-7]?[0-7]?" "\\|" "\\\\N{[^{}]*}" "\\)"
	  "\\)?"
	  "\\|"
	  "\\("				; 7: other escapes
	    "\\\\[pP]" "\\([^{]\\|{[^{}]*}\\)"
	    "\\|" "\\\\[^pP]" "\\)"
	  )
	 endbracket 'toend)
      (if (match-beginning 4)
	  (cperl-postpone-fontification
	   (match-beginning 4) (match-end 4)
	   'face dashface))
      ;; save match data (for looking-at)
      (setq lll (mapcar (function (lambda (elt) (cons (match-beginning elt)
						      (match-end elt)))) l))
      (while lll
	(setq ll (car lll))
	(setq lle (cdr ll)
	      ll (car ll))
	;; (message "Got %s of %s" ll l)
	(if (and ll (eq (char-after ll) ?\\ ))
	    (save-excursion
	      (goto-char ll)
	      (cperl-postpone-fontification ll (1+ ll)
	       'face bsface)
	      (if (looking-at "\\\\[a-zA-Z0-9]")
		  (cperl-postpone-fontification (1+ ll) lle
		   'face onec-space))))
	(setq lll (cdr lll))))
    (goto-char endbracket)		; just in case something misbehaves???
    t))

;;; Debugging this may require (setq max-specpdl-size 2000)...
(defun cperl-find-pods-heres (&optional min max non-inter end ignore-max end-of-here-doc)
  "Scans the buffer for hard-to-parse Perl constructions.
If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify

				  (cperl-postpone-fontification
				   (1- REx-subgr-start) (point)
				   'face my-cperl-REx-length1-face))))
			      (setq was-subgr nil)) ; We do stuff here
			     ((match-beginning 3) ; [charclass]
			      ;; Highlight leader, trailer, POSIX classes
			      (forward-char 1)
			      (if (eq (char-after b) ?^ )
				  (and (eq (following-char) ?\\ )
				       (eq (char-after (cperl-1+ (point)))
					   ?^ )
				       (forward-char 2))
				(and (eq (following-char) ?^ )
				     (forward-char 1)))
			      (setq argument b ; continue? & end of last POSIX
				    tag nil ; list of POSIX classes
				    qtag (point)) ; after leading ^ if present
			      (if (eq (char-after b) ?\] )
				  (and (eq (following-char) ?\\ )
				       (eq (char-after (cperl-1+ (point)))
					   ?\] )
				       (setq qtag (1+ qtag))
				       (forward-char 2))
				(and (eq (following-char) ?\] )
				     (forward-char 1)))
			      (setq REx-subgr-end qtag)	;EndOf smart-highlighed
			      ;; Apparently, I can't put \] into a charclass
			      ;; in m]]: m][\\\]\]] produces [\\]]
;;; POSIX?  [:word:] [:^word:] only inside []
;;;	       "\\=\\(\\\\.\\|[^][\\\\]\\|\\[:\\^?\sw+:]\\|\\[[^:]\\)*]")
			      (while	; look for unescaped ]
				  (and argument
				       (re-search-forward
					(if (eq (char-after b) ?\] )
					    "\\=\\(\\\\[^]]\\|[^]\\\\]\\)*\\\\]"
					  "\\=\\(\\\\.\\|[^]\\\\]\\)*]")

				;; Is this ] an end of POSIX class?
				(if (save-excursion
				      (and
				       (search-backward "[" argument t)
				       (< REx-subgr-start (point))
				       (setq argument (point)) ; POSIX-start
				       (or ; Should work with delim = \
					(not (eq (preceding-char) ?\\ ))
					;; XXXX Double \\ is needed with 19.33
					(= (% (skip-chars-backward "\\\\") 2) 0))
				       (looking-at
					(cond
					 ((eq (char-after b) ?\] )
					  "\\\\*\\[:\\^?\\sw+:\\\\\\]")
					 ((eq (char-after b) ?\: )

					  (concat
					   "\\\\*\\[:\\(\\\\\\^\\)?\\(\\\\"
					   (char-to-string (char-after b))
					   "\\|\\sw\\)+:\]"))
					 (t "\\\\*\\[:\\^?\\sw*:]")))
				       (goto-char REx-subgr-end)
				       (cperl-highlight-charclass
					argument my-cperl-REx-spec-char-face
					my-cperl-REx-0length-face my-cperl-REx-length1-face)))
				    (setq tag (cons (cons argument (point))
						    tag)
					  argument (point)
					  REx-subgr-end argument) ; continue
				  (setq argument nil)))
			      (and argument
				   (message "Couldn't find end of charclass in a REx, pos=%s"
					    REx-subgr-start))
			      (setq argument (1- (point)))
			      (goto-char REx-subgr-end)
			      (cperl-highlight-charclass
			       argument my-cperl-REx-spec-char-face
			       my-cperl-REx-0length-face my-cperl-REx-length1-face)
			      (forward-char 1)
			      ;; Highlight starter, trailer, POSIX
			      (if (and cperl-use-syntax-table-text-property
				       (> (- (point) 2) REx-subgr-start))
				  (put-text-property
				   (1+ REx-subgr-start) (1- (point))
				   'syntax-table cperl-st-punct))

				   (- (point) 2) (1- (point))
				   'face my-cperl-REx-0length-face))
			      (while tag
				(cperl-postpone-fontification
				 (car (car tag)) (cdr (car tag))
				 'face font-lock-variable-name-face) ;my-cperl-REx-length1-face
				(setq tag (cdr tag)))
			      (setq was-subgr nil)) ; did facing already
			     ;; Now rare stuff:
			     ((and (match-beginning 2) ; #-comment
				   (/= (match-beginning 2) (match-end 2)))

			       REx-subgr-start REx-subgr-end
			       'face font-lock-comment-face))))))
		    (if (and is-REx is-x-REx)
			(put-text-property (1+ b) (1- e)
					   'syntax-subtype 'x-REx)))
		  (if (and i2 e1 (or (not b1) (> e1 b1)))
		      (progn		; No errors finding the second part...
			(cperl-postpone-fontification
			 (1- e1) e1 'face my-cperl-delimiters-face)
			(if (and (not (eobp))
				 (assoc (char-after b) cperl-starters))

	       (setq empty (looking-at "[ \t]*\n"))
	       (and (setq comm (looking-at "[ \t]*#"))
		    (or (eq (current-indentation) (or old-comm-indent
						      comment-column))
			(setq old-comm-indent nil))))
	      (if (and old-comm-indent
		       (not empty)
		       (= (current-indentation) old-comm-indent)
		       (not (eq (get-text-property (point) 'syntax-type) 'pod))
		       (not (eq (get-text-property (point) 'syntax-table)
				cperl-st-cfence)))
		  (let ((comment-column new-comm-indent))
		    (indent-for-comment)))
	    (progn
	      (setq i (cperl-indent-line indent-info))
	      (or comm
		  (not i)
		  (progn
		    (if cperl-indent-region-fix-constructs
			(goto-char (cperl-fix-line-spacing end indent-info)))
		    (if (setq old-comm-indent
			      (and (cperl-to-comment-or-eol)
				   (not (memq (get-text-property (point)
								 'syntax-type)
					      '(pod here-doc)))
				   (not (eq (get-text-property (point)
							       'syntax-table)
					    cperl-st-cfence))
				   (current-column)))
			(progn (indent-for-comment)
			       (skip-chars-backward " \t")
			       (skip-chars-backward "#")
			       (setq new-comm-indent (current-column))))))))
	  (beginning-of-line 2)))
      ;; Now run the update hooks
      (and after-change-functions
	   cperl-update-end
	   (save-excursion
	     (goto-char cperl-update-end)

	 (save-excursion
	   (while (progn (forward-line 1)
			 (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]")))
	   (point)))
	;; Remove existing hashes
	(goto-char (point-min))
	(save-excursion
	  (while (progn (forward-line 1) (< (point) (point-max)))
	    (skip-chars-forward " \t")
	    (if (looking-at "#+")
		(progn
		  (if (and (eq (point) (match-beginning 0))
			   (not (eq (point) (match-end 0)))) nil
		    (error
 "Bug in Emacs: `looking-at' in `narrow-to-region': match-data is garbage"))
		(delete-char (- (match-end 0) (match-beginning 0)))))))

	;; Lines with only hashes on them can be paragraph boundaries.

	  (if (fboundp 'font-lock-fontify-anchored-keywords)
	      (setq font-lock-anchored t))
	  (setq
	   t-font-lock-keywords
	   (list
	    (list "[ \t]+$" 0 cperl-invalid-face t)
	    (cons
	     (concat
	      "\\(^\\|[^$@%&\\]\\)\\<\\("
	      (mapconcat
	       'identity

	(setq cperl-hierarchy (list l1 l2 l3))
	(if (featurep 'xemacs)		; Not checked
	    (progn
	      (or tags-file-name
		  ;; Does this work in XEmacs?
		  (call-interactively 'visit-tags-table))
	      (message "Updating list of classes...")
	      (set-buffer (get-file-buffer tags-file-name))
	      (cperl-tags-hier-fill))
	  (or tags-table-list
	      (call-interactively 'visit-tags-table))
	  (mapc
	   (function
	    (lambda (tagsfile)
	      (message "Updating list of classes... %s" tagsfile)
	      (set-buffer (get-file-buffer tagsfile))
	      (cperl-tags-hier-fill)))
	   tags-table-list)
	  (message "Updating list of classes... postprocessing..."))
	(mapc remover (car cperl-hierarchy))
	(mapc remover (nth 1 cperl-hierarchy))
	(setq to (list nil (cons "Packages: " (nth 1 cperl-hierarchy))

  ;; EMBED is nil if we process the whole REx.
  ;; The REx is guaranteed to have //x
  ;; LEVEL shows how many levels deep to go
  ;; position at enter and at leave is not defined
  (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline code pos)
    (if embed
	(progn
	  (goto-char b)
	  (setq c (if (eq embed t) (current-indentation) (current-column)))
	  (cond ((looking-at "(\\?\\\\#") ; (?#) wrongly commented when //x-ing
		 (forward-char 2)
		 (delete-char 1)
		 (forward-char 1))
		((looking-at "(\\?[^a-zA-Z]")
		 (forward-char 3))
		((looking-at "(\\?")	; (?i)
		 (forward-char 2))
		(t
		 (forward-char 1))))
      (goto-char (1+ b))
      (setq c (1- (current-column))))
    (setq c1 (+ c (or cperl-regexp-indent-step cperl-indent-level)))
    (or (looking-at "[ \t]*[\n#]")
	(progn
	  (insert "\n")))
    (goto-char e)
    (beginning-of-line)

    (or cperl-use-syntax-table-text-property
	(error "I need to have a regexp marked!"))
    ;; Find the start
    (if (looking-at "\\s|")
	nil				; good already
      (if (or (looking-at "\\([smy]\\|qr\\)\\s|")
	      (and (eq (preceding-char) ?q)
		   (looking-at "\\(r\\)\\s|")))
	  (goto-char (match-end 1))
	(re-search-backward "\\s|")))	; Assume it is scanned already.
    ;;(forward-char 1)
    (let ((b (point)) (e (make-marker)) have-x delim (c (current-column))
	  (sub-p (eq (preceding-char) ?s)) s)
      (forward-sexp 1)

  (save-excursion
    (cperl-regext-to-level-start)
    (let ((b (point)) (e (make-marker)))
      (forward-sexp 1)
      (set-marker e (1- (point)))
      (cperl-beautify-regexp-piece b e 'level deep))))

(defun cperl-invert-if-unless-modifiers ()
  "Change `B if A;' into `if (A) {B}' etc if possible.
\(Unfinished.)"
  (interactive)
  (let (A B pre-B post-B pre-if post-if pre-A post-A if-string
	  (w-rex "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>"))
    (and (= (char-syntax (preceding-char)) ?w)
	 (forward-sexp -1))
    (setq pre-if (point))

		   (string-match "^[a-z]+$" word)
		   (string-match (concat "^" word "\\>")
				 (documentation-property
				  'cperl-short-docs
				  'variable-documentation))))
	 (Man-switches "")
	 (manual-program (if is-func "perldoc -f" "perldoc")))
    (cond
     ((featurep 'xemacs)
      (let ((Manual-program "perldoc")
	    (Manual-switches (if is-func (list "-f"))))

  (cond
   ((featurep 'xemacs)
    (let ((Manual-program "perldoc"))
      (manual-entry buffer-file-name)))
   (t
    (let* ((manual-program "perldoc")
	   (Man-switches ""))
      (Man-getpage-in-background buffer-file-name)))))

(defun cperl-pod2man-build-command ()
  "Builds the entire background manpage and cleaning command."
  (let ((command (concat pod2man-program " %s 2>/dev/null"))

	(save-excursion
	  (goto-char from)
	  (cperl-fontify-syntaxically to)))))

(defvar cperl-version
  (let ((v  "Revision: 6.2"))
    (string-match ":\\s *\\([0-9.]+\\)" v)
    (substring v (match-beginning 1) (match-end 1)))
  "Version of IZ-supported CPerl package this file is based on.")

(provide 'cperl-mode)