# HG changeset patch
# User Richard M. Stallman <rms@gnu.org>
# Date 915236165 0
# Node ID abc9bc6aef59603ec37e67d98d5ede892cf620bf
# Parent  12c74d5eff80c90f5ccfb1212f725fa1ff0ec908
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.

diff -r 12c74d5eff80 -r abc9bc6aef59 lisp/progmodes/cperl-mode.el
--- a/lisp/progmodes/cperl-mode.el	Sat Jan 02 00:14:41 1999 +0000
+++ b/lisp/progmodes/cperl-mode.el	Sat Jan 02 00:16:05 1999 +0000
@@ -62,6 +62,61 @@
 
 ;;; Code:
 
+;; Some macros are needed for `defcustom'
+(if (fboundp 'eval-when-compile)
+   (eval-when-compile
+      (defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version))
+      (defmacro cperl-is-face (arg)	; Takes quoted arg
+	    (cond ((fboundp 'find-face)
+		   (` (find-face (, arg))))
+		  (;;(and (fboundp 'face-list)
+		   ;;	(face-list))
+		   (fboundp 'face-list)
+		   (` (member (, arg) (and (fboundp 'face-list)
+					   (face-list)))))
+		  (t
+		   (` (boundp (, arg))))))
+      (defmacro cperl-make-face (arg descr) ; Takes unquoted arg
+	(cond ((fboundp 'make-face)
+	       (` (make-face (quote (, arg)))))
+	      (t
+	       (` (defconst (, arg) (quote (, arg)) (, descr))))))
+      (defmacro cperl-force-face (arg descr) ; Takes unquoted arg
+	(` (progn
+	     (or (cperl-is-face (quote (, arg)))
+		 (cperl-make-face (, arg) (, descr)))
+	     (or (boundp (quote (, arg))) ; We use unquoted variants too
+		 (defconst (, arg) (quote (, arg)) (, descr))))))
+      (if cperl-xemacs-p
+	  (defmacro cperl-etags-snarf-tag (file line)
+	    (` (progn
+		 (beginning-of-line 2)
+		 (list (, file) (, line)))))
+	(defmacro cperl-etags-snarf-tag (file line)
+	  (` (etags-snarf-tag))))
+      (if cperl-xemacs-p
+	  (defmacro cperl-etags-goto-tag-location (elt)
+	    (` ;;(progn
+		 ;; (switch-to-buffer (get-file-buffer (elt (, elt) 0)))
+		 ;; (set-buffer (get-file-buffer (elt (, elt) 0)))
+		 ;; Probably will not work due to some save-excursion???
+		 ;; Or save-file-position?
+		 ;; (message "Did I get to line %s?" (elt (, elt) 1))
+		 (goto-line (string-to-int (elt (, elt) 1)))))
+	    ;;)
+	(defmacro cperl-etags-goto-tag-location (elt)
+	  (` (etags-goto-tag-location (, elt)))))))
+
+(defun cperl-choose-color (&rest list)
+  (let (answer)
+    (while list
+      (or answer
+	  (if (or (x-color-defined-p (car list))
+		  (null (cdr list)))
+	      (setq answer (car list))))
+      (setq list (cdr list)))
+    answer))
+
 (defgroup cperl nil
   "Major mode for editing Perl code."
   :prefix "cperl-"
@@ -257,6 +312,16 @@
   :type '(repeat (list symbol string))
   :group 'cperl)
 
+(defcustom cperl-clobber-mode-lists 
+  (not
+   (and
+    (boundp 'interpreter-mode-alist)
+    (assoc "miniperl" interpreter-mode-alist)
+    (assoc "\\.\\([pP][Llm]\\|al\\)$" auto-mode-alist)))
+  "*Whether to install us into `interpreter-' and `extension' mode lists."
+  :type 'boolean
+  :group 'cperl)
+
 (defcustom cperl-info-on-command-no-prompt nil
   "*Not-nil (and non-null) means not to prompt on C-h f.
 The opposite behaviour is always available if prefixed with C-c.
@@ -293,11 +358,21 @@
   :type 'face
   :group 'cperl-faces)
 
+(defcustom cperl-invalid-face ''underline ; later evaluated by `font-lock'
+  "*The result of evaluation of this expression highlights trailing whitespace."
+  :type 'face
+  :group 'cperl-faces)
+
 (defcustom cperl-pod-here-fontify '(featurep 'font-lock)
   "*Not-nil after evaluation means to highlight pod and here-docs sections."
   :type 'boolean
   :group 'cperl-faces)
 
+(defcustom cperl-fontify-m-as-s t
+  "*Not-nil means highlight 1arg regular expressions operators same as 2arg."
+  :type 'boolean
+  :group 'cperl-faces)
+
 (defcustom cperl-pod-here-scan t
   "*Not-nil means look for pod and here-docs sections during startup.
 You can always make lookup from menu or using \\[cperl-find-pods-heres]."
@@ -401,12 +476,86 @@
   :type 'boolean
   :group 'cperl-indentation-details)
 
-(defcustom cperl-syntaxify-by-font-lock nil
+(defcustom cperl-syntaxify-by-font-lock 
+  (and window-system 
+       (boundp 'parse-sexp-lookup-properties))
   "*Non-nil means that CPerl uses `font-lock's routines for syntaxification.
-Not debugged yet."
+Having it TRUE may be not completely debugged yet."
+  :type '(choice (const message) boolean)
+  :group 'cperl-speed)
+
+(defcustom cperl-syntaxify-unwind
+  t
+  "*Non-nil means that CPerl unwinds to a start of along construction
+when syntaxifying a chunk of buffer."
   :type 'boolean
   :group 'cperl-speed)
 
+(defcustom cperl-ps-print-face-properties
+  '((font-lock-keyword-face		nil nil		bold shadow)
+    (font-lock-variable-name-face	nil nil		bold)
+    (font-lock-function-name-face	nil nil		bold italic box)
+    (font-lock-constant-face		nil "LightGray"	bold)
+    (cperl-array-face			nil "LightGray"	bold underline)
+    (cperl-hash-face			nil "LightGray"	bold italic underline)
+    (font-lock-comment-face		nil "LightGray"	italic)
+    (font-lock-string-face		nil nil		italic underline)
+    (cperl-nonoverridable-face		nil nil		italic underline)
+    (font-lock-type-face		nil nil		underline)
+    (underline				nil "LightGray"	strikeout))
+  "List given as an argument to `ps-extend-face-list' in `cperl-ps-print'."
+  :type '(repeat (cons symbol 
+		       (cons (choice (const nil) string)
+			     (cons (choice (const nil) string)
+				   (repeat symbol)))))
+  :group 'cperl-faces)
+
+(if window-system
+    (progn
+      (defvar cperl-dark-background 
+	(cperl-choose-color "navy" "os2blue" "darkgreen"))
+      (defvar cperl-dark-foreground 
+	(cperl-choose-color "orchid1" "orange"))
+
+      (defface cperl-nonoverridable-face
+	(` ((((class grayscale) (background light))
+	     (:background "Gray90" :italic t :underline t))
+	    (((class grayscale) (background dark))
+	     (:foreground "Gray80" :italic t :underline t :bold t))
+	    (((class color) (background light)) 
+	     (:foreground "chartreuse3"))
+	    (((class color) (background dark)) 
+	     (:foreground (, cperl-dark-foreground)))
+	    (t (:bold t :underline t))))
+	"Font Lock mode face used to highlight array names."
+	:group 'cperl-faces)
+
+      (defface cperl-array-face
+	(` ((((class grayscale) (background light))
+	     (:background "Gray90" :bold t))
+	    (((class grayscale) (background dark))
+	     (:foreground "Gray80" :bold t))
+	    (((class color) (background light)) 
+	     (:foreground "Blue" :background "lightyellow2" :bold t))
+	    (((class color) (background dark)) 
+	     (:foreground "yellow" :background (, cperl-dark-background) :bold t))
+	    (t (:bold t))))
+	"Font Lock mode face used to highlight array names."
+	:group 'cperl-faces)
+
+      (defface cperl-hash-face
+	(` ((((class grayscale) (background light))
+	     (:background "Gray90" :bold t :italic t))
+	    (((class grayscale) (background dark))
+	     (:foreground "Gray80" :bold t :italic t))
+	    (((class color) (background light)) 
+	     (:foreground "Red" :background "lightyellow2" :bold t :italic t))
+	    (((class color) (background dark)) 
+	     (:foreground "Red" :background (, cperl-dark-background) :bold t :italic t))
+	    (t (:bold t :italic t))))
+	"Font Lock mode face used to highlight hash names."
+	:group 'cperl-faces)))
+
 
 
 ;;; Short extra-docs.
@@ -419,6 +568,13 @@
 Subdirectory `cperl-mode' may contain yet newer development releases and/or
 patches to related files.
 
+For best results apply to an older Emacs the patches from
+  ftp://ftp.math.ohio-state.edu/pub/users/ilya/cperl-mode/patches
+\(this upgrades syntax-parsing abilities of RMS Emaxen v19.34 and 
+v20.2 up to the level of RMS Emacs v20.3 - a must for a good Perl
+mode.)  You will not get much from XEmacs, it's syntax abilities are
+too primitive.
+
 Get support packages choose-color.el (or font-lock-extra.el before
 19.30), imenu-go.el from the same place.  \(Look for other files there
 too... ;-).  Get a patch for imenu.el in 19.29.  Note that for 19.30 and
@@ -434,27 +590,41 @@
   http://www.metronet.com:70/9/perlinfo/perl5/manual/perl5-info.tar.gz
 
 If you use imenu-go, run imenu on perl5-info buffer (you can do it
-from CPerl menu).  If many files are related, generate TAGS files from
-Tools/Tags submenu in CPerl menu.
+from Perl menu).  If many files are related, generate TAGS files from
+Tools/Tags submenu in Perl menu.
 
 If some class structure is too complicated, use Tools/Hierarchy-view
-from CPerl menu, or hierarchic view of imenu. The second one uses the
+from Perl menu, or hierarchic view of imenu. The second one uses the
 current buffer only, the first one requires generation of TAGS from
-CPerl/Tools/Tags menu beforehand.
-
-Run CPerl/Tools/Insert-spaces-if-needed to fix your lazy typing.
-
-Switch auto-help on/off with CPerl/Tools/Auto-help.
-
-Before reporting (non-)problems look in the problem section on what I
-know about them.")
+Perl/Tools/Tags menu beforehand.
+
+Run Perl/Tools/Insert-spaces-if-needed to fix your lazy typing.
+
+Switch auto-help on/off with Perl/Tools/Auto-help.
+
+Though with contemporary Emaxen CPerl mode should maintain the correct
+parsing of Perl even when editing, sometimes it may be lost.  Fix this by
+
+  M-x norm RET
+
+In cases of more severe confusion sometimes it is helpful to do
+
+  M-x load-l RET cperl-mode RET
+  M-x norm RET
+
+Before reporting (non-)problems look in the problem section of online
+micro-docs on what I know about CPerl problems.")
 
 (defvar cperl-problems 'please-ignore-this-line
 "Some faces will not be shown on some versions of Emacs unless you
 install choose-color.el, available from
    ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs/
 
-Even with newer Emacsen interaction of `font-lock' and
+Emacs had a _very_ restricted syntax parsing engine until RMS's Emacs
+20.1.  Most problems below are corrected starting from this version of
+Emacs, and all of them should go with (future) RMS's version 20.3.
+
+Note that even with newer Emacsen interaction of `font-lock' and
 syntaxification is not cleaned up.  You may get slightly different
 colors basing on the order of fontification and syntaxification.  This
 might be corrected by setting `cperl-syntaxify-by-font-lock' to t, but
@@ -480,9 +650,10 @@
 Similar problems arise in regexps, when /(\\s|$)/ should be rewritten
 as /($|\\s)/.  Note that such a transposition is not always possible.
 
-The solution is to upgrade your Emacs.  Note that Emacs 20.2 has some
-bugs related to `syntax-table' text properties.  Patches are available
-on the main CPerl download site, and on CPAN.
+The solution is to upgrade your Emacs or patch an older one.  Note
+that RMS's 20.2 has some bugs related to `syntax-table' text
+properties.  Patches are available on the main CPerl download site,
+and on CPAN.
 
 If these bugs cannot be fixed on your machine (say, you have an inferior
 environment and cannot recompile), you may still disable all the fancy stuff
@@ -490,7 +661,9 @@
 
 (defvar cperl-non-problems 'please-ignore-this-line
 "As you know from `problems' section, Perl syntax is too hard for CPerl on 
-older Emacsen.
+older Emacsen.  Here is what you can do if you cannot upgrade, or if
+you want to switch off these capabilities on RMS Emacs 20.2 (+patches) or 20.3
+or better.  Please skip this docs if you run a capable Emacs already.
 
 Most of the time, if you write your own code, you may find an equivalent
 \(and almost as readable) expression (what is discussed below is usually
@@ -538,6 +711,7 @@
 Imenu in 19.31 is broken.  Set `imenu-use-keymap-menu' to t, and remove
 `car' before `imenu-choose-buffer-index' in `imenu'.
 `imenu-add-to-menubar' in 20.2 is broken.  
+
 A lot of things on XEmacs may be broken too, judging by bug reports I
 recieve.  Note that some releases of XEmacs are better than the others
 as far as bugs reports I see are concerned.")
@@ -549,8 +723,11 @@
 
 1) It does 99% of Perl syntax correct (as opposed to 80-90% in Perl
 mode - but the latter number may have improved too in last years) even 
-without `syntax-table' property; When using this property, it should 
-handle 99.995% of lines correct - or somesuch.
+with old Emaxen which do not support `syntax-table' property.
+
+When using `syntax-table' property for syntax assist hints, it should
+handle 99.995% of lines correct - or somesuch.  It automatically
+updates syntax assist hints when you edit your script.
 
 2) It is generally believed to be \"the most user-friendly Emacs
 package\" whatever it may mean (I doubt that the people who say similar
@@ -599,6 +776,10 @@
 	   to
 		B if A;
 
+        n) Highlights (by user-choice) either 3-delimiters constructs
+	   (such as tr/a/b/), or regular expressions and `y/tr'.
+	o) Highlights trailing whitespace.
+
 5) The indentation engine was very smart, but most of tricks may be
 not needed anymore with the support for `syntax-table' property.  Has
 progress indicator for indentation (with `imenu' loaded).
@@ -655,8 +836,46 @@
     syntax-engine-helping scan, thus will make many more Perl
     constructs be wrongly recognized by CPerl, thus may lead to
     wrongly matched parentheses, wrong indentation, etc.
+
+    One can unset `cperl-syntaxify-unwind'.  This might speed up editing
+    of, say, long POD sections.
 ")
 
+(defvar cperl-tips-faces 'please-ignore-this-line
+  "CPerl mode uses following faces for highlighting:
+
+  cperl-array-face		Array names
+  cperl-hash-face		Hash names
+  font-lock-comment-face	Comments, PODs and whatever is considered
+				syntaxically to be not code
+  font-lock-constant-face	HERE-doc delimiters, labels, delimiters of
+				2-arg operators s/y/tr/ or of RExen,
+  font-lock-function-name-face	Special-cased m// and s//foo/, _ as 
+				a target of a file tests, file tests,
+				subroutine names at the moment of definition
+				(except those conflicting with Perl operators),
+				package names (when recognized), format names
+  font-lock-keyword-face	Control flow switch constructs, declarators
+  cperl-nonoverridable-face	Non-overridable keywords, modifiers of RExen
+  font-lock-string-face		Strings, qw() constructs, RExen, POD sections,
+				literal parts and the terminator of formats
+				and whatever is syntaxically considered
+				as string literals
+  font-lock-type-face		Overridable keywords
+  font-lock-variable-name-face	Variable declarations, indirect array and
+				hash names, POD headers/item names
+  cperl-invalid-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.)
+
+\(Not finished.)")
+
 
 
 ;;; Portability stuff:
@@ -713,9 +932,12 @@
     'lazy-lock)
   "Text property which inhibits refontification.")
 
-(defsubst cperl-put-do-not-fontify (from to)
+(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))
+		       to cperl-do-not-fontify t)))
 
 (defcustom cperl-mode-hook nil
   "Hook run by `cperl-mode'."
@@ -724,6 +946,8 @@
 
 (defvar cperl-syntax-state nil)
 (defvar cperl-syntax-done-to nil)
+(defvar cperl-emacs-can-parse (> (length (save-excursion
+					   (parse-partial-sexp 1 1))) 9))
 
 ;; Make customization possible "in reverse"
 (defsubst cperl-val (symbol &optional default hairy)
@@ -734,11 +958,12 @@
 
 ;;; Probably it is too late to set these guys already, but it can help later:
 
+;;;(and cperl-clobber-mode-lists
 ;;;(setq auto-mode-alist
 ;;;      (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode))  auto-mode-alist ))
 ;;;(and (boundp 'interpreter-mode-alist)
 ;;;     (setq interpreter-mode-alist (append interpreter-mode-alist
-;;;					  '(("miniperl" . perl-mode)))))
+;;;					  '(("miniperl" . perl-mode))))))
 (if (fboundp 'eval-when-compile)
     (eval-when-compile
       (condition-case nil
@@ -759,31 +984,18 @@
       (condition-case nil
 	  (require 'info)
 	(error nil))
+      (if (fboundp 'ps-extend-face-list)
+	  (defmacro cperl-ps-extend-face-list (arg)
+	    (` (ps-extend-face-list (, arg))))
+	(defmacro cperl-ps-extend-face-list (arg)
+	  (` (error "This version of Emacs has no `ps-extend-face-list'."))))
       ;; Calling `cperl-enable-font-lock' below doesn't compile on XEmacs,
       ;; macros instead of defsubsts don't work on Emacs, so we do the
       ;; expansion manually.  Any other suggestions?
       (if (or (string-match "XEmacs\\|Lucid" emacs-version)
 	      window-system)
 	  (require 'font-lock))
-      (require 'cl)
-      ;; Avoid warning (tmp definitions)
-      (or (fboundp 'x-color-defined-p)
-	  (defalias 'x-color-defined-p 
-	    (cond ((fboundp 'color-defined-p) 'color-defined-p)
-		  ;; XEmacs >= 19.12
-		  ((fboundp 'valid-color-name-p) 'valid-color-name-p)
-		  ;; XEmacs 19.11
-		  (t 'x-valid-color-name-p))))
-      (fset 'cperl-is-face
-	    (cond ((fboundp 'find-face)
-		   (symbol-function 'find-face))
-		  ((and (fboundp 'face-list)
-			(face-list))
-		   (function (lambda (face) 
-			       (member face (and (fboundp 'face-list)
-						 (face-list))))))
-		  (t
-		   (function (lambda (face) (boundp face))))))))
+      (require 'cl)))
 
 (defvar cperl-mode-abbrev-table nil
   "Abbrev table in use in Cperl-mode buffers.")
@@ -820,14 +1032,8 @@
   (cperl-define-key "\177" 'cperl-electric-backspace)
   (cperl-define-key "\t" 'cperl-indent-command)
   ;; don't clobber the backspace binding:
-  (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command
-		    [(control c) (control h) f])
   (cperl-define-key "\C-c\C-hF" 'cperl-info-on-command
 		    [(control c) (control h) F])
-  (cperl-define-key "\C-c\C-hv"
-		    ;;(concat (char-to-string help-char) "v") ; does not work
-		    'cperl-get-help
-		    [(control c) (control h) v])
   (if (cperl-val 'cperl-clobber-lisp-bindings)
       (progn
 	(cperl-define-key "\C-hf"
@@ -837,7 +1043,21 @@
 	(cperl-define-key "\C-hv"
 			  ;;(concat (char-to-string help-char) "v") ; does not work
 			  'cperl-get-help
-			  [(control h) v])))
+			  [(control h) v])
+	(cperl-define-key "\C-c\C-hf"
+			  ;;(concat (char-to-string help-char) "f") ; does not work
+			  (key-binding "\C-hf")
+			  [(control c) (control h) f])
+	(cperl-define-key "\C-c\C-hv"
+			  ;;(concat (char-to-string help-char) "v") ; does not work
+			  (key-binding "\C-hv")
+			  [(control c) (control h) v]))
+    (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command
+		      [(control c) (control h) f])
+    (cperl-define-key "\C-c\C-hv"
+		      ;;(concat (char-to-string help-char) "v") ; does not work
+		      'cperl-get-help
+		      [(control c) (control h) v]))
   (if (and cperl-xemacs-p 
 	   (<= emacs-minor-version 11) (<= emacs-major-version 19))
       (progn
@@ -902,6 +1122,8 @@
 	    ["Insert spaces if needed" cperl-find-bad-style t]
 	    ["Class Hierarchy from TAGS" cperl-tags-hier-init t]
 	    ;;["Update classes" (cperl-tags-hier-init t) tags-table-list]
+	    ["CPerl pretty print (exprmntl)" cperl-ps-print 
+	     (fboundp 'ps-extend-face-list)]
 	    ["Imenu on info" cperl-imenu-on-info (featurep 'imenu)]
 	    ("Tags"
 ;;;	     ["Create tags for current file" cperl-etags t]
@@ -960,7 +1182,11 @@
 	    ["Non-problems" (describe-variable 'cperl-non-problems) t]
 	    ["Speed" (describe-variable 'cperl-speed) t]
 	    ["Praise" (describe-variable 'cperl-praise) t]
-	    ["CPerl mode" (describe-function 'cperl-mode) t]))))
+	    ["Faces" (describe-variable 'cperl-tips-faces) t]
+	    ["CPerl mode" (describe-function 'cperl-mode) t]
+	    ["CPerl version" 
+	     (message "The version of master-file for this CPerl is %s" 
+		      cperl-version) t]))))
   (error nil))
 
 (autoload 'c-macro-expand "cmacexp"
@@ -1271,7 +1497,7 @@
 	;; Fix broken font-lock:
 	(or (boundp 'font-lock-unfontify-region-function)
 	    (set 'font-lock-unfontify-region-function
-		  'font-lock-default-unfontify-buffer))
+		  'font-lock-default-unfontify-region))
 	(make-variable-buffer-local 'font-lock-unfontify-region-function)
 	(set 'font-lock-unfontify-region-function 
 	      'cperl-font-lock-unfontify-region-function)
@@ -1306,11 +1532,12 @@
   (run-hooks 'cperl-mode-hook)
   ;; After hooks since fontification will break this
   (if cperl-pod-here-scan 
-      (or (and (boundp 'font-lock-mode)
-	       (eval 'font-lock-mode)	; Avoid warning
-	       (boundp 'font-lock-hot-pass) ; Newer font-lock
-	       cperl-syntaxify-by-font-lock)
-	  (cperl-find-pods-heres))))
+      (or ;;(and (boundp 'font-lock-mode)
+	  ;;     (eval 'font-lock-mode)	; Avoid warning
+	  ;;     (boundp 'font-lock-hot-pass) ; Newer font-lock
+       cperl-syntaxify-by-font-lock  ;;)
+       (progn (or cperl-faces-init (cperl-init-faces-weak))
+	      (cperl-find-pods-heres)))))
 
 ;; Fix for perldb - make default reasonable
 (defvar gud-perldb-history)
@@ -1348,13 +1575,28 @@
 ;; based on its context.  Do fallback if comment is found wrong.
 
 (defvar cperl-wrong-comment)
+(defvar cperl-st-cfence '(14))		; Comment-fence
+(defvar cperl-st-sfence '(15))		; String-fence
+(defvar cperl-st-punct '(1))
+(defvar cperl-st-word '(2))
+(defvar cperl-st-bra '(4 . ?\>))
+(defvar cperl-st-ket '(5 . ?\<))
+
 
 (defun cperl-comment-indent ()
-  (let ((p (point)) (c (current-column)) was)
+  (let ((p (point)) (c (current-column)) was phony)
     (if (looking-at "^#") 0		; Existing comment at bol stays there.
       ;; Wrong comment found
       (save-excursion
-	(setq was (cperl-to-comment-or-eol))
+	(setq was (cperl-to-comment-or-eol)
+	      phony (eq (get-text-property (point) 'syntax-table)
+			cperl-st-cfence))
+	(if phony
+	    (progn
+	      (re-search-forward "#\\|$") ; Hmm, what about embedded #?
+	      (if (eq (preceding-char) ?\#)
+		  (forward-char -1))
+	      (setq was nil)))
 	(if (= (point) p)
 	    (progn
 	      (skip-chars-backward " \t")
@@ -1609,7 +1851,7 @@
 	 (save-excursion 
 	   (not 
 	    (re-search-backward
-	     "[#\"'`]\\|\\<q\\(\\|[wqx]\\)\\>"
+	     "[#\"'`]\\|\\<q\\(\\|[wqxr]\\)\\>"
 	     beg t)))
 	 (save-excursion (or (not (re-search-backward "^=" nil t))
 			     (or
@@ -1681,6 +1923,7 @@
 	      (forward-char -1)
 	      (bolp))
 	    (or 
+	     (get-text-property (point) 'in-pod)
 	     (cperl-after-expr-p nil "{;:")
 	     (and (re-search-backward
 		   "\\(\\`\n?\\|\n\n\\)=\\sw+" (point-min) t)
@@ -1741,7 +1984,7 @@
 	 (save-excursion 
 	   (not 
 	    (re-search-backward
-	     "[#\"'`]\\|\\<q\\(\\|[wqx]\\)\\>"
+	     "[#\"'`]\\|\\<q\\(\\|[wqxr]\\)\\>"
 	     beg t)))
 	 (save-excursion (or (not (re-search-backward "^=" nil t))
 			     (looking-at "=cut")
@@ -1980,6 +2223,7 @@
 so that this line becomes properly indented.
 The relative indentation among the lines of the expression are preserved."
   (interactive "P")
+  (cperl-update-syntaxification (point) (point))
   (if whole-exp
       ;; If arg, always indent this line as Perl
       ;; and shift remaining lines of expression the same amount.
@@ -2003,13 +2247,13 @@
 	(insert-tab)
       (cperl-indent-line))))
 
-(defun cperl-indent-line (&optional symbol)
+(defun cperl-indent-line (&optional parse-data)
   "Indent current line as Perl code.
 Return the amount the indentation changed by."
   (let (indent i beg shift-amt
 	(case-fold-search nil)
 	(pos (- (point-max) (point))))
-    (setq indent (cperl-calculate-indent nil symbol)
+    (setq indent (cperl-calculate-indent parse-data)
 	  i indent)
     (beginning-of-line)
     (setq beg (point))
@@ -2056,16 +2300,20 @@
 	 (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:[^:]"))))
 
 (defun cperl-get-state (&optional parse-start start-state)
-  ;; returns list (START STATE DEPTH PRESTART), START is a good place
-  ;; to start parsing, STATE is what is returned by
-  ;; `parse-partial-sexp'.  DEPTH is true is we are immediately after
-  ;; end of block which contains START.  PRESTART is the position
-  ;; basing on which START was found.
+  ;; returns list (START STATE DEPTH PRESTART),
+  ;; START is a good place to start parsing, or equal to
+  ;; PARSE-START if preset, 
+  ;; STATE is what is returned by `parse-partial-sexp'.
+  ;; DEPTH is true is we are immediately after end of block
+  ;; which contains START.
+  ;; PRESTART is the position basing on which START was found.
   (save-excursion
     (let ((start-point (point)) depth state start prestart)
-      (if parse-start
+      (if (and parse-start
+	       (<= parse-start start-point))
 	  (goto-char parse-start)
-	(beginning-of-defun))
+	(beginning-of-defun)
+	(setq start-state nil))
       (setq prestart (point))
       (if start-state nil
 	;; Try to go out, if sub is not on the outermost level
@@ -2079,7 +2327,6 @@
 	    (beginning-of-line 2)))	; Go to the next line.
 	(if start (goto-char start)))	; Not at the start of file
       (setq start (point))
-      (if (< start start-point) (setq parse-start start))
       (or state (setq state (parse-partial-sexp start start-point -1 nil start-state)))
       (list start state depth prestart))))
 
@@ -2095,7 +2342,7 @@
 	     (backward-sexp)
 	     ;; Need take into account `bless', `return', `tr',...
 	     (or (and (looking-at "[a-zA-Z0-9_:]+[ \t\n\f]*[{#]") ; Method call syntax
-		      (not (looking-at "\\(bless\\|return\\|qw\\|tr\\|[smy]\\)\\>")))
+		      (not (looking-at "\\(bless\\|return\\|q[wqrx]?\\|tr\\|[smy]\\)\\>")))
 		 (progn
 		   (skip-chars-backward " \t\n\f")
 		   (and (memq (char-syntax (preceding-char)) '(?w ?_))
@@ -2106,10 +2353,13 @@
 
 (defvar cperl-look-for-prop '((pod in-pod) (here-doc-delim here-doc-group)))
 
-(defun cperl-calculate-indent (&optional parse-start symbol)
+(defun cperl-calculate-indent (&optional parse-data) ; was parse-start
   "Return appropriate indentation for current line as Perl code.
 In usual case returns an integer: the column to indent to.
-Returns nil if line starts inside a string, t if in a comment."
+Returns nil if line starts inside a string, t if in a comment.
+
+Will not correct the indentation for labels, but will correct it for braces
+and closing parentheses and brackets.."
   (save-excursion
     (if (or
 	 (memq (get-text-property (point) 'syntax-type) 
@@ -2148,15 +2398,22 @@
 		(setq pre-indent-point (point)))))))
       (goto-char pre-indent-point)
       (let* ((case-fold-search nil)
-	     (s-s (cperl-get-state))
-	     (start (nth 0 s-s))
+	     (s-s (cperl-get-state (car parse-data) (nth 1 parse-data)))
+	     (start (or (nth 2 parse-data) 
+			(nth 0 s-s)))
 	     (state (nth 1 s-s))
 	     (containing-sexp (car (cdr state)))
-	     (start-indent (save-excursion
-			     (goto-char start)
-			     (- (current-indentation)
-				(if (nth 2 s-s) cperl-indent-level 0))))
 	     old-indent)
+	(if (and 
+	     ;;containing-sexp		;; We are buggy at toplevel :-(
+	     parse-data) 
+	    (progn
+	      (setcar parse-data pre-indent-point)
+	      (setcar (cdr parse-data) state)
+	      (or (nth 2 parse-data)
+		  (setcar (cddr parse-data) start))
+	      ;; Before this point: end of statement
+	      (setq old-indent (nth 3 parse-data))))
 	;;      (or parse-start (null symbol)
 	;;	  (setq parse-start (symbol-value symbol) 
 	;;		start-indent (nth 2 parse-start) 
@@ -2206,26 +2463,36 @@
 	       ;; unless that ends in a closeparen without semicolon,
 	       ;; in which case this line is the first argument decl.
 	       (skip-chars-forward " \t")
-	       (+ start-indent
-		  (if (= (following-char) ?{) cperl-continued-brace-offset 0)
+	       (+ (save-excursion
+		    (goto-char start)
+		    (- (current-indentation)
+		       (if (nth 2 s-s) cperl-indent-level 0)))
+		  (if (= char-after ?{) cperl-continued-brace-offset 0)
 		  (progn
-		    (cperl-backward-to-noncomment (or parse-start (point-min)))
+		    (cperl-backward-to-noncomment (or old-indent (point-min)))
 		    ;; Look at previous line that's at column 0
 		    ;; to determine whether we are in top-level decls
 		    ;; or function's arg decls.  Set basic-indent accordingly.
 		    ;; Now add a little if this is a continuation line.
 		    (if (or (bobp)
+			    (eq (point) old-indent) ; old-indent was at comment
 			    (eq (preceding-char) ?\;)
 			    ;;  Had ?\) too
 			    (and (eq (preceding-char) ?\})
-				 (cperl-after-block-and-statement-beg start))
+				 (cperl-after-block-and-statement-beg
+				  (point-min)))	; Was start - too close
 			    (memq char-after (append ")]}" nil))
 			    (and (eq (preceding-char) ?\:) ; label
 				 (progn
 				   (forward-sexp -1)
 				   (skip-chars-backward " \t")
 				   (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:")))) 
-			0
+			(progn
+			  (if (and parse-data
+				   (not (eq char-after ?\C-j)))
+			      (setcdr (cddr parse-data)
+				      (list pre-indent-point)))
+			  0)
 		      cperl-continued-statement-offset))))
 	      ((/= (char-after containing-sexp) ?{)
 	       ;; line is expression, not statement:
@@ -2255,11 +2522,13 @@
 	       (cperl-backward-to-noncomment containing-sexp)
 	       ;; Back up over label lines, since they don't
 	       ;; affect whether our line is a continuation.
-	       (while (or (eq (preceding-char) ?\,)
+	       ;; (Had \, too)
+	       (while ;;(or (eq (preceding-char) ?\,)
 			  (and (eq (preceding-char) ?:)
 			       (or;;(eq (char-after (- (point) 2)) ?\') ; ????
 				(memq (char-syntax (char-after (- (point) 2)))
-				      '(?w ?_)))))
+				      '(?w ?_))))
+			  ;;)
 		 (if (eq (preceding-char) ?\,)
 		     ;; Will go to beginning of line, essentially.
 		     ;; Will ignore embedded sexpr XXXX.
@@ -2275,12 +2544,22 @@
 		   ;; This line is continuation of preceding line's statement;
 		   ;; indent  `cperl-continued-statement-offset'  more than the
 		   ;; previous line of the statement.
+		   ;;
+		   ;; There might be a label on this line, just
+		   ;; consider it bad style and ignore it.
 		   (progn
 		     (cperl-backward-to-start-of-continued-exp containing-sexp)
 		     (+ (if (memq char-after (append "}])" nil))
 			    0		; Closing parenth
 			  cperl-continued-statement-offset)
-			(current-column)
+			(if (looking-at "\\w+[ \t]*:")
+			    (if (> (current-indentation) cperl-min-label-indent)
+				(- (current-indentation) cperl-label-offset)
+			      ;; Do not move `parse-data', this should
+			      ;; be quick anyway (this comment comes 
+			      ;;from different location):
+			      (cperl-calculate-indent))
+			  (current-column))
 			(if (eq char-after ?\{)
 			    cperl-continued-brace-offset 0)))
 		 ;; This line starts a new statement.
@@ -2364,9 +2643,9 @@
 			       (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]"))
 			     (if (> (current-indentation) cperl-min-label-indent)
 				 (- (current-indentation) cperl-label-offset)
-			       (cperl-calculate-indent 
-				(if (and parse-start (<= parse-start (point)))
-				    parse-start)))
+			       ;; Do not move `parse-data', this should
+			       ;; be quick anyway:
+			       (cperl-calculate-indent))
 			   (current-indentation))))))))))))))
 
 (defvar cperl-indent-alist
@@ -2528,9 +2807,7 @@
 			   (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]"))
 			 (if (> (current-indentation) cperl-min-label-indent)
 			     (- (current-indentation) cperl-label-offset)
-			   (cperl-calculate-indent 
-			    (if (and parse-start (<= parse-start (point)))
-				parse-start)))
+			   (cperl-calculate-indent))
 		       (current-indentation))))))))
       res)))
 
@@ -2578,7 +2855,7 @@
 			   "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*"
 			   lim 'move)
 			  (setq stop-in t)))
-		     ((looking-at "\\(m\\|q\\([qxw]\\)?\\)\\>")
+		     ((looking-at "\\(m\\|q\\([qxwr]\\)?\\)\\>")
 		      (or (re-search-forward
 			   "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#"
 			   lim 'move)
@@ -2598,13 +2875,6 @@
 (defsubst cperl-1+ (p)
   (min (point-max) (1+ p)))
 
-(defvar cperl-st-cfence '(14))		; Comment-fence
-(defvar cperl-st-sfence '(15))		; String-fence
-(defvar cperl-st-punct '(1))
-(defvar cperl-st-word '(2))
-(defvar cperl-st-bra '(4 . ?\>))
-(defvar cperl-st-ket '(5 . ?\<))
-
 (defsubst cperl-modify-syntax-type (at how)
   (if (< at (point-max))
       (progn
@@ -2618,9 +2888,10 @@
     (while (re-search-forward "^\\s(" e 'to-end)
       (put-text-property (1- (point)) (point) 'syntax-table cperl-st-punct))))
 
-(defun cperl-commentify (bb e string)
+(defun cperl-commentify (bb e string &optional noface)
   (if cperl-use-syntax-table-text-property 
-      (progn
+      (if (eq noface 'n)		; Only immediate
+	  nil
 	;; We suppose that e is _after_ the end of construction, as after eol.
 	(setq string (if string cperl-st-sfence cperl-st-cfence))
 	(cperl-modify-syntax-type bb string)
@@ -2628,7 +2899,16 @@
 	(if (and (eq string cperl-st-sfence) (> (- e 2) bb))
 	    (put-text-property (1+ bb) (1- e) 
 			       'syntax-table cperl-string-syntax-table))
-	(cperl-protect-defun-start bb e))))
+	(cperl-protect-defun-start bb e))
+    ;; Fontify
+    (or noface
+	(not cperl-pod-here-fontify)
+	(put-text-property bb e 'face (if string 'font-lock-string-face
+					'font-lock-comment-face)))))
+(defvar cperl-starters '(( ?\( . ?\) )
+			 ( ?\[ . ?\] )
+			 ( ?\{ . ?\} )
+			 ( ?\< . ?\> )))
 
 (defun cperl-forward-re (lim end is-2arg set-st st-l err-l argument
 			     &optional ostart oend)
@@ -2638,13 +2918,8 @@
     (skip-chars-forward " \t")
     ;; ender means matching-char matcher.
     (setq b (point) 
-	  starter (char-after b)
-	  ;; ender:
-	  ender (cdr (assoc starter '(( ?\( . ?\) )
-				      ( ?\[ . ?\] )
-				      ( ?\{ . ?\} )
-				      ( ?\< . ?\> )
-				      ))))
+	  starter (if (eobp) 0 (char-after b))
+	  ender (cdr (assoc starter cperl-starters)))
     ;; What if starter == ?\\  ????
     (if set-st
 	(if (car st-l)
@@ -2666,6 +2941,8 @@
 	   (modify-syntax-entry ender  (concat ")" (list starter)) st)))
     (condition-case bb
 	(progn
+	  ;; We use `$' syntax class to find matching stuff, but $$
+	  ;; is recognized the same as $, so we need to check this manually.
 	  (if (and (eq starter (char-after (cperl-1+ b)))
 		   (not ender))
 	      ;; $ has TeXish matching rules, so $$ equiv $...
@@ -2681,6 +2958,7 @@
 		   (forward-char -2)
 		   (= 0 (% (skip-chars-backward "\\\\") 2)))
 		 (forward-char -1)))
+	  ;; Now we are after the first part.
 	  (and is-2arg			; Have trailing part
 	       (not ender)
 	       (eq (following-char) starter) ; Empty trailing part
@@ -2703,15 +2981,14 @@
 		(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 t st-l err-l argument starter ender)
+		(setq ender (cperl-forward-re lim end nil t st-l err-l
+					      argument starter ender)
 		 ender (nth 2 ender)))))
       (error (goto-char lim)
 	     (setq set-st nil)
 	     (or end
 		 (message
-		  "End of `%s%s%c ... %c' string not found: %s"
+		  "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)
@@ -2720,11 +2997,60 @@
 	(progn
 	  (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st)
 	  (if ender (modify-syntax-entry ender "." st))))
+    ;; i: have 2 args, after end of the first arg
+    ;; i2: start of the second arg, if any (before delim iff `ender').
+    ;; ender: the last arg bounded by parens-like chars, the second one of them
+    ;; starter: the starting delimiter of the first arg
+    ;; go-forward: has 2 args, and the second part is empth
     (list i i2 ender starter go-forward)))
 
 (defvar font-lock-string-face)
-(defvar font-lock-reference-face)
+;;(defvar font-lock-reference-face)
 (defvar font-lock-constant-face)
+(defsubst cperl-postpone-fontification (b e type val &optional now) 
+  ;; Do after syntactic fontification?
+  (if cperl-syntaxify-by-font-lock
+      (or now (put-text-property b e 'cperl-postpone (cons type val)))
+      (put-text-property b e type val)))
+
+;;; Here is how the global structures (those which cannot be
+;;; recognized locally) are marked:
+;;	a) PODs: 
+;;		Start-to-end is marked `in-pod' ==> t
+;;		Each non-literal part is marked `syntax-type' ==> `pod'
+;;		Each literal part is marked `syntax-type' ==> `in-pod'
+;;	b) HEREs: 
+;;		Start-to-end is marked `here-doc-group' ==> t
+;;		The body is marked `syntax-type' ==> `here-doc'
+;;		The delimiter is marked `syntax-type' ==> `here-doc-delim'
+;;	c) FORMATs: 
+;;		After-initial-line--to-end is marked `syntax-type' ==> `format'
+;;	d) 'Q'uoted string: 
+;;		part between markers inclusive is marked `syntax-type' ==> `string'
+
+(defun cperl-unwind-to-safe (before &optional end)
+  ;; if BEFORE, go to the previous start-of-line on each step of unwinding
+  (let ((pos (point)) opos)
+    (setq opos pos)
+    (while (and pos (get-text-property pos 'syntax-type))
+      (setq pos (previous-single-property-change pos 'syntax-type))
+      (if pos
+	  (if before
+	      (progn
+		(goto-char (cperl-1- pos))
+		(beginning-of-line)
+		(setq pos (point)))
+	    (goto-char (setq pos (cperl-1- pos))))
+	;; Up to the start
+	(goto-char (point-min))))
+    (if end
+	;; Do the same for end, going small steps
+	(progn
+	  (while (and end (get-text-property end 'syntax-type))
+	    (setq pos end
+		  end (next-single-property-change end 'syntax-type)))
+	  (or end pos)))))
+
 (defun cperl-find-pods-heres (&optional min max non-inter end ignore-max)
   "Scans the buffer for hard-to-parse Perl constructions.
 If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify 
@@ -2735,8 +3061,8 @@
 		cperl-syntax-state nil
 		cperl-syntax-done-to min))
   (or max (setq max (point-max)))
-  (let* (face head-face here-face b e bb tag qtag b1 e1 argument i c tail
-	      (cperl-pod-here-fontify (eval cperl-pod-here-fontify)) go
+  (let* (face head-face here-face b e bb tag qtag b1 e1 argument i c tail tb
+	      (cperl-pod-here-fontify (eval cperl-pod-here-fontify)) go tmpend 
 	      (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t)
 	      (modified (buffer-modified-p))
 	      (after-change-functions nil)
@@ -2752,6 +3078,17 @@
 	      (font-lock-string-face (if (boundp 'font-lock-string-face)
 					 font-lock-string-face
 				       'font-lock-string-face))
+	      (font-lock-constant-face (if (boundp 'font-lock-constant-face)
+					 font-lock-constant-face
+				       'font-lock-constant-face))
+	      (font-lock-function-name-face 
+	       (if (boundp 'font-lock-function-name-face)
+		   font-lock-function-name-face
+		 'font-lock-function-name-face))
+	      (cperl-nonoverridable-face 
+	       (if (boundp 'cperl-nonoverridable-face)
+		   cperl-nonoverridable-face
+		 'cperl-nonoverridable-face))
 	      (stop-point (if ignore-max 
 			      (point-max)
 			    max))
@@ -2761,16 +3098,17 @@
 		"\\|"
 		;; One extra () before this:
 		"<<" 
-		  "\\(" 
+		  "\\("			; 1 + 1
 		  ;; First variant "BLAH" or just ``.
-		     "\\([\"'`]\\)"
-		     "\\([^\"'`\n]*\\)"
+		     "\\([\"'`]\\)"	; 2 + 1
+		     "\\([^\"'`\n]*\\)"	; 3 + 1
 		     "\\3"
 		  "\\|"
-		  ;; Second variant: Identifier or empty
-		    "\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)"
-		    ;; Check that we do not have <<= or << 30 or << $blah.
-		    "\\([^= \t$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)"
+		  ;; Second variant: Identifier or \ID or empty
+		    "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1
+		    ;; Do not have <<= or << 30 or <<30 or << $blah.
+		    ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1
+		    "\\(\\)"		; To preserve count of pars :-( 6 + 1
 		  "\\)"
 		"\\|"
 		;; 1+6 extra () before this:
@@ -2779,10 +3117,10 @@
 		    (concat
 		     "\\|"
 		     ;; 1+6+2=9 extra () before this:
-		     "\\<\\(q[wxq]?\\|[msy]\\|tr\\)\\>"
+		     "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>"
 		     "\\|"
 		     ;; 1+6+2+1=10 extra () before this:
-		     "\\([?/]\\)"	; /blah/ or ?blah?
+		     "\\([?/<]\\)"	; /blah/ or ?blah? or <file*glob>
 		     "\\|"
 		     ;; 1+6+2+1+1=11 extra () before this:
 		     "\\<sub\\>[ \t]*\\([a-zA-Z_:'0-9]+[ \t]*\\)?\\(([^()]*)\\)"
@@ -2808,7 +3146,8 @@
 		      head-face cperl-pod-head-face
 		      here-face cperl-here-face))
 	    (remove-text-properties min max 
-				    '(syntax-type t in-pod t syntax-table t))
+				    '(syntax-type t in-pod t syntax-table t
+						  cperl-postpone t))
 	    ;; Need to remove face as well...
 	    (goto-char min)
 	    (and (eq system-type 'emx)
@@ -2819,70 +3158,110 @@
 	    (while (and
 		    (< (point) max)
 		    (re-search-forward search max t))
+	      (setq tmpend nil)		; Valid for most cases
 	      (cond 
 	       ((match-beginning 1)	; POD section
 		;;  "\\(\\`\n?\\|\n\n\\)=" 
 		(if (looking-at "\n*cut\\>")
-		    (progn
+		    (if ignore-max
+			nil		; Doing a chunk only
 		      (message "=cut is not preceded by a POD section")
 		      (or (car err-l) (setcar err-l (point))))
 		  (beginning-of-line)
 		
-		  (setq b (point) bb b)
+		  (setq b (point) 
+			bb b
+			tb (match-beginning 0)
+			b1 nil)		; error condition
 		  ;; We do not search to max, since we may be called from
 		  ;; some hook of fontification, and max is random
 		  (or (re-search-forward "\n\n=cut\\>" stop-point 'toend)
 		      (progn
 			(message "End of a POD section not marked by =cut")
+			(setq b1 t)
 			(or (car err-l) (setcar err-l b))))
 		  (beginning-of-line 2)	; An empty line after =cut is not POD!
 		  (setq e (point))
+		  (if (and b1 (eobp))
+		      ;; Unrecoverable error
+		      nil
 		  (and (> e max)
-		       (remove-text-properties max e
-					       '(syntax-type t in-pod t syntax-table t)))
+			 (progn
+			   (remove-text-properties 
+			    max e '(syntax-type t in-pod t syntax-table t
+						'cperl-postpone t))
+			   (setq tmpend tb)))
 		  (put-text-property b e 'in-pod t)
+		    (put-text-property b e 'syntax-type 'in-pod)
 		  (goto-char b)
 		  (while (re-search-forward "\n\n[ \t]" e t)
 		    ;; We start 'pod 1 char earlier to include the preceding line
 		    (beginning-of-line)
 		    (put-text-property (cperl-1- b) (point) 'syntax-type 'pod)
-		    (cperl-put-do-not-fontify b (point))
-		    (if cperl-pod-here-fontify (put-text-property b (point) 'face face))
+		      (cperl-put-do-not-fontify b (point) t)
+		      ;; mark the non-literal parts as PODs
+		      (if cperl-pod-here-fontify 
+			  (cperl-postpone-fontification b (point) 'face face t))
 		    (re-search-forward "\n\n[^ \t\f\n]" e 'toend)
 		    (beginning-of-line)
 		    (setq b (point)))
 		  (put-text-property (cperl-1- (point)) e 'syntax-type 'pod)
-		  (cperl-put-do-not-fontify (point) e)
+		    (cperl-put-do-not-fontify (point) e t)
 		  (if cperl-pod-here-fontify 
-		      (progn (put-text-property (point) e 'face face)
+			(progn 
+			  ;; mark the non-literal parts as PODs
+			  (cperl-postpone-fontification (point) e 'face face t)
 			     (goto-char bb)
 			     (if (looking-at 
 				  "=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$")
-				 (put-text-property 
+			      ;; mark the headers
+			      (cperl-postpone-fontification 
 				  (match-beginning 1) (match-end 1)
 				  'face head-face))
 			     (while (re-search-forward
 				     ;; One paragraph
 				     "\n\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$"
 				     e 'toend)
-			       (put-text-property 
+			    ;; mark the headers
+			    (cperl-postpone-fontification 
 				(match-beginning 1) (match-end 1)
 				'face head-face))))
 		  (cperl-commentify bb e nil)
 		  (goto-char e)
 		  (or (eq e (point-max))
-		      (forward-char -1)))) ; Prepare for immediate pod start.
+			(forward-char -1))))) ; Prepare for immediate pod start.
 	       ;; Here document
 	       ;; We do only one here-per-line
-	       ;; 1 () ahead
-	       ;; "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\3\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)\\)"
+               ;; ;; One extra () before this:
+	       ;;"<<" 
+	       ;;  "\\("			; 1 + 1
+	       ;;  ;; First variant "BLAH" or just ``.
+	       ;;     "\\([\"'`]\\)"	; 2 + 1
+	       ;;     "\\([^\"'`\n]*\\)"	; 3 + 1
+	       ;;     "\\3"
+	       ;;  "\\|"
+	       ;;  ;; Second variant: Identifier or \ID or empty
+	       ;;    "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1
+	       ;;    ;; Do not have <<= or << 30 or <<30 or << $blah.
+	       ;;    ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1
+	       ;;    "\\(\\)"		; To preserve count of pars :-( 6 + 1
+	       ;;  "\\)"
 	       ((match-beginning 2)	; 1 + 1
 		;; Abort in comment:
 		(setq b (point))
 		(setq state (parse-partial-sexp state-point b nil nil state)
-		      state-point b)
-		(if (or (nth 3 state) (nth 4 state))
-		    (goto-char (match-end 2))
+		      state-point b
+		      tb (match-beginning 0)
+		      i (or (nth 3 state) (nth 4 state)))
+		(if i 
+		    (setq c t)
+		  (setq c (and
+			   (match-beginning 5)
+			   (not (match-beginning 6)) ; Empty
+			   (looking-at
+			    "[ \t]*[=0-9$@%&(]"))))
+		(if c			; Not here-doc
+		    nil			; Skip it.
 		  (if (match-beginning 5) ;4 + 1
 		      (setq b1 (match-beginning 5) ; 4 + 1
 			    e1 (match-end 5)) ; 4 + 1
@@ -2891,8 +3270,9 @@
 		  (setq tag (buffer-substring b1 e1)
 			qtag (regexp-quote tag))
 		  (cond (cperl-pod-here-fontify 
-			 (put-text-property b1 e1 'face font-lock-constant-face)
-			 (cperl-put-do-not-fontify b1 e1)))
+			 ;; Highlight the starting delimiter
+			 (cperl-postpone-fontification b1 e1 'face font-lock-constant-face)
+			 (cperl-put-do-not-fontify b1 e1 t)))
 		  (forward-line)
 		  (setq b (point))
 		  ;; We do not search to max, since we may be called from
@@ -2901,10 +3281,12 @@
 					    stop-point 'toend)
 			 (if cperl-pod-here-fontify 
 			     (progn
-			       (put-text-property (match-beginning 0) (match-end 0) 
+			       ;; Highlight the ending delimiter
+			       (cperl-postpone-fontification (match-beginning 0) (match-end 0) 
 						  'face font-lock-constant-face)
-			       (cperl-put-do-not-fontify b (match-end 0))
-			       (put-text-property b (match-beginning 0) 
+			       (cperl-put-do-not-fontify b (match-end 0) t)
+			       ;; Highlight the HERE-DOC
+			       (cperl-postpone-fontification b (match-beginning 0) 
 						  'face here-face)))
 			 (setq e1 (cperl-1+ (match-end 0)))
 			 (put-text-property b (match-beginning 0) 
@@ -2914,7 +3296,9 @@
 			 (put-text-property b e1
 					    'here-doc-group t)
 			 (cperl-commentify b e1 nil)
-			 (cperl-put-do-not-fontify b (match-end 0)))
+			 (cperl-put-do-not-fontify b (match-end 0) t)
+			 (if (> e1 max)
+			     (setq tmpend tb)))
 			(t (message "End of here-document `%s' not found." tag)
 			   (or (car err-l) (setcar err-l b))))))
 	       ;; format
@@ -2925,7 +3309,8 @@
 		      name (if (match-beginning 8) ; 7 + 1
 			       (buffer-substring (match-beginning 8) ; 7 + 1
 						 (match-end 8)) ; 7 + 1
-			     ""))
+			     "")
+		      tb (match-beginning 0))
 		(setq argument nil)
 		(if cperl-pod-here-fontify 
 		    (while (and (eq (forward-line) 0)
@@ -2942,30 +3327,34 @@
 			(setq b1 (point))
 			(setq argument (looking-at "^[^\n]*[@^]"))
 			(end-of-line)
-			(put-text-property b1 (point) 
+			;; Highlight the format line
+			(cperl-postpone-fontification b1 (point) 
 					   'face font-lock-string-face)
 			(cperl-commentify b1 (point) nil)
-			(cperl-put-do-not-fontify b1 (point)))))
+			(cperl-put-do-not-fontify b1 (point) t))))
 		  ;; We do not search to max, since we may be called from
 		  ;; some hook of fontification, and max is random
 		  (re-search-forward "^[.;]$" stop-point 'toend))
 		(beginning-of-line)
-		(if (looking-at "^[.;]$")
+		(if (looking-at "^\\.$")	; ";" is not supported yet
 		    (progn
-		      (put-text-property (point) (+ (point) 2)
+		      ;; Highlight the ending delimiter
+		      (cperl-postpone-fontification (point) (+ (point) 2)
 					 'face font-lock-string-face)
 		      (cperl-commentify (point) (+ (point) 2) nil)
-		      (cperl-put-do-not-fontify (point) (+ (point) 2)))
+		      (cperl-put-do-not-fontify (point) (+ (point) 2) t))
 		  (message "End of format `%s' not found." name)
 		  (or (car err-l) (setcar err-l b)))
 		(forward-line)
+		(if (> (point) max)
+		    (setq tmpend tb))
 		(put-text-property b (point) 'syntax-type 'format))
 	       ;; Regexp:
 	       ((or (match-beginning 10) (match-beginning 11))
 		;; 1+6+2=9 extra () before this:
-		;; "\\<\\(q[wxq]?\\|[msy]\\|tr\\)\\>"
+		;; "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>"
 		;; "\\|"
-		;; "\\([?/]\\)"	; /blah/ or ?blah?
+		;; "\\([?/<]\\)"	; /blah/ or ?blah? or <file*glob>
 		(setq b1 (if (match-beginning 10) 10 11)
 		      argument (buffer-substring
 				(match-beginning b1) (match-end b1))
@@ -2973,19 +3362,26 @@
 		      i b
 		      c (char-after (match-beginning b1))
 		      bb (char-after (1- (match-beginning b1)))	; tmp holder
-		      bb (and		; user variables/whatever
-			  (match-beginning 10)
+		      ;; bb == "Not a stringy"
+		      bb (if (eq b1 10) ; user variables/whatever
 			  (or
 			   (memq bb '(?\$ ?\@ ?\% ?\* ?\#)) ; $#y
 			   (and (eq bb ?-) (eq c ?s)) ; -s file test
 			   (and (eq bb ?\&) ; &&m/blah/
 				(not (eq (char-after 
 					  (- (match-beginning b1) 2))
-					 ?\&))))))
+					    ?\&))))
+			   ;; <file> or <$file>
+			   (and (eq c ?\<)
+				;; Do not stringify <FH> :
+				(save-match-data
+				  (looking-at 
+				   "\\s *\\$?\\([_a-zA-Z:][_a-zA-Z0-9:]*\\s *\\)?>"))))
+		      tb (match-beginning 0))
 		(goto-char (match-beginning b1))
 		(cperl-backward-to-noncomment (point-min))
 		(or bb
-		    (if (eq b1 11)	; bare /blah/ or ?blah?
+		    (if (eq b1 11)	; bare /blah/ or ?blah? or <foo>
 			(setq argument ""
 			      bb	; Not a regexp?
 			      (progn
@@ -2993,10 +3389,10 @@
 				 ;; What is below: regexp-p?
 				 (and
 				  (or (memq (preceding-char)
-					    (append (if (eq c ?\?)
+					    (append (if (memq c '(?\? ?\<))
 							;; $a++ ? 1 : 2
-							"~{(=|&*!,;"
-						      "~{(=|&+-*!,;") nil))
+							"~{(=|&*!,;:"
+						      "~{(=|&+-*!,;:") nil))
 				      (and (eq (preceding-char) ?\})
 					   (cperl-after-block-p (point-min)))
 				      (and (eq (char-syntax (preceding-char)) ?w)
@@ -3004,8 +3400,11 @@
 					     (forward-sexp -1)
 ;;; After these keywords `/' starts a RE.  One should add all the
 ;;; functions/builtins which expect an argument, but ...
+					     (if (eq (preceding-char) ?-)
+						 ;; -d ?foo? is a RE
+						 (looking-at "[a-zA-Z]\\>")
 					     (looking-at 
-					      "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>")))
+						"\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>"))))
 				      (and (eq (preceding-char) ?.)
 					   (eq (char-after (- (point) 2)) ?.))
 				      (bobp))
@@ -3037,53 +3436,106 @@
 		  ;;   2 or 3 later if some special quoting is needed.
 		  ;; e1 means matching-char matcher.
 		  (setq b (point)
+			;; has 2 args
+			i2 (string-match "^\\([sy]\\|tr\\)$" argument)
 			;; We do not search to max, since we may be called from
 			;; some hook of fontification, and max is random
 			i (cperl-forward-re stop-point end
-					    (string-match "^\\([sy]\\|tr\\)$" argument)
+					    i2
 					    t st-l err-l argument)
-			i2 (nth 1 i)	; start of the second part
-			e1 (nth 2 i)	; ender, true if matching second part
+			;; Note that if `go', then it is considered as 1-arg
+			b1 (nth 1 i)	; start of the second part
+			tag (nth 2 i)	; ender-char, true if second part 
+					; is with matching chars []
 			go (nth 4 i)	; There is a 1-char part after the end
 			i (car i)	; intermediate point
-			tail (if (and i (not e1)) (1- (point)))
-			e nil)		; need to preserve backslashitis
+			e1 (point)	; end 
+			;; Before end of the second part if non-matching: ///
+			tail (if (and i (not tag)) 
+				 (1- e1))
+			e (if i i e1)	; end of the first part
+			qtag nil)	; need to preserve backslashitis
 		  ;; Commenting \\ is dangerous, what about ( ?
 		  (and i tail
 		       (eq (char-after i) ?\\)
-		       (setq e t))
+		       (setq qtag t))
 		  (if (null i)
+		      ;; Considered as 1arg form
 		      (progn
 			(cperl-commentify b (point) t)
-			(if go (forward-char 1)))
+			(put-text-property b (point) 'syntax-type 'string)
+			(and go
+			     (setq e1 (cperl-1+ e1))
+			     (or (eobp)
+				 (forward-char 1))))
 		    (cperl-commentify b i t)
 		    (if (looking-at "\\sw*e") ; s///e
 			(progn
 			  (and
 			   ;; silent:
-			   (cperl-find-pods-heres i2 (1- (point)) t end)
+			   (cperl-find-pods-heres b1 (1- (point)) t end)
 			   ;; Error
 			   (goto-char (1+ max)))
-			  (if (and e1 (eq (preceding-char) ?\>))
+			  (if (and tag (eq (preceding-char) ?\>))
 			      (progn
 				(cperl-modify-syntax-type (1- (point)) cperl-st-ket)
-				(cperl-modify-syntax-type i cperl-st-bra))))
-		      (cperl-commentify i2 (point) t)
-		      (if e
+				(cperl-modify-syntax-type i cperl-st-bra)))
+			  (put-text-property b i 'syntax-type 'string))
+		      (cperl-commentify b1 (point) t)
+		      (put-text-property b (point) 'syntax-type 'string)
+		      (if qtag
 			  (cperl-modify-syntax-type (1+ i) cperl-st-punct))
 		      (setq tail nil)))
+		  ;; Now: tail: if the second part is non-matching without ///e
 		  (if (eq (char-syntax (following-char)) ?w)
 		      (progn
 			(forward-word 1) ; skip modifiers s///s
-			(if tail (cperl-commentify tail (point) t))))))
+			(if tail (cperl-commentify tail (point) t))
+			(cperl-postpone-fontification 
+			 e1 (point) 'face cperl-nonoverridable-face)))
+		  ;; Check whether it is m// which means "previous match"
+		  ;; and highlight differently
+		  (if (and (eq e (+ 2 b))
+			   (string-match "^\\([sm]?\\|qr\\)$" argument)
+			   ;; <> is already filtered out
+			   ;; split // *is* using zero-pattern
+			   (save-excursion
+			     (condition-case nil
+				 (progn
+				   (goto-char tb)
+				   (forward-sexp -1)
+				   (not (looking-at "split\\>")))
+			       (error t))))
+		      (cperl-postpone-fontification 
+		       b e 'face font-lock-function-name-face)
+		    (if (or i2		; Has 2 args
+			    (and cperl-fontify-m-as-s
+				 (or
+				  (string-match "^\\(m\\|qr\\)$" argument)
+				  (and (eq 0 (length argument))
+				       (not (eq ?\< (char-after b)))))))
+			(progn
+			  (cperl-postpone-fontification 
+			   b (cperl-1+ b) 'face font-lock-constant-face)
+			  (cperl-postpone-fontification 
+			   (1- e) e 'face font-lock-constant-face))))
+		  (if i2
+		      (progn
+			(cperl-postpone-fontification 
+			 (1- e1) e1 'face font-lock-constant-face)
+			(if (assoc (char-after b) cperl-starters)
+			    (cperl-postpone-fontification 
+			     b1 (1+ b1) 'face font-lock-constant-face))))
+		  (if (> (point) max)
+		      (setq tmpend tb))))
 	       ((match-beginning 13)	; sub with prototypes
 		(setq b (match-beginning 0))
 		(if (memq (char-after (1- b))
 			  '(?\$ ?\@ ?\% ?\& ?\*))
 		    nil
 		  (setq state (parse-partial-sexp 
-			       state-point (1- b) nil nil state)
-			state-point (1- b))
+			       state-point b nil nil state)
+			state-point b)
 		  (if (or (nth 3 state) (nth 4 state))
 		      nil
 		    ;; Mark as string
@@ -3139,7 +3591,7 @@
 		      (or (car err-l) (setcar err-l b)))
 		    (goto-char stop-point))))
 	    (setq cperl-syntax-state (cons state-point state)
-		  cperl-syntax-done-to (max (point) max)))
+		  cperl-syntax-done-to (or tmpend (max (point) max))))
 	  (if (car err-l) (goto-char (car err-l))
 	    (or non-inter
 		(message "Scanning for \"hard\" Perl constructions... done"))))
@@ -3151,18 +3603,21 @@
 
 (defun cperl-backward-to-noncomment (lim)
   ;; Stops at lim or after non-whitespace that is not in comment
-  (let (stop p)
+  (let (stop p pr)
     (while (and (not stop) (> (point) (or lim 1)))
       (skip-chars-backward " \t\n\f" lim)
       (setq p (point))
       (beginning-of-line)
+      (if (memq (setq pr (get-text-property (point) 'syntax-type))
+		'(pod here-doc here-doc-delim))
+	  (cperl-unwind-to-safe nil)
       (if (or (looking-at "^[ \t]*\\(#\\|$\\)")
 	      (progn (cperl-to-comment-or-eol) (bolp)))
 	  nil	; Only comment, skip
 	;; Else
 	(skip-chars-backward " \t")
 	(if (< p (point)) (goto-char p))
-	(setq stop t)))))
+	  (setq stop t))))))
 
 (defun cperl-after-block-p (lim)
   ;; We suppose that the preceding char is }.
@@ -3176,7 +3631,7 @@
 	      (if (eq (char-syntax (preceding-char)) ?w) ; else {}
 		  (save-excursion
 		    (forward-sexp -1)
-		    (or (looking-at "\\(else\\|grep\\|map\\)\\>")
+		    (or (looking-at "\\(else\\|grep\\|map\\|BEGIN\\|END\\)\\>")
 			;; sub f {}
 			(progn
 			  (cperl-backward-to-noncomment lim)
@@ -3200,11 +3655,19 @@
 	(setq p (point))
 	(beginning-of-line)
 	(if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip
-	  ;; Else: last iteration (What to do with labels?)
+	  ;; Else: last iteration, or a label
 	  (cperl-to-comment-or-eol) 
 	  (skip-chars-backward " \t")
 	  (if (< p (point)) (goto-char p))
-	  (setq stop t)))
+	  (setq p (point))
+	  (if (and (eq (preceding-char) ?:)
+		   (progn
+		     (forward-char -1)
+		     (skip-chars-backward " \t\n\f" lim)
+		     (eq (char-syntax (preceding-char)) ?w)))
+	      (forward-sexp -1)		; Possibly label.  Skip it
+	    (goto-char p)
+	    (setq stop t))))
       (or (bobp)			; ???? Needed
 	  (eq (point) lim)
 	  (progn
@@ -3243,8 +3706,9 @@
 
 (defun cperl-indent-exp ()
   "Simple variant of indentation of continued-sexp.
-Should be slow.  Will not indent comment if it starts at `comment-indent'
-or looks like continuation of the comment on the previous line.
+
+Will not indent comment if it starts at `comment-indent' or looks like
+continuation of the comment on the previous line.
 
 If `cperl-indent-region-fix-constructs', will improve spacing on 
 conditional/loop constructs."
@@ -3262,7 +3726,10 @@
 	  (while (< (point) tmp-end)
 	    (parse-partial-sexp (point) tmp-end nil t) ; To start-sexp or eol
 	    (or (eolp) (forward-sexp 1)))
-	  (if (> (point) tmp-end) (progn (end-of-line) (setq tmp-end (point)))
+	  (if (> (point) tmp-end)
+	      (save-excursion
+		(end-of-line)
+		(setq tmp-end (point)))
 	    (setq done t)))
 	(goto-char tmp-end)
 	(setq tmp-end (point-marker)))
@@ -3270,16 +3737,25 @@
 	  (cperl-fix-line-spacing tmp-end))
       (cperl-indent-region (point) tmp-end))))
 
-(defun cperl-fix-line-spacing (&optional end)
-  "Improve whitespace in a conditional/loop construct."
+(defun cperl-fix-line-spacing (&optional end parse-data)
+  "Improve whitespace in a conditional/loop construct.
+Returns some position at the last line."
   (interactive)
   (or end
       (setq end (point-max)))
-  (let (p pp ml 
+  (let (p pp ml have-brace ret
+	  (ee (save-excursion (end-of-line) (point)))
 	  (cperl-indent-region-fix-constructs
 	   (or cperl-indent-region-fix-constructs 1)))
     (save-excursion
       (beginning-of-line)
+      (setq ret (point))
+      ;;  }? continue 
+      ;;  blah; }
+      (if (not 
+	   (or (looking-at "[ \t]*\\(els\\(e\\|if\\)\\|continue\\|if\\|while\\|for\\(each\\)?\\|until\\)")
+	       (setq have-brace (save-excursion (search-forward "}" ee t)))))
+	  nil				; Do not need to do anything
       ;; Looking at:
       ;; }  
       ;; else
@@ -3304,7 +3780,7 @@
       ;; Looking at:
       ;; else   {
       (if (looking-at 
-	   "[ \t]*}?[ \t]*\\<\\(\\els\\(e\\|if\\)\\|continue\\|if\\|while\\|for\\(each\\)?\\|until\\)\\>\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]")
+	   "[ \t]*}?[ \t]*\\<\\(\\els\\(e\\|if\\)\\|continue\\|unless\\|if\\|while\\|for\\(each\\)?\\|until\\)\\>\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]")
 	  (progn
 	    (forward-word 1)
 	    (delete-horizontal-space)
@@ -3332,7 +3808,7 @@
       ;; Looking at:
       ;; } foreach my $var ()    {
       (if (looking-at 
-	     "[ \t]*\\(}[ \t]*\\)?\\<\\(\\els\\(e\\|if\\)\\|continue\\|if\\|while\\|for\\(each\\)?\\(\\([ t]+\\(my\\|local\\)\\)?[ \t]*\\$[_a-zA-Z0-9]+\\)?\\|until\\)\\>\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{")
+	     "[ \t]*\\(}[ \t]*\\)?\\<\\(\\els\\(e\\|if\\)\\|continue\\|if\\|unless\\|while\\|for\\(each\\)?\\(\\([ t]+\\(my\\|local\\)\\)?[ \t]*\\$[_a-zA-Z0-9]+\\)?\\|until\\)\\>\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{")
 	  (progn
 	    (setq ml (match-beginning 8))
 	    (re-search-forward "[({]")
@@ -3365,8 +3841,11 @@
 			(progn
 			  (delete-horizontal-space)
 			  (insert "\n")
-			  (if (cperl-indent-line)
-			      (cperl-fix-line-spacing end)))
+			  (setq ret (point))
+			  (if (cperl-indent-line parse-data)
+			      (progn 
+				(cperl-fix-line-spacing end parse-data)
+				(setq ret (point)))))
 		      (insert
 		       (make-string cperl-indent-region-fix-constructs ?\ ))))
 		   ((and (looking-at "[ \t]*\n")
@@ -3393,15 +3872,17 @@
 			      (goto-char (1+ pp))
 			      (delete-horizontal-space)
 			      (insert "\n")
-			      (if (cperl-indent-line)
-				  (cperl-fix-line-spacing end))))))))))
+			      (setq ret (point))
+			      (if (cperl-indent-line parse-data)
+				  (setq ret (cperl-fix-line-spacing end parse-data)))))))))))
       (beginning-of-line)
-      (setq p (point) pp (save-excursion (end-of-line) (point)))
+      (setq p (point) pp (save-excursion (end-of-line) (point))) ; May be different from ee.
       ;; Now check whether there is a hanging `}'
       ;; Looking at:
       ;; } blah
       (if (and 
 	   cperl-fix-hanging-brace-when-indent
+	   have-brace
 	   (not (looking-at "[ \t]*}[ \t]*\\(\\<\\(els\\(if\\|e\\)\\|continue\\|while\\|until\\)\\>\\|$\\|#\\)"))
 	   (condition-case nil
 	       (progn
@@ -3419,7 +3900,7 @@
 	    (if (bolp)
 		;; `}' was the first thing on the line, insert NL *after* it.
 		(progn
-		  (cperl-indent-line)
+		  (cperl-indent-line parse-data)
 		  (search-forward "}")
 		  (delete-horizontal-space)
 		  (insert "\n"))
@@ -3429,10 +3910,18 @@
 		  (and (eq (preceding-char) ?\} )
 		       (cperl-after-block-p (point-min)))
 		  (insert ";"))
-	      (insert "\n"))
-	    (if (cperl-indent-line)
-		(cperl-fix-line-spacing end))
-	    (beginning-of-line))))))
+	      (insert "\n")
+	      (setq ret (point)))
+	    (if (cperl-indent-line parse-data)
+		(setq ret (cperl-fix-line-spacing end parse-data)))
+	    (beginning-of-line)))))
+    ret))
+
+(defvar cperl-update-start)		; Do not need to make them local
+(defvar cperl-update-end)
+(defun cperl-delay-update-hook (beg end old-len)
+  (setq cperl-update-start (min beg (or cperl-update-start (point-max))))
+  (setq cperl-update-end (max end (or cperl-update-end (point-min)))))
 
 (defun cperl-indent-region (start end)
   "Simple variant of indentation of region in CPerl mode.
@@ -3444,9 +3933,16 @@
 If `cperl-indent-region-fix-constructs', will improve spacing on 
 conditional/loop constructs."
   (interactive "r")
+  (cperl-update-syntaxification end end)
   (save-excursion
-    (let (st comm indent-info old-comm-indent new-comm-indent p pp i
+    (let (cperl-update-start cperl-update-end (h-a-c after-change-functions))
+      (let (st comm old-comm-indent new-comm-indent p pp i empty
+	       (indent-info (if cperl-emacs-can-parse
+				(list nil nil nil) ; Cannot use '(), since will modify
+			      nil))
+	       after-change-functions	; Speed it up!
 	     (pm 0) (imenu-scanning-message "Indenting... (%3d%%)"))
+	(if h-a-c (add-hook 'after-change-functions 'cperl-delay-update-hook))
       (goto-char start)
       (setq old-comm-indent (and (cperl-to-comment-or-eol)
 				 (current-column))
@@ -3460,30 +3956,36 @@
 	(and (fboundp 'imenu-progress-message)
 	     (imenu-progress-message 
 	      pm (/ (* 100 (- (point) start)) (- end start -1))))
-	(setq st (point) 
-	      indent-info nil
-	      ) ; Believe indentation of the current
-	(if (and (setq comm (looking-at "[ \t]*#"))
+	  (setq st (point))
+	  (if (or
+	       (setq empty (looking-at "[ \t]*\n"))
+	       (and (setq comm (looking-at "[ \t]*#"))
 		 (or (eq (current-indentation) (or old-comm-indent 
 						   comment-column))
-		     (setq old-comm-indent nil)))
+			(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-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))
+	      (setq i (cperl-indent-line indent-info))
 	    (or comm
 		(not i)
 		(progn
 		  (if cperl-indent-region-fix-constructs
-		      (cperl-fix-line-spacing end))
+			(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")
@@ -3492,7 +3994,18 @@
 	(beginning-of-line 2))
       	(if (fboundp 'imenu-progress-message)
 	     (imenu-progress-message pm 100)
-	  (message nil)))))
+	  (message nil)))
+      ;; Now run the update hooks
+      (if after-change-functions
+	  (save-excursion
+	    (if cperl-update-end
+		(progn
+		  (goto-char cperl-update-end)
+		  (insert " ")
+		  (delete-char -1)
+		  (goto-char cperl-update-start)
+		  (insert " ")
+		  (delete-char -1))))))))
 
 ;; Stolen from lisp-mode with a lot of improvements
 
@@ -3827,8 +4340,16 @@
 
 (defvar font-lock-background-mode)
 (defvar font-lock-display-type)
+(defun cperl-init-faces-weak ()
+  ;; Allow `cperl-find-pods-heres' to run.
+  (or (boundp 'font-lock-constant-face)
+      (cperl-force-face font-lock-constant-face
+                        "Face for constant and label names")
+      ;;(setq font-lock-constant-face 'font-lock-constant-face)
+      ))
+
 (defun cperl-init-faces ()
-  (condition-case nil
+  (condition-case errs
       (progn
 	(require 'font-lock)
 	(and (fboundp 'font-lock-fontify-anchored-keywords)
@@ -3840,6 +4361,7 @@
 	  (setq 
 	   t-font-lock-keywords
 	   (list
+	    (list "[ \t]+$" 0 cperl-invalid-face t)
 	    (cons
 	     (concat
 	      "\\(^\\|[^$@%&\\]\\)\\<\\("
@@ -3873,7 +4395,7 @@
 	      ;; "getservbyport" "getservent" "getsockname"
 	      ;; "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int"
 	      ;; "ioctl" "join" "kill" "lc" "lcfirst" "le" "length"
-	      ;; "link" "listen" "localtime" "log" "lstat" "lt"
+	      ;; "link" "listen" "localtime" "lock" "log" "lstat" "lt"
 	      ;; "mkdir" "msgctl" "msgget" "msgrcv" "msgsnd" "ne"
 	      ;; "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe"
 	      ;; "quotemeta" "rand" "read" "readdir" "readline"
@@ -3905,7 +4427,7 @@
 	      "ent\\)\\|gr\\(ent\\|nam\\|gid\\)\\)\\)\\)\\|"
 	      "hex\\|i\\(n\\(t\\|dex\\)\\|octl\\)\\|join\\|kill\\|"
 	      "l\\(i\\(sten\\|nk\\)\\|stat\\|c\\(\\|first\\)\\|t\\|e"
-	      "\\(\\|ngth\\)\\|o\\(caltime\\|g\\)\\)\\|m\\(sg\\(rcv\\|snd\\|"
+	      "\\(\\|ngth\\)\\|o\\(c\\(altime\\|k\\)\\|g\\)\\)\\|m\\(sg\\(rcv\\|snd\\|"
 	      "ctl\\|get\\)\\|kdir\\)\\|n\\(e\\|ot\\)\\|o\\(pen\\(\\|dir\\)\\|"
 	      "r\\(\\|d\\)\\|ct\\)\\|p\\(ipe\\|ack\\)\\|quotemeta\\|"
 	      "r\\(index\\|and\\|mdir\\|e\\(quire\\|ad\\(pipe\\|\\|lin"
@@ -3941,19 +4463,19 @@
 	      "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|if\\|keys\\|"
 	      "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|"
 	      "p\\(ackage\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|"
-	      "q\\(\\|q\\|w\\|x\\)\\|re\\(turn\\|do\\)\\|s\\(pli\\(ce\\|t\\)\\|"
+	      "q\\(\\|q\\|w\\|x\\|r\\)\\|re\\(turn\\|do\\)\\|s\\(pli\\(ce\\|t\\)\\|"
 	      "calar\\|tudy\\|ub\\|hift\\|ort\\)\\|t\\(r\\|ie\\)\\|"
 	      "u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|"
 	      "while\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually
 	      "\\|[sm]"			; Added manually
-	      "\\)\\>") 2 'font-lock-other-type-face)
+	      "\\)\\>") 2 'cperl-nonoverridable-face)
 	    ;;		(mapconcat 'identity
 	    ;;			   '("#endif" "#else" "#ifdef" "#ifndef" "#if"
 	    ;;			     "#include" "#define" "#undef")
 	    ;;			   "\\|")
 	    '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0
 	      font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]"
-	    '("\\<sub[ \t]+\\([^ \t{;]+\\)[ \t]*\\(([^()]*)[ \t]*\\)?[#{\n]" 1
+	    '("\\<sub[ \t]+\\([^ \t{;()]+\\)[ \t]*\\(([^()]*)[ \t]*\\)?[#{\n]" 1
 	      font-lock-function-name-face)
 	    '("\\<\\(package\\|require\\|use\\|import\\|no\\|bootstrap\\)[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t;]" ; require A if B;
 	      2 font-lock-function-name-face)
@@ -4002,15 +4524,15 @@
 		'(
 		  ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1
 		   (if (eq (char-after (match-beginning 2)) ?%)
-		       font-lock-other-emphasized-face
-		     font-lock-emphasized-face)
+		       cperl-hash-face
+		     cperl-array-face)
 		   t)			; arrays and hashes
 		  ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)"
 		   1
 		   (if (= (- (match-end 2) (match-beginning 2)) 1) 
 		       (if (eq (char-after (match-beginning 3)) ?{)
-			   font-lock-other-emphasized-face
-			 font-lock-emphasized-face) ; arrays and hashes
+			   cperl-hash-face
+			 cperl-array-face) ; arrays and hashes
 		     font-lock-variable-name-face) ; Just to put something
 		   t)
 		  ;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2")
@@ -4021,10 +4543,14 @@
 		  ;; (if (cperl-slash-is-regexp)
 		  ;;    font-lock-function-name-face 'default) nil t))
 		  )))
-	  (setq perl-font-lock-keywords-1 t-font-lock-keywords
+	  (setq perl-font-lock-keywords-1 
+		(if cperl-syntaxify-by-font-lock
+		    (cons 'cperl-fontify-update
+			  t-font-lock-keywords)
+		  t-font-lock-keywords)
 		perl-font-lock-keywords perl-font-lock-keywords-1
 		perl-font-lock-keywords-2 (append
-					   t-font-lock-keywords
+					   perl-font-lock-keywords-1
 					   t-font-lock-keywords-1)))
 	(if (fboundp 'ps-print-buffer) (cperl-ps-print-init))
 	(if (or (featurep 'choose-color) (featurep 'font-lock-extra))
@@ -4044,12 +4570,6 @@
 		    nil
 		    [nil		nil		t		t	t]
 		    nil)
-	      (list 'font-lock-keyword-face
-		    ["Purple"		"LightSteelBlue" "DimGray"	"Gray90"]
-		    nil
-		    [nil		nil		t		t	t]
-		    nil
-		    nil)
 	      (list 'font-lock-function-name-face
 		    (vector
 		     "Blue"		"LightSkyBlue"	"Gray50"	"LightGray"
@@ -4082,7 +4602,7 @@
 		    nil
 		    [nil		nil		t		t	t]
 		    )
-	      (list 'font-lock-other-type-face
+	      (list 'cperl-nonoverridable-face
 		    ["chartreuse3"	("orchid1" "orange")
 		     nil		"Gray80"]
 		    [nil		nil		"gray90"]
@@ -4090,74 +4610,106 @@
 		    [nil		nil		t		t]
 		    [nil		nil		t		t	t]
 		    )
-	      (list 'font-lock-emphasized-face
+	      (list 'cperl-array-face
 		    ["blue"		"yellow" 	nil		"Gray80"]
 		    ["lightyellow2"	("navy" "os2blue" "darkgreen")
 		     "gray90"]
 		    t
 		    nil
 		    nil)
-	      (list 'font-lock-other-emphasized-face
+	      (list 'cperl-hash-face
 		    ["red"		"red"	 	nil		"Gray80"]
 		    ["lightyellow2"	("navy" "os2blue" "darkgreen")
 		     "gray90"]
 		    t
 		    t
 		    nil))))
+	  ;; Do it the dull way, without choose-color
 	  (defvar cperl-guessed-background nil
 	    "Display characteristics as guessed by cperl.")
-	  (or (fboundp 'x-color-defined-p)
-	      (defalias 'x-color-defined-p 
-		(cond ((fboundp 'color-defined-p) 'color-defined-p)
-		      ;; XEmacs >= 19.12
-		      ((fboundp 'valid-color-name-p) 'valid-color-name-p)
-		      ;; XEmacs 19.11
-		      (t 'x-valid-color-name-p))))
-	  (defvar font-lock-constant-face 'font-lock-constant-face)
-	  (defvar font-lock-variable-name-face 'font-lock-variable-name-face)
-	  (or (boundp 'font-lock-type-face)
-	      (defconst font-lock-type-face
-		'font-lock-type-face
-		"Face to use for data types."))
-	  (or (boundp 'font-lock-other-type-face)
-	      (defconst font-lock-other-type-face
-		'font-lock-other-type-face
-		"Face to use for data types from another group."))
-	  (if (not cperl-xemacs-p) nil
-	    (or (boundp 'font-lock-comment-face)
-		(defconst font-lock-comment-face
-		  'font-lock-comment-face
-		  "Face to use for comments."))
-	    (or (boundp 'font-lock-keyword-face)
-		(defconst font-lock-keyword-face
-		  'font-lock-keyword-face
-		  "Face to use for keywords."))
-	    (or (boundp 'font-lock-function-name-face)
-		(defconst font-lock-function-name-face
-		  'font-lock-function-name-face
-		  "Face to use for function names.")))
-	  (or (boundp 'font-lock-other-emphasized-face)
-	      (defconst font-lock-other-emphasized-face
-		'font-lock-other-emphasized-face
-		"Face to use for another type of emphasizing."))
-	  (or (boundp 'font-lock-emphasized-face)
-	      (defconst font-lock-emphasized-face
-		'font-lock-emphasized-face
-		"Face to use for emphasizing."))
+;;	  (or (fboundp 'x-color-defined-p)
+;;	      (defalias 'x-color-defined-p 
+;;		(cond ((fboundp 'color-defined-p) 'color-defined-p)
+;;		      ;; XEmacs >= 19.12
+;;		      ((fboundp 'valid-color-name-p) 'valid-color-name-p)
+;;		      ;; XEmacs 19.11
+;;		      (t 'x-valid-color-name-p))))
+	  (cperl-force-face font-lock-constant-face 
+			    "Face for constant and label names")
+	  (cperl-force-face font-lock-variable-name-face
+			    "Face for variable names")
+	  (cperl-force-face font-lock-type-face
+			    "Face for data types")
+	  (cperl-force-face cperl-nonoverridable-face
+			    "Face for data types from another group")
+	  (cperl-force-face font-lock-comment-face
+			    "Face for comments")
+	  (cperl-force-face font-lock-function-name-face
+			    "Face for function names")
+	  (cperl-force-face cperl-hash-face
+			    "Face for hashes")
+	  (cperl-force-face cperl-array-face
+			    "Face for arrays")
+	  ;;(defvar font-lock-constant-face 'font-lock-constant-face)
+	  ;;(defvar font-lock-variable-name-face 'font-lock-variable-name-face)
+	  ;;(or (boundp 'font-lock-type-face)
+	  ;;    (defconst font-lock-type-face
+	  ;;	'font-lock-type-face
+	  ;;	"Face to use for data types."))
+	  ;;(or (boundp 'cperl-nonoverridable-face)
+	  ;;    (defconst cperl-nonoverridable-face
+	  ;;	'cperl-nonoverridable-face
+	  ;;	"Face to use for data types from another group."))
+	  ;;(if (not cperl-xemacs-p) nil
+	  ;;  (or (boundp 'font-lock-comment-face)
+	  ;;	(defconst font-lock-comment-face
+	  ;;	  'font-lock-comment-face
+	  ;;	  "Face to use for comments."))
+	  ;;  (or (boundp 'font-lock-keyword-face)
+	  ;;	(defconst font-lock-keyword-face
+	  ;;	  'font-lock-keyword-face
+	  ;;	  "Face to use for keywords."))
+	  ;;  (or (boundp 'font-lock-function-name-face)
+	  ;;	(defconst font-lock-function-name-face
+	  ;;	  'font-lock-function-name-face
+	  ;;	  "Face to use for function names.")))
+	  (if (and
+	       (not (cperl-is-face 'cperl-array-face)) 
+	       (cperl-is-face 'font-lock-emphasized-face)) 
+	      (copy-face 'font-lock-emphasized-face 'cperl-array-face))
+	  (if (and
+	       (not (cperl-is-face 'cperl-hash-face)) 
+	       (cperl-is-face 'font-lock-other-emphasized-face)) 
+	      (copy-face 'font-lock-other-emphasized-face 
+			 'cperl-hash-face))
+	  (if (and
+	       (not (cperl-is-face 'cperl-nonoverridable-face)) 
+	       (cperl-is-face 'font-lock-other-type-face)) 
+	      (copy-face 'font-lock-other-type-face 
+			 'cperl-nonoverridable-face))
+	  ;;(or (boundp 'cperl-hash-face)
+	  ;;    (defconst cperl-hash-face
+	  ;;	'cperl-hash-face
+	  ;;	"Face to use for hashes."))
+	  ;;(or (boundp 'cperl-array-face)
+	  ;;    (defconst cperl-array-face
+	  ;;	'cperl-array-face
+	  ;;	"Face to use for arrays."))
 	  ;; Here we try to guess background
 	  (let ((background
 		 (if (boundp 'font-lock-background-mode)
 		     font-lock-background-mode
 		   'light)) 
 		(face-list (and (fboundp 'face-list) (face-list)))
-		cperl-is-face)
-	    (fset 'cperl-is-face
-		  (cond ((fboundp 'find-face)
-			 (symbol-function 'find-face))
-			(face-list
-			 (function (lambda (face) (member face face-list))))
-			(t
-			 (function (lambda (face) (boundp face))))))
+		;; cperl-is-face
+		)
+;;;;	    (fset 'cperl-is-face
+;;;;		  (cond ((fboundp 'find-face)
+;;;;			 (symbol-function 'find-face))
+;;;;			(face-list
+;;;;			 (function (lambda (face) (member face face-list))))
+;;;;			(t
+;;;;			 (function (lambda (face) (boundp face))))))
 	    (defvar cperl-guessed-background
 	      (if (and (boundp 'font-lock-display-type)
 		       (eq font-lock-display-type 'grayscale))
@@ -4167,7 +4719,6 @@
 	    (if (and 
 		 (not (cperl-is-face 'font-lock-constant-face)) 
 		 (cperl-is-face 'font-lock-reference-face)) 
-		nil
 	      (copy-face 'font-lock-reference-face 'font-lock-constant-face))
 	    (if (cperl-is-face 'font-lock-type-face) nil
 	      (copy-face 'default 'font-lock-type-face)
@@ -4184,88 +4735,137 @@
 				       "pink")))
 	       (t
 		(set-face-background 'font-lock-type-face "gray90"))))
-	    (if (cperl-is-face 'font-lock-other-type-face)
+	    (if (cperl-is-face 'cperl-nonoverridable-face)
 		nil
-	      (copy-face 'font-lock-type-face 'font-lock-other-type-face)
+	      (copy-face 'font-lock-type-face 'cperl-nonoverridable-face)
 	      (cond
 	       ((eq background 'light)
-		(set-face-foreground 'font-lock-other-type-face
+		(set-face-foreground 'cperl-nonoverridable-face
 				     (if (x-color-defined-p "chartreuse3")
 					 "chartreuse3"
 				       "chartreuse")))
 	       ((eq background 'dark)
-		(set-face-foreground 'font-lock-other-type-face
+		(set-face-foreground 'cperl-nonoverridable-face
 				     (if (x-color-defined-p "orchid1")
 					 "orchid1"
 				       "orange")))))
-	    (if (cperl-is-face 'font-lock-other-emphasized-face) nil
-	      (copy-face 'bold-italic 'font-lock-other-emphasized-face)
-	      (cond
-	       ((eq background 'light)
-		(set-face-background 'font-lock-other-emphasized-face
-				     (if (x-color-defined-p "lightyellow2")
-					 "lightyellow2"
-				       (if (x-color-defined-p "lightyellow")
-					   "lightyellow"
-					 "light yellow"))))
-	       ((eq background 'dark)
-		(set-face-background 'font-lock-other-emphasized-face
-				     (if (x-color-defined-p "navy")
-					 "navy"
-				       (if (x-color-defined-p "darkgreen")
-					   "darkgreen"
-					 "dark green"))))
-	       (t (set-face-background 'font-lock-other-emphasized-face "gray90"))))
-	    (if (cperl-is-face 'font-lock-emphasized-face) nil
-	      (copy-face 'bold 'font-lock-emphasized-face)
-	      (cond
-	       ((eq background 'light)
-		(set-face-background 'font-lock-emphasized-face
-				     (if (x-color-defined-p "lightyellow2")
-					 "lightyellow2"
-				       "lightyellow")))
-	       ((eq background 'dark)
-		(set-face-background 'font-lock-emphasized-face
-				     (if (x-color-defined-p "navy")
-					 "navy"
-				       (if (x-color-defined-p "darkgreen")
-					   "darkgreen"
-					 "dark green"))))
-	       (t (set-face-background 'font-lock-emphasized-face "gray90"))))
+;;;	    (if (cperl-is-face 'font-lock-other-emphasized-face) nil
+;;;	      (copy-face 'bold-italic 'font-lock-other-emphasized-face)
+;;;	      (cond
+;;;	       ((eq background 'light)
+;;;		(set-face-background 'font-lock-other-emphasized-face
+;;;				     (if (x-color-defined-p "lightyellow2")
+;;;					 "lightyellow2"
+;;;				       (if (x-color-defined-p "lightyellow")
+;;;					   "lightyellow"
+;;;					 "light yellow"))))
+;;;	       ((eq background 'dark)
+;;;		(set-face-background 'font-lock-other-emphasized-face
+;;;				     (if (x-color-defined-p "navy")
+;;;					 "navy"
+;;;				       (if (x-color-defined-p "darkgreen")
+;;;					   "darkgreen"
+;;;					 "dark green"))))
+;;;	       (t (set-face-background 'font-lock-other-emphasized-face "gray90"))))
+;;;	    (if (cperl-is-face 'font-lock-emphasized-face) nil
+;;;	      (copy-face 'bold 'font-lock-emphasized-face)
+;;;	      (cond
+;;;	       ((eq background 'light)
+;;;		(set-face-background 'font-lock-emphasized-face
+;;;				     (if (x-color-defined-p "lightyellow2")
+;;;					 "lightyellow2"
+;;;				       "lightyellow")))
+;;;	       ((eq background 'dark)
+;;;		(set-face-background 'font-lock-emphasized-face
+;;;				     (if (x-color-defined-p "navy")
+;;;					 "navy"
+;;;				       (if (x-color-defined-p "darkgreen")
+;;;					   "darkgreen"
+;;;					 "dark green"))))
+;;;	       (t (set-face-background 'font-lock-emphasized-face "gray90"))))
 	    (if (cperl-is-face 'font-lock-variable-name-face) nil
 	      (copy-face 'italic 'font-lock-variable-name-face))
 	    (if (cperl-is-face 'font-lock-constant-face) nil
 	      (copy-face 'italic 'font-lock-constant-face))))
 	(setq cperl-faces-init t))
-    (error nil)))
+    (error (message "cperl-init-faces (ignored): %s" errs))))
 
 
 (defun cperl-ps-print-init ()
   "Initialization of `ps-print' components for faces used in CPerl."
-  ;; Guard against old versions
-  (defvar ps-underlined-faces nil)
-  (defvar ps-bold-faces nil)
-  (defvar ps-italic-faces nil)
-  (setq ps-bold-faces
-	(append '(font-lock-emphasized-face
-		  font-lock-keyword-face 
-		  font-lock-variable-name-face 
-		  font-lock-constant-face 
-		  font-lock-reference-face 
-		  font-lock-other-emphasized-face) 
-		ps-bold-faces))
-  (setq ps-italic-faces
-	(append '(font-lock-other-type-face
-		  font-lock-constant-face 
-		  font-lock-reference-face 
-		  font-lock-other-emphasized-face)
-		ps-italic-faces))
-  (setq ps-underlined-faces
-	(append '(font-lock-emphasized-face
-		  font-lock-other-emphasized-face 
-		  font-lock-other-type-face font-lock-type-face)
-		ps-underlined-faces))
-  (cons 'font-lock-type-face ps-underlined-faces))
+  (eval-after-load "ps-print"
+    '(setq ps-bold-faces
+	   ;; 			font-lock-variable-name-face 
+	   ;;			font-lock-constant-face
+	   (append '(cperl-array-face
+		     cperl-hash-face) 
+		   ps-bold-faces)
+	   ps-italic-faces
+	   ;;			font-lock-constant-face
+	   (append '(cperl-nonoverridable-face
+		     cperl-hash-face)
+		   ps-italic-faces)
+	   ps-underlined-faces
+	   ;;	     font-lock-type-face
+	   (append '(cperl-array-face
+		     cperl-hash-face
+		     underline
+		     cperl-nonoverridable-face)
+		   ps-underlined-faces))))
+
+(defvar ps-print-face-extension-alist)
+
+(defun cperl-ps-print (&optional file)
+  "Pretty-print in CPerl style.
+If optional argument FILE is an empty string, prints to printer, otherwise
+to the file FILE.  If FILE is nil, prompts for a file name.
+
+Style of printout regulated by the variable `cperl-ps-print-face-properties'."
+  (interactive)
+  (or file 
+      (setq file (read-from-minibuffer 
+		  "Print to file (if empty - to printer): "
+		  (concat (buffer-file-name) ".ps")
+		  nil nil 'file-name-history)))
+  (or (> (length file) 0)
+      (setq file nil))
+  (require 'ps-print)			; To get ps-print-face-extension-alist
+  (let ((ps-print-color-p t)
+	(ps-print-face-extension-alist ps-print-face-extension-alist))
+    (cperl-ps-extend-face-list cperl-ps-print-face-properties)
+    (ps-print-buffer-with-faces file)))
+
+;;; (defun cperl-ps-print-init ()
+;;;   "Initialization of `ps-print' components for faces used in CPerl."
+;;;   ;; Guard against old versions
+;;;   (defvar ps-underlined-faces nil)
+;;;   (defvar ps-bold-faces nil)
+;;;   (defvar ps-italic-faces nil)
+;;;   (setq ps-bold-faces
+;;; 	(append '(font-lock-emphasized-face
+;;; 		  cperl-array-face
+;;; 		  font-lock-keyword-face 
+;;; 		  font-lock-variable-name-face 
+;;; 		  font-lock-constant-face 
+;;; 		  font-lock-reference-face 
+;;; 		  font-lock-other-emphasized-face
+;;; 		  cperl-hash-face) 
+;;; 		ps-bold-faces))
+;;;   (setq ps-italic-faces
+;;; 	(append '(cperl-nonoverridable-face
+;;; 		  font-lock-constant-face 
+;;; 		  font-lock-reference-face 
+;;; 		  font-lock-other-emphasized-face
+;;; 		  cperl-hash-face)
+;;; 		ps-italic-faces))
+;;;   (setq ps-underlined-faces
+;;; 	(append '(font-lock-emphasized-face
+;;; 		  cperl-array-face
+;;; 		  font-lock-other-emphasized-face
+;;; 		  cperl-hash-face
+;;; 		  cperl-nonoverridable-face font-lock-type-face)
+;;; 		ps-underlined-faces))
+;;;   (cons 'font-lock-type-face ps-underlined-faces))
 
 
 (if (cperl-enable-font-lock) (cperl-windowed-init))
@@ -4333,7 +4933,7 @@
      ;;(cperl-extra-newline-before-brace .  nil) ; ???
      (cperl-continued-statement-offset .  4)))
   "(Experimental) list of variables to set to get a particular indentation style.
-Should be used via `cperl-set-style' or via CPerl menu.")
+Should be used via `cperl-set-style' or via Perl menu.")
 
 (defun cperl-set-style (style)
   "Set CPerl-mode variables to use one of several different indentation styles.
@@ -4675,7 +5275,9 @@
   "Toggle whether `indent-region'/`indent-sexp' fix whitespace too."
   (interactive)
   (setq cperl-indent-region-fix-constructs 
-	(not cperl-indent-region-fix-constructs))
+	(if cperl-indent-region-fix-constructs
+	    nil
+	  1))
   (message "indent-region/indent-sexp will %sbe automatically fix whitespace." 
 	   (if cperl-indent-region-fix-constructs "" "not ")))
 
@@ -4765,8 +5367,10 @@
 	      (lambda (elt)
 		(cond ((string-match "^[_a-zA-Z]" (car elt))
 		       (goto-char (cdr elt))
+		       (beginning-of-line) ; pos should be of the start of the line
 		       (list (car elt) 
-			     (point) (count-lines 1 (point))
+			     (point) 
+			     (1+ (count-lines 1 (point))) ; 1+ since at beg-o-l
 			     (buffer-substring (progn
 						 (skip-chars-forward 
 						  ":_a-zA-Z0-9")
@@ -4787,9 +5391,9 @@
 			  (substring (car elt) 8)
 			(car elt) )
 		      1
-		      (number-to-string (elt elt 1))
+		      (number-to-string (elt elt 2)) ; Line
 		      ","
-		      (number-to-string (elt elt 2))
+		      (number-to-string (1- (elt elt 1))) ; Char pos 0-based
 		      "\n")
 	      (if (and (string-match "^[_a-zA-Z]+::" (car elt))
 		       (string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]"
@@ -4841,11 +5445,13 @@
       (setq topdir default-directory))
   (let ((tags-file-name "TAGS")
 	(case-fold-search (eq system-type 'emx))
-	xs)
+	xs rel)
     (save-excursion
       (cond (inbuffer nil)		; Already there
 	    ((file-exists-p tags-file-name)
-	     (visit-tags-table-buffer tags-file-name))
+	     (if cperl-xemacs-p
+		 (visit-tags-table-buffer)
+	      (visit-tags-table-buffer tags-file-name)))
 	    (t (set-buffer (find-file-noselect tags-file-name))))
       (cond
        (dir
@@ -4876,7 +5482,12 @@
 		  (erase (erase-buffer))
 		  (t
 		   (goto-char 1)
-		   (if (search-forward (concat "\f\n" file ",") nil t)
+		   (setq rel file)
+		   ;; On case-preserving filesystems (EMX on OS/2) case might be encoded in properties
+		   (set-text-properties 0 (length rel) nil rel)
+		   (and (equal topdir (substring rel 0 (length topdir)))
+			(setq rel (substring file (length topdir))))
+		   (if (search-forward (concat "\f\n" rel ",") nil t)
 		       (progn
 			 (search-backward "\f\n")
 			 (delete-region (point)
@@ -4928,11 +5539,12 @@
 	    (setq ;;str (buffer-substring (match-beginning 1) (match-end 1))
 		  name (buffer-substring (match-beginning 2) (match-end 2))
 		  ;;pos (buffer-substring (match-beginning 3) (match-end 3))
-		  line (buffer-substring (match-beginning 4) (match-end 4))
+		  line (buffer-substring (match-beginning 3) (match-end 3))
 		  ord (if pack 1 0)
-		  info (etags-snarf-tag) ; Moves to beginning of the next line
 		  file (file-of-tag)
-		  fileind (format "%s:%s" file line))
+		  fileind (format "%s:%s" file line)
+		  ;; Moves to beginning of the next line:
+		  info (cperl-etags-snarf-tag file line))
 	    ;; Move back
 	    (forward-char -1)
 	    ;; Make new member of hierarchy name ==> file ==> pos if needed
@@ -4958,22 +5570,31 @@
   (require 'etags)
   (require 'imenu)
   (if (or update (null (nth 2 cperl-hierarchy)))
-      (let (pack name cons1 to l1 l2 l3 l4
+      (let (pack name cons1 to l1 l2 l3 l4 b
 		 (remover (function (lambda (elt) ; (name (file1...) (file2..))
 				      (or (nthcdr 2 elt)
 					  ;; Only in one file
 					  (setcdr elt (cdr (nth 1 elt))))))))
 	;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later!
 	(setq cperl-hierarchy (list l1 l2 l3))
-	(or tags-table-list
+	(if cperl-xemacs-p		; 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))
 	(mapcar 
 	 (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..."))
 	(mapcar remover (car cperl-hierarchy))
 	(mapcar remover (nth 1 cperl-hierarchy))
 	(setq to (list nil (cons "Packages: " (nth 1 cperl-hierarchy))
@@ -4998,7 +5619,7 @@
   (if (vectorp update) 
       (progn
 	(find-file (elt update 0))
-	(etags-goto-tag-location (elt update 1))))
+	(cperl-etags-goto-tag-location (elt update 1))))
   (if (eq update -999) (cperl-tags-hier-init t)))
 
 (defun cperl-tags-treeify (to level)
@@ -5129,14 +5750,17 @@
      "[a-zA-Z0-9_][|&][a-zA-Z0-9_$]"	; abc|def abc&def are often used.
      "&[(a-zA-Z0-9_$]"			; &subroutine &(var->field)
      "<\\$?\\sw+\\(\\.\\sw+\\)?>"	; <IN> <stdin.h>
-     "-[a-zA-Z][ \t]+[_$\"'`]"		; -f file
+     "-[a-zA-Z][ \t]+[_$\"'`a-zA-Z]"	; -f file, -t STDIN
      "-[0-9]"				; -5
      "\\+\\+"				; ++var
      "--"				; --var
      ".->"				; a->b
      "->"				; a SPACE ->b
      "\\[-"				; a[-1]
+     "\\\\[&$@*\\\\]"			; \&func
      "^="				; =head
+     "\\$."				; $|
+     "<<[a-zA-Z_'\"`]"			; <<FOO, <<'FOO'
      "||"
      "&&"
      "[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C<code like text>
@@ -5407,6 +6031,7 @@
 $^H     The current set of syntax checks enabled by `use strict'.
 $^I	The value of the in-place edit extension (perl -i option).
 $^L     What formats output to perform a formfeed.  Default is \f.
+$^M     A buffer for emergency memory allocation when running out of memory.
 $^O     The operating system name under which this copy of Perl was built.
 $^P	Internal debugging flag.
 $^T	The time the script was started.  Used by -A/-M/-C file tests.
@@ -5945,11 +6570,11 @@
   ;; Returns position of the start
   (save-excursion
     (or cperl-use-syntax-table-text-property
-	(error "I need to have regex marked!"))
+	(error "I need to have a regexp marked!"))
     ;; Find the start
     (if (looking-at "\\s|")
 	nil				; good already
-      (if (looking-at "[smy]\\s|")
+      (if (looking-at "\\([smy]\\|qr\\)\\s|")
 	  (forward-char 1)
 	(re-search-backward "\\s|")))		; Assume it is scanned already.
     ;;(forward-char 1)
@@ -5999,7 +6624,7 @@
       (or done (forward-char -1)))))
 
 (defun cperl-contract-level ()
-  "Find an enclosing group in regexp and contract it.  Unfinished.
+  "Find an enclosing group in regexp and contract it.
 \(Experimental, may change semantics, recheck the result.)
 We suppose that the regexp is scanned already."
   (interactive)
@@ -6022,7 +6647,7 @@
 	(just-one-space))))))
 
 (defun cperl-contract-levels ()
-  "Find an enclosing group in regexp and contract all the kids.  Unfinished.
+  "Find an enclosing group in regexp and contract all the kids.
 \(Experimental, may change semantics, recheck the result.)
 We suppose that the regexp is scanned already."
   (interactive)
@@ -6137,6 +6762,7 @@
 	  (error "`%s' not with an (EXPR)" s0)))
     (error "Not at `if', `unless', `while', or `unless'")))
 
+;;; By Anthony Foiani <afoiani@uswest.com>
 ;;; Getting help on modules in C-h f ?
 ;;; This is a modified version of `man'.
 ;;; Need to teach it how to lookup functions
@@ -6174,6 +6800,7 @@
   :type 'file
   :group 'cperl)
 
+;;; By Nick Roberts <Nick.Roberts@src.bae.co.uk> (with changes)
 (defun cperl-pod-to-manpage ()
   "Create a virtual manpage in Emacs from the Perl Online Documentation."
   (interactive)
@@ -6261,11 +6888,17 @@
 
 (defvar cperl-d-l nil)
 (defun cperl-fontify-syntaxically (end)
-  (let ((start (point)) (dbg (point)))
+  ;; Some vars for debugging only
+  (let (start (dbg (point)) (iend end) 
+	(istate (car cperl-syntax-state)))
+    (and cperl-syntaxify-unwind
+	 (setq end (cperl-unwind-to-safe t end)))
+    (setq start (point))
     (or cperl-syntax-done-to
 	(setq cperl-syntax-done-to (point-min)))
     (if (or (not (boundp 'font-lock-hot-pass))
-	    (eval 'font-lock-hot-pass))
+	    (eval 'font-lock-hot-pass)
+	    t)				; Not debugged otherwise
 	;; Need to forget what is after `start'
 	(setq start (min cperl-syntax-done-to start))
       ;; Fontification without a change
@@ -6279,11 +6912,38 @@
     ;;(let ((standard-output (get-buffer "*Messages*")))
 	;;(princ (format "Syntaxifying %s..%s from %s to %s\n" 
 		;;       dbg end start cperl-syntax-done-to)))
-    (if (eq cperl-syntaxify-by-font-lock 1)
-	(message "Syntaxifying %s..%s from %s to %s" 
-		 dbg end start cperl-syntax-done-to)) ; For debugging 
+    (if (eq cperl-syntaxify-by-font-lock 'message)
+	(message "Syntaxified %s..%s from %s to %s(%s), state %s-->%s" 
+		 dbg iend 
+		 start end cperl-syntax-done-to 
+		 istate (car cperl-syntax-state))) ; For debugging 
     nil))					; Do not iterate
 
+(defun cperl-fontify-update (end)
+  (let ((pos (point)) prop posend)
+    (while (< pos end)
+      (setq prop (get-text-property pos 'cperl-postpone))
+      (setq posend (next-single-property-change pos 'cperl-postpone nil end))
+      (and prop (put-text-property pos posend (car prop) (cdr prop)))
+      (setq pos posend)))
+  nil)				; Do not iterate
+
+(defun cperl-update-syntaxification (from to)
+  (if (and cperl-use-syntax-table-text-property
+	   cperl-syntaxify-by-font-lock
+	   (or (null cperl-syntax-done-to)
+	       (< cperl-syntax-done-to to)))
+      (progn
+	(save-excursion
+	  (goto-char from)
+	  (cperl-fontify-syntaxically to)))))
+
+(defvar cperl-version 
+  (let ((v  "Revision: 4.21"))
+    (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)
 
 ;;; cperl-mode.el ends here