;;; htmlfontify.el --- htmlize a buffer/source tree with optional hyperlinks -*- lexical-binding: t -*- ;; Copyright (C) 2002-2003, 2009-2017 Free Software Foundation, Inc. ;; Emacs Lisp Archive Entry ;; Package: htmlfontify ;; Filename: htmlfontify.el ;; Version: 0.21 ;; Keywords: html, hypermedia, markup, etags ;; Author: Vivek Dasmohapatra ;; Maintainer: Vivek Dasmohapatra ;; Created: 2002-01-05 ;; Description: htmlize a buffer/source tree with optional hyperlinks ;; URL: http://rtfm.etla.org/emacs/htmlfontify/ ;; Compatibility: Emacs23, Emacs22 ;; Incompatibility: Emacs19, Emacs20, Emacs21 ;; Last Updated: Thu 2009-11-19 01:31:21 +0000 ;; This file is part of GNU Emacs. ;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see . ;;; Commentary: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; I have made some changes to make it work for Emacs 22. A lot of ;; small bug fixes related to the format of text and overlay ;; properties (which might have changed since the beginning of 2003 ;; when this file was originally written). ;; ;; The function `hfy-face-at' currently carries much of the burden of ;; my lacking understanding of the formats mentioned above and should ;; need some knowledgeable help. ;; ;; Another thing that maybe could be fixed is that overlay background ;; colors which are now only seen where there is text (in the XHTML ;; output). A bit of CSS tweaking is necessary there. ;; ;; The face 'default has a value :background "SystemWindow" for the ;; background color. There is no explicit notion that this should be ;; considered transparent, but I have assumed that it could be handled ;; like if it was here. (I am unsure that background and foreground ;; priorities are handled ok, but it looks ok in my tests now.) ;; ;; 2007-12-27 Lennart Borgman ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Here's some elisp code to html-pretty-print an Emacs buffer, preserving ;; the Emacs syntax/whatever highlighting. It also knows how to drive etags ;; (exuberant-ctags or Emacs etags) and hyperlink the code according ;; to its (etags') output. ;; NOTE: Currently the hyperlinking code only knows how to drive GNU find ;; and the exuberant and GNU variants of etags : I do not know of any other ;; etags variants, but mechanisms have been provided to allow htmlfontify ;; to be taught how to drive them. As long as your version of find has ;; the -path test and is reasonably sane, you should be fine. ;; A sample of the htmlfontified / hyperlinked output of this module can be ;; found at http://rtfm.etla.org/sql/dbishell/src/ - it's not perfect, but ;; it's a hell of a lot faster and more thorough than I could hope to be ;; doing this by hand. ;; some user / horrified onlooker comments: ;; What? No! There's something deeply wrong here... (R. Shufflebotham) ;; You're a freak. (D. Silverstone) ;; Aren't we giving you enough to do? (J. Busuttil) ;; You're almost as messed up as Lexx is! (N. Graves-Morris) ;;; History: ;; Changes: moved to changelog (CHANGES) file. ;;; Code: (eval-when-compile (require 'cl-lib)) (require 'faces) ;; (`facep' `face-attr-construct' `x-color-values' `color-values' `face-name') (require 'custom) ;; (`defgroup' `defcustom') (require 'font-lock) ;; (`font-lock-fontify-region') (require 'cus-edit) (require 'htmlfontify-loaddefs) (defconst htmlfontify-version 0.21) (defconst hfy-meta-tags (format "" emacs-version htmlfontify-version) "The generator meta tag for this version of htmlfontify.") (defconst htmlfontify-manual "Htmlfontify Manual" "Copy and convert buffers and files to HTML, adding hyperlinks between files \(driven by etags) if requested. \nInteractive functions: `htmlfontify-buffer' `htmlfontify-run-etags' `htmlfontify-copy-and-link-dir' `htmlfontify-load-rgb-file' `htmlfontify-unload-rgb-file'\n In order to:\n fontify a file you have open: \\[htmlfontify-buffer] prepare the etags map for a directory: \\[htmlfontify-run-etags] copy a directory, fontifying as you go: \\[htmlfontify-copy-and-link-dir]\n The following might be useful when running non-windowed or in batch mode: \(note that they shouldn't be necessary - we have a built in map)\n load an X11 style rgb.txt file: \\[htmlfontify-load-rgb-file] unload the current rgb.txt file: \\[htmlfontify-unload-rgb-file]\n And here's a programmatic example:\n \(defun rtfm-build-page-header (file style) (format \"#define TEMPLATE red+black.html #define DEBUG 1 #include \\n html-css-url := /css/red+black.css title := rtfm.etla.org ( %s / src/%s ) bodytag := head <=STYLESHEET;\\n %s STYLESHEET main-title := rtfm / %s / src/%s\\n main-content <=MAIN_CONTENT;\\n\" rtfm-section file style rtfm-section file)) \(defun rtfm-build-page-footer (file) \"\\nMAIN_CONTENT\\n\") \(defun rtfm-build-source-docs (section srcdir destdir) (interactive \"s section[eg- emacs / p4-blame]:\\nD source-dir: \\nD output-dir: \") (require \\='htmlfontify) (hfy-load-tags-cache srcdir) (let ((hfy-page-header \\='rtfm-build-page-header) (hfy-page-footer \\='rtfm-build-page-footer) (rtfm-section section) (hfy-index-file \"index\")) (htmlfontify-run-etags srcdir) (htmlfontify-copy-and-link-dir srcdir destdir \".src\" \".html\")))") (defgroup htmlfontify nil "Convert buffers and files to HTML." :group 'applications :link '(variable-link htmlfontify-manual) :link '(custom-manual "(htmlfontify) Top") :link '(info-link "(htmlfontify) Customization") :prefix "hfy-") (defcustom hfy-page-header 'hfy-default-header "Function called to build the header of the HTML source. This is called with two arguments (the filename relative to the top level source directory being etag'd and fontified), and a string containing the text to embed in the document. It should return a string that will be used as the header for the htmlfontified version of the source file.\n See also `hfy-page-footer'." :group 'htmlfontify ;; FIXME: Why place such a :tag everywhere? Isn't it imposing your ;; own Custom preference on your users? --Stef :tag "page-header" :type '(function)) (defcustom hfy-split-index nil "Whether or not to split the index `hfy-index-file' alphabetically. If non-nil, the index is split on the first letter of each tag. Useful when the index would otherwise be large and take a long time to render or be difficult to navigate." :group 'htmlfontify :tag "split-index" :type '(boolean)) (defcustom hfy-page-footer 'hfy-default-footer "As `hfy-page-header', but generates the output footer. It takes only one argument, the filename." :group 'htmlfontify :tag "page-footer" :type '(function)) (defcustom hfy-extn ".html" "File extension used for output files." :group 'htmlfontify :tag "extension" :type '(string)) (defcustom hfy-src-doc-link-style "text-decoration: underline;" "String to add to the `\n"))) (funcall hfy-page-header file stylesheet))) ;; tag all the dangerous characters we want to escape ;; (ie any "<> chars we _didn't_ put there explicitly for css markup) (defun hfy-html-enkludge-buffer () "Mark dangerous [\"<>] characters with the `hfy-quoteme' property.\n See also `hfy-html-dekludge-buffer'." ;;(message "hfy-html-enkludge-buffer");;DBUG (save-excursion (goto-char (point-min)) (while (re-search-forward hfy-html-quote-regex nil t) (put-text-property (match-beginning 0) (point) 'hfy-quoteme t))) ) ;; dangerous char -> &entity; (defun hfy-html-quote (char-string) "Map CHAR-STRING to an HTML safe string (entity) if need be." ;;(message "hfy-html-quote");;DBUG (or (cadr (assoc char-string hfy-html-quote-map)) char-string) ) ;; actually entity-ise dangerous chars. ;; note that we can't do this until _after_ we have inserted the css ;; markup, since we use a position-based map to insert this, and if we ;; enter any other text before we do this, we'd have to track another ;; map of offsets, which would be tedious... (defun hfy-html-dekludge-buffer () "Transform all dangerous characters marked with the `hfy-quoteme' property using `hfy-html-quote'.\n See also `hfy-html-enkludge-buffer'." ;;(message "hfy-html-dekludge-buffer");;DBUG (save-excursion (goto-char (point-min)) (while (re-search-forward hfy-html-quote-regex nil t) (if (get-text-property (match-beginning 0) 'hfy-quoteme) (replace-match (hfy-html-quote (match-string 1))) )) )) ;; Borrowed from font-lock.el (defmacro hfy-save-buffer-state (varlist &rest body) "Bind variables according to VARLIST and eval BODY restoring buffer state. Do not record undo information during evaluation of BODY." (declare (indent 1) (debug let)) (let ((modified (make-symbol "modified"))) `(let* ,(append varlist `((,modified (buffer-modified-p)) (buffer-undo-list t) (inhibit-read-only t) (inhibit-point-motion-hooks t) (inhibit-modification-hooks t) deactivate-mark buffer-file-name buffer-file-truename)) (progn ,@body) (unless ,modified (restore-buffer-modified-p nil))))) (defun hfy-mark-trailing-whitespace () "Tag trailing whitespace with a hfy property if it is currently highlighted." (when show-trailing-whitespace (let ((inhibit-read-only t)) (save-excursion (goto-char (point-min)) (hfy-save-buffer-state nil (while (re-search-forward "[ \t]+$" nil t) (put-text-property (match-beginning 0) (match-end 0) 'hfy-show-trailing-whitespace t))))))) (defun hfy-unmark-trailing-whitespace () "Undo the effect of `hfy-mark-trailing-whitespace'." (when show-trailing-whitespace (hfy-save-buffer-state nil (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. FILE, if set, is the file name." (if srcdir (setq srcdir (directory-file-name srcdir))) (let* ( (html-buffer (hfy-buffer)) (css-sheet nil) (css-map nil) (invis-ranges nil) (rovl nil) (rmin (when mark-active (region-beginning))) (rmax (when mark-active (region-end ))) ) (when (and mark-active transient-mark-mode) (unless (and (= rmin (point-min)) (= rmax (point-max))) (setq rovl (make-overlay rmin rmax)) (overlay-put rovl 'priority 1000) (overlay-put rovl 'face 'region))) ;; copy the buffer, including fontification, and switch to it: (hfy-mark-trailing-whitespace) (setq css-sheet (hfy-compile-stylesheet ) css-map (hfy-compile-face-map ) invis-ranges (hfy-find-invisible-ranges)) (hfy-unmark-trailing-whitespace) (when rovl (delete-overlay rovl)) (copy-to-buffer html-buffer (point-min) (point-max)) (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) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; at this point, html-buffer retains the fontification of the parent: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; we don't really need or want text in the html buffer to be invisible, as ;; that can make it look like we've rendered invalid xhtml when all that's ;; happened is some tags are in the invisible portions of the buffer: (setq buffer-invisibility-spec nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ##################################################################### ;; if we are in etags mode, add properties to mark the anchors and links (if (and srcdir file) (progn (hfy-mark-tag-names srcdir file) ;; mark anchors (hfy-mark-tag-hrefs srcdir file))) ;; mark links ;; ##################################################################### ;; mark the 'dangerous' characters ;;(message "marking dangerous characters") (hfy-html-enkludge-buffer) ;; trawl the position-based face-map, inserting span tags as we go ;; note that we cannot change any character positions before this point ;; or we will invalidate the map: ;; NB: This also means we have to trawl the map in descending file-offset ;; order, obviously. ;; --------------------------------------------------------------------- ;; Remember, inserting pushes properties to the right, which we don't ;; actually want to happen for link properties, so we have to flag ;; them and move them by hand - if you don't, you end up with ;; ;; texta... ;; ;; instead of: ;; ;; texta... ;; ;; If my analysis of the problem is correct, we can detect link-ness by ;; either hfy-linkp or hfy-endl properties at the insertion point, but I ;; 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) (dolist (point-face css-map) (let ((pt (car point-face)) (fn (cdr point-face)) (move-link nil)) (goto-char pt) (setq move-link (or (get-text-property pt 'hfy-linkp) (get-text-property pt 'hfy-endl ))) (if (eq 'end fn) (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: (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)) (put-text-property pt (1+ pt) 'hfy-endl t)))))) ;; ##################################################################### ;; Invisibility ;; Maybe just make the text invisible in XHTML? ;; DONE -- big block of obsolete invisibility code elided here -- v ;; ##################################################################### ;; (message "checking to see whether we should link...") (if (and srcdir file) (let ((lp 'hfy-link) (pt (point-min)) (pr nil) (rr nil)) ;; (message " yes we should.") ;; translate 'hfy-anchor properties to anchors (while (setq pt (next-single-property-change pt 'hfy-anchor)) (if (setq pr (get-text-property pt 'hfy-anchor)) (progn (goto-char pt) (remove-text-properties pt (1+ pt) '(hfy-anchor nil)) (insert (concat ""))))) ;; translate alternate 'hfy-link and 'hfy-endl props to opening ;; and closing links. (this should avoid those spurious closes ;; we sometimes get by generating only paired tags) (setq pt (point-min)) (while (setq pt (next-single-property-change pt lp)) (if (not (setq pr (get-text-property pt lp))) nil (goto-char pt) (remove-text-properties pt (1+ pt) (list lp nil)) (cl-case lp (hfy-link (if (setq rr (get-text-property pt 'hfy-inst)) (insert (format "" rr))) (insert (format "" pr)) (setq lp 'hfy-endl)) (hfy-endl (insert "") (setq lp 'hfy-link)) ))) )) ;; ##################################################################### ;; transform the dangerous chars. This changes character positions ;; since entities have > char length. ;; note that this deletes the dangerous characters, and therefore ;; destroys any properties they may contain (such as 'hfy-endl), ;; so we have to do this after we use said properties: ;; (message "munging dangerous characters") (hfy-html-dekludge-buffer) (unless (hfy-opt 'body-text-only) ;; 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 "
")) (insert "\n
")
      (goto-char (point-max))
      (insert "
\n") (if (hfy-opt 'div-wrapper) (insert "
")) ;;(message "inserting footer") (insert (funcall hfy-page-footer file))) ;; call any post html-generation hooks: (run-hooks 'hfy-post-html-hook) ;; return the html buffer (set-buffer-modified-p nil) html-buffer)) (defun htmlfontify-string (string) "Take a STRING and return a fontified version of it. It is assumed that STRING has text properties that allow it to be fontified. This is a simple convenience wrapper around `htmlfontify-buffer'." (let* ((hfy-optimizations-1 (copy-sequence hfy-optimizations)) (hfy-optimizations (cl-pushnew 'skip-refontification hfy-optimizations-1))) (with-temp-buffer (insert string) (htmlfontify-buffer) (buffer-string)))) (defun hfy-force-fontification () "Try to force font-locking even when it is optimized away." (run-hooks 'hfy-init-kludge-hook) (eval-and-compile (require 'font-lock)) (if (boundp 'font-lock-cache-position) (or font-lock-cache-position (setq font-lock-cache-position (make-marker)))) (cond (noninteractive (message "hfy batch mode (%s:%S)" (or (buffer-file-name) (buffer-name)) major-mode) (if (fboundp 'font-lock-ensure) (font-lock-ensure) (when font-lock-defaults (font-lock-fontify-buffer)))) ((fboundp #'jit-lock-fontify-now) (message "hfy jit-lock mode (%S %S)" window-system major-mode) (jit-lock-fontify-now)) (t (message "hfy interactive mode (%S %S)" window-system major-mode) ;; If jit-lock is not in use, then the buffer is already fontified! ;; (when (and font-lock-defaults ;; font-lock-mode) ;; (font-lock-fontify-region (point-min) (point-max) nil)) ))) ;;;###autoload (defun htmlfontify-buffer (&optional srcdir file) "Create a new buffer, named for the current buffer + a .html extension, containing an inline CSS-stylesheet and formatted CSS-markup HTML that reproduces the look of the current Emacs buffer as closely as possible. Dangerous characters in the existing buffer are turned into HTML entities, so you should even be able to do HTML-within-HTML fontified display. You should, however, note that random control or non-ASCII characters such as ^L (U+000C FORM FEED (FF)) or ¤ (U+00A4 CURRENCY SIGN) won't get mapped yet. If the SRCDIR and FILE arguments are set, lookup etags derived entries in the `hfy-tags-cache' and add HTML anchors and hyperlinks as appropriate." (interactive) ;; pick up the file name in case we didn't receive it (if (not file) (progn (setq file (or (buffer-file-name) (buffer-name))) (if (string-match "/\\([^/]*\\)\\'" file) (setq file (match-string 1 file)))) ) (if (not (hfy-opt 'skip-refontification)) (save-excursion ;; Keep region (hfy-force-fontification))) (if (called-interactively-p 'any) ;; display the buffer in interactive mode: (switch-to-buffer (hfy-fontify-buffer srcdir file)) (hfy-fontify-buffer srcdir file))) ;; recursive file listing (defun hfy-list-files (directory) "Return a list of files under DIRECTORY. Strips any leading \"./\" from each filename." ;;(message "hfy-list-files");;DBUG ;; FIXME: this changes the dir of the current buffer. Is that right?? (cd directory) (mapcar (lambda (F) (if (string-match "^./\\(.*\\)" F) (match-string 1 F) F)) (split-string (shell-command-to-string hfy-find-cmd))) ) ;; strip the filename off, return a directory name ;; not a particularly thorough implementation, but it will be ;; fed pretty carefully, so it should be Ok: (defun hfy-dirname (file) "Return everything preceding the last \"/\" from a relative filename FILE, on the assumption that this will produce a relative directory name. Hardly bombproof, but good enough in the context in which it is being used." ;;(message "hfy-dirname");;DBUG (let ((f (directory-file-name file))) (and (string-match "^\\(.*\\)/" f) (match-string 1 f)))) ;; create a directory, cf mkdir -p (defun hfy-make-directory (dir) "Approx. equivalent of mkdir -p DIR." ;;(message "hfy-make-directory");;DBUG (if (file-exists-p dir) (if (file-directory-p dir) t) (make-directory dir t))) (defun hfy-text-p (srcdir file) "Is SRCDIR/FILE text? Uses `hfy-istext-command' to determine this." (let* ((cmd (format hfy-istext-command (expand-file-name file srcdir))) (rsp (shell-command-to-string cmd))) (string-match "text" rsp))) ;; open a file, check fontification, if fontified, write a fontified copy ;; to the destination directory, otherwise just copy the file: (defun hfy-copy-and-fontify-file (srcdir dstdir file) "Open FILE in SRCDIR - if fontified, write a fontified copy to DSTDIR adding an extension of `hfy-extn'. Fontification is actually done by `htmlfontify-buffer'. If the buffer is not fontified, just copy it." ;;(message "hfy-copy-and-fontify-file");;DBUG (let (;;(fast-lock-minimum-size hfy-fast-lock-save) ;;(font-lock-support-mode 'fast-lock-mode) ;;(window-system (or window-system 'htmlfontify)) (target nil) (source nil) (html nil)) (cd srcdir) (with-current-buffer (setq source (find-file-noselect file)) ;; FIXME: Shouldn't this use expand-file-name? --Stef (setq target (concat dstdir "/" file)) (hfy-make-directory (hfy-dirname target)) (if (not (hfy-opt 'skip-refontification)) (hfy-force-fontification)) (if (or (hfy-fontified-p) (hfy-text-p srcdir file)) (progn (setq html (hfy-fontify-buffer srcdir file)) (set-buffer html) (write-file (concat target hfy-extn)) (kill-buffer html)) ;; #o0200 == 128, but emacs20 doesn't know that (if (and (file-exists-p target) (not (file-writable-p target))) (set-file-modes target (logior (file-modes target) 128))) (copy-file (buffer-file-name source) target 'overwrite)) (kill-buffer source)) )) ;; list of tags in file in srcdir (defun hfy-tags-for-file (cache-hash file) "List of etags tags that have definitions in this FILE. CACHE-HASH is the tags cache." ;;(message "hfy-tags-for-file");;DBUG (let* ((tag-list nil)) (if cache-hash (maphash (lambda (K V) (if (assoc file V) (setq tag-list (cons K tag-list)))) cache-hash)) tag-list)) ;; mark the tags native to this file for anchors (defun hfy-mark-tag-names (srcdir file) "Mark tags in FILE (lookup SRCDIR in `hfy-tags-cache') with the `hfy-anchor' property, with a value of \"tag.line-number\"." ;;(message "(hfy-mark-tag-names %s %s)" srcdir file);;DBUG (let* ((cache-entry (assoc srcdir hfy-tags-cache)) (cache-hash (cadr cache-entry))) (if cache-hash (mapcar (lambda (TAG) (mapcar (lambda (TLIST) (if (string= file (car TLIST)) (let* ((line (cadr TLIST) ) (chr (cl-caddr TLIST)) (link (format "%s.%d" TAG line) )) (put-text-property (+ 1 chr) (+ 2 chr) 'hfy-anchor link)))) (gethash TAG cache-hash))) (hfy-tags-for-file cache-hash file))))) (defun hfy-relstub (file &optional start) "Return a \"../\" stub of the appropriate length for the current source tree depth, as determined from FILE (a filename). START is the offset at which to start looking for the / character in FILE." ;;(message "hfy-relstub");;DBUG (let ((c "")) (while (setq start (string-match "/" file start)) (setq start (1+ start)) (setq c (concat c "../"))) c)) (defun hfy-href-stub (this-file def-files tag) "Return an href stub for a tag href in THIS-FILE. If DEF-FILES (list of files containing definitions for the tag in question) contains only one entry, the href should link straight to that file. Otherwise, the link should be to the index file.\n We are not yet concerned with the file extensions/tag line number and so on at this point.\n If `hfy-split-index' is set, and the href wil be to an index file rather than a source file, append a .X to `hfy-index-file', where X is the uppercased first character of TAG.\n See also `hfy-relstub', `hfy-index-file'." ;;(message "hfy-href-stub");;DBUG ;; FIXME: Why not use something like ;; (file-relative-name (if ...) (file-name-directory this-file)) ? --Stef (concat (hfy-relstub this-file) (if (= 1 (length def-files)) (car def-files) (if (not hfy-split-index) hfy-index-file (concat hfy-index-file "." (upcase (substring tag 0 1)))))) ) (defun hfy-href (this-file def-files tag tag-map) "Return a relative href to the tag in question, based on\n THIS-FILE `hfy-link-extn' `hfy-extn' DEF-FILES TAG and TAG-MAP\n THIS-FILE is the current source file DEF-FILES is a list of file containing possible link endpoints for TAG TAG is the tag in question TAG-MAP is the entry in `hfy-tags-cache'." ;;(message "hfy-href");;DBUG (concat (hfy-href-stub this-file def-files tag) (or hfy-link-extn hfy-extn) "#" tag ;;(.src -> .html) (if (= 1 (length def-files)) (concat "." (format "%d" (cadr (assoc (car def-files) tag-map)))))) ) (defun hfy-word-regex (string) "Return a regex that matches STRING as the first `match-string', with non word characters on either side." ;; FIXME: Should this use [^$[:alnum:]_] instead? --Stef (concat "[^$A-Za-z_0-9]\\(" (regexp-quote string) "\\)[^A-Za-z_0-9]")) ;; mark all tags for hyperlinking, except the tags at ;; their own points of definition, iyswim: (defun hfy-mark-tag-hrefs (srcdir file) "Mark href start points with the `hfy-link' prop (value: href string).\n Mark href end points with the `hfy-endl' prop (value t).\n Avoid overlapping links, and mark links in descending length of tag name in order to prevent subtags from usurping supertags, \(eg \"term\" for \"terminal\"). SRCDIR is the directory being \"published\". FILE is the specific file we are rendering." ;;(message "hfy-mark-tag-hrefs");;DBUG (let ((cache-entry (assoc srcdir hfy-tags-cache)) (list-cache (assoc srcdir hfy-tags-sortl)) (rmap-cache (assoc srcdir hfy-tags-rmap )) (no-comment (hfy-opt 'zap-comment-links)) (no-strings (hfy-opt 'zap-string-links )) (cache-hash nil) (tags-list nil) (tags-rmap nil) (case-fold-search nil)) ;; extract the tag mapping hashes (fwd and rev) and the tag list: (if (and (setq cache-hash (cadr cache-entry)) (setq tags-rmap (cadr rmap-cache )) (setq tags-list (cadr list-cache ))) (mapcar (lambda (TAG) (let* ((start nil) (stop nil) (href nil) (name nil) (case-fold-search nil) (tmp-point nil) (maybe-start nil) (face-at nil) (rmap-entry nil) (rnew-elt nil) (rmap-line nil) (tag-regex (hfy-word-regex TAG)) (tag-map (gethash TAG cache-hash)) (tag-files (mapcar #'car tag-map))) ;; find instances of TAG and do what needs to be done: (goto-char (point-min)) (while (search-forward TAG nil 'NOERROR) (setq tmp-point (point) maybe-start (- (match-beginning 0) 1)) (goto-char maybe-start) (if (not (looking-at tag-regex)) nil (setq start (match-beginning 1)) (setq stop (match-end 1)) (setq face-at (and (or no-comment no-strings) (hfy-face-at start))) (if (listp face-at) (setq face-at (cadr (memq :inherit face-at)))) (if (or (text-property-any start (1+ stop) 'hfy-linkp t) (and no-comment (eq 'font-lock-comment-face face-at)) (and no-strings (eq 'font-lock-string-face face-at))) nil ;; already a link, NOOP ;; set a reverse map entry: (setq rmap-line (line-number-at-pos) rmap-entry (gethash TAG tags-rmap) rnew-elt (list file rmap-line start) rmap-entry (cons rnew-elt rmap-entry) name (format "%s.%d" TAG rmap-line)) (put-text-property start (1+ start) 'hfy-inst name) (puthash TAG rmap-entry tags-rmap) ;; mark the link. link to index if the tag has > 1 def ;; add the line number to the #name if it does not: (setq href (hfy-href file tag-files TAG tag-map)) (put-text-property start (1+ start) 'hfy-link href) (put-text-property stop (1+ stop ) 'hfy-endl t ) (put-text-property start (1+ stop ) 'hfy-linkp t ))) (goto-char tmp-point)) )) tags-list) ))) (defun hfy-shell () "Return `shell-file-name', or \"/bin/sh\" if it is a non-Bourne shell." (if (string-match "\\\\|\\\\|\\" shell-file-name) shell-file-name (or hfy-shell-file-name "/bin/sh"))) ;; cache the #(tag => file line point) entries for files under srcdir ;; and cache the descending sorted list of tags in the relevant alist, ;; also keyed by srcdir: (defun hfy-load-tags-cache (srcdir) "Run `hfy-etags-cmd' on SRCDIR, then call `hfy-parse-tags-buffer'." ;;(message "hfy-load-tags-cache");;DBUG (let ((etags-buffer (get-buffer-create "*hfy-tags*")) (etags-command (format hfy-etags-cmd hfy-etags-bin)) (shell-file-name (hfy-shell))) (cd srcdir) (shell-command etags-command etags-buffer) (hfy-parse-tags-buffer srcdir etags-buffer)) ) ;; break this out from `hfy-load-tags-cache' to make the tar file ;; functionality easier to implement. ;; ( tar file functionality not merged here because it requires a ;; hacked copy of etags capable of tagging stdin: if Francesco ;; Potortì accepts a patch, or otherwise implements stdin tagging, ;; then I will provide a `htmlfontify-tar-file' defun ) (defun hfy-parse-tags-buffer (srcdir buffer) "Parse a BUFFER containing etags formatted output, loading the `hfy-tags-cache' and `hfy-tags-sortl' entries for SRCDIR." (let ((cache-entry (assoc srcdir hfy-tags-cache)) (tlist-cache (assoc srcdir hfy-tags-sortl)) (trmap-cache (assoc srcdir hfy-tags-rmap )) (cache-hash nil) (trmap-hash nil) (tags-list nil) (hash-entry nil) (tag-string nil) (tag-line nil) (tag-point nil) (new-entry nil) (etags-file nil)) ;; (re)initialize the tag reverse map: (if trmap-cache (setq trmap-hash (cadr trmap-cache)) (setq trmap-hash (make-hash-table :test 'equal)) (setq hfy-tags-rmap (list (list srcdir trmap-hash) hfy-tags-rmap))) (clrhash trmap-hash) ;; (re)initialize the tag cache: (if cache-entry (setq cache-hash (cadr cache-entry)) (setq cache-hash (make-hash-table :test 'equal)) (setq hfy-tags-cache (list (list srcdir cache-hash) hfy-tags-cache))) (clrhash cache-hash) ;; cache the TAG => ((file line point) (file line point) ... ) entries: (with-current-buffer buffer (goto-char (point-min)) (while (and (looking-at "^\x0c") (= 0 (forward-line 1))) ;;(message "^L boundary") (if (and (looking-at "^\\(.+\\),\\([0-9]+\\)$") (= 0 (forward-line 1))) (progn (setq etags-file (match-string 1)) ;;(message "TAGS for file: %s" etags-file) (while (and (looking-at hfy-etag-regex) (= 0 (forward-line 1))) (setq tag-string (match-string 1)) (if (= 0 (length tag-string)) nil ;; noop (setq tag-line (round (string-to-number (match-string 2)))) (setq tag-point (round (string-to-number (match-string 3)))) (setq hash-entry (gethash tag-string cache-hash)) (setq new-entry (list etags-file tag-line tag-point)) (push new-entry hash-entry) ;;(message "HASH-ENTRY %s %S" tag-string new-entry) (puthash tag-string hash-entry cache-hash)))) ))) ;; cache a list of tags in descending length order: (maphash (lambda (K _V) (push K tags-list)) cache-hash) (setq tags-list (sort tags-list (lambda (A B) (< (length B) (length A))))) ;; put the tag list into the cache: (if tlist-cache (setcar (cdr tlist-cache) tags-list) (push (list srcdir tags-list) hfy-tags-sortl)) ;; return the number of tags found: (length tags-list) )) (defun hfy-prepare-index-i (srcdir dstdir filename &optional stub map) "Prepare a tags index buffer for SRCDIR. `hfy-tags-cache' must already have an entry for SRCDIR for this to work. `hfy-page-header', `hfy-page-footer', `hfy-link-extn' and `hfy-extn' all play a part here.\n If STUB is set, prepare an (appropriately named) index buffer specifically for entries beginning with STUB.\n If MAP is set, use that instead of `hfy-tags-cache'. FILENAME is the name of the file being indexed. DSTDIR is the output directory, where files will be written." ;;(message "hfy-write-index");;DBUG (let ((cache-entry (assoc srcdir (or map hfy-tags-cache))) (cache-hash nil) (tag-list nil) (index-file (concat filename (if stub (concat "." stub) "") hfy-extn)) (index-buf nil)) (if (not (and cache-entry (setq cache-hash (cadr cache-entry)) (setq index-buf (get-buffer-create index-file)))) nil ;; noop (maphash (lambda (K _V) (push K tag-list)) cache-hash) (setq tag-list (sort tag-list 'string<)) (set-buffer index-buf) (erase-buffer) (insert (funcall hfy-page-header filename "")) (insert "\n") (dolist (TAG tag-list) (let ((tag-started nil)) (dolist (DEF (gethash TAG cache-hash)) (if (and stub (not (string-match (concat "^" stub) TAG))) nil ;; we have a stub and it didn't match: NOOP (let ((file (car DEF)) (line (cadr DEF))) (insert (format (concat " \n" " \n" " \n" " \n" " \n") (if (string= TAG tag-started) " " (format "%s" TAG TAG)) file (or hfy-link-extn hfy-extn) file file (or hfy-link-extn hfy-extn) TAG line line)) (setq tag-started TAG)))))) (insert "
%s%s%d
\n") (insert (funcall hfy-page-footer filename)) (and dstdir (cd dstdir)) (set-visited-file-name index-file) index-buf) )) (defun hfy-prepare-index (srcdir dstdir) "Return a list of index buffer(s), as determined by `hfy-split-index'. SRCDIR and DSTDIR are the source and output directories respectively." (if (not hfy-split-index) (list (hfy-prepare-index-i srcdir dstdir hfy-index-file nil)) (let ((stub-list nil) (cache-hash nil) (index-list nil) (cache-entry (assoc srcdir hfy-tags-cache))) (if (and cache-entry (setq cache-hash (cadr cache-entry))) (maphash (lambda (K _V) (let ((stub (upcase (substring K 0 1)))) (if (member stub stub-list) nil ;; seen this already: NOOP (setq stub-list (cons stub stub-list) index-list (cons (hfy-prepare-index-i srcdir dstdir hfy-index-file stub) index-list)) ))) cache-hash) ) index-list))) (defun hfy-prepare-tag-map (srcdir dstdir) "Prepare the counterpart(s) to the index buffer(s) - a list of buffers with the same structure, but listing (and linking to) instances of tags \(as opposed to their definitions).\n SRCDIR and DSTDIR are the source and output directories respectively. See also `hfy-prepare-index', `hfy-split-index'." (if (not hfy-split-index) (list (hfy-prepare-index-i srcdir dstdir hfy-instance-file nil hfy-tags-rmap)) (let ((stub-list nil) (cache-hash nil) (index-list nil) (cache-entry (assoc srcdir hfy-tags-rmap))) (if (and cache-entry (setq cache-hash (cadr cache-entry))) (maphash (lambda (K _V) (let ((stub (upcase (substring K 0 1)))) (if (member stub stub-list) nil ;; seen this already: NOOP (setq stub-list (cons stub stub-list) index-list (cons (hfy-prepare-index-i srcdir dstdir hfy-instance-file stub hfy-tags-rmap) index-list)) ))) cache-hash) ) index-list))) (defun hfy-subtract-maps (srcdir) "Internal function - strips definitions of tags from the instance map. SRCDIR is the directory being \"published\". See also `hfy-tags-cache', `hfy-tags-rmap'." (let ((new-list nil) (old-list nil) (def-list nil) (exc-list nil) (fwd-map (cadr (assoc srcdir hfy-tags-cache))) (rev-map (cadr (assoc srcdir hfy-tags-rmap ))) (taglist (cadr (assoc srcdir hfy-tags-sortl)))) (dolist (TAG taglist) (setq def-list (gethash TAG fwd-map) old-list (gethash TAG rev-map) exc-list (mapcar (lambda (P) (list (car P) (cadr P))) def-list) new-list nil) (dolist (P old-list) (or (member (list (car P) (cadr P)) exc-list) (push P new-list))) (puthash TAG new-list rev-map)))) (defun htmlfontify-run-etags (srcdir) "Load the etags cache for SRCDIR. See also `hfy-load-tags-cache'." (interactive "D source directory: ") (hfy-load-tags-cache (directory-file-name srcdir))) ;;(defun hfy-test-read-args (foo bar) ;; (interactive "D source directory: \nD target directory: ") ;; (message "foo: %S\nbar: %S" foo bar)) (defun hfy-save-kill-buffers (buffer-list &optional dstdir) (dolist (B buffer-list) (set-buffer B) (and dstdir (file-directory-p dstdir) (cd dstdir)) (save-buffer) (kill-buffer B))) ;;;###autoload (defun htmlfontify-copy-and-link-dir (srcdir dstdir &optional f-ext l-ext) "Trawl SRCDIR and write fontified-and-hyperlinked output in DSTDIR. F-EXT and L-EXT specify values for `hfy-extn' and `hfy-link-extn'.\n You may also want to set `hfy-page-header' and `hfy-page-footer'." (interactive "D source directory: \nD output directory: ") ;;(message "htmlfontify-copy-and-link-dir") (setq srcdir (directory-file-name srcdir)) (setq dstdir (directory-file-name dstdir)) (let ((source-files "SETME: list of source files, relative to srcdir") (tr-cache (assoc srcdir hfy-tags-rmap)) (hfy-extn (or f-ext ".html")) (hfy-link-extn (or l-ext ".html"))) ;; oops, forgot to load etags for srcdir: (if tr-cache nil (message "autoload of tags cache") (hfy-load-tags-cache srcdir) (setq tr-cache (assoc srcdir hfy-tags-rmap))) ;; clear out the old cache: (clrhash (cadr tr-cache)) (hfy-make-directory dstdir) (setq source-files (hfy-list-files srcdir)) (dolist (file source-files) (hfy-copy-and-fontify-file srcdir dstdir file)) (hfy-subtract-maps srcdir) (hfy-save-kill-buffers (hfy-prepare-index srcdir dstdir) dstdir) (hfy-save-kill-buffers (hfy-prepare-tag-map srcdir dstdir) dstdir) )) ;; name of the init file we want: (defun hfy-initfile () "Return the expected location of the htmlfontify specific init/custom file." (let* ((file (or (getenv "HFY_INITFILE") ".hfy.el"))) (expand-file-name file "~") )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; incomplete as yet : transfer hook settings to hfy init file: ;; (defalias 'hfy-set-hooks 'custom-set-variables) ;; (defun hfy-pp-hook (H) ;; (and (string-match "-hook\\'" (symbol-name H)) ;; (boundp H) ;; (symbol-value H) ;; (insert (format "\n '(%S %S)" H (symbol-value H))) ;; ) ;; ) ;; (defun hfy-save-hooks () ;; (let ((custom-file (hfy-initfile))) ;; (custom-save-delete 'hfy-set-hooks) ;; (let ((standard-output (current-buffer))) ;; (princ "(hfy-set-hooks\n;;auto-generated, only one copy allowed\n") ;; (mapatoms 'hfy-pp-hook) ;; (insert "\n)") ;; ) ;; ) ;; ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defalias 'hfy-init-progn 'progn) (defun hfy-save-initvar (sym) (princ (format "(setq %s\n '" sym)) (pp (symbol-value sym)) (princ ")\n")) (defun htmlfontify-save-initfile () "Save the htmlfontify settings to the htmlfontify init file." (interactive) (let* ((start-pos nil) (custom-file (hfy-initfile)) (standard-output (find-file-noselect custom-file 'nowarn))) (save-excursion (custom-save-delete 'hfy-init-progn) (setq start-pos (point)) (princ "(hfy-init-progn\n;;auto-generated, only one copy allowed\n") ;; FIXME: This saving&restoring of global customization ;; variables can interfere with other customization settings for ;; those vars (in .emacs or in Customize). (mapc 'hfy-save-initvar '(auto-mode-alist interpreter-mode-alist)) (princ ")\n") (indent-region start-pos (point) nil)) (custom-save-all) )) (defun htmlfontify-load-initfile () "Load the htmlfontify specific init/custom file." (interactive) (let ((file (hfy-initfile))) (load file 'NOERROR nil nil) )) (provide 'htmlfontify) ;;; htmlfontify.el ends here