Function: cperl-init-faces
cperl-init-faces is a byte-compiled function defined in
cperl-mode.el.gz.
Signature
(cperl-init-faces)
Documentation
Initialize the faces for CPerl mode.
Source Code
;; Defined in /usr/src/emacs/lisp/progmodes/cperl-mode.el.gz
(defun cperl-init-faces ()
"Initialize the faces for CPerl mode."
(condition-case errs
(progn
(let (t-font-lock-keywords t-font-lock-keywords-1)
(setq
t-font-lock-keywords
(list
;; -------- function definition _and_ declaration
;; (matcher (subexp facespec))
;; facespec is evaluated depending on whether the
;; statement ends in a "{" (definition) or ";"
;; (declaration without body)
(list (concat "\\<" cperl-sub-regexp
;; group 1: optional subroutine name
(rx
(sequence (eval cperl--ws+-rx)
(group (optional
(eval cperl--normal-identifier-rx)))))
;; "fontified" elsewhere: Prototype
(rx (optional
(sequence (eval cperl--ws*-rx)
(eval cperl--prototype-rx))))
;; fontified elsewhere: Attributes
(rx (optional (sequence (eval cperl--ws*-rx)
(eval cperl--attribute-list-rx))))
(rx (eval cperl--ws*-rx))
;; group 2: Identifies the start of the anchor
(rx (group
(or (group-n 3 ";") ; Either a declaration...
"{" ; ... or a code block
;; ... or a complete signature
(sequence (eval cperl--signature-rx)
(eval cperl--ws*-rx))
;; ... or the start of a "sloppy" signature
(sequence (eval cperl--sloppy-signature-rx))
;; make sure we have a reasonably
;; short match for an incomplete sub
(not (in ";{("))
buffer-end))))
'(1 (if (match-beginning 3)
'font-lock-variable-name-face
'font-lock-function-name-face)
nil ; override
t) ; laxmatch in case of anonymous subroutines
;; -------- anchored: Signature
`(,(rx (sequence (in "(,")
(eval cperl--ws*-rx)
(group (eval cperl--basic-variable-rx))))
(progn
(goto-char (match-beginning 2)) ; pre-match: Back to sig
;; While typing, forward-sexp might fail with a scan error.
;; If so, stop looking for declarations at (match-end 2)
(condition-case nil
(save-excursion
(forward-sexp)
(point))
(error (match-end 2))))
nil
(1 font-lock-variable-name-face)))
;; -------- flow control
;; (matcher . subexp) font-lock-keyword-face by default
;; This highlights declarations and definitions differently.
;; We do not try to highlight in the case of attributes:
;; it is already done by `cperl-find-pods-heres'
(cons
(concat
"\\(^\\|[^$@%&\\]\\)\\<\\("
(regexp-opt
(append
cperl-sub-keywords
'("if" "until" "while" "elsif" "else"
"given" "when" "default" "break"
"unless" "for"
"try" "catch" "defer" "finally"
"foreach" "continue" "exit" "die" "last" "goto" "next"
"redo" "return" "local" "exec"
"do" "dump"
"use" "our"
"require" "package" "eval" "evalbytes" "my" "state"
"class" "field" "method"
"ADJUST" "BEGIN" "CHECK"
"END" "INIT" "UNITCHECK"
;; not in core, but per popular request
"async" "await"))) ; Flow control
"\\)\\>") 2) ; was "\\)[ \n\t;():,|&]"
; In what follows we use `type' style
; for overwritable builtins
;; -------- avoid method calls being fontified as keywords
;; (matcher (subexp facespec))
(list
(rx "->" (* space) (group-n 1(eval cperl--basic-identifier-rx)))
1 ''cperl-method-call)
;; -------- builtin functions
;; (matcher subexp facespec)
(list
(concat
"\\(^\\|[^$@%&\\]\\)\\<\\("
(regexp-opt
'("CORE" "__FILE__" "__LINE__" "__SUB__" "__PACKAGE__" "__CLASS__"
"abs" "accept" "alarm" "and" "atan2"
"bind" "binmode" "bless" "caller"
"chdir" "chmod" "chown" "chr" "chroot" "close"
"closedir" "cmp" "connect" "continue" "cos" "crypt"
"dbmclose" "dbmopen" "die" "dump" "endgrent"
"endhostent" "endnetent" "endprotoent" "endpwent"
"endservent" "eof" "eq" "exec" "exit" "exp" "fc" "fcntl"
"fileno" "flock" "fork" "formline" "ge" "getc"
"getgrent" "getgrgid" "getgrnam" "gethostbyaddr"
"gethostbyname" "gethostent" "getlogin"
"getnetbyaddr" "getnetbyname" "getnetent"
"getpeername" "getpgrp" "getppid" "getpriority"
"getprotobyname" "getprotobynumber" "getprotoent"
"getpwent" "getpwnam" "getpwuid" "getservbyname"
"getservbyport" "getservent" "getsockname"
"getsockopt" "glob" "gmtime" "gt" "hex" "index" "int"
"ioctl" "join" "kill" "lc" "lcfirst" "le" "length"
"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"
"readlink" "readpipe" "recv" "ref" "rename" "require"
"reset" "reverse" "rewinddir" "rindex" "rmdir" "seek"
"seekdir" "select" "semctl" "semget" "semop" "send"
"setgrent" "sethostent" "setnetent" "setpgrp"
"setpriority" "setprotoent" "setpwent" "setservent"
"setsockopt" "shmctl" "shmget" "shmread" "shmwrite"
"shutdown" "sin" "sleep" "socket" "socketpair"
"sprintf" "sqrt" "srand" "stat" "substr" "symlink"
"syscall" "sysopen" "sysread" "sysseek" "system" "syswrite" "tell"
"telldir" "time" "times" "truncate" "uc" "ucfirst"
"umask" "unlink" "unpack" "utime" "values" "vec"
"wait" "waitpid" "wantarray" "warn" "write" "x" "xor"))
"\\)\\>")
2 'font-lock-type-face)
;; In what follows we use `other' style
;; for nonoverwritable builtins
;; This is a bit shaky because the status
;; "nonoverwritable" can change between Perl versions.
;; -------- "non overridable" functions
;; (matcher subexp facespec)
(list
(concat
"\\(^\\|[^$@%&\\]\\)\\<\\("
(regexp-opt
'("AUTOLOAD" "BEGIN" "CHECK" "DESTROY" "END" "INIT" "UNITCHECK"
"__END__" "__DATA__"
"all" "any"
"break" "catch" "chomp" "chop" "default"
"defined" "delete" "do" "each" "else" "elsif" "eval"
"evalbytes" "exists" "finally" "for" "foreach" "format" "given"
"goto" "grep" "if" "keys" "last" "local" "m" "map" "my" "next"
"no" "our" "package" "pop" "pos" "print" "printf" "prototype"
"push" "q" "qq" "qr" "qw" "qx" "redo" "return" "s" "say" "scalar"
"shift" "sort" "splice" "split" "state" "study" "sub" "tie"
"tied" "tr" "try" "undef" "unless" "unshift" "untie" "until"
"use" "when" "while" "y"))
"\\)\\>")
2 ''cperl-nonoverridable-face) ; unbound as var, so: doubly quoted
;; (mapconcat #'identity
;; '("#endif" "#else" "#ifdef" "#ifndef" "#if"
;; "#include" "#define" "#undef")
;; "\\|")
;; -------- -X file tests
;; (matcher subexp facespec)
'("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0
font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]"
;; -------- various stuff calling for a package name
;; (matcher (subexp facespec) (subexp facespec))
`(,(rx (sequence
(or (sequence (or line-start space "{" )
(or "package" "require" "use" "import"
"no" "bootstrap" "class")
(eval cperl--ws+-rx))
(sequence (group-n 2 (sequence ":"
(eval cperl--ws*-rx)
"isa"))
"("
(eval cperl--ws*-rx)))
(group-n 1 (eval cperl--normal-identifier-rx))
(any " \t\n;)"))) ; require A if B;
(1 font-lock-function-name-face)
(2 font-lock-constant-face t t))
;; -------- formats
;; (matcher subexp facespec)
'("^[ \t]*format[ \t]+\\([a-zA-Z_][a-zA-Z_0-9:]*\\)[ \t]*=[ \t]*$"
1 font-lock-function-name-face)
;; -------- labels
;; (matcher subexp facespec)
`(,(rx
(sequence
(0+ space)
(group (eval cperl--label-rx))
(0+ space)
(or line-end "#" "{"
(sequence word-start
(or "until" "while" "for" "foreach" "do")
word-end))))
1 font-lock-constant-face)
;; -------- labels as targets (no trailing colon!)
;; (matcher subexp facespec)
`(,(rx
(sequence
symbol-start
(or "continue" "next" "last" "redo" "break" "goto")
(1+ space)
(group (eval cperl--basic-identifier-rx))))
1 font-lock-constant-face)
;; Uncomment to get perl-mode-like vars
;; '("[$*]{?\\(\\sw+\\)" 1 font-lock-variable-name-face)
;; '("\\([@%]\\|\\$#\\)\\(\\sw+\\)"
;; (2 (cons font-lock-variable-name-face '(underline))))
;; 1=my_etc, 2=white? 3=(+white? 4=white? 5=var
;; -------- variable declarations
;; (matcher (subexp facespec) ...
`(,(rx (sequence (or "state" "my" "local" "our"))
(eval cperl--ws*-rx)
(opt (group (sequence "(" (eval cperl--ws*-rx))))
(group
(in "$@%*")
(or
(eval cperl--normal-identifier-rx)
(eval cperl--special-identifier-rx))
)
)
;; (concat "\\<\\(state\\|my\\|local\\|our\\)"
;; cperl-maybe-white-and-comment-rex
;; "\\(("
;; cperl-maybe-white-and-comment-rex
;; "\\)?\\([$@%*]\\([a-zA-Z0-9_:]+\\|[^a-zA-Z0-9_]\\)\\)")
(2 font-lock-variable-name-face)
;; ... (anchored-matcher pre-form post-form subex-highlighters)
(,(rx (sequence point
(eval cperl--ws*-rx)
","
(eval cperl--ws*-rx)
(group
(in "$@%*")
(or
(eval cperl--normal-identifier-rx)
(eval cperl--special-identifier-rx))
)
)
)
;; ,(concat "\\="
;; cperl-maybe-white-and-comment-rex
;; ","
;; cperl-maybe-white-and-comment-rex
;; "\\([$@%*]\\([a-zA-Z0-9_:]+\\|[^a-zA-Z0-9_]\\)\\)")
;; Bug in font-lock: limit is used not only to limit
;; searches, but to set the "extend window for
;; facification" property. Thus we need to minimize.
(if (match-beginning 1) ; list declaration
(save-excursion
(goto-char (match-beginning 1))
(condition-case nil
(forward-sexp 1)
(error
(condition-case nil
(forward-char 200)
(error nil)))) ; typeahead
(1- (point))) ; report limit
(forward-char -2)) ; disable continued expr
nil
(1 font-lock-variable-name-face)))
;; -------- builtin constants with and without package prefix
;; (matcher subexp facespec)
`(,(rx (or space (in "=<>-"))
(group (optional "&")
(optional "builtin::")
(or "inf" "nan")
symbol-end))
1 'font-lock-constant-face)
;; -------- field declarations
`(,(rx "field"
(eval cperl--ws+-rx)
(group (eval cperl--basic-variable-rx))
(optional (sequence
(eval cperl--ws+-rx)
(group (eval cperl--attribute-list-rx)))))
(1 font-lock-variable-name-face)
;; -------- optional attributes
;; (anchored-matcher pre-form post-form subex-highlighters)
(,(rx
(group (optional ":" (eval cperl--ws*-rx))
(eval cperl--basic-identifier-rx))
(optional "("
(group (eval cperl--basic-identifier-rx))
")"))
;; pre-form: Define range for anchored matcher
(if (match-beginning 2)
(progn
(goto-char (match-beginning 2))
(match-end 2))
;; If there's no attribute list in match 2, set a short
;; limit to the search for the anchored matcher,
;; otherwise it might interpret stuff from the
;; initializer expression as attribute.
(1+ (point)))
nil
(1 font-lock-constant-face)
(2 font-lock-string-face nil t) ; lax match, value is optional
))
;; ----- foreach my $foo (
;; (matcher subexp facespec)
`(,(rx symbol-start "for" (opt "each")
(opt (sequence (1+ blank)
(or "state" "my" "local" "our")))
(0+ blank)
(group-n 1 (sequence "$"
(eval cperl--basic-identifier-rx)))
(0+ blank) "(")
;; '("\\<for\\(each\\)?\\([ \t]+\\(state\\|my\\|local\\|our\\)\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*("
1 font-lock-variable-name-face)
;; Avoid $!, and s!!, qq!! etc. when not fontifying syntactically
;; -------- ! as a negation char like $false = !$true
;; (matcher subexp facespec)
'("\\(?:^\\|[^smywqrx$]\\)\\(!\\)" 1 font-lock-negation-char-face)
;; -------- ^ as a negation char in character classes m/[^abc]/
;; (matcher subexp facespec)
'("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend)))
(setq
t-font-lock-keywords-1
`(
;; -------- bareword hash key: $foo{bar}, $foo[1]{bar}
;; (matcher (subexp facespec) ...
(,(rx (or (in "]}\\%@>*&")
(sequence "$" (eval cperl--normal-identifier-rx)))
(0+ blank) "{" (0+ blank)
(group-n 1 (sequence (opt "-")
(eval cperl--basic-identifier-rx)))
(0+ blank) "}")
;; '("\\([]}\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"
(1 font-lock-string-face)
;; -------- anchored bareword hash key: $foo{bar}{baz}
;; ... (anchored-matcher pre-form post-form subex-highlighters)
(,(rx point
(0+ blank) "{" (0+ blank)
(group-n 1 (sequence (opt "-")
(eval cperl--basic-identifier-rx)))
(0+ blank) "}")
;; ("\\=[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"
nil nil
(1 font-lock-string-face)))
;; -------- hash element assignments with bareword key => value
;; (matcher subexp facespec)
(,(rx (in "[ \t{,()")
(group-n 1 (sequence (opt "-")
(eval cperl--basic-identifier-rx)))
(0+ blank) "=>")
1 font-lock-string-face)
;; -------- @$ array dereferences, $#$ last array index
;; (matcher (subexp facespec) (subexp facespec))
(,(rx (group-n 1 (or "@" "$#"))
(group-n 2 (sequence "$"
(or (eval cperl--normal-identifier-rx)
(not (in " \t\n"))))))
;; ("\\(@\\|\\$#\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)"
(1 'cperl-array-face)
(2 font-lock-variable-name-face))
;; -------- %$ hash dereferences
;; (matcher (subexp facespec) (subexp facespec))
(,(rx (group-n 1 "%")
(group-n 2 (sequence "$"
(or (eval cperl--normal-identifier-rx)
(not (in " \t\n"))))))
;; ("\\(%\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)"
(1 'cperl-hash-face)
(2 font-lock-variable-name-face))
;; -------- access to array/hash elements
;; (matcher subexp facespec)
;; facespec is an expression to distinguish between arrays and hashes
(,(rx (group-n 1 (group-n 2 (in "$@%"))
(eval cperl--normal-identifier-rx))
(0+ blank)
(group-n 3 (in "[{")))
;; ("\\(\\([$@%]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)"
1
(if (= (- (match-end 2) (match-beginning 2)) 1)
(if (eq (char-after (match-beginning 3)) ?{)
'cperl-hash-face
'cperl-array-face) ; arrays and hashes
font-lock-variable-name-face) ; Just to put something
nil) ; do not override previous
;; -------- "Pure" arrays and hashes.
;; (matcher subexp facespec)
;; facespec is an expression to distinguish between arrays and hashes
(,(rx (group-n 1 (group-n 2 (or (in "@%") "$#"))
(eval cperl--normal-identifier-rx)))
1
;; ("\\(\\([@%]\\|\\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1
(if (eq (char-after (match-beginning 2)) ?%)
'cperl-hash-face
'cperl-array-face)
nil)
;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2")
;; Too much noise from \s* @s[ and friends
;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)"
;;(3 font-lock-function-name-face t t)
;;(4
;; (if (cperl-slash-is-regexp)
;; font-lock-function-name-face 'default) nil t))
))
(if cperl-highlight-variables-indiscriminately
(setq t-font-lock-keywords-1
(append t-font-lock-keywords-1
(list '("\\([$*]{?\\(?:\\sw+\\|::\\)+\\)" 1
font-lock-variable-name-face)))))
(setq cperl-font-lock-keywords-1
(if cperl-syntaxify-by-font-lock
(cons 'cperl-fontify-update
t-font-lock-keywords)
t-font-lock-keywords)
cperl-font-lock-keywords cperl-font-lock-keywords-1
cperl-font-lock-keywords-2 (append
t-font-lock-keywords-1
cperl-font-lock-keywords-1)))
(cperl-ps-print-init)
(setq cperl-faces-init t))
(error (message "cperl-init-faces (ignored): %s" errs))))