;; This code released under the GNU GPL (v2) ;; ( A copy of which you can find at ;; http://rtfm.etla.org/sql/oracle_time/gpl.html ) ;; Copyright (C) 2002 Vivek Dasmohapatra ;; here's some emacs code to html-pretty-print an emacs buffer, preserving ;; the emacs syntax/whatever highlighting ;; Have added code to drive the htmlfontification code in an even funkier ;; way (hfy-copy-and-fontify-dir "/src/directory" "/dst/directory") is ;; capable of generating and harvesting an etags index for that source ;; tree and using it to generate hyperlinked-and-fontified files. ;; NOTE: Currently the hyperlinking code only knows how to drive GNU find ;; and the exuberant-ctags variant of etags (on platforms where the -R ;; (recursion) switch is implemented). I will probably adapt this code to ;; drive other variants of etags - I am much less likely to support other ;; variants of find, though, unless they support the -path test. ;; hmm, must write some proper docs for this - still, it should be ;; reasonably easy to follow, though... ;; 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 through 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) (defvar hfy-page-header 'hfy-default-header) (defvar hfy-page-footer 'hfy-default-footer) (defvar hfy-extn ".html") (defvar hfy-link-extn nil) (defvar hfy-index-file "hfy-index") (defvar hfy-tags-cache nil) (defvar hfy-tags-sortl nil) (defvar hfy-etags-cmd "etags -R -f -") (defvar hfy-find-cmd "find . -type f \\! -name \\*~ \\! -name \\*.flc \\! -path \\*/CVS/\\*") (defun hfy-default-header (file) "\n\n") (defun hfy-default-footer (file) "\n") ;; utility functions - cast emacs style specification values into their ;; css2 equivalents: (defun hfy-triplet (colour) "Takes a colour name (string) and return a css rgb(R, G, B) triplet string. Uses the definition of \"white\" to map the numbers to the 0-255 range, so if you\'ve redefined white, (esp if you've redefined it to have a triplet member lower than that of the colour you are processing, strange things may happen)" (let ((white (mapcar (lambda (I) (float (1+ I))) (color-values "white"))) (rgb16 (mapcar (lambda (I) (float (1+ I))) (color-values colour)))) (if rgb16 (apply 'format "rgb(%d, %d, %d)" (mapcar (lambda (X) (* (/ (nth X rgb16) (nth X white)) 255)) '(0 1 2))))) ) (defun hfy-family (family) (list (cons "font-family" family))) (defun hfy-bgcol (colour) (list (cons "background" (hfy-triplet colour)))) (defun hfy-colour (colour) (list (cons "color" (hfy-triplet colour)))) (defun hfy-width (width) (list (cons "font-stretch" (symbol-name width)))) (defun hfy-size (height) "Derive a css font-size specifier from an emacs font :height attribute. Does not cope with the case where height is a function to be applied to the height of the underlying font" (list (cond ((floatp height) (cons "font-size" (format "%d%%" (* height 100)))) ((integerp height) (cons "font-size" (format "%dpt" (/ height 10 )))) )) ) (defun hfy-slant (slant) "Derive a font-style css specifier from the emacs :slant attribute - CSS does not define the reverse-* styles, so just maps those to the regular specifiers." (list (cons "font-style" (cond ((eq 'italic slant) "italic" ) ((eq 'reverse-italic slant) "italic" ) ((eq 'oblique slant) "oblique") ((eq 'reverse-oblique slant) "oblique") (t "normal" )))) ) (defun hfy-weight (weight) (list (cons "font-weight" (cond ((eq 'ultra-bold weight) "900") ((eq 'extra-bold weight) "800") ((eq 'bold weight) "700") ((eq 'semi-bold weight) "600") ((eq 'normal weight) "500") ((eq 'semi-light weight) "400") ((eq 'light weight) "300") ((eq 'extra-light weight) "200") ((eq 'ultra-light weight) "100")))) ) (defun hfy-box-to-border-assoc (spec) (if spec (let ((tag (car spec)) (val (cadr spec))) (cons (cond ((string= tag ":color") (cons "colour" val)) ((string= tag ":width") (cons "width" val)) ((string= tag ":style") (cons "style" val))) (hfy-box-to-border-assoc (cddr spec))))) ) (defun hfy-box-to-style (spec) (let* ((css (hfy-box-to-border-assoc spec)) (col (cdr (assoc "colour" css))) (s (cdr (assoc "style" css)))) (list (if col (cons "border-color" (cdr (assoc "colour" css)))) (cons "border-width" (format "%dpx" (or (cdr (assoc "width" css)) 1))) (cons "border-style" (cond ((string= s "released-button") "outset") ((string= s "released-button") "inset" ) (t "solid" ))))) ) (defun hfy-box (box) "Derive CSS border-* attributes from the emacs :box attribute." (if box (cond ((integerp box) (list (cons "border-width" (format "%dpx" box)))) ((stringp box) (list (cons "border" (format "solid %s 1px" box)))) ((listp box) (hfy-box-to-style box) )) )) (defun hfy-decor (tag val) "Derive CSS text-decoration specifiers from various emacs font attributes." (list (cond ((string= tag ":underline" ) (cons "text-decoration" "underline" )) ((string= tag ":overline" ) (cons "text-decoration" "overline" )) ((string= tag ":strike-through") (cons "text-decoration" "line-through")))) ) ;; construct an assoc of (css-tag-name . css-tag-value) pairs ;; from a face or assoc of face attributes: (defun hfy-face-to-style-i (fn) "The guts of `hfy-face-to-style': FN should be a `defface' font specification, as returned by `face-attr-construct'. Note that this function does not get font-sizes right if they are based on inherited modifiers (via the :inherit) attribute, and any other modifiers that are cumulative if they appear multiple times need to be merged by the user - `hfy-uniq-styles' should do this. (It currently only handles font-size)." ;;(message "-- (%s %S)" 'hfy-face-to-style-i fn) (if fn (let ((key (car fn)) (val (cadr fn)) (next (cddr fn)) (that nil) (this nil) (parent nil)) (setq this (cond ((string= key ":family" ) (hfy-family val)) ((string= key ":width" ) (hfy-width val)) ((string= key ":weight" ) (hfy-weight val)) ((string= key ":slant" ) (hfy-slant val)) ((string= key ":foreground") (hfy-colour val)) ((string= key ":background") (hfy-bgcol val)) ((string= key ":box" ) (hfy-box val)) ((string= key ":height" ) (hfy-size val)) ((and (string= key ":underline" ) val) (hfy-decor key val)) ((and (string= key ":overline" ) val) (hfy-decor key val)) ((and (string= key ":strike-through") val) (hfy-decor key val)) ((and (string= key ":bold" ) val) (hfy-weight 'bold)) ((and (string= key ":italic" ) val) (hfy-slant 'italic)))) (setq that (hfy-face-to-style-i next)) (if (string= key ":inherit") (setq parent (hfy-face-to-style-i (face-attr-construct val)))) (nconc this that parent) ) ) ) (defun hfy-size-to-int (spec) "Convert SPEC, a css font-size specifier, back to an emacs :height attribute value. Used while merging multiple font-size attributes." (list (if (string-match "\$[[:digit:]]+\$\$%\\|pt\$" spec) (cond ((string= "%" (match-string 2 spec)) (/ (string-to-int (match-string 1 spec)) 100.0)) ((string= "pt" (match-string 2 spec)) (* (string-to-int (match-string 1 spec)) 10)) ) (string-to-number spec))) ) ;; size is different, in that in order to get it right at all, ;; we have to trawl the inheritance path, accumulating modifiers, ;; _until_ we get to an absolute (pt) specifier, then combine the lot (defun hfy-uniq-styles (style) "Take STYLE (see `hfy-face-to-style-i', `hfy-face-to-style') and merge any multiple attributes appropriately. Currently only font-size is merged down to a single occurrence - others may need special handling, but I haven\'t encountered them yet. Returns a `hfy-style-assoc'." (let ((n 0) (m (list 1)) (x nil) (r nil)) (mapcar (lambda (css) (if (string= (car css) "font-size") (progn ;;(message "- [%S]" css) (if (not x) (setq m (nconc m (hfy-size-to-int (cdr css))))) (if (string-match "pt" (cdr css)) (setq x t))) ;;(message "+ [%S]" css) (setq r (nconc r (list css))))) style) ;;(message "= [%S]" r) ;;(message "* [%S]%s" m (if x ".pt" ".%")) (setq n (apply '* m)) (nconc r (hfy-size (if x (round n) (* n 1.0)))) r)) (defun hfy-face-to-style (fn) "Take FN, a font or `defface' style font specification, $as returned by `face-attr-construct'$ and return a `hfy-style-assoc'. See also: `hfy-face-to-style-i', `hfy-uniq-styles'." (let ((face-def (if (facep fn) (face-attr-construct fn) fn)) (final-style nil)) (setq final-style (hfy-uniq-styles (hfy-face-to-style-i face-def))) (if (not (assoc "text-decoration" final-style)) (progn (setq final-style (nconc final-style '(("text-decoration"."none")))))) final-style)) ;; strip redundant bits from a name. Technically, this could result in ;; a collision, but it is pretty unlikely - will fix later... (defun hfy-css-name (fn) "Strip some of the boring bits from a font-name and return a css style name." (let ((face-name (format "%s" fn))) (if (or (string-match "font-lock-\$.*\$" face-name) (string-match "cperl-\$.*\$" face-name) (string-match "[Ii]nfo-\$.*\$" face-name)) (progn (setq face-name (match-string 1 face-name)) (if (string-match "\$.*\$-face" face-name) (setq face-name (match-string 1 face-name))) face-name) face-name)) ) ;; 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. See also: `hfy-face-to-style'" (let ((css-list nil) (css-text nil) (style nil) (seen nil)) (setq css-list (hfy-face-to-style fn)) (setq css-text (nconc (mapcar (lambda (E) (if (car E) (if (not (member (car E) seen)) (progn (setq seen (cons (car E) seen)) (format " %s: %s; " (car E) (cdr E)))))) css-list))) ;;(message "seen :: %S" seen) (cons (hfy-css-name fn) (format "{%s}" (apply 'concat css-text)))) ) ;; extract a face from a list of char properties, if there is one: (defun hfy-p-to-face (props) "Given PROPS, a list of text-properties, return the value of the face property, or nil." (if props (if (string= (car props) "face") (if (listp (cadr props)) (car (cadr props)) (cadr props)) (hfy-p-to-face (cddr props))) nil)) (defun hfy-face-at (p) "Find face in effect at point P" (hfy-p-to-face (text-properties-at p))) ;; construct an assoc of (face-name . (css-name . "{ css-style }")) elements: (defun hfy-compile-stylesheet () "Trawl the current buffer, construct an return a `hfy-sheet-assoc'." (let ((pt (point-min)) (fn nil) (css nil) (style nil)) (save-excursion (goto-char pt) (while (< pt (point-max)) (if (and (setq fn (hfy-face-at pt)) (not (assoc fn style))) (setq style (cons (cons fn (hfy-face-to-css fn)) style))) (setq pt (next-char-property-change pt))) ) style) ) ;; remember to generate 'synthetic' entries - ;; emacs copes by just having a stack of styles in effect ;; and only using the top one: html has a more simplistic approach - ;; we have to explicitly end a style, there's no way of temporarily ;; overriding it w. another one... (afaik) (defun hfy-compile-face-map () "Compile and return a `hfy-facemap-assoc' for the current buffer." (let ((pt (point-min)) (fn nil) (map nil) (last-tag nil)) ;; t if the last tag-point was a span-start ;; nil if it was a span-stop (save-excursion (goto-char pt) (while (< pt (point-max)) (if (setq fn (hfy-face-at pt)) (progn (if last-tag (setq map (cons (cons pt 'end) map))) (setq map (cons (cons pt fn) map)) (setq last-tag t)) (setq map (cons (cons pt 'end) map)) (setq last-tag nil)) (setq pt (next-char-property-change pt)))) map) ) ;; generate a buffer to hold the output. Should make this safer, really... (defun hfy-buffer () (get-buffer-create (concat (buffer-name) hfy-extn))) ;; get a css style name for a face from the style: (defun hfy-lookup (face style) (cadr (assoc face style))) ;; barf up the inline css stylesheet (defun hfy-sprintf-stylesheet (css file) (concat (apply 'concat (funcall hfy-page-header file) "\n\n

\n") )

;; 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 ()
  (save-excursion
    (goto-char (point-min))
    (while (re-search-forward "\\(\"\\|<\\|>\\)" nil t)
      (put-text-property (match-beginning 0) (point) 'hfy-quoteme t)
      )
    )
  )

;; dangerous char -> &entity;
(defun hfy-html-quote (string)
  (cadr (assoc 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 ()
  (save-excursion
    (goto-char (point-min))
    (while (re-search-forward "\\(\"\\|<\\|>\\)" nil t)
      (if (get-text-property (match-beginning 0) 'hfy-quoteme)
	  (replace-match (hfy-html-quote (match-string 1)))
	)
      )
    )
  )

;; do it:
(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.

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)
  (let ((in-style                         nil)
	(html-buffer (hfy-buffer            ))
	(css-sheet   (hfy-compile-stylesheet))
	(css-map     (hfy-compile-face-map  )))
    ;; copy the buffer, including fontification, and switch to it:
    (copy-to-buffer html-buffer (point-min) (point-max))
    (set-buffer     html-buffer)
    ;; at this point, html-buffer retains the fontification of the parent:
    ;; #####################################################################
    ;; if we are in etags mode, add properties to mark the anchors and links
    (if (and srcdir file)
	(progn
	  (hfy-mark-tags-this-file  srcdir file) ;; mark anchors
	  (hfy-mark-tags-other-file srcdir file))) ;; mark links
    ;; #####################################################################
    ;; mark the '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.
    (mapcar
     (lambda (point-face)
       (let ((pt (car point-face))
	     (fn (cdr point-face)))
	 (goto-char pt)
	 (if (eq 'end fn) (insert "")
	   (insert (format ""
			   (hfy-lookup fn css-sheet))) ))) css-map)
    ;; #####################################################################
    (if (and srcdir file)
	(let ((pt nil)
	      (pr nil)
	      (x  nil))
	  (progn
	    (setq pt (point-min))
	    (while (setq pt (next-single-property-change pt 'hfy-anchor))
	      (if (setq pr (get-text-property pt 'hfy-anchor))
		  (progn (goto-char pt)
			 ;;(message "%s :: %s <- %s" pt file pr)
			 (remove-text-properties pt (1+ pt) '(hfy-anchor nil))
			 (insert (concat "")))))
 	    (setq pt (point-min))
 	    (while (setq pt (next-single-property-change pt 'hfy-link))
	      (if (setq pr (get-text-property pt 'hfy-link))
 		  (progn (goto-char pt)
			  ;;(setq pr (hfy-p-to-href pr)) ;; IMPLEMENTME
			 (remove-text-properties pt (1+ pt) '(hfy-link nil))
			 (insert (format "" pr)))))
 	    (setq pt (point-min))
 	    (while (setq pt (next-single-property-change pt 'hfy-endl))
 	      (if (get-text-property pt 'hfy-endl)
		  (progn (goto-char pt)
			 (remove-text-properties pt (1+ pt) '(hfy-endl nil))
			 (insert ""))))
	    ) ) )
    ;; #####################################################################
    ;; transform the dangerous chars. This changes character positions
    ;; since entities have > char length.
    ;; note that this deletes the dangerous characters, and therefore
    ;; destroys any ptoperties they may contain (such as 'hfy-endl),
    ;; so we have to do this after we use said properties:
    (hfy-html-dekludge-buffer)
    ;; insert the stylesheet at the top:
    (goto-char (point-min))
    (insert (hfy-sprintf-stylesheet css-sheet file))
    (goto-char (point-max))
    (insert "\n

\n") (insert (funcall hfy-page-footer file)) ;; display the html buffer, if interactive: (if (interactive-p) (switch-to-buffer html-buffer)) html-buffer) ) ;; recursive file listing (defun hfy-list-files (directory) (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) (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) (if (file-exists-p dir) (if (file-directory-p dir) t) (make-directory dir t))) ;; 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) (let ((target nil) (source nil) (html nil)) (cd srcdir) (save-excursion (setq source (find-file-noselect file)) (set-buffer source) (setq target (concat dstdir "/" file)) (hfy-make-directory (hfy-dirname target)) (if (and font-lock-mode font-lock-fontified) (progn (setq html (htmlfontify-buffer srcdir file)) (set-buffer html) (write-file (concat target hfy-extn)) (kill-buffer html)) ;;(message "(copy-file %S %S)" (buffer-file-name source) target) (copy-file (buffer-file-name source) target 'overwrite)) (kill-buffer source)) ) ) ;; what line are we on? (defun hfy-line-number () (let ((opoint (point)) start) (save-excursion (goto-char (point-min)) (forward-line 0) (setq start (point)) (goto-char opoint) (forward-line 0) (1+ (count-lines 1 (point)))))) ;; list of tags in file in srcdir (defun hfy-tags-for-file (srcdir file) (let ((cache-entry (assoc srcdir hfy-tags-cache)) (cache-hash nil) (tag-list nil)) (if (setq cache-hash (cadr cache-entry)) (maphash (lambda (K V) (if (assoc file V) (setq tag-list (cons K tag-list)))) cache-hash)) tag-list)) (defconst etags-tag-regex (concat ".*" "\x7f" "\$.+\$" "\x01" "\$[[:digit:]]+\$" "," "\$[[:digit:]]+\$$")) ;; mark the tags native to this file for anchors (defun hfy-mark-tags-this-file (srcdir file) (let ((cache-entry (assoc srcdir hfy-tags-cache)) (cache-hash nil)) (if (setq cache-hash (cadr cache-entry)) (mapcar (lambda (TAG) (let* ((V (gethash TAG cache-hash)) (line (cadr (assoc file V) )) (chr (car (cddr (assoc file V)))) (link (concat TAG "." (format "%d" line)))) (put-text-property (1+ chr) (+ 2 chr) 'hfy-anchor link))) (hfy-tags-for-file srcdir file))))) (defun hfy-relstub (file &optional start) (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) (concat (hfy-relstub this-file) (if (= 1 (length def-files)) (car def-files) hfy-index-file))) (defun hfy-href (this-file def-files tag tag-map) (concat (hfy-href-stub this-file def-files) (or hfy-link-extn hfy-extn) "#" tag ;;(.src -> .html) (if (= 1 (length def-files)) (concat "." (format "%d" (cadr (assoc (car def-files) tag-map)))))) ) ;; mark all tags for hyperlinking, except the tags at ;; their own points of definition, iyswim: (defun hfy-mark-tags-other-file (srcdir file) (let ((cache-entry (assoc srcdir hfy-tags-cache)) (list-cache (assoc srcdir hfy-tags-sortl)) (cache-hash nil) (tags-list nil) (case-fold-search nil)) (if (and (setq cache-hash (cadr cache-entry)) (setq tags-list (cadr list-cache ))) (mapcar (lambda (TAG) (let* ((start nil ) (stop nil ) (href nil ) (tag-map (gethash TAG cache-hash)) (tag-files (mapcar (lambda (X) (car X)) tag-map)) ) (goto-char (point-min)) (while (word-search-forward TAG nil 'NOERROR) (setq start (match-beginning 0)) (setq stop (point)) (if (or (text-property-any start (1+ stop) 'hfy-linkp t) (and (member file tag-files) ;; tag defined in this file (= (hfy-line-number) ;; and we're on that line (cadr (assoc file tag-map))))) ;; this is already marked for linking, ;; OR we are at one of the tag's points of definition nil ;; mark the link. link to the 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 )) ))) tags-list) ))) ;; 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) (let ((etags-buffer (get-buffer-create "*hfy-etags*")) (cache-entry (assoc srcdir hfy-tags-cache)) (tlist-cache (assoc srcdir hfy-tags-sortl)) (cache-hash nil) (tags-list nil) (hash-entry nil) (tag-string nil) (tag-line nil) (tag-point nil) (etags-file nil)) (cd srcdir) (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))) (shell-command hfy-etags-cmd etags-buffer) (clrhash cache-hash) ;; cache the TAG => ((file line point) (file line point) ... ) ;; entries: (save-excursion (set-buffer etags-buffer) (goto-char (point-min)) (while (and (looking-at "^\x0c") (= 0 (forward-line 1))) (if (and (looking-at "^\$.+\$,\$[[:digit:]]+\$$") (= 0 (forward-line 1))) (progn (setq etags-file (match-string 1)) (while (and (looking-at etags-tag-regex) (= 0 (forward-line 1))) (setq tag-string (match-string 1)) (setq tag-line (string-to-int (match-string 2))) (setq tag-point (string-to-int (match-string 3))) (setq hash-entry (gethash tag-string cache-hash)) (setq hash-entry (cons (list etags-file tag-line tag-point) hash-entry)) (puthash tag-string hash-entry cache-hash)) )))) ;; cache a list of tags in descending length order: (maphash (lambda (K V) (setq tags-list (cons K tags-list))) cache-hash) (setq tags-list (sort tags-list (lambda (A B) (< (length B) (length A))))) (if tlist-cache (setcar (cdr tlist-cache) tags-list) (setq hfy-tags-sortl (cons (list srcdir tags-list) hfy-tags-sortl))) )) (defun hfy-write-index (srcdir dstdir) (let ((cache-entry (assoc srcdir hfy-tags-cache)) (cache-hash nil) (tag-list nil) (index-file (concat hfy-index-file hfy-extn)) (index-buf nil) ) (if (and cache-entry (setq cache-hash (cadr cache-entry)) (setq index-buf (find-file-noselect index-file))) (progn (maphash (lambda (K V) (setq tag-list (cons K tag-list))) cache-hash) (setq tag-list (sort tag-list 'string<)) (set-buffer index-buf) (erase-buffer) (insert (funcall hfy-page-header hfy-index-file)) (insert "

\n")
	  (mapcar
	   (lambda (TAG)
	     (insert (format "" TAG))
	     (mapcar
	      (lambda (DEF)
		(let ((file (car  DEF))
		      (line (cadr DEF)))
		(insert
		 (format "%s (%s,%d)\n"
			 file
			 (or hfy-link-extn hfy-extn) ;;(.src -> .html)
			 TAG
			 line
			 TAG
			 file
			 line)))) (gethash TAG cache-hash))) tag-list)
	  (insert "

\n") (insert (funcall hfy-page-footer hfy-index-file)) (cd dstdir) (write-file index-file)) ) ) ) (defun htmlfontify-copy-and-link-dir (srcdir dstdir &optional f-ext l-ext) (let ((source-files "SETME: list of source files, relative to srcdir") (font-lock-support-mode 'fast-lock-mode) (hfy-extn (or f-ext ".html")) (hfy-link-extn (or l-ext ".html"))) (hfy-make-directory dstdir) (setq source-files (hfy-list-files srcdir)) (hfy-load-tags-cache srcdir) (mapcar (lambda (file) (hfy-copy-and-fontify-file srcdir dstdir file)) source-files) (hfy-write-index srcdir dstdir)) ) ;; ########################################################################## ;; this is for part of the build system for rtfm.etla.org: ;; it's not really part of htmlfontify - but it's an example ;; of how to use it: (defun rtfm-build-page-header (file) (format "#define TEMPLATE red+black.html #define DEBUG 1 #include html-css-url := /css/red+black.css title := rtfm.etla.org ( SQL / dbishell / src/%s ) bodytag := head := main-title := rtfm / SQL / dbishell / src/%s main-content <=MAIN_CONTENT;\n" file file)) (defun rtfm-build-page-footer (file) "\nMAIN_CONTENT\n") (defun rtfm-build-source-docs (srcdir destdir) (let ((hfy-page-header 'rtfm-build-page-header) (hfy-page-footer 'rtfm-build-page-footer) (hfy-index-file "index")) (htmlfontify-copy-and-link-dir srcdir destdir ".src" ".html"))) ;; TLF