Function: perl-syntax-propertize-special-constructs

perl-syntax-propertize-special-constructs is a byte-compiled function defined in perl-mode.el.gz.

Signature

(perl-syntax-propertize-special-constructs LIMIT)

Documentation

Propertize special constructs like regexps and formats.

Source Code

;; Defined in /usr/src/emacs/lisp/progmodes/perl-mode.el.gz
(defun perl-syntax-propertize-special-constructs (limit)
  "Propertize special constructs like regexps and formats."
  (let ((state (syntax-ppss))
        char)
    (cond
     ((eq 2 (nth 7 state))
      ;; A Here document.
      (let ((names (cdr (get-text-property (nth 8 state) 'syntax-table))))
        (when (cdr names)
          (setq names (reverse names))
          ;; Multiple heredocs on a single line, we have to search from the
          ;; beginning, since we don't know which names might be
          ;; before point.
          (goto-char (nth 8 state)))
        (while (and names
                    (re-search-forward
                     (pcase-let ((`(,name . ,indented) (pop names)))
                       (concat "^" (if indented "[ \t]*")
                               (regexp-quote name) "\n"))
                     limit 'move))
          (unless names
            (put-text-property (1- (point)) (point) 'syntax-table
                               (string-to-syntax "> c"))))))
     ((or (null (setq char (nth 3 state)))
          (and (characterp char)
               (null (get-text-property (nth 8 state) 'syntax-table))))
      ;; Normal text, or comment, or docstring, or normal string.
      nil)
     ((eq (nth 3 state) ?\n)
      ;; A `format' command.
      (when (re-search-forward "^\\s *\\.\\s *\n" limit 'move)
        (put-text-property (1- (point)) (point)
                           'syntax-table (string-to-syntax "\""))))
     (t
      ;; This is regexp like quote thingy.
      (setq char (char-after (nth 8 state)))
      (let ((startpos (point))
            (twoargs (save-excursion
                       (goto-char (nth 8 state))
                       (skip-syntax-backward " ")
                       (skip-syntax-backward "w")
                       (member (buffer-substring
                                (point) (progn (forward-word-strictly 1)
                                               (point)))
                               '("tr" "s" "y"))))
            (close (cdr (assq char perl-quote-like-pairs)))
            (middle nil)
            (st (perl-quote-syntax-table char)))
        (when (with-syntax-table st
		(if close
		    ;; For paired delimiters, Perl allows nesting them, but
		    ;; since we treat them as strings, Emacs does not count
		    ;; those delimiters in `state', so we don't know how deep
		    ;; we are: we have to go back to the beginning of this
		    ;; "string" and count from there.
		    (condition-case nil
			(progn
			  ;; Start after the first char since it doesn't have
			  ;; paren-syntax (an alternative would be to let-bind
			  ;; parse-sexp-lookup-properties).
			  (goto-char (1+ (nth 8 state)))
			  (up-list 1)
			  t)
                      ;; In case of error, make sure we don't move backward.
		      (scan-error (goto-char startpos) nil))
		  (not (or (nth 8 (parse-partial-sexp
				   ;; Since we don't know if point is within
				   ;; the first or the scond arg, we have to
				   ;; start from the beginning.
				   (if twoargs (1+ (nth 8 state)) (point))
				   limit nil nil state 'syntax-table))
			   ;; If we have a self-paired opener and a twoargs
			   ;; command, the form is s/../../ so we have to skip
			   ;; a second time.
			   ;; In the case of s{...}{...}, we only handle the
			   ;; first part here and the next below.
			   (when (and twoargs (not close))
			     (setq middle (point))
			     (nth 8 (parse-partial-sexp
				     (point) limit
				     nil nil state 'syntax-table)))))))
	  ;; Point is now right after the arg(s).
	  (when (eq (char-before (1- (point))) ?$)
	    (put-text-property (- (point) 2) (1- (point))
			       'syntax-table '(1)))
	  (if (and middle (memq char '(?\" ?\')))
	      (put-text-property (1- middle) middle
			     'syntax-table '(1))
	    (put-text-property (1- (point)) (point)
			       'syntax-table
			       (if close
				   (string-to-syntax "|")
				 (string-to-syntax "\""))))
	  ;; If we have two args with a non-self-paired starter (e.g.
	  ;; s{...}{...}) we're right after the first arg, so we still have to
	  ;; handle the second part.
	  (when (and twoargs close)
	    ;; Skip whitespace and make sure that font-lock will
	    ;; refontify the second part in the proper context.
	    (put-text-property
	     (point) (progn (forward-comment (point-max)) (point))
	     'syntax-multiline t)
	    ;;
	    (when (< (point) limit)
	      (put-text-property (point) (1+ (point))
				 'syntax-table
				 (if (assoc (char-after)
					    perl-quote-like-pairs)
                                     ;; Put an `e' in the cdr to mark this
                                     ;; char as "second arg starter".
				     (string-to-syntax "|e")
				   (string-to-syntax "\"e")))
	      (forward-char 1)
	      ;; Re-use perl-syntax-propertize-special-constructs to handle the
	      ;; second part (the first delimiter of second part can't be
	      ;; preceded by "s" or "tr" or "y", so it will not be considered
	      ;; as twoarg).
	      (perl-syntax-propertize-special-constructs limit)))))))))