Syntax-Highlight-WithEmacs
view release on metacpan or search on metacpan
(defvar htmlize-buffer-places)
;;; Some cross-Emacs compatibility.
;; I try to conditionalize on features rather than Emacs version, but
;; in some cases checking against the version *is* necessary.
(defconst htmlize-running-xemacs (string-match "XEmacs" emacs-version))
;; We need a function that efficiently finds the next change of a
;; property regardless of whether the change occurred because of a
;; text property or an extent/overlay.
(cond
(htmlize-running-xemacs
(defun htmlize-next-change (pos prop &optional limit)
(if prop
(next-single-char-property-change pos prop nil (or limit (point-max)))
(next-property-change pos nil (or limit (point-max)))))
(defun htmlize-next-face-change (pos &optional limit)
(htmlize-next-change pos 'face limit)))
(t
(defun htmlize-next-change (pos prop &optional limit)
(if prop
(next-single-char-property-change pos prop nil limit)
(next-char-property-change pos limit)))
(defun htmlize-overlay-faces-at (pos)
(delq nil (mapcar (lambda (o) (overlay-get o 'face)) (overlays-at pos))))
(defun htmlize-next-face-change (pos &optional limit)
;; (htmlize-next-change pos 'face limit) would skip over entire
;; overlays that specify the `face' property, even when they
;; contain smaller text properties that also specify `face'.
;; Emacs display engine merges those faces, and so must we.
(or limit
(setq limit (point-max)))
(let ((next-prop (next-single-property-change pos 'face nil limit))
(overlay-faces (htmlize-overlay-faces-at pos)))
(while (progn
(setq pos (next-overlay-change pos))
(and (< pos next-prop)
(equal overlay-faces (htmlize-overlay-faces-at pos)))))
(setq pos (min pos next-prop))
;; Additionally, we include the entire region that specifies the
;; `display' property.
(when (get-char-property pos 'display)
(setq pos (next-single-char-property-change pos 'display nil limit)))
pos)))
(t
(error "htmlize requires next-single-property-change or \
next-single-char-property-change")))
(defmacro htmlize-lexlet (&rest letforms)
(declare (indent 1) (debug let))
(if (and (boundp 'lexical-binding)
lexical-binding)
`(let ,@letforms)
;; cl extensions have a macro implementing lexical let
`(lexical-let ,@letforms)))
;; Simple overlay emulation for XEmacs
(cond
(htmlize-running-xemacs
(defalias 'htmlize-make-overlay 'make-extent)
(defalias 'htmlize-overlay-put 'set-extent-property)
(defalias 'htmlize-overlay-get 'extent-property)
(defun htmlize-overlays-in (beg end) (extent-list nil beg end))
(defalias 'htmlize-delete-overlay 'detach-extent))
(t
(defalias 'htmlize-make-overlay 'make-overlay)
(defalias 'htmlize-overlay-put 'overlay-put)
(defalias 'htmlize-overlay-get 'overlay-get)
(defalias 'htmlize-overlays-in 'overlays-in)
(defalias 'htmlize-delete-overlay 'delete-overlay)))
;;; Transformation of buffer text: HTML escapes, untabification, etc.
(defvar htmlize-basic-character-table
;; Map characters in the 0-127 range to either one-character strings
;; or to numeric entities.
(let ((table (make-vector 128 ?\0)))
;; Map characters in the 32-126 range to themselves, others to
;; &#CODE entities;
;; If the match of buffer-invisibility-spec has a non-nil
;; CDR, replace the invisible text with an ellipsis.
(let ((match (if (symbolp invisible)
(htmlize-match-inv-spec invisible)
(some #'htmlize-match-inv-spec invisible))))
(cond ((null match) t)
((cdr-safe (car match)) 'ellipsis)
(t nil)))))
(defun htmlize-add-before-after-strings (beg end text)
;; Find overlays specifying before-string and after-string in [beg,
;; pos). If any are found, splice them into TEXT and return the new
;; text.
(let (additions)
(dolist (overlay (overlays-in beg end))
(let ((before (overlay-get overlay 'before-string))
(after (overlay-get overlay 'after-string)))
(when after
(push (cons (- (overlay-end overlay) beg)
after)
additions))
(when before
(push (cons (- (overlay-start overlay) beg)
before)
additions))))
(if additions
(let ((textlist nil)
(strpos 0))
(dolist (add (stable-sort additions #'< :key #'car))
(let ((addpos (car add))
(addtext (cdr add)))
(push (substring text strpos addpos) textlist)
(push addtext textlist)
(setq strpos addpos)))
(push (substring text strpos) textlist)
(apply #'concat (nreverse textlist)))
text)))
(defun htmlize-copy-prop (prop beg end string)
;; Copy the specified property from the specified region of the
;; buffer to the target string. We cannot rely on Emacs to copy the
;; property because we want to handle properties coming from both
;; text properties and overlays.
(let ((pos beg))
(while (< pos end)
(let ((value (get-char-property pos prop))
(next-change (htmlize-next-change pos prop end)))
(when value
(put-text-property (- pos beg) (- next-change beg)
prop value string))
(setq pos next-change)))))
(defun htmlize-get-text-with-display (beg end)
(values text trailing-ellipsis)))
(defun htmlize-despam-address (string)
"Replace every occurrence of '@' in STRING with %40.
This is used to protect mailto links without modifying their meaning."
;; Suggested by Ville Skytta.
(while (string-match "@" string)
(setq string (replace-match "%40" nil t string)))
string)
(defun htmlize-make-tmp-overlay (beg end props)
(let ((overlay (htmlize-make-overlay beg end)))
(htmlize-overlay-put overlay 'htmlize-tmp-overlay t)
(while props
(htmlize-overlay-put overlay (pop props) (pop props)))
overlay))
(defun htmlize-delete-tmp-overlays ()
(dolist (overlay (htmlize-overlays-in (point-min) (point-max)))
(when (htmlize-overlay-get overlay 'htmlize-tmp-overlay)
(htmlize-delete-overlay overlay))))
(defun htmlize-make-link-overlay (beg end uri)
(htmlize-make-tmp-overlay beg end `(htmlize-link (:uri ,uri))))
(defun htmlize-create-auto-links ()
"Add `htmlize-link' property to all mailto links in the buffer."
(save-excursion
(goto-char (point-min))
(while (re-search-forward
"<\\(\\(mailto:\\)?\\([-=+_.a-zA-Z0-9]+@[-_.a-zA-Z0-9]+\\)\\)>"
nil t)
(let* ((address (match-string 3))
(beg (match-beginning 0)) (end (match-end 0))
(uri (concat "mailto:" (htmlize-despam-address address))))
(htmlize-make-link-overlay beg end uri)))
(goto-char (point-min))
(while (re-search-forward "<\\(\\(URL:\\)?\\([a-zA-Z]+://[^;]+\\)\\)>"
nil t)
(htmlize-make-link-overlay
(match-beginning 0) (match-end 0) (match-string 3)))))
;; Tests for htmlize-create-auto-links:
;; <mailto:hniksic@xemacs.org>
;; <http://fly.srk.fer.hr>
;; <URL:http://www.xemacs.org>
;; <http://www.mail-archive.com/bbdb-info@xemacs.org/>
;; <hniksic@xemacs.org>
;; <xalan-dev-sc.10148567319.hacuhiucknfgmpfnjcpg-john=doe.com@xml.apache.org>
(defun htmlize-shadow-form-feeds ()
(let ((s "\n<hr />"))
(put-text-property 0 (length s) 'htmlize-literal t s)
(let ((disp `(display ,s)))
(while (re-search-forward "\n\^L" nil t)
(htmlize-make-tmp-overlay (match-beginning 0) (match-end 0) disp)))))
(defun htmlize-defang-local-variables ()
;; Juri Linkov reports that an HTML-ized "Local variables" can lead
;; visiting the HTML to fail with "Local variables list is not
;; properly terminated". He suggested changing the phrase to
;; syntactically equivalent HTML that Emacs doesn't recognize.
(goto-char (point-min))
(while (search-forward "Local Variables:" nil t)
(replace-match "Local Variables:" nil t)))
((null (cdr fstruct-list))
;; Optimize for the common case of a single face, simply
;; return it.
(car fstruct-list))
(t
(reduce #'htmlize-merge-two-faces
(cons (make-htmlize-fstruct) fstruct-list)))))
;; GNU Emacs 20+ supports attribute lists in `face' properties. For
;; example, you can use `(:foreground "red" :weight bold)' as an
;; overlay's "face", or you can even use a list of such lists, etc.
;; We call those "attrlists".
;;
;; htmlize supports attrlist by converting them to fstructs, the same
;; as with regular faces.
(defun htmlize-attrlist-to-fstruct (attrlist)
;; Like htmlize-face-to-fstruct, but accepts an ATTRLIST as input.
(let ((fstruct (make-htmlize-fstruct)))
(cond ((eq (car attrlist) 'foreground-color)
;; ATTRLIST is (foreground-color . COLOR)
"If FACE is a string, return it interned, otherwise return it unchanged."
(if (stringp face)
(intern face)
face))
(defun htmlize-faces-in-buffer ()
"Return a list of faces used in the current buffer.
Under XEmacs, this returns the set of faces specified by the extents
with the `face' property. (This covers text properties as well.) Under
GNU Emacs, it returns the set of faces specified by the `face' text
property and by buffer overlays that specify `face'."
(let (faces)
;; Testing for (fboundp 'map-extents) doesn't work because W3
;; defines `map-extents' under FSF.
(if htmlize-running-xemacs
(let (face-prop)
(map-extents (lambda (extent ignored)
(setq face-prop (extent-face extent)
;; FACE-PROP can be a face or a list of
;; faces.
faces (if (listp face-prop)
(point-min) (point-max) nil nil 'face))
;; FSF Emacs code.
;; Faces used by text properties.
(let ((pos (point-min)) face-prop next)
(while (< pos (point-max))
(setq face-prop (get-text-property pos 'face)
next (or (next-single-property-change pos 'face) (point-max)))
(setq faces (nunion (htmlize-decode-face-prop face-prop)
faces :test 'equal))
(setq pos next)))
;; Faces used by overlays.
(dolist (overlay (overlays-in (point-min) (point-max)))
(let ((face-prop (overlay-get overlay 'face)))
(setq faces (nunion (htmlize-decode-face-prop face-prop)
faces :test 'equal)))))
faces))
;; htmlize-faces-at-point returns the faces in use at point. The
;; faces are sorted by increasing priority, i.e. the last face takes
;; precedence.
;;
;; Under XEmacs, this returns all the faces in all the extents at
;; point. Under GNU Emacs, this returns all the faces in the `face'
;; property and all the faces in the overlays at point.
(cond (htmlize-running-xemacs
(defun htmlize-faces-at-point ()
(let (extent extent-list face-list face-prop)
(while (setq extent (extent-at (point) nil 'face extent))
(push extent extent-list))
;; extent-list is in reverse display order, meaning that
;; smallest ones come last. That is the order we want,
;; except it can be overridden by the `priority' property.
(setq extent-list (stable-sort extent-list #'<
(cons face-prop face-list))))
(nreverse face-list))))
(t
(defun htmlize-faces-at-point ()
(let (all-faces)
;; Faces from text properties.
(let ((face-prop (get-text-property (point) 'face)))
;; we need to reverse the `face' prop because we want
;; more specific faces to come later
(setq all-faces (nreverse (htmlize-decode-face-prop face-prop))))
;; Faces from overlays.
(let ((overlays
;; Collect overlays at point that specify `face'.
(delete-if-not (lambda (o)
(overlay-get o 'face))
(overlays-at (point))))
list face-prop)
;; Sort the overlays so the smaller (more specific) ones
;; come later. The number of overlays at each one
;; position should be very small, so the sort shouldn't
;; slow things down.
(setq overlays (sort* overlays
;; Sort by ascending...
#'<
;; ...overlay size.
:key (lambda (o)
(- (overlay-end o)
(overlay-start o)))))
;; Overlay priorities, if present, override the above
;; established order. Larger overlay priority takes
;; precedence and therefore comes later in the list.
(setq overlays (stable-sort
overlays
;; Reorder (stably) by acending...
#'<
;; ...overlay priority.
:key (lambda (o)
(or (overlay-get o 'priority) 0))))
(dolist (overlay overlays)
(setq face-prop (overlay-get overlay 'face)
list (nconc (htmlize-decode-face-prop face-prop) list)))
;; Under "Merging Faces" the manual explicitly states
;; that faces specified by overlays take precedence over
;; faces specified by text properties.
(setq all-faces (nconc all-faces list)))
all-faces))))
;; htmlize supports generating HTML in several flavors, some of which
;; use CSS, and others the <font> element. We take an OO approach and
;; define "methods" that indirect to the functions that depend on
;; `htmlize-output-type'. The currently used methods are `doctype',
;; `insert-head', `body-tag', and `text-markup'. Not all output types
;; define all methods.
(funcall htmlize-html-major-mode))
(set (make-local-variable 'htmlize-buffer-places)
(symbol-plist places))
(run-hooks 'htmlize-after-hook)
(buffer-enable-undo))
(setq completed t)
htmlbuf)
(when (not completed)
(kill-buffer htmlbuf))
(htmlize-delete-tmp-overlays)))))
;; Utility functions.
(defmacro htmlize-with-fontify-message (&rest body)
;; When forcing fontification of large buffers in
;; htmlize-ensure-fontified, inform the user that he is waiting for
;; font-lock, not for htmlize to finish.
`(progn
(if (> (buffer-size) 65536)
(message "Forcing fontification of %s..."
( run in 1.146 second using v1.01-cache-2.11-cpan-49f99fa48dc )