diff --git a/ChangeLog b/ChangeLog index 3fb0476970d675280d434564e629a8efd8786ab9_Q2hhbmdlTG9n..65f6f065ed3fc08bb82f0f0127e3fb96b2d56178_Q2hhbmdlTG9n 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,19 @@ +1998-10-27 SL Baur <steve@altair.xemacs.org> + + * flyspell.el (flyspell-mode): Autoload. + Remove # in add-minor-mode call (it isn't needed). + Move add-minor-mode setup to end of file. + +1998-10-21 Greg Klanderman <greg@alphatech.com> + + * flyspell.el (flyspell-mode-map): add autoload cookie. + (top level): pass the function flyspell-mode as the fifth + argument to add-minor-mode, not the value of the variable. + +1998-10-21 Greg Klanderman <greg@alphatech.com> + + * flyspell.el: synch to author version 1.4d. + 1998-09-24 SL Baur <steve@altair.xemacs.org> * flyspell.el (flyspell-mode-line-string): New variable. diff --git a/Makefile b/Makefile index 3fb0476970d675280d434564e629a8efd8786ab9_TWFrZWZpbGU=..65f6f065ed3fc08bb82f0f0127e3fb96b2d56178_TWFrZWZpbGU= 100644 --- a/Makefile +++ b/Makefile @@ -19,7 +19,7 @@ # This XEmacs package contains independent single file lisp packages -VERSION = 1.13 +VERSION = 1.15 AUTHOR_VERSION = MAINTAINER = XEmacs Development Team <xemacs-beta@xemacs.org> PACKAGE = text-modes diff --git a/flyspell.el b/flyspell.el index 3fb0476970d675280d434564e629a8efd8786ab9_Zmx5c3BlbGwuZWw=..65f6f065ed3fc08bb82f0f0127e3fb96b2d56178_Zmx5c3BlbGwuZWw= 100644 --- a/flyspell.el +++ b/flyspell.el @@ -3,6 +3,7 @@ ;; Copyright (C) 1998 Free Software Foundation, Inc. ;; Author: Manuel Serrano <Manuel.Serrano@unice.fr> +;; Version: 1.4d + 2 XEmacs bugfixes ;; Keywords: convenience ;;; This file is part of GNU Emacs. @@ -241,4 +242,5 @@ ;*---------------------------------------------------------------------*/ ;* The minor mode declaration. */ ;*---------------------------------------------------------------------*/ +;;;###autoload (defvar flyspell-mode nil) @@ -244,3 +246,4 @@ (defvar flyspell-mode nil) +;;;###autoload (make-variable-buffer-local 'flyspell-mode) @@ -245,5 +248,7 @@ (make-variable-buffer-local 'flyspell-mode) +;;; XEmacs change: add autoload for flyspell-mode-map +;;;###autoload (defvar flyspell-mode-map (make-sparse-keymap)) (defvar flyspell-mouse-map (make-sparse-keymap)) @@ -247,23 +252,6 @@ (defvar flyspell-mode-map (make-sparse-keymap)) (defvar flyspell-mouse-map (make-sparse-keymap)) -;;;###autoload -(if (fboundp 'add-minor-mode) - (add-minor-mode 'flyspell-mode - flyspell-mode-line-string - flyspell-mode-map - nil - flyspell-mode) - (or (assoc 'flyspell-mode minor-mode-alist) - (setq minor-mode-alist - (cons '(flyspell-mode flyspell-mode-line-string) - minor-mode-alist))) - - (or (assoc 'flyspell-mode minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'flyspell-mode flyspell-mode-map) - minor-mode-map-alist)))) - (define-key flyspell-mode-map "\M-\t" 'flyspell-auto-correct-word) ;; mouse bindings @@ -642,6 +630,8 @@ The answer depends of several criteria. Mostly we check word delimiters." (cond + ((not (numberp flyspell-pre-point)) + t) ((and (>= flyspell-pre-point start) (<= flyspell-pre-point stop)) nil) ((let ((pos (point))) @@ -718,7 +708,10 @@ (progn (setq flyspell-pre-pre-buffer nil) (setq flyspell-pre-pre-point nil) - (setq flyspell-word-cache-end -1))) + ;; when a word is not checked because of a delayed command + ;; we do not disable the ispell cache. + (if (and (symbolp this-command) (get this-command 'flyspell-delayed)) + (setq flyspell-word-cache-end -1)))) (while (consp flyspell-changes) (let ((start (car (car flyspell-changes))) (stop (cdr (car flyspell-changes)))) @@ -737,8 +730,9 @@ (if (interactive-p) (setq following ispell-following-word)) (save-excursion - (flyspell-accept-buffer-local-defs) ; use the correct dictionary - (let ((cursor-location (point)) ; retain cursor location + ;; use the correct dictionary + (flyspell-accept-buffer-local-defs) + (let ((cursor-location (point)) (word (flyspell-get-word following 'full-tex)) start end poss) (if (or (eq word nil) @@ -752,7 +746,9 @@ word (car word)) ;; before checking in the directory, we check for doublons. (cond - ((and flyspell-mark-duplications-flag + ((and (or (not (eq ispell-parser 'tex)) + (not (eq (char-after start) ?\\))) + flyspell-mark-duplications-flag (save-excursion (goto-char start) (word-search-backward word @@ -766,6 +762,13 @@ (string-equal flyspell-word-cache-word word)) ;; this word had been already checked, we skip nil) + ((and (eq ispell-parser 'tex) + (flyspell-tex-command-p word)) + ;; this is a correct word (because a tex command) + (flyspell-unhighlight-at start) + (if (> end start) + (flyspell-unhighlight-at (- end 1))) + t) (t ;; we setup the cache (setq flyspell-word-cache-start start) @@ -804,8 +807,7 @@ ((null poss) (flyspell-unhighlight-at start) (if (> end start) - (flyspell-unhighlight-at (- end 1))) - (message "Error in ispell process")) + (flyspell-unhighlight-at (- end 1)))) ((or (and (< flyspell-duplicate-distance 0) (or (save-excursion (goto-char start) @@ -840,7 +842,8 @@ (if flyspell-highlight-flag (flyspell-highlight-incorrect-region start end) (message (format "mispelling `%s'" word))))) - (goto-char cursor-location) ; return to original location + ;; return to original location + (goto-char cursor-location) (if ispell-quit (setq ispell-quit nil))))))))) ;*---------------------------------------------------------------------*/ @@ -844,6 +847,13 @@ (if ispell-quit (setq ispell-quit nil))))))))) ;*---------------------------------------------------------------------*/ +;* flyspell-tex-command-p ... */ +;*---------------------------------------------------------------------*/ +(defun flyspell-tex-command-p (word) + "Return t if WORD is a TeX command." + (eq (aref word 0) ?\\)) + +;*---------------------------------------------------------------------*/ ;* flyspell-casechars-cache ... */ ;*---------------------------------------------------------------------*/ (defvar flyspell-casechars-cache nil) @@ -1465,5 +1475,15 @@ ispell-dictionary)) menu)))) -(provide 'flyspell) +;;;###autoload +(if (fboundp 'add-minor-mode) + (add-minor-mode 'flyspell-mode + flyspell-mode-line-string + flyspell-mode-map + nil + 'flyspell-mode) + (or (assoc 'flyspell-mode minor-mode-alist) + (setq minor-mode-alist + (cons '(flyspell-mode flyspell-mode-line-string) + minor-mode-alist))) @@ -1469,2 +1489,8 @@ + (or (assoc 'flyspell-mode minor-mode-map-alist) + (setq minor-mode-map-alist + (cons (cons 'flyspell-mode flyspell-mode-map) + minor-mode-map-alist)))) + +(provide 'flyspell) ;;; flyspell.el ends here diff --git a/htmlize.el b/htmlize.el new file mode 100644 index 0000000000000000000000000000000000000000..65f6f065ed3fc08bb82f0f0127e3fb96b2d56178_aHRtbGl6ZS5lbA== --- /dev/null +++ b/htmlize.el @@ -0,0 +1,592 @@ +;; htmlize.el -- HTML-ize font-lock buffers + +;; Copyright (C) 1997,1998 Free Software Foundation + +;; Author: Hrvoje Niksic <hniksic@srce.hr> +;; Keywords: hypermedia, extensions + +;; This file is not yet part of any Emacs, but it may be distributed +;; under the XEmacs distribution terms: + +;; XEmacs 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 2, or (at your option) +;; any later version. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: not in FSF + +;;; Commentary: + +;; This package will allow you to HTML-ize your font-lock buffers, +;; analyzing the text properties and transforming them to HTML. Mail +;; to <hniksic@srce.hr> to discuss features and additions. All +;; suggestions are more than welcome. + +;; To use, just switch to a buffer you want HTML-ized, and type `M-x +;; htmlize-buffer'. After that, you should find yourself in an HTML +;; buffer, which you can save. + +;; The code attempts to generate compliant HTML, but I can't make any +;; guarantees; I haven't yet bothered to run the generated markup +;; through a validator. I tried to make the package elisp-compatible +;; with multiple Emacsen, specifically aiming for XEmacs 19.14+ and +;; GNU Emacs 19.34+. Please let me know if it doesn't, and I'll try +;; to fix it. I relied heavily on the presence of CL extensions, +;; especially for compatibility; please don't try to remove that +;; dependency. + +;; When compiling under GNU Emacs, you'll likely to get oodles of +;; warnings; ignore them all. For any of this to work, you need to +;; run Emacs under a window-system -- anything else will almost +;; certainly fail. + +;; Thanks go to: Ron Gut <rgut@aware.com> for useful additions that I +;; incorporated; to Bob Weiner <weiner@altrasoft.com> for neat ideas +;; (use of rgb.txt and caching face colors); to Toni Drabik +;; <tdrabik@public.srce.hr> for a crash course to CSS1. + +;; TODO: Should attempt to merge faces (utilize CSS for this?). +;; Should recognize all extents under XEmacs, not just text +;; properties. Should recognize overlays under FSF Emacs. Should +;; ignore invisible text. Should expand TABs. + +;; User quotes: "You sir, are a sick, sick, _sick_ person. :)" +;; -- Bill Perry, author of Emacs/W3 + + +;;; Code: + +(require 'cl) +(eval-when-compile + (if (string-match "XEmacs" emacs-version) + (byte-compiler-options + (warnings (- unresolved))))) + +(defconst htmlize-version "0.33") + +;; BLOB to make custom stuff work even without customize +(eval-and-compile + (condition-case () + (require 'custom) + (error nil)) + (if (and (featurep 'custom) (fboundp 'custom-declare-variable)) + nil ;; We've got what we needed + ;; We have the old custom-library, hack around it! + (defmacro defgroup (&rest args) + nil) + (defmacro defcustom (var value doc &rest args) + (` (defvar (, var) (, value) (, doc)))))) + +(defgroup htmlize nil + "HTMLize font-locked buffers." + :group 'hypermedia) + +(defcustom htmlize-head-tags "" + "*Additional tags to insert within HEAD of the generated document." + :type 'string + :group 'htmlize) + +(defcustom htmlize-output-type 'css + "*Output type of generated HTML. Legal values are `css' and `font'. +When set to `css' (the default), htmlize will generate a style sheet +with description of faces, and use it in the HTML document, specifying +the faces in the actual text with <span>. + +When set to `font', the properties will be set using layout tags +<font>, <b>, <i>, <u>, and <strike>." + :type '(choice (const css) (const font)) + :group 'htmlize) + +(defcustom htmlize-use-rgb-map t + "*Controls when `rgb.txt' should be looked up for color values. + +When set to t (the default), htmlize will, when running under an X +display, look for the `rgb.txt' file and use it to obtain the RGB +values for named colors. This is useful when the values reported by +`color-instance-rgb-components'/`x-color-values' are incorrect because +of color approximation. + +When set to nil, htmlize will never look for `rgb.txt' and will always +use the values Emacs returns. + +When set to `force', htmlize will try to look for `rgb.txt' even on +non-X devices." + :type '(choice (const :tag "When Appropriate" t) + (const :tag "Never" nil) + (const :tag "Always" force)) + :group 'htmlize) + +(defvar htmlize-before-hook nil + "Hook run before htmlizing a buffer. +The hook is run in the original buffer (not HTML buffer), so you may +wish to add `font-lock-fontify-buffer' here.") + +(defvar htmlize-after-hook nil + "Hook run after htmlizing a buffer. +Unlike `htmlize-before-hook', these functions are run in the HTML +buffer. You may use them to modify the outlook of the final HTML +output.") + +;; I try to conditionalize on features rather than Emacs version, but +;; in some cases checking against the version *is* necessary. +(defconst htmlize-running-xemacs (string-match "XEmacs" emacs-version)) + + +;;; Protection of HTML strings. + +(defvar htmlize-character-table + (let ((table (make-vector 256 ?\0))) + (dotimes (i 256) + (setf (aref table i) (char-to-string i))) + (setf (aref table ?&) "&" + (aref table ?<) "<" + (aref table ?>) ">" + (aref table ?\") """) + table)) + +(defun htmlize-protect-string (string) + ;; Checking whether STRING contains dangerous stuff removes a lot of + ;; unnecessary consing. + (if (not (string-match "[&<>\"]" string)) + string + (mapconcat (lambda (char) + (aref htmlize-character-table char)) + string ""))) + +;; Currently unused. +;(defun htmlize-protect-region (start end) +; (goto-char start) +; (let (match replacement) +; (while (re-search-forward "[&<>\"]" end t) +; (setq match (char-after (1- (point))) +; replacement (aref htmlize-character-table match)) +; (delete-region (1- (point)) (point)) +; (insert replacement) +; (incf end (1- (length replacement))))) +; (goto-char end)) + +;;; Color handling. + +(if (fboundp 'locate-file) + (defalias 'htmlize-locate-file 'locate-file) + (defun htmlize-locate-file (file path) + (dolist (dir path nil) + (when (file-exists-p (expand-file-name file dir)) + (return (expand-file-name file dir)))))) + +(unless (fboundp 'with-current-buffer) + (defmacro with-current-buffer (buffer &rest forms) + `(save-excursion (set-buffer ,buffer) ,@forms))) +(unless (fboundp 'with-temp-buffer) + (defmacro with-temp-buffer (&rest forms) + (let ((temp-buffer (make-symbol "temp-buffer"))) + `(let ((,temp-buffer + (get-buffer-create (generate-new-buffer-name " *temp*")))) + (unwind-protect + (with-current-buffer ,temp-buffer + ,@forms) + (and (buffer-name ,temp-buffer) + (kill-buffer ,temp-buffer))))))) + +(defvar htmlize-x-library-search-path + '("/usr/X11R6/lib/X11/" + "/usr/X11R5/lib/X11/" + "/usr/lib/X11R6/X11/" + "/usr/lib/X11R5/X11/" + "/usr/local/X11R6/lib/X11/" + "/usr/local/X11R5/lib/X11/" + "/usr/local/lib/X11R6/X11/" + "/usr/local/lib/X11R5/X11/" + "/usr/X11/lib/X11/" + "/usr/lib/X11/" + "/usr/local/lib/X11/" + "/usr/X386/lib/X11/" + "/usr/x386/lib/X11/" + "/usr/XFree86/lib/X11/" + "/usr/unsupported/lib/X11/" + "/usr/athena/lib/X11/" + "/usr/local/x11r5/lib/X11/" + "/usr/lpp/Xamples/lib/X11/" + "/usr/openwin/lib/X11/" + "/usr/openwin/share/lib/X11/")) + +(defun htmlize-get-color-rgb-hash (&optional rgb-file) + "Return a hash table mapping X color names to RGB values. +The keys to the hash table are X color names as strings, and the +values are the #rrggbb RGB specifications, extracted from `rgb.txt'. + +If RGB-FILE is nil, the function will try hard to find a suitable file +in the system directories." + (let ((rgb-file (or rgb-file (htmlize-locate-file + "rgb.txt" + htmlize-x-library-search-path))) + (hash (make-hash-table :test 'equal))) + (with-temp-buffer + (insert-file-contents rgb-file) + (while (not (eobp)) + (cond ((looking-at "^!") + ;; Skip comments + ) + ((looking-at "[ \t]*\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\(.*\\)") + (setf (gethash (downcase (match-string 4)) hash) + (format "#%02x%02x%02x" + (string-to-number (match-string 1)) + (string-to-number (match-string 2)) + (string-to-number (match-string 3))))) + (t + (error "Unrecognized line in rgb.txt: %s" + (buffer-substring (point) (progn (end-of-line) (point)))))) + (forward-line 1))) + hash)) + +(defvar htmlize-color-rgb-hash nil) +(and (or (eq htmlize-use-rgb-map 'force) + (and (eq htmlize-use-rgb-map t) + (eq window-system 'x))) + (null htmlize-color-rgb-hash) + (setq htmlize-color-rgb-hash (htmlize-get-color-rgb-hash))) + +;;; Face handling + +;; (htmlize-face-foreground FACE) should return the foreground color +;; of the face, either as color name string or as #rrggbb string. +(cond ((fboundp 'face-foreground-name) + ;; New XEmacs + (defalias 'htmlize-face-foreground 'face-foreground-name) + (defalias 'htmlize-face-background 'face-background-name)) + ((fboundp 'color-instance-name) + ;; XEmacs before 20.4, hopefully + (defun htmlize-face-foreground (face) + (color-instance-name (face-foreground-instance face))) + (defun htmlize-face-background (face) + (color-instance-name (face-background-instance face)))) + ((fboundp 'x-color-values) + ;; FSF Emacs + (defun htmlize-face-foreground (face) + (or (face-foreground face) + (face-foreground 'default) + ;; Totally bogus, but in my FSFmacs, (face-foreground + ;; 'default) simply returns nil. Is it a bug? Is there + ;; a way around it? + "black")) + (defun htmlize-face-background (face) + (or (face-background face) + (face-background 'default) + "white"))) + (t + (error "WTF?!"))) + +(if (fboundp 'find-face) + (defalias 'htmlize-symbol-face-p 'find-face) + (defalias 'htmlize-symbol-face-p 'facep)) + +;; Return the #rrggbb string for foreground color of FACE. If BG-P is +;; non-nil, background color is used. +(defun htmlize-face-rgb-string-direct (face &optional bg-p) + (apply #'format "#%02x%02x%02x" + (if (fboundp 'color-instance-rgb-components) + (mapcar (lambda (arg) + (/ arg 256)) + (color-instance-rgb-components + (if bg-p + (face-background-instance face) + (face-foreground-instance face)))) + (mapcar (lambda (arg) + (/ arg 256)) + (x-color-values (if bg-p (htmlize-face-background face) + (htmlize-face-foreground face))))))) + +(defun htmlize-face-rgb-string (face &optional bg-p) + (if (and htmlize-use-rgb-map + htmlize-color-rgb-hash) + (let* ((oname (downcase (if bg-p (htmlize-face-background face) + (htmlize-face-foreground face)))) + (name (if (string-match "^#" oname) + oname + (gethash oname htmlize-color-rgb-hash)))) + (unless name + (error "Something is rotten (face %s, color %s)" face oname)) + name) + (htmlize-face-rgb-string-direct face bg-p))) + +(defstruct htmlize-face + rgb-foreground ; foreground color, #rrggbb + rgb-background ; background color, #rrggbb + boldp ; whether face is bold + italicp ; whether face is italic + underlinep ; whether face is underlined + strikep ; whether face is strikethrough + css-name ; CSS name of face + ) +(defvar htmlize-face-hash (make-hash-table :type 'eq)) + +(defun htmlize-make-face-hash (faces) + (clrhash htmlize-face-hash) + (let (face-fancy-names b-font i-font bi-font use-bi use-i) + (when htmlize-running-xemacs + (setq b-font (face-font-name 'bold) + i-font (face-font-name 'italic) + bi-font (face-font-name 'bold-italic) + use-bi (not (or (equal b-font bi-font) (equal i-font bi-font))) + use-i (not (equal b-font i-font)))) + (dolist (face faces) + (let ((object (make-htmlize-face + :rgb-foreground (htmlize-face-rgb-string face) + :rgb-background (htmlize-face-rgb-string face t) + :underlinep (face-underline-p face)))) + ;; Portability junk -- there is no good way of detecting + ;; whether a face is bold or italic under XEmacs, so I need to + ;; resort to disgusting hacks. Please close your eyes lest + ;; you vomit or spontaneously combust. + (if htmlize-running-xemacs + (let* ((font (face-font-name face))) + ;; Boldness, XEmacs + (setf (htmlize-face-boldp object) + (or (equal font (face-font-name 'bold)) + (and use-bi + (equal font (face-font-name 'bold-italic))))) + ;; Italic-ness, XEmacs + (setf (htmlize-face-italicp object) + (and use-i + (or (equal font (face-font-name 'italic)) + (and use-bi + (equal font (face-font-name 'bold-italic)))))) + ;; OK, you may open them again. + ;; Strikethrough, XEmacs + (setf (htmlize-face-strikep object) (face-strikethru-p face))) + (setf + ;; Boldness, GNU Emacs + (htmlize-face-boldp object) (face-bold-p face) + ;; Italic-ness, GNU Emacs + (htmlize-face-italicp object) (face-italic-p face) + ;; Strikethrough is not supported by GNU Emacs. + (htmlize-face-strikep object) nil)) + + ;; css-name. Emacs is lenient about face names -- virtually + ;; any string may name a face, even those consisting of + ;; characters such as ^@. We try hard to beat the face name + ;; into shape, both esthetically and according to CSS1 specs. + (setf (htmlize-face-css-name object) + (let ((name (downcase (symbol-name face)))) + (when (string-match "\\`font-lock-" name) + (setq name (replace-match "" t t name))) + (when (string-match "-face\\'" name) + (setq name (replace-match "" t t name))) + (while (string-match "[^-a-zA-Z0-9]" name) + (setq name (replace-match "X" t t name))) + (when (string-match "^[-0-9]" name) + (setq name (concat "X" name))) + (let ((i 1)) + (while (member name face-fancy-names) + (setq name (format "%s-%d" name i)) + (incf i))) + (push name face-fancy-names) + name)) + ;; Hash it away. + (setf (gethash face htmlize-face-hash) object))))) + +(defun htmlize-faces-in-buffer () + "Return a list of faces used by the extents in the current buffer." + (let (faces) + (if (fboundp 'map-extents) + (map-extents (lambda (extent ignored) + (let ((face (extent-face extent))) + (when (consp face) + (setq face (car face))) + (when (htmlize-symbol-face-p face) + (pushnew face faces))) + nil) + nil nil nil nil nil 'face) + (save-excursion + (goto-char (point-min)) + (let (face next) + (while (not (eobp)) + (setq face (get-text-property (point) 'face) + next (or (next-single-property-change (point) 'face) + (point-max))) + (when (consp face) + (setq face (car face))) + (when (htmlize-symbol-face-p face) + (pushnew face faces)) + (goto-char next))) + (setq faces (delq nil faces)))) + (delq 'default faces))) + +;;; CSS1 support + +(defun htmlize-css-doctype () + nil ; no doc-string + "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0//EN\">") + +;; Internal function; not a method. +(defun htmlize-css-specs (face-object &optional default-face-object) + (let (result) + (when (or (not default-face-object) + (not (equal (htmlize-face-rgb-foreground face-object) + (htmlize-face-rgb-foreground default-face-object)))) + (push (format "color: %s;" (htmlize-face-rgb-foreground face-object)) + result)) + (when (or (not default-face-object) + (not (equal (htmlize-face-rgb-background face-object) + (htmlize-face-rgb-background default-face-object)))) + (push (format "background-color: %s;" + (htmlize-face-rgb-background face-object)) result)) + (when (and (htmlize-face-boldp face-object) + (or (not default-face-object) + (not (htmlize-face-boldp default-face-object)))) + (push "font-weight: bold;" result)) + (when (and (htmlize-face-italicp face-object) + (or (not default-face-object) + (not (htmlize-face-italicp default-face-object)))) + (push "font-style: italic;" result)) + (when (and (htmlize-face-underlinep face-object) + (or (not default-face-object) + (not (htmlize-face-underlinep default-face-object)))) + (push "text-decoration: underline;" result)) + (when (and (htmlize-face-strikep face-object) + (or (not default-face-object) + (not (htmlize-face-strikep default-face-object)))) + (push "text-decoration: line-through;" result)) + (nreverse result))) + +(defun htmlize-css-insert-head () + (insert " <style type=\"text/css\">\n <!--\n") + (let ((default-face-object (gethash 'default htmlize-face-hash))) + (insert " BODY {\n " + (mapconcat #'identity (htmlize-css-specs default-face-object) + "\n ") + "\n } /* default */\n") + (maphash + (lambda (face face-object) + (let ((cleaned-up-face-name (symbol-name face))) + ;; If face name contains `--' or `*/', we must nix them out. + (while (string-match "--" cleaned-up-face-name) + (setq cleaned-up-face-name (replace-match "-" t t + cleaned-up-face-name))) + (while (string-match "*/" cleaned-up-face-name) + (setq cleaned-up-face-name (replace-match "XX" t t + cleaned-up-face-name))) + (unless (eq face 'default) + (let ((specs (htmlize-css-specs face-object default-face-object))) + (insert " span." (htmlize-face-css-name face-object)) + (if (null specs) + (insert " {") + (insert " {\n " + (mapconcat #'identity specs "\n "))) + (insert "\n } /* " cleaned-up-face-name " */\n"))))) + htmlize-face-hash)) + (insert " -->\n </style>\n")) + +(defun htmlize-css-face-prejunk (face-object) + (concat "<span class=\"" (htmlize-face-css-name face-object) "\">")) +(defun htmlize-css-face-postjunk (face-object) + nil ; no doc-string + "</span>") + +;;; <font> support + +;; We use the HTML Pro DTD by default. Note that under W3-procured +;; DTD's it is illegal to specify <font> under <pre>. +(defun htmlize-font-doctype () + nil ; no doc-string + "<!DOCTYPE HTML PUBLIC \"+//Silmaril//DTD HTML Pro v0r11 19970101//EN\">") + +(defun htmlize-font-body-tag () + (let ((face-object (gethash 'default htmlize-face-hash))) + (format "<body text=\"%s\" bgcolor=\"%s\">" + (htmlize-face-rgb-foreground face-object) + (htmlize-face-rgb-background face-object)))) +(defun htmlize-font-face-prejunk (face-object) + (concat "<font color=\"" (htmlize-face-rgb-foreground face-object) "\">" + (and (htmlize-face-boldp face-object) "<b>") + (and (htmlize-face-italicp face-object) "<i>") + (and (htmlize-face-underlinep face-object) "<u>") + (and (htmlize-face-strikep face-object) "<strike>"))) +(defun htmlize-font-face-postjunk (face-object) + (concat (and (htmlize-face-strikep face-object) "</strike>") + (and (htmlize-face-underlinep face-object) "</u>") + (and (htmlize-face-italicp face-object) "</i>") + (and (htmlize-face-boldp face-object) "</b>") + "</font>")) + +(defmacro htmlize-method (method &rest args) + (let ((func (gensym "hm-"))) + `(let ((,func (intern (format "htmlize-%s-%s" htmlize-output-type ',method)))) + (and (fboundp ,func) + (funcall ,func ,@args))))) + +;; The one and only entry level function. + +;;;###autoload +(defun htmlize-buffer (&optional buffer) + "HTML-ize BUFFER." + (interactive) + (or buffer + (setq buffer (current-buffer))) + (save-excursion + (set-buffer buffer) + (run-hooks 'htmlize-before-hook) + (htmlize-make-face-hash (cons 'default (htmlize-faces-in-buffer)))) + (let* ((newbuf (generate-new-buffer "*html*")) + next-change face face-object) + (switch-to-buffer newbuf) + (buffer-disable-undo) + (insert (htmlize-method doctype) ?\n + (format "<!-- Created by htmlize-%s in %s mode. -->\n" + htmlize-version htmlize-output-type)) + (insert "<html>\n <head>\n <title>" + (htmlize-protect-string (if (stringp buffer) buffer + (buffer-name buffer))) + "</title>\n" htmlize-head-tags) + (htmlize-method insert-head) + (insert " </head>") + (insert "\n " + (or (htmlize-method body-tag) + "<body>") + "\n <pre>\n") + (with-current-buffer buffer + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (setq face (get-text-property (point) 'face) + next-change (or (next-single-property-change (point) 'face) + (point-max))) + (and (consp face) + ;; Choose the first face. + (setq face (car face))) + (and (eq face 'default) + (setq face nil)) + ;; FSF Emacs allows `face' property to contain arbitrary + ;; stuff. + (or (htmlize-symbol-face-p face) + (setq face nil)) + (when face + (setq face-object (gethash face htmlize-face-hash)) + (princ (htmlize-method face-prejunk face-object) newbuf)) + (princ (htmlize-protect-string + (buffer-substring-no-properties (point) next-change)) + newbuf) + (when face + (princ (htmlize-method face-postjunk face-object) newbuf)) + (goto-char next-change)))) + (insert "</pre>\n </body>\n</html>\n") + (goto-char (point-min)) + (run-hooks 'htmlize-after-hook) + (buffer-enable-undo) + ;; We won't be needing the stored data anymore, so allow next gc + ;; to free up the used conses. + (clrhash htmlize-face-hash))) + +(provide 'htmlize) + +;;; htmlize.el ends here