tags And the following are planned but not yet available:\n kill-context-leak : Suppress hyperlinking between files highlighted by different modes.\n @@ -463,7 +471,8 @@ which can never slow you down, but may result in incomplete fontification." (const :tag "skip-refontification" skip-refontification) (const :tag "kill-context-leak" kill-context-leak ) (const :tag "div-wrapper" div-wrapper ) - (const :tag "keep-overlays" keep-overlays )) + (const :tag "keep-overlays" keep-overlays ) + (const :tag "body-text-only" body-text-only )) :group 'htmlfontify :tag "optimizations") @@ -709,7 +718,7 @@ STYLE is the inline CSS stylesheet (or tag referring to an external sheet)." --> \n" - file style)) + (mapconcat 'hfy-html-quote (mapcar 'char-to-string file) "") style)) (defun hfy-default-footer (_file) "Default value for `hfy-page-footer'. @@ -740,6 +749,10 @@ if you've redefined white, (esp. if you've redefined it to have a triplet member lower than that of the color you are processing) strange things may happen." ;;(message "hfy-colour-vals");;DBUG + ;; TODO? Can we do somehow do better than this? + (cond + ((equal colour "unspecified-fg") (setq colour "black")) + ((equal colour "unspecified-bg") (setq colour "white"))) (let ((white (mapcar (lambda (I) (float (1+ I))) (hfy-colour-vals "white"))) (rgb16 (mapcar (lambda (I) (float (1+ I))) (hfy-colour-vals colour)))) (if rgb16 @@ -765,6 +778,8 @@ may happen." "Derive a CSS font-size specifier from an Emacs font :height attribute HEIGHT. Does not cope with the case where height is a function to be applied to the height of the underlying font." + ;; In ttys, the default face has :height == 1. + (and (not (display-graphic-p)) (equal 1 height) (setq height 100)) (list (cond ;;(t (cons "font-size" ": 1em")) @@ -859,13 +874,13 @@ If CLASS is set, it must be a `defface' alist key [see below], in which case the first face specification returned by `hfy-combined-face-spec' which *doesn't* clash with CLASS is returned.\n \(A specification with a class of t is considered to match any class you -specify - this matches Emacs' behavior when deciding on which face attributes +specify - this matches Emacs's behavior when deciding on which face attributes to use, to the best of my understanding).\n If CLASS is nil, then you just get whatever `face-attr-construct' returns, ie the current specification in effect for FACE.\n *NOTE*: This function forces any face that is not 'default and which has no :inherit property to inherit from 'default (this is because 'default -is magical in that Emacs' fonts behave as if they inherit implicitly from +is magical in that Emacs's fonts behave as if they inherit implicitly from 'default, but no such behavior exists in HTML/CSS).\n See also `hfy-display-class' for details of valid values for CLASS." (let ((face-spec @@ -1044,9 +1059,7 @@ haven't encountered them yet. Returns a `hfy-style-assoc'." ((facep fn) (hfy-face-attr-for-class fn hfy-display-class)) ((and (symbolp fn) - (facep (symbol-value fn))) - ;; Obsolete faces like `font-lock-reference-face' are defined as - ;; aliases for another face. + (facep (symbol-value fn))) (hfy-face-attr-for-class (symbol-value fn) hfy-display-class)) (t nil))) @@ -1108,10 +1121,9 @@ See also `hfy-face-to-style-i', `hfy-flatten-style'." ;; construct an assoc of (stripped-name . "{ css-stuff-here }") pairs ;; from a face: -(defun hfy-face-to-css (fn) - "Take FN, a font or `defface' specification (cf `face-attr-construct') -and return a CSS style specification.\n -See also `hfy-face-to-style'." +(defun hfy-face-to-css-default (fn) + "Default handler for mapping faces to styles. +See also `hfy-face-to-css'." ;;(message "hfy-face-to-css");;DBUG (let* ((css-list (hfy-face-to-style fn)) (seen nil) @@ -1125,6 +1137,17 @@ See also `hfy-face-to-style'." css-list))) (cons (hfy-css-name fn) (format "{%s}" (apply 'concat css-text)))) ) +(defvar hfy-face-to-css 'hfy-face-to-css-default + "Handler for mapping faces to styles. +The signature of the handler is of the form \(lambda (FN) ...\). +FN is a font or `defface' specification (cf +`face-attr-construct'). The handler should return a cons cell of +the form (STYLE-NAME . STYLE-SPEC). + +The default handler is `hfy-face-to-css-default'. + +See also `hfy-face-to-style'.") + (defalias 'hfy-prop-invisible-p (if (fboundp 'invisible-p) #'invisible-p (lambda (prop) @@ -1305,26 +1328,31 @@ return a `defface' style list of face properties instead of a face symbol." (defun hfy-overlay-props-at (p) "Grab overlay properties at point P. The plists are returned in descending priority order." - (sort (mapcar #'overlay-properties (overlays-at p)) - (lambda (A B) (> (or (cadr (memq 'priority A)) 0) ;FIXME: plist-get? - (or (cadr (memq 'priority B)) 0))))) + (mapcar #'overlay-properties (overlays-at p 'sorted))) ;; construct an assoc of (face-name . (css-name . "{ css-style }")) elements: (defun hfy-compile-stylesheet () - "Trawl the current buffer, construct and return a `hfy-sheet-assoc'." + "Trawl the current buffer, construct and return a `hfy-sheet-assoc'. +If `hfy-user-sheet-assoc' is currently bound then use it to +collect new styles discovered during this run. Otherwise create +a new assoc." ;;(message "hfy-compile-stylesheet");;DBUG (let ((pt (point-min)) ;; Make the font stack stay: ;;(hfy-tmpfont-stack nil) (fn nil) - (style nil)) + (style (and (boundp 'hfy-user-sheet-assoc) hfy-user-sheet-assoc))) (save-excursion (goto-char pt) (while (< pt (point-max)) (if (and (setq fn (hfy-face-at pt)) (not (assoc fn style))) - (push (cons fn (hfy-face-to-css fn)) style)) - (setq pt (next-char-property-change pt))) ) - (push (cons 'default (hfy-face-to-css 'default)) style))) + (push (cons fn (funcall hfy-face-to-css fn)) style)) + (setq pt (next-char-property-change pt)))) + (unless (assoc 'default style) + (push (cons 'default (funcall hfy-face-to-css 'default)) style)) + (when (boundp 'hfy-user-sheet-assoc) + (setq hfy-user-sheet-assoc style)) + style)) (defun hfy-fontified-p () "`font-lock' doesn't like to say it's been fontified when in batch @@ -1425,7 +1453,7 @@ Returns a modified copy of FACE-MAP." (setq pt (next-char-property-change pt)) (setq pt-narrow (+ offset pt))) (if (and map (not (eq 'end (cdar map)))) - (push (cons (- (point-max) (point-min)) 'end) map))) + (push (cons (1+ (- (point-max) (point-min))) 'end) map))) (if (hfy-opt 'merge-adjacent-tags) (hfy-merge-adjacent-spans map) map))) (defun hfy-buffer () @@ -1547,6 +1575,61 @@ Do not record undo information during evaluation of BODY." (remove-text-properties (point-min) (point-max) '(hfy-show-trailing-whitespace))))) +(defun hfy-begin-span (style text-block text-id text-begins-block-p) + "Default handler to begin a span of text. +Insert \"\". See +`hfy-begin-span-handler' for more information." + (when text-begins-block-p + (insert + (format "â¦" text-block))) + + (insert + (if text-block + (format "" style text-block text-id) + (format "" style)))) + +(defun hfy-end-span () + "Default handler to end a span of text. +Insert \"\". See `hfy-end-span-handler' for more +information." + (insert "")) + +(defvar hfy-begin-span-handler 'hfy-begin-span + "Handler to begin a span of text. +The signature of the handler is \(lambda (STYLE TEXT-BLOCK +TEXT-ID TEXT-BEGINS-BLOCK-P) ...\). The handler must insert +appropriate tags to begin a span of text. + +STYLE is the name of the style that begins at point. It is +derived from the face attributes as part of `hfy-face-to-css' +callback. The other arguments TEXT-BLOCK, TEXT-ID, +TEXT-BEGINS-BLOCK-P are non-nil only if the buffer contains +invisible text. + +TEXT-BLOCK is a string that identifies a single chunk of visible +or invisible text of which the current position is a part. For +visible portions, it's value is \"nil\". For invisible portions, +it's value is computed as part of `hfy-invisible-name'. + +TEXT-ID marks a unique position within a block. It is set to +value of `point' at the current buffer position. + +TEXT-BEGINS-BLOCK-P is a boolean and is non-nil if the current +span also begins a invisible portion of text. + +An implementation can use TEXT-BLOCK, TEXT-ID, +TEXT-BEGINS-BLOCK-P to implement fold/unfold-on-mouse-click like +behavior. + +The default handler is `hfy-begin-span'.") + +(defvar hfy-end-span-handler 'hfy-end-span + "Handler to end a span of text. +The signature of the handler is \(lambda () ...\). The handler +must insert appropriate tags to end a span of text. + +The default handler is `hfy-end-span'.") + (defun hfy-fontify-buffer (&optional srcdir file) "Implement the guts of `htmlfontify-buffer'. SRCDIR, if set, is the directory being htmlfontified. @@ -1557,7 +1640,6 @@ FILE, if set, is the file name." (css-map nil) (invis-ranges nil) (rovl nil) - (orig-ovls (overlays-in (point-min) (point-max))) (rmin (when mark-active (region-beginning))) (rmax (when mark-active (region-end ))) ) (when (and mark-active @@ -1579,12 +1661,6 @@ FILE, if set, is the file name." (set-buffer html-buffer) ;; rip out props that could interfere with our htmlization of the buffer: (remove-text-properties (point-min) (point-max) hfy-ignored-properties) - ;; Apply overlay invisible spec - (setq orig-ovls - (sort orig-ovls - (lambda (A B) - (> (or (cadr (memq 'priority (overlay-properties A))) 0) - (or (cadr (memq 'priority (overlay-properties B))) 0))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; at this point, html-buffer retains the fontification of the parent: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1624,7 +1700,7 @@ FILE, if set, is the file name." ;; think we only need to relocate the hfy-endl property, as the hfy-linkp ;; property has already served its main purpose by this point. ;;(message "mapcar over the CSS-MAP") - (message "invis-ranges:\n%S" invis-ranges) + ;; (message "invis-ranges:\n%S" invis-ranges) (dolist (point-face css-map) (let ((pt (car point-face)) (fn (cdr point-face)) @@ -1634,23 +1710,19 @@ FILE, if set, is the file name." (or (get-text-property pt 'hfy-linkp) (get-text-property pt 'hfy-endl ))) (if (eq 'end fn) - (insert "") + (funcall hfy-end-span-handler) (if (not (and srcdir file)) nil (when move-link (remove-text-properties (point) (1+ (point)) '(hfy-endl nil)) (put-text-property pt (1+ pt) 'hfy-endl t) )) ;; if we have invisible blocks, we need to do some extra magic: - (if invis-ranges - (let ((iname (hfy-invisible-name pt invis-ranges)) - (fname (hfy-lookup fn css-sheet ))) - (when (assq pt invis-ranges) - (insert - (format "" iname)) - (insert "â¦")) - (insert - (format "" fname iname pt))) - (insert (format "" (hfy-lookup fn css-sheet)))) + (funcall hfy-begin-span-handler + (hfy-lookup fn css-sheet) + (and invis-ranges + (format "%s" (hfy-invisible-name pt invis-ranges))) + (and invis-ranges pt) + (and invis-ranges (assq pt invis-ranges))) (if (not move-link) nil ;;(message "removing prop2 @ %d" (point)) (if (remove-text-properties (point) (1+ (point)) '(hfy-endl nil)) @@ -1698,23 +1770,39 @@ FILE, if set, is the file name." ;; so we have to do this after we use said properties: ;; (message "munging dangerous characters") (hfy-html-dekludge-buffer) - ;; insert the stylesheet at the top: - (goto-char (point-min)) - ;;(message "inserting stylesheet") - (insert (hfy-sprintf-stylesheet css-sheet file)) - (if (hfy-opt 'div-wrapper) (insert "
") - (goto-char (point-max)) - (insert "\n") - (if (hfy-opt 'div-wrapper) (insert "
") + (goto-char (point-max)) + (insert "\n") + (if (hfy-opt 'div-wrapper) (insert "