From ebccd804aa39215c67ebc7a2176575fd7e4c4284 Mon Sep 17 00:00:00 2001 From: Jambunathan K Date: Fri, 19 Aug 2011 01:40:55 +0530 Subject: [PATCH 1/6] * contrib/lisp/htmlfontify.el: Added from emacs-24 trunk --- contrib/lisp/htmlfontify.el | 2343 +++++++++++++++++++++++++++++++++++++++++++ 1 files changed, 2343 insertions(+), 0 deletions(-) create mode 100755 contrib/lisp/htmlfontify.el diff --git a/contrib/lisp/htmlfontify.el b/contrib/lisp/htmlfontify.el new file mode 100755 index 0000000..c8e9558 --- /dev/null +++ b/contrib/lisp/htmlfontify.el @@ -0,0 +1,2343 @@ +;;; htmlfontify.el --- htmlise a buffer/source tree with optional hyperlinks + +;; Copyright (C) 2002-2003, 2009-2011 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: htmlise 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 +;; Version: 0.21 + +;; 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)) +(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) + +(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) + :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 the string returned 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-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) + (orig-ovls (overlays-in (point-min) (point-max))) + (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 htmlisation 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: + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; 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) + (insert "") + (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)))) + (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)) + (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) + ;; 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-hooks) + ;; return the html buffer + (set-buffer-modified-p nil) + html-buffer)) + +(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 + (set 'font-lock-cache-position (make-marker)))) + (if (not noninteractive) + (progn + (message "hfy interactive mode (%S %S)" window-system major-mode) + (when (and font-lock-defaults + font-lock-mode) + (font-lock-fontify-region (point-min) (point-max) nil))) + (message "hfy batch mode (%s:%S)" + (or (buffer-file-name) (buffer-name)) major-mode) + (when font-lock-defaults + (font-lock-fontify-buffer)) )) + +;;;###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 eight-bit +characters such as ^L (\x0c) or ¤ (\xa4) 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 currrent 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 directiry name +;; not a particularly thorough implementaion, 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 (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 +;; Potorti 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)initialise 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)initialise 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) )) + + +;;;### (autoloads (hfy-fallback-colour-values htmlfontify-load-rgb-file) +;;;;;; "hfy-cmap" "hfy-cmap.el" "8dce008297f15826cc6ab82203c46fa6") +;;; Generated autoloads from hfy-cmap.el + +(autoload 'htmlfontify-load-rgb-file "hfy-cmap" "\ +Load an X11 style rgb.txt FILE. +Search `hfy-rgb-load-path' if FILE is not specified. +Loads the variable `hfy-rgb-txt-colour-map', which is used by +`hfy-fallback-colour-values'. + +\(fn &optional FILE)" t nil) + +(autoload 'hfy-fallback-colour-values "hfy-cmap" "\ +Use a fallback method for obtaining the rgb values for a color. + +\(fn COLOUR-STRING)" nil nil) + +;;;*** + + +(provide 'htmlfontify) + +;; Local Variables: +;; coding: utf-8 +;; End: + +;;; htmlfontify.el ends here -- 1.7.2.3