Text-EmacsColor
view release on metacpan or search on metacpan
share/lisp/htmlize.el view on Meta::CPAN
Set this to nil if you prefer the default (fundamental) mode."
:type '(radio (const :tag "No mode (fundamental)" nil)
(function-item html-mode)
(function :tag "User-defined major mode"))
:group 'htmlize)
(defvar htmlize-before-hook nil
"Hook run before htmlizing a buffer.
The hook functions are run in the source buffer (not the resulting HTML
buffer).")
(defvar htmlize-after-hook nil
"Hook run after htmlizing a buffer.
Unlike `htmlize-before-hook', these functions are run in the generated
HTML buffer. You may use them to modify the outlook of the final HTML
output.")
(defvar htmlize-file-hook nil
"Hook run by `htmlize-file' after htmlizing a file, but before saving it.")
(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))
(eval-and-compile
;; save-current-buffer, with-current-buffer, and with-temp-buffer
;; are not available in 19.34 and in older XEmacsen. Strictly
;; speaking, we should stick to our own namespace and define and use
;; htmlize-save-current-buffer, etc. But non-standard special forms
;; are a pain because they're not properly fontified or indented and
;; because they look weird and ugly. So I'll just go ahead and
;; define the real ones if they're not available. If someone
;; convinces me that this breaks something, I'll switch to the
;; "htmlize-" namespace.
(unless (fboundp 'save-current-buffer)
(defmacro save-current-buffer (&rest forms)
`(let ((__scb_current (current-buffer)))
(unwind-protect
(progn ,@forms)
(set-buffer __scb_current)))))
(unless (fboundp 'with-current-buffer)
(defmacro with-current-buffer (buffer &rest forms)
`(save-current-buffer (set-buffer ,buffer) ,@forms)))
(unless (fboundp 'with-temp-buffer)
(defmacro with-temp-buffer (&rest forms)
(let ((temp-buffer (gensym "tb-")))
`(let ((,temp-buffer
(get-buffer-create (generate-new-buffer-name " *temp*"))))
(unwind-protect
(with-current-buffer ,temp-buffer
,@forms)
(and (buffer-live-p ,temp-buffer)
(kill-buffer ,temp-buffer))))))))
;; We need a function that efficiently finds the next change of a
;; property (usually `face'), preferably regardless of whether the
;; change occurred because of a text property or an extent/overlay.
;; As it turns out, it is not easy to do that compatibly.
;;
;; Under XEmacs, `next-single-property-change' does that. Under GNU
;; Emacs beginning with version 21, `next-single-char-property-change'
;; is available and does the same. GNU Emacs 20 had
;; `next-char-property-change', which we can use. GNU Emacs 19 didn't
;; provide any means for simultaneously examining overlays and text
;; properties, so when using Emacs 19.34, we punt and fall back to
;; `next-single-property-change', thus ignoring overlays altogether.
(cond
(htmlize-running-xemacs
;; XEmacs: good.
(defun htmlize-next-change (pos prop &optional limit)
(next-single-property-change pos prop nil (or limit (point-max)))))
((fboundp 'next-single-char-property-change)
;; GNU Emacs 21: good.
(defun htmlize-next-change (pos prop &optional limit)
(next-single-char-property-change pos prop nil limit)))
((fboundp 'next-char-property-change)
;; GNU Emacs 20: bad, but fixable.
(defun htmlize-next-change (pos prop &optional limit)
(let ((done nil)
(current-value (get-char-property pos prop))
newpos next-value)
;; Loop over positions returned by next-char-property-change
;; until the value of PROP changes or we've hit EOB.
(while (not done)
(setq newpos (next-char-property-change pos limit)
next-value (get-char-property newpos prop))
(cond ((eq newpos pos)
;; Possibly at EOB? Whatever, just don't infloop.
(setq done t))
((eq next-value current-value)
;; PROP hasn't changed -- keep looping.
)
(t
(setq done t)))
(setq pos newpos))
pos)))
(t
;; GNU Emacs 19.34: hopeless, cannot properly support overlays.
(defun htmlize-next-change (pos prop &optional limit)
(unless limit
(setq limit (point-max)))
(let ((res (next-single-property-change pos prop)))
(if (or (null res)
(> res limit))
limit
res)))))
;;; 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;
(dotimes (i 128)
(setf (aref table i) (if (and (>= i 32) (<= i 126))
(char-to-string i)
(format "&#%d;" i))))
;; Set exceptions manually.
(setf
;; Don't escape newline, carriage return, and TAB.
(aref table ?\n) "\n"
(aref table ?\r) "\r"
(aref table ?\t) "\t"
;; Escape &, <, and >.
(aref table ?&) "&"
(aref table ?<) "<"
(aref table ?>) ">"
;; Not escaping '"' buys us a measurable speedup. It's only
;; necessary to quote it for strings used in attribute values,
;; which htmlize doesn't do.
;(aref table ?\") """
)
table))
;; A cache of HTML representation of non-ASCII characters. Depending
;; on availability of `encode-char' and the setting of
;; `htmlize-convert-nonascii-to-entities', this maps non-ASCII
;; characters to either "&#<code>;" or "<char>" (mapconcat's mapper
;; must always return strings). It's only filled as characters are
;; encountered, so that in a buffer with e.g. French text, it will
;; only ever contain French accented characters as keys. It's cleared
;; on each entry to htmlize-buffer-1 to allow modifications of
;; `htmlize-convert-nonascii-to-entities' to take effect.
(defvar htmlize-extended-character-cache (make-hash-table :test 'eq))
(defun htmlize-protect-string (string)
"HTML-protect string, escaping HTML metacharacters and I18N chars."
;; Only protecting strings that actually contain unsafe or non-ASCII
;; chars removes a lot of unnecessary funcalls and consing.
(if (not (string-match "[^\r\n\t -%'-;=?-~]" string))
string
(mapconcat (lambda (char)
(cond
((< char 128)
;; ASCII: use htmlize-basic-character-table.
(aref htmlize-basic-character-table char))
share/lisp/htmlize.el view on Meta::CPAN
(when (string-match "-face\\'" name)
;; Drop the redundant "-face" suffix.
(setq name (replace-match "" t t name)))
(while (string-match "[^-a-zA-Z0-9]" name)
;; Drop the non-alphanumerics.
(setq name (replace-match "X" t t name)))
(when (string-match "\\`[-0-9]" name)
;; CSS identifiers may not start with a digit.
(setq name (concat "X" name)))
;; After these transformations, the face could come
;; out empty.
(when (equal name "")
(setq name "face"))
;; Apply the prefix.
(setq name (concat htmlize-css-name-prefix name))
name))
fstruct))
(defmacro htmlize-copy-attr-if-set (attr-list dest source)
;; Expand the code of the type
;; (and (htmlize-fstruct-ATTR source)
;; (setf (htmlize-fstruct-ATTR dest) (htmlize-fstruct-ATTR source)))
;; for the given list of boolean attributes.
(cons 'progn
(loop for attr in attr-list
for attr-sym = (intern (format "htmlize-fstruct-%s" attr))
collect `(and (,attr-sym ,source)
(setf (,attr-sym ,dest) (,attr-sym ,source))))))
(defun htmlize-merge-size (merged next)
;; Calculate the size of the merge of MERGED and NEXT.
(cond ((null merged) next)
((integerp next) next)
((null next) merged)
((floatp merged) (* merged next))
((integerp merged) (round (* merged next)))))
(defun htmlize-merge-two-faces (merged next)
(htmlize-copy-attr-if-set
(foreground background boldp italicp underlinep overlinep strikep)
merged next)
(setf (htmlize-fstruct-size merged)
(htmlize-merge-size (htmlize-fstruct-size merged)
(htmlize-fstruct-size next)))
merged)
(defun htmlize-merge-faces (fstruct-list)
(cond ((null fstruct-list)
;; Nothing to do, return a dummy face.
(make-htmlize-fstruct))
((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)
(setf (htmlize-fstruct-foreground fstruct)
(htmlize-color-to-rgb (cdr attrlist))))
((eq (car attrlist) 'background-color)
;; ATTRLIST is (background-color . COLOR)
(setf (htmlize-fstruct-background fstruct)
(htmlize-color-to-rgb (cdr attrlist))))
(t
;; ATTRLIST is a plist.
(while attrlist
(let ((attr (pop attrlist))
(value (pop attrlist)))
(when (and value (not (eq value 'unspecified)))
(htmlize-face-emacs21-attr fstruct attr value))))))
(setf (htmlize-fstruct-css-name fstruct) "ATTRLIST")
fstruct))
(defun htmlize-face-list-p (face-prop)
"Return non-nil if FACE-PROP is a list of faces, nil otherwise."
;; If not for attrlists, this would return (listp face-prop). This
;; way we have to be more careful because attrlist is also a list!
(cond
((eq face-prop nil)
;; FACE-PROP being nil means empty list (no face), so return t.
t)
((symbolp face-prop)
;; A symbol other than nil means that it's only one face, so return
;; nil.
nil)
((not (consp face-prop))
;; Huh? Not a symbol or cons -- treat it as a single element.
nil)
(t
;; We know that FACE-PROP is a cons: check whether it looks like an
;; ATTRLIST.
(let* ((car (car face-prop))
(attrlist-p (and (symbolp car)
(or (eq car 'foreground-color)
(eq car 'background-color)
(eq (aref (symbol-name car) 0) ?:)))))
;; If FACE-PROP is not an ATTRLIST, it means it's a list of
;; faces.
(not attrlist-p)))))
(defun htmlize-make-face-map (faces)
;; Return a hash table mapping Emacs faces to htmlize's fstructs.
;; The keys are either face symbols or attrlists, so the test
;; function must be `equal'.
(let ((face-map (make-hash-table :test 'equal))
css-names)
(dolist (face faces)
(unless (gethash face face-map)
;; Haven't seen FACE yet; convert it to an fstruct and cache
;; it.
(let ((fstruct (if (symbolp face)
(htmlize-face-to-fstruct face)
(htmlize-attrlist-to-fstruct face))))
(setf (gethash face face-map) fstruct)
(let* ((css-name (htmlize-fstruct-css-name fstruct))
(new-name css-name)
(i 0))
;; Uniquify the face's css-name by using NAME-1, NAME-2,
;; etc.
(while (member new-name css-names)
(setq new-name (format "%s-%s" css-name (incf i))))
(unless (equal new-name css-name)
(setf (htmlize-fstruct-css-name fstruct) new-name))
(push new-name css-names)))))
face-map))
(defun htmlize-unstringify-face (face)
"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)
(union face-prop faces)
(adjoin face-prop faces)))
nil)
nil
;; Specify endpoints explicitly to respect
;; narrowing.
(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)))
;; FACE-PROP can be a face/attrlist or a list thereof.
(setq faces (if (htmlize-face-list-p face-prop)
(nunion (mapcar #'htmlize-unstringify-face face-prop)
faces :test 'equal)
(adjoin (htmlize-unstringify-face 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)))
;; FACE-PROP can be a face/attrlist or a list thereof.
(setq faces (if (htmlize-face-list-p face-prop)
(nunion (mapcar #'htmlize-unstringify-face face-prop)
faces :test 'equal)
(adjoin (htmlize-unstringify-face 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 #'<
:key #'extent-priority))
(dolist (extent extent-list)
(setq face-prop (extent-face extent))
;; extent's face-list is in reverse order from what we
;; want, but the `nreverse' below will take care of it.
(setq face-list (if (listp face-prop)
(append face-prop face-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)))
(setq all-faces (if (htmlize-face-list-p face-prop)
(nreverse (mapcar #'htmlize-unstringify-face
face-prop))
(list (htmlize-unstringify-face 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))
(setq list (if (htmlize-face-list-p face-prop)
(nconc (nreverse (mapcar
#'htmlize-unstringify-face
face-prop))
list)
(cons (htmlize-unstringify-face 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 two several fundamentally
;; different ways, one with the use of CSS and nested <span> tags, and
;; the other with the use of the old <font> tags. Rather than adding
;; a bunch of ifs to many places, we take a semi-OO approach.
;; `htmlize-buffer-1' calls a number of "methods", which indirect to
;; the functions that depend on `htmlize-output-type'. The currently
;; used methods are `doctype', `insert-head', `body-tag', and
;; `insert-text'. Not all output types define all methods.
;;
;; Methods are called either with (htmlize-method METHOD ARGS...)
;; special form, or by accessing the function with
;; (htmlize-method-function 'METHOD) and calling (funcall FUNCTION).
;; The latter form is useful in tight loops because `htmlize-method'
;; conses.
;;
;; Currently defined output types are `css' and `font'.
(defmacro htmlize-method (method &rest args)
;; Expand to (htmlize-TYPE-METHOD ...ARGS...). TYPE is the value of
;; `htmlize-output-type' at run time.
`(funcall (htmlize-method-function ',method) ,@args))
(defun htmlize-method-function (method)
;; Return METHOD's function definition for the current output type.
;; The returned object can be safely funcalled.
(let ((sym (intern (format "htmlize-%s-%s" htmlize-output-type method))))
(indirect-function (if (fboundp sym)
sym
(let ((default (intern (concat "htmlize-default-"
(symbol-name method)))))
(if (fboundp default)
default
'ignore))))))
(defvar htmlize-memoization-table (make-hash-table :test 'equal))
(defmacro htmlize-memoize (key generator)
"Return the value of GENERATOR, memoized as KEY.
That means that GENERATOR will be evaluated and returned the first time
it's called with the same value of KEY. All other times, the cached
\(memoized) value will be returned."
(let ((value (gensym)))
`(let ((,value (gethash ,key htmlize-memoization-table)))
(unless ,value
(setq ,value ,generator)
(setf (gethash ,key htmlize-memoization-table) ,value))
,value)))
;;; Default methods.
(defun htmlize-default-doctype ()
nil ; no doc-string
;; According to DTDs published by the W3C, it is illegal to embed
;; <font> in <pre>. This makes sense in general, but is bad for
;; htmlize's intended usage of <font> to specify the document color.
( run in 0.601 second using v1.01-cache-2.11-cpan-df04353d9ac )