Function: rst-classify-adornment

rst-classify-adornment is a byte-compiled function defined in rst.el.gz.

Signature

(rst-classify-adornment ADORNMENT END &optional ACCEPT-OVER-ONLY)

Documentation

Classify adornment string for section titles and transitions.

ADORNMENT is the complete adornment string as found in the buffer with optional trailing whitespace. END is the point after the last character of ADORNMENT. Return a rst-Ttl or nil if no syntactically valid adornment is found. If ACCEPT-OVER-ONLY an overline with a missing underline is accepted as valid and returned.

Source Code

;; Defined in /usr/src/emacs/lisp/textmodes/rst.el.gz
(defun rst-classify-adornment (adornment end &optional accept-over-only)
  ;; testcover: ok.
  "Classify adornment string for section titles and transitions.
ADORNMENT is the complete adornment string as found in the buffer
with optional trailing whitespace.  END is the point after the
last character of ADORNMENT.  Return a `rst-Ttl' or nil if no
syntactically valid adornment is found.  If ACCEPT-OVER-ONLY an
overline with a missing underline is accepted as valid and
returned."
  (save-excursion
    (save-match-data
      (when (string-match (rst-re 'ado-beg-2-1) adornment)
	(goto-char end)
	(let* ((ado-ch (string-to-char (match-string 2 adornment)))
	       (ado-re (rst-re ado-ch 'adorep3-hlp)) ; RE matching the
						     ; adornment.
	       (beg-pnt (progn
			  (1value
			   (rst-forward-line-strict 0))
			  (point)))
	       (nxt-emp ; Next line nonexistent or empty
		(not (rst-forward-line-looking-at +1 'lin-end #'not)))
	       (prv-emp ; Previous line nonexistent or empty
		(not (rst-forward-line-looking-at -1 'lin-end #'not)))
	       txt-blw
	       (ttl-blw ; Title found below starting here.
		(rst-forward-line-looking-at
		 +1 'ttl-beg-1
                 (lambda (mtcd)
                   (when mtcd
                     (setq txt-blw (match-string-no-properties 1))
                     (point)))))
	       txt-abv
	       (ttl-abv ; Title found above starting here.
		(rst-forward-line-looking-at
		  -1 'ttl-beg-1
                  (lambda (mtcd)
                    (when mtcd
                      (setq txt-abv (match-string-no-properties 1))
                      (point)))))
	       (und-fnd ; Matching underline found starting here.
		(and ttl-blw
		     (rst-forward-line-looking-at
		      +2 (list ado-re 'lin-end)
                      (lambda (mtcd)
                        (when mtcd
                          (point))))))
	       (ovr-fnd ; Matching overline found starting here.
		(and ttl-abv
		     (rst-forward-line-looking-at
		      -2 (list ado-re 'lin-end)
                      (lambda (mtcd)
                        (when mtcd
                          (point))))))
	       (und-wng ; Wrong underline found starting here.
		(and ttl-blw
		     (not und-fnd)
		     (rst-forward-line-looking-at
		      +2 'ado-beg-2-1
                      (lambda (mtcd)
                        (when mtcd
                          (point))))))
	       (ovr-wng ; Wrong overline found starting here.
		(and ttl-abv (not ovr-fnd)
		     (rst-forward-line-looking-at
		       -2 'ado-beg-2-1
                       (lambda (mtcd)
                         (when (and
                                mtcd
                                ;; An adornment above may be a legal
                                ;; adornment for the line above - consider it
                                ;; a wrong overline only when it is equally
                                ;; long.
                                (equal
                                 (length (match-string-no-properties 1))
                                 (length adornment)))
                           (point)))))))
	  (cond
	   ((and nxt-emp prv-emp)
	    ;; A transition.
	    (rst-Ttl-from-buffer (rst-Ado-new-transition)
				 nil beg-pnt nil nil))
	   (ovr-fnd ; Prefer overline match over underline match.
	    ;; An overline with an underline.
	    (rst-Ttl-from-buffer (rst-Ado-new-over-and-under ado-ch)
				 ovr-fnd ttl-abv beg-pnt txt-abv))
	   (und-fnd
	    ;; An overline with an underline.
	    (rst-Ttl-from-buffer (rst-Ado-new-over-and-under ado-ch)
				 beg-pnt ttl-blw und-fnd txt-blw))
	   ((and ttl-abv (not ovr-wng))
	    ;; An underline.
	    (rst-Ttl-from-buffer (rst-Ado-new-simple ado-ch)
				 nil ttl-abv beg-pnt txt-abv))
	   ((and accept-over-only ttl-blw (not und-wng))
	    ;; An overline with a missing underline.
	    (rst-Ttl-from-buffer (rst-Ado-new-over-and-under ado-ch)
				 beg-pnt ttl-blw nil txt-blw))
	   (t
	    ;; Invalid adornment.
	    nil)))))))