Function: faceup-markup-to-buffer

faceup-markup-to-buffer is a byte-compiled function defined in faceup.el.gz.

Signature

(faceup-markup-to-buffer TO-BUFFER &optional BUFFER)

Documentation

Convert content of BUFFER to faceup form and insert in TO-BUFFER.

Source Code

;; Defined in /usr/src/emacs/lisp/emacs-lisp/faceup.el.gz
(defun faceup-markup-to-buffer (to-buffer &optional buffer)
  "Convert content of BUFFER to faceup form and insert in TO-BUFFER."
  (save-excursion
    (if buffer
        (set-buffer buffer))
    ;; Font-lock often only fontifies the visible sections. This
    ;; ensures that the entire buffer is fontified before converting
    ;; it.
    (if (and font-lock-mode
             ;; Prevent clearing out face attributes explicitly
             ;; inserted by functions like `list-faces-display'.
             ;; (Font-lock mode is enabled, for some reason, in those
             ;; buffers.)
             (not (and (eq major-mode 'help-mode)
                       (not font-lock-defaults))))
        (font-lock-fontify-region (point-min) (point-max)))
    (let ((last-pos (point-min))
          (pos nil)
          ;; List of (prop . value), representing open faceup blocks.
          (state '()))
      (while (setq pos (faceup-next-property-change pos))
        ;; Insert content.
        (faceup-copy-and-quote last-pos pos to-buffer)
        (setq last-pos pos)
        (let ((prop-values (faceup-get-text-properties pos)))
          (let ((next-state '()))
            (setq state (reverse state))
            ;; Find all existing sequences that should continue.
            (let ((cont t))
              (while (and state
                          prop-values
                          cont)
                (let* ((prop (car (car state)))
                       (value (cdr (car state)))
                       (pair (assq prop prop-values)))
                  (if (memq prop faceup-face-like-properties)
                      ;; Element by element.
                      (if (equal value (car (cdr pair)))
                          (setcdr pair (cdr (cdr pair)))
                        (setq cont nil))
                    ;; Full value.
                    ;;
                    ;; Note: Comparison is done by `eq', since (at
                    ;; least) the `display' property treats
                    ;; eq-identical values differently than when
                    ;; comparing using `equal'. See "Display Specs
                    ;; That Replace The Text" in the elisp manual.
                    (if (eq value (cdr pair))
                        (setq prop-values (delq pair prop-values))
                      (setq cont nil))))
                (when cont
                  (push (pop state) next-state))))
            ;; End values that should not be included in the next state.
            (while state
              (with-current-buffer to-buffer
                (insert (make-string 1 faceup-markup-end-char)))
              (pop state))
            ;; Start new ranges.
            (with-current-buffer to-buffer
              (while prop-values
                (let ((pair (pop prop-values)))
                  (if (memq (car pair) faceup-face-like-properties)
                      ;; Face-like.
                      (dolist (element (cdr pair))
                        (insert (make-string 1 faceup-markup-start-char))
                        (unless (eq (car pair) faceup-default-property)
                          (insert "(")
                          (insert (symbol-name (car pair)))
                          (insert "):"))
                        (if (symbolp element)
                            (let ((short
                                   (assq element faceup-face-short-alist)))
                              (if short
                                  (insert (cdr short) ":")
                                (insert ":" (symbol-name element) ":")))
                          (insert ":")
                          (prin1 element (current-buffer))
                          (insert ":"))
                        (push (cons (car pair) element) next-state))
                    ;; Not face-like.
                    (insert (make-string 1 faceup-markup-start-char))
                    (insert "(")
                    (insert (symbol-name (car pair)))
                    (insert "):")
                    (prin1 (cdr pair) (current-buffer))
                    (insert ":")
                    (push pair next-state)))))
            ;; Insert content.
            (setq state next-state))))
      ;; Insert whatever is left after the last face change.
      (faceup-copy-and-quote last-pos (point-max) to-buffer))))