Anonymous avatar Anonymous committed c1fed8a Merge

fixup commit for tag 'sumo-current'

Comments (0)

Files changed (4)

lisp/custom-load.el

-;;; custom-load.el --- automatically extracted custom dependencies
-
-;;; Code:
-
-(autoload 'custom-add-loads "cus-load")
-
-(custom-add-loads 'url '("url-gw" "url-irc" "url-news" "url-vars" "url"))
-(custom-add-loads 'ssl '("ssl"))
-(custom-add-loads 'url-cookie '("url-cookie" "url-vars"))
-(custom-add-loads 'hypermedia '("url-vars" "w3-cus"))
-(custom-add-loads 'w3-advanced '("w3-cus"))
-(custom-add-loads 'w3-menus '("w3-cus" "w3-menu"))
-(custom-add-loads 'w3-java '("w3-java"))
-(custom-add-loads 'url-gateway '("url-gw"))
-(custom-add-loads 'socks '("socks"))
-(custom-add-loads 'w3-files '("w3-cus"))
-(custom-add-loads 'comm '("ssl"))
-(custom-add-loads 'url-cache '("url-cache" "url-vars"))
-(custom-add-loads 'w3-printing '("w3-cus"))
-(custom-add-loads 'w3-images '("w3-cus" "w3-display"))
-(custom-add-loads 'url-history '("url-vars"))
-(custom-add-loads 'url-hairy '("url-vars"))
-(custom-add-loads 'url-mime '("url-vars"))
-(custom-add-loads 'faces '("font"))
-(custom-add-loads 'processes '("socks"))
-(custom-add-loads 'w3-hooks '("w3-cus"))
-(custom-add-loads 'w3 '("url-vars" "w3-cus" "w3-java" "w3-script"))
-(custom-add-loads 'url-file '("url-cache" "url-vars"))
-(custom-add-loads 'url-news '("url-news"))
-(custom-add-loads 'w3-display '("w3-cus"))
-(custom-add-loads 'w3-parsing '("w3-cus"))
-(custom-add-loads 'i18n '("url-vars"))
-(custom-add-loads 'w3-scripting '("w3-script"))
-
-;;; custom-load.el ends here
+;;; font.el --- New font model
+;; Author: wmperry
+;; Created: 1999/04/29 15:46:58
+;; Version: 1.3
+;; Keywords: faces
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Copyright (c) 1995, 1996 by William M. Perry <wmperry@cs.indiana.edu>
+;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
+;;;
+;;; 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 2, 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; see the file COPYING.  If not, write to the
+;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;;; Boston, MA 02111-1307, USA.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The emacsen compatibility package - load it up before anything else
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(require 'cl)
+(require 'devices)
+
+;; Needed for XEmacs 19.13, noop on all others, since it is always loaded.
+(require 'disp-table)
+
+(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))))))
+
+(if (not (fboundp 'try-font-name))
+    (defun try-font-name (fontname &rest args)
+      (case window-system
+	((x win32 w32 pm) (car-safe (x-list-fonts fontname)))
+	(mswindows (car-safe (mswindows-list-fonts fontname)))
+	(otherwise nil))))
+
+(if (not (fboundp 'facep))
+    (defun facep (face)
+      "Return t if X is a face name or an internal face vector."
+      (declare (special global-face-data))
+      (if (not window-system)
+	  nil				; FIXME if FSF ever does TTY faces
+	(and (or (internal-facep face)
+		 (and (symbolp face) (assq face global-face-data)))
+	     t))))
+
+(if (not (fboundp 'set-face-property))
+    (defun set-face-property (face property value &optional locale
+				   tag-set how-to-add)
+      "Change a property of FACE."
+      (and (symbolp face)
+	   (put face property value))))
+
+(if (not (fboundp 'face-property))
+    (defun face-property (face property &optional locale tag-set exact-p)
+      "Return FACE's value of the given PROPERTY."
+      (and (symbolp face) (get face property))))
+
+(require 'disp-table)
+
+(if (not (fboundp '<<))   (fset '<< 'lsh))
+(if (not (fboundp '&))    (fset '& 'logand))
+(if (not (fboundp '|))    (fset '| 'logior))
+(if (not (fboundp '~))    (fset '~ 'lognot))
+(if (not (fboundp '>>))   (defun >> (value count) (<< value (- count))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Lots of variables / keywords for use later in the program
+;;; Not much should need to be modified
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defconst font-running-xemacs (string-match "XEmacs" (emacs-version))
+  "Whether we are running in XEmacs or not.")
+
+(defconst font-running-emacs-new-redisplay (and (fboundp 'set-face-attribute)
+						(fboundp 'set-face-background-pixmap))
+  "Whether we are running in Emacs with the new redisplay engine.")
+
+(defmacro define-font-keywords (&rest keys)
+  (`
+   (eval-and-compile
+     (let ((keywords (quote (, keys))))
+       (while keywords
+	 (or (boundp (car keywords))
+	     (set (car keywords) (car keywords)))
+	 (setq keywords (cdr keywords)))))))  
+
+(defconst font-window-system-mappings
+  '((x        . (x-font-create-name x-font-create-object))
+    (mswindows . (mswindows-font-create-name mswindows-font-create-object))
+    (win32    . (x-font-create-name x-font-create-object))
+    (w32      . (x-font-create-name x-font-create-object))
+    (pm       . (x-font-create-name x-font-create-object)) ; Change? FIXME
+    (tty      . (tty-font-create-plist tty-font-create-object)))
+  "An assoc list mapping device types to the function used to create
+a font name from a font structure.")
+
+(defconst ns-font-weight-mappings
+  '((:extra-light . "extralight")
+    (:light       . "light")
+    (:demi-light  . "demilight")
+    (:medium      . "medium")
+    (:normal      . "medium")
+    (:demi-bold   . "demibold")
+    (:bold        . "bold")
+    (:extra-bold  . "extrabold"))
+  "An assoc list mapping keywords to actual NeXTstep specific
+information to use")
+
+(defconst x-font-weight-mappings
+  '((:extra-light . "extralight")
+    (:light       . "light")
+    (:demi-light  . "demilight")
+    (:demi        . "demi")
+    (:book        . "book")
+    (:medium      . "medium")
+    (:normal      . "medium")
+    (:demi-bold   . "demibold")
+    (:bold        . "bold")
+    (:extra-bold  . "extrabold"))
+  "An assoc list mapping keywords to actual Xwindow specific strings
+for use in the 'weight' field of an X font string.")
+
+(defconst font-new-redisplay-weight-mappings
+  '((:extra-light . extra-light)
+    (:light       . light)
+    (:demi-light  . semi-light)
+    (:demi        . semi-light)
+    (:book        . normal)
+    (:medium      . normal)
+    (:normal      . normal)
+    (:demi-bold   . semi-bold)
+    (:bold        . bold)
+    (:extra-bold  . extra-bold))
+  "An assoc list mapping font weights to the actual symbols used by
+the new redisplay engine.")
+
+(defconst font-possible-weights
+  (mapcar 'car x-font-weight-mappings))
+
+(defvar font-rgb-file nil
+  "Where the RGB file was found.")
+
+(defvar font-maximum-slippage "1pt"
+  "How much a font is allowed to vary from the desired size.")
+
+(define-font-keywords :family :style :size :registry :encoding)
+
+(define-font-keywords
+  :weight :extra-light :light :demi-light :medium :normal :regular
+  :demi-bold :bold :extra-bold)
+
+(defvar font-style-keywords nil)
+
+(defsubst set-font-family (fontobj family)
+  (aset fontobj 1 family))
+
+(defsubst set-font-weight (fontobj weight)
+  (aset fontobj 3 weight))
+
+(defsubst set-font-style (fontobj style)
+  (aset fontobj 5 style))
+
+(defsubst set-font-size (fontobj size)
+  (aset fontobj 7 size))
+
+(defsubst set-font-registry (fontobj reg)
+  (aset fontobj 9 reg))
+
+(defsubst set-font-encoding (fontobj enc)
+  (aset fontobj 11 enc))
+
+(defsubst font-family (fontobj)
+  (aref fontobj 1))
+
+(defsubst font-weight (fontobj)
+  (aref fontobj 3))
+
+(defsubst font-style (fontobj)
+  (aref fontobj 5))
+
+(defsubst font-size (fontobj)
+  (aref fontobj 7))
+
+(defsubst font-registry (fontobj)
+  (aref fontobj 9))
+
+(defsubst font-encoding (fontobj)
+  (aref fontobj 11))
+
+(eval-when-compile
+  (defmacro define-new-mask (attr mask)
+    (`
+     (progn
+       (setq font-style-keywords
+	     (cons (cons (quote (, attr))
+			 (cons
+			  (quote (, (intern (format "set-font-%s-p" attr))))
+			  (quote (, (intern (format "font-%s-p" attr))))))
+		   font-style-keywords))
+       (defconst (, (intern (format "font-%s-mask" attr))) (<< 1 (, mask))
+	 (, (format
+	     "Bitmask for whether a font is to be rendered in %s or not."
+	     attr)))
+       (defun (, (intern (format "font-%s-p" attr))) (fontobj)
+	 (, (format "Whether FONTOBJ will be renderd in `%s' or not." attr))
+	 (if (/= 0 (& (font-style fontobj)
+		      (, (intern (format "font-%s-mask" attr)))))
+	     t
+	   nil))
+       (defun (, (intern (format "set-font-%s-p" attr))) (fontobj val)
+	 (, (format "Set whether FONTOBJ will be renderd in `%s' or not."
+		    attr))
+	 (cond
+	  (val
+	   (set-font-style fontobj (| (font-style fontobj)
+				      (, (intern
+					  (format "font-%s-mask" attr))))))
+	  (((, (intern (format "font-%s-p" attr))) fontobj)
+	   (set-font-style fontobj (- (font-style fontobj)
+				      (, (intern
+					  (format "font-%s-mask" attr))))))))
+       ))))
+
+(let ((mask 0))
+  (define-new-mask bold        (setq mask (1+ mask)))
+  (define-new-mask italic      (setq mask (1+ mask)))
+  (define-new-mask oblique     (setq mask (1+ mask)))
+  (define-new-mask dim         (setq mask (1+ mask)))
+  (define-new-mask underline   (setq mask (1+ mask)))
+  (define-new-mask overline    (setq mask (1+ mask)))
+  (define-new-mask linethrough (setq mask (1+ mask)))
+  (define-new-mask strikethru  (setq mask (1+ mask)))
+  (define-new-mask reverse     (setq mask (1+ mask)))
+  (define-new-mask blink       (setq mask (1+ mask)))
+  (define-new-mask smallcaps   (setq mask (1+ mask)))
+  (define-new-mask bigcaps     (setq mask (1+ mask)))
+  (define-new-mask dropcaps    (setq mask (1+ mask))))
+
+(defvar font-caps-display-table
+  (let ((table (make-display-table))
+	(i 0))
+    ;; Standard ASCII characters
+    (while (< i 26)
+      (aset table (+ i ?a) (+ i ?A))
+      (setq i (1+ i)))
+    ;; Now ISO translations
+    (setq i 224)
+    (while (< i 247)			;; Agrave - Ouml
+      (aset table i (- i 32))
+      (setq i (1+ i)))
+    (setq i 248)
+    (while (< i 255)			;; Oslash - Thorn
+      (aset table i (- i 32))
+      (setq i (1+ i)))
+    table))    
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Utility functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defsubst set-font-style-by-keywords (fontobj styles)
+  (make-local-variable 'font-func)
+  (declare (special font-func))
+  (if (listp styles)
+      (while styles
+	(setq font-func (car-safe (cdr-safe (assq (car styles) font-style-keywords)))
+	      styles (cdr styles))
+	(and (fboundp font-func) (funcall font-func fontobj t)))
+    (setq font-func (car-safe (cdr-safe (assq styles font-style-keywords))))
+    (and (fboundp font-func) (funcall font-func fontobj t))))
+
+(defsubst font-properties-from-style (fontobj)
+  (let ((todo font-style-keywords)
+	type func retval)
+    (while todo
+      (setq func (cdr (cdr (car todo)))
+	    type (car (pop todo)))
+      (if (funcall func fontobj)
+	  (setq retval (cons type retval))))
+    retval))
+
+(defun font-unique (list)
+  (let ((retval)
+	(cur))
+    (while list
+      (setq cur (car list)
+	    list (cdr list))
+      (if (member cur retval)
+	  nil
+	(setq retval (cons cur retval))))
+    (nreverse retval)))
+
+(defun font-higher-weight (w1 w2)
+  (let ((index1 (length (memq w1 font-possible-weights)))
+	(index2 (length (memq w2 font-possible-weights))))
+    (cond
+     ((<= index1 index2)
+      (or w1 w2))
+     ((not w2)
+      w1)
+     (t
+      w2))))
+
+(defun font-spatial-to-canonical (spec &optional device)
+  "Convert SPEC (in inches, millimeters, points, or picas) into points"
+  ;; 1 in = 6 pa = 25.4 mm = 72 pt
+  (cond
+   ((numberp spec)
+    spec)
+   ((null spec)
+    nil)
+   (t
+    (let ((num nil)
+	  (type nil)
+	  ;; If for any reason we get null for any of this, default
+	  ;; to 1024x768 resolution on a 17" screen
+	  (pix-width (float (or (device-pixel-width device) 1024)))
+	  (mm-width (float (or (device-mm-width device) 293)))
+	  (retval nil))
+      (cond
+       ((string-match "^ *\\([-+*/]\\) *" spec) ; math!  whee!
+	(let ((math-func (intern (match-string 1 spec)))
+	      (other (font-spatial-to-canonical
+		      (substring spec (match-end 0) nil)))
+	      (default (font-spatial-to-canonical
+			(font-default-size-for-device device))))
+	  (if (fboundp math-func)
+	      (setq type "px"
+		    spec (int-to-string (funcall math-func default other)))
+	    (setq type "px"
+		  spec (int-to-string other)))))
+       ((string-match "[^0-9.]+$" spec)
+	(setq type (substring spec (match-beginning 0))
+	      spec (substring spec 0 (match-beginning 0))))
+       (t
+	(setq type "px"
+	      spec spec)))
+      (setq num (string-to-number spec))
+      (cond
+       ((member type '("pixel" "px" "pix"))
+	(setq retval (* num (/ pix-width mm-width) (/ 25.4 72.0))))
+       ((member type '("point" "pt"))
+	(setq retval num))
+       ((member type '("pica" "pa"))
+	(setq retval (* num 12.0)))
+       ((member type '("inch" "in"))
+	(setq retval (* num 72.0)))
+       ((string= type "mm")
+	(setq retval (* num (/ 72.0 25.4))))
+       ((string= type "cm")
+	(setq retval (* num 10 (/ 72.0 25.4))))
+       (t
+	(setq retval num))
+       )
+      retval))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The main interface routines - constructors and accessor functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun make-font (&rest args)
+  (vector :family
+	  (if (stringp (plist-get args :family))
+	      (list (plist-get args :family))
+	    (plist-get args :family))
+	  :weight
+	  (plist-get args :weight)
+	  :style
+	  (if (numberp (plist-get args :style))
+	      (plist-get args :style)
+	    0)
+	  :size
+	  (plist-get args :size)
+	  :registry
+	  (plist-get args :registry)
+	  :encoding
+	  (plist-get args :encoding)))
+
+(defun font-create-name (fontobj &optional device)
+  (let* ((type (device-type device))
+	 (func (car (cdr-safe (assq type font-window-system-mappings)))))
+    (and func (fboundp func) (funcall func fontobj device))))
+
+;;;###autoload
+(defun font-create-object (fontname &optional device)
+  (let* ((type (device-type device))
+	 (func (car (cdr (cdr-safe (assq type font-window-system-mappings))))))
+    (and func (fboundp func) (funcall func fontname device))))
+
+(defun font-combine-fonts-internal (fontobj-1 fontobj-2)
+  (let ((retval (make-font))
+	(size-1 (and (font-size fontobj-1)
+		     (font-spatial-to-canonical (font-size fontobj-1))))
+	(size-2 (and (font-size fontobj-2)
+		     (font-spatial-to-canonical (font-size fontobj-2)))))
+    (set-font-weight retval (font-higher-weight (font-weight fontobj-1)
+						(font-weight fontobj-2)))
+    (set-font-family retval (font-unique (append (font-family fontobj-1)
+						 (font-family fontobj-2))))
+    (set-font-style retval (| (font-style fontobj-1) (font-style fontobj-2)))
+    (set-font-registry retval (or (font-registry fontobj-1)
+				  (font-registry fontobj-2)))
+    (set-font-encoding retval (or (font-encoding fontobj-1)
+				  (font-encoding fontobj-2)))
+    (set-font-size retval (cond
+			   ((and size-1 size-2 (>= size-2 size-1))
+			    (font-size fontobj-2))
+			   ((and size-1 size-2)
+			    (font-size fontobj-1))
+			   (size-1
+			    (font-size fontobj-1))
+			   (size-2
+			    (font-size fontobj-2))
+			   (t nil)))
+
+    retval))
+
+(defun font-combine-fonts (&rest args)
+  (cond
+   ((null args)
+    (error "Wrong number of arguments to font-combine-fonts"))
+   ((= (length args) 1)
+    (car args))
+   (t
+    (let ((retval (font-combine-fonts-internal (nth 0 args) (nth 1 args))))
+      (setq args (cdr (cdr args)))
+      (while args
+	(setq retval (font-combine-fonts-internal retval (car args))
+	      args (cdr args)))
+      retval))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The window-system dependent code (TTY-style)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun tty-font-create-object (fontname &optional device)
+  (make-font :size "12pt"))
+
+(defun tty-font-create-plist (fontobj &optional device)
+  (list
+   (cons 'underline (font-underline-p fontobj))
+   (cons 'highlight (if (or (font-bold-p fontobj)
+			    (memq (font-weight fontobj) '(:bold :demi-bold)))
+			t))
+   (cons 'dim       (font-dim-p fontobj))
+   (cons 'blinking  (font-blink-p fontobj))
+   (cons 'reverse   (font-reverse-p fontobj))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The window-system dependent code (X-style)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defvar font-x-font-regexp (or (and font-running-xemacs
+				    (boundp 'x-font-regexp)
+				    x-font-regexp)
+ (let
+     ((- 		"[-?]")
+      (foundry		"[^-]*")
+      (family 		"[^-]*")
+      ;(weight		"\\(bold\\|demibold\\|medium\\|black\\)")
+      (weight\?		"\\([^-]*\\)")
+      ;(slant		"\\([ior]\\)")
+      (slant\?		"\\([^-]?\\)")
+      (swidth		"\\([^-]*\\)")
+      (adstyle		"\\([^-]*\\)")
+      (pixelsize	"\\(\\*\\|[0-9]+\\)")
+      (pointsize	"\\(\\*\\|0\\|[0-9][0-9]+\\)")
+      (resx		"\\([*0]\\|[0-9][0-9]+\\)")
+      (resy		"\\([*0]\\|[0-9][0-9]+\\)")
+      (spacing		"[cmp?*]")
+      (avgwidth		"\\(\\*\\|[0-9]+\\)")
+      (registry		"[^-]*")
+      (encoding	"[^-]+")
+      )
+   (concat "\\`\\*?[-?*]"
+	   foundry - family - weight\? - slant\? - swidth - adstyle -
+	   pixelsize - pointsize - resx - resy - spacing - avgwidth -
+	   registry - encoding - "*" "\\'"
+	   ))))
+
+(defvar font-x-registry-and-encoding-regexp
+  (or (and font-running-xemacs
+	   (boundp 'x-font-regexp-registry-and-encoding)
+	   (symbol-value 'x-font-regexp-registry-and-encoding))
+      (let ((- "[-?]")
+	    (registry "[^-]*")
+	    (encoding "[^-]+"))
+	(concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'"))))
+
+(defvar font-x-family-mappings
+  '(
+    ("serif"        . ("new century schoolbook"
+ 		       "utopia"
+ 		       "charter"
+ 		       "times"
+ 		       "lucidabright"
+ 		       "garamond"
+ 		       "palatino"
+ 		       "times new roman"
+ 		       "baskerville"
+ 		       "bookman"
+ 		       "bodoni"
+ 		       "computer modern"
+ 		       "rockwell"
+ 		       ))
+    ("sans-serif"   . ("lucida"
+ 		       "helvetica"
+ 		       "gills-sans"
+ 		       "avant-garde"
+ 		       "univers"
+ 		       "optima"))
+    ("elfin"        . ("tymes"))
+    ("monospace"    . ("courier"
+ 		       "fixed"
+ 		       "lucidatypewriter"
+ 		       "clean"
+ 		       "terminal"))
+    ("cursive"      . ("sirene"
+ 		       "zapf chancery"))
+    )
+  "A list of font family mappings on X devices.")
+ 
+(defun x-font-create-object (fontname &optional device)
+  (let ((case-fold-search t))
+    (if (or (not (stringp fontname))
+	    (not (string-match font-x-font-regexp fontname)))
+	(make-font)
+      (let ((family nil)
+	    (size nil)
+	    (weight  (match-string 1 fontname))
+	    (slant   (match-string 2 fontname))
+	    (swidth  (match-string 3 fontname))
+	    (adstyle (match-string 4 fontname))
+	    (pxsize  (match-string 5 fontname))
+	    (ptsize  (match-string 6 fontname))
+	    (retval nil)
+	    (case-fold-search t)
+	    )
+	(if (not (string-match x-font-regexp-foundry-and-family fontname))
+	    nil
+	  (setq family (list (downcase (match-string 1 fontname)))))
+	(if (string= "*" weight)  (setq weight  nil))
+	(if (string= "*" slant)   (setq slant   nil))
+	(if (string= "*" swidth)  (setq swidth  nil))
+	(if (string= "*" adstyle) (setq adstyle nil))
+	(if (string= "*" pxsize)  (setq pxsize  nil))
+	(if (string= "*" ptsize)  (setq ptsize  nil))
+	(if ptsize (setq size (/ (string-to-int ptsize) 10)))
+	(if (and (not size) pxsize) (setq size (concat pxsize "px")))
+	(if weight (setq weight (intern-soft (concat ":" (downcase weight)))))
+	(if (and adstyle (not (equal adstyle "")))
+	    (setq family (append family (list (downcase adstyle)))))
+	(setq retval (make-font :family family
+				:weight weight
+				:size size))
+	(set-font-bold-p retval (eq :bold weight))
+	(cond
+	 ((null slant) nil)
+	 ((member slant '("i" "I"))
+	  (set-font-italic-p retval t))
+	 ((member slant '("o" "O"))
+	  (set-font-oblique-p retval t)))
+	(when (string-match font-x-registry-and-encoding-regexp fontname)
+	  (set-font-registry retval (match-string 1 fontname))
+	  (set-font-encoding retval (match-string 2 fontname)))
+	retval))))
+
+(defun x-font-families-for-device (&optional device no-resetp)
+  (ignore-errors (require 'x-font-menu))
+  (or device (setq device (selected-device)))
+  (if (boundp 'device-fonts-cache)
+      (let ((menu nil))
+	(declare (special device-fonts-cache))
+	(setq menu (cdr-safe (assq device device-fonts-cache)))
+	(if (and (not menu) (not no-resetp))
+	    (progn
+	      (reset-device-font-menus device)
+	      (x-font-families-for-device device t))
+	  (let ((scaled (mapcar (lambda (x) (if x (aref x 0)))
+				(aref menu 0)))
+		(normal (mapcar (lambda (x) (if x (aref x 0)))
+				(aref menu 1))))
+	    (sort (font-unique (nconc scaled normal)) 'string-lessp))))
+    (cons "monospace" (mapcar 'car font-x-family-mappings))))
+
+(defvar font-default-cache nil)
+
+;;;###autoload
+(defun font-default-font-for-device (&optional device)
+  (or device (setq device (selected-device)))
+  (if font-running-xemacs
+      (font-truename
+       (make-font-specifier
+	(face-font-name 'default device)))
+    (let ((font (cdr-safe (assq 'font (frame-parameters device)))))
+      (if (and (fboundp 'fontsetp) (fontsetp font))
+	  (aref (get-font-info (aref (cdr (get-fontset-info font)) 0)) 2)
+	font))))
+	  
+;;;###autoload
+(defun font-default-object-for-device (&optional device)
+  (let ((font (font-default-font-for-device device)))
+    (or (cdr-safe (assoc font font-default-cache))
+ 	(let ((object (font-create-object font)))
+ 	  (push (cons font object) font-default-cache)
+ 	  object))))
+
+;;;###autoload
+(defun font-default-family-for-device (&optional device)
+  (font-family (font-default-object-for-device device)))
+
+;;;###autoload
+(defun font-default-registry-for-device (&optional device)
+  (font-registry (font-default-object-for-device device)))
+
+;;;###autoload
+(defun font-default-encoding-for-device (&optional device)
+  (font-encoding (font-default-object-for-device device)))
+
+;;;###autoload
+(defun font-default-size-for-device (&optional device)
+  ;; face-height isn't the right thing (always 1 pixel too high?)
+  ;; (if font-running-xemacs
+  ;;    (format "%dpx" (face-height 'default device))
+  (font-size (font-default-object-for-device device)))
+
+(defun x-font-create-name (fontobj &optional device)
+  (if (and (not (or (font-family fontobj)
+		    (font-weight fontobj)
+		    (font-size fontobj)
+		    (font-registry fontobj)
+		    (font-encoding fontobj)))
+	   (= (font-style fontobj) 0))
+      (face-font 'default)
+    (or device (setq device (selected-device)))
+    (let* ((default (font-default-object-for-device device))
+	   (family (or (font-family fontobj)
+		       (font-family default)
+		       (x-font-families-for-device device)))
+	   (weight (or (font-weight fontobj) :medium))
+	   (size (or (if font-running-xemacs
+			 (font-size fontobj))
+		     (font-size default)))
+	   (registry (or (font-registry fontobj)
+			 (font-registry default)
+			 "*"))
+	   (encoding (or (font-encoding fontobj)
+			 (font-encoding default)
+			 "*")))
+      (if (stringp family)
+	  (setq family (list family)))
+      (setq weight (font-higher-weight weight
+				       (and (font-bold-p fontobj) :bold)))
+      (if (stringp size)
+	  (setq size (truncate (font-spatial-to-canonical size device))))
+      (setq weight (or (cdr-safe (assq weight x-font-weight-mappings)) "*"))
+      (let ((done nil)			; Did we find a good font yet?
+	    (font-name nil)		; font name we are currently checking
+	    (cur-family nil)		; current family we are checking
+	    )
+	(while (and family (not done))
+	  (setq cur-family (car family)
+		family (cdr family))
+	  (if (assoc cur-family font-x-family-mappings)
+	      ;; If the family name is an alias as defined by
+	      ;; font-x-family-mappings, then append those families
+	      ;; to the front of 'family' and continue in the loop.
+	      (setq family (append
+			    (cdr-safe (assoc cur-family
+					     font-x-family-mappings))
+			    family))
+	    ;; Not an alias for a list of fonts, so we just check it.
+	    ;; First, convert all '-' to spaces so that we don't screw up
+	    ;; the oh-so wonderful X font model.  Wheee.
+	    (let ((x (length cur-family)))
+	      (while (> x 0)
+		(if (= ?- (aref cur-family (1- x)))
+		    (aset cur-family (1- x) ? ))
+		(setq x (1- x))))
+	    ;; We treat oblique and italic as equivalent.  Don't ask.
+	    (let ((slants '("o" "i")))
+	      (while (and slants (not done))
+		(setq font-name (format "-*-%s-%s-%s-*-*-*-%s-*-*-*-*-%s-%s"
+					cur-family weight
+					(if (or (font-italic-p fontobj)
+						(font-oblique-p fontobj))
+					    (car slants)
+					  "r")
+					(if size
+					    (int-to-string (* 10 size)) "*")
+					registry
+					encoding
+					)
+		      slants (cdr slants)
+		      done (try-font-name font-name device))))))
+	(if done font-name)))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The window-system dependent code (mswindows-style)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; mswindows fonts look like:
+;;;	fontname[:[weight][ style][:pointsize[:effects]]][:charset]
+;;; A minimal mswindows font spec looks like:
+;;;	Courier New
+;;; A maximal mswindows font spec looks like:
+;;;	Courier New:Bold Italic:10:underline strikeout:western
+;;; Missing parts of the font spec should be filled in with these values:
+;;;	Courier New:Regular:10::western
+;;  "^[a-zA-Z ]+:[a-zA-Z ]*:[0-9]+:[a-zA-Z ]*:[a-zA-Z 0-9]*$"
+(defvar font-mswindows-font-regexp
+  (let
+      ((- 		":")
+       (fontname	"\\([a-zA-Z ]+\\)")
+       (weight		"\\([a-zA-Z]*\\)")
+       (style		"\\( [a-zA-Z]*\\)?")
+       (pointsize	"\\([0-9]+\\)")
+       (effects		"\\([a-zA-Z ]*\\)")
+       (charset		"\\([a-zA-Z 0-9]*\\)")
+       )
+    (concat "^"
+	    fontname - weight style - pointsize - effects - charset "$")))
+
+(defconst mswindows-font-weight-mappings
+  '((:extra-light . "Extralight")
+    (:light       . "Light")
+    (:demi-light  . "Demilight")
+    (:demi        . "Demi")
+    (:book        . "Book")
+    (:medium      . "Medium")
+    (:normal      . "Normal")
+    (:demi-bold   . "Demibold")
+    (:bold        . "Bold")
+    (:regular	  . "Regular")
+    (:extra-bold  . "Extrabold"))
+  "An assoc list mapping keywords to actual mswindows specific strings
+for use in the 'weight' field of an mswindows font string.")
+
+(defvar font-mswindows-family-mappings
+  '(
+    ("serif"        . ("times new roman"
+		       "century schoolbook"
+		       "book antiqua"
+		       "bookman old style"))
+    ("sans-serif"   . ("arial"
+		       "verdana"
+		       "lucida sans unicode"))
+    ("monospace"    . ("courier new"
+		       "lucida console"
+		       "courier"
+		       "terminal"))
+    ("cursive"      . ("roman"
+		       "script"))
+    )
+  "A list of font family mappings on mswindows devices.")
+
+(defun mswindows-font-create-object (fontname &optional device)
+  (let ((case-fold-search t)
+	(font (mswindows-font-canonicalize-name fontname)))
+    (if (or (not (stringp font))
+	    (not (string-match font-mswindows-font-regexp font)))
+	(make-font)
+      (let ((family	(match-string 1 font))
+	    (weight	(match-string 2 font))
+	    (style	(match-string 3 font))
+	    (pointsize	(match-string 4 font))
+	    (effects	(match-string 5 font))
+	    (charset	(match-string 6 font))
+	    (retval nil)
+	    (size nil)
+	    (case-fold-search t)
+	    )
+	(if pointsize (setq size (concat pointsize "pt")))
+	(if weight (setq weight (intern-soft (concat ":" (downcase weight)))))
+	(setq retval (make-font :family family
+				:weight weight
+				:size size
+				:encoding charset))
+	(set-font-bold-p retval (eq :bold weight))
+	(cond
+	 ((null style) nil)
+	 ((string-match "^ *[iI]talic" style)
+	  (set-font-italic-p retval t)))
+	(cond
+	 ((null effects) nil)
+	 ((string-match "^[uU]nderline [sS]trikeout" effects)
+	  (set-font-underline-p retval t)
+	  (set-font-strikethru-p retval t))
+	 ((string-match "[uU]nderline" effects)
+	  (set-font-underline-p retval t))
+	 ((string-match "[sS]trikeout" effects)
+	  (set-font-strikethru-p retval t)))
+	retval))))
+
+(defun mswindows-font-create-name (fontobj &optional device)
+  (if (and (not (or (font-family fontobj)
+		    (font-weight fontobj)
+		    (font-size fontobj)
+		    (font-registry fontobj)
+		    (font-encoding fontobj)))
+	   (= (font-style fontobj) 0))
+      (face-font 'default)
+    (or device (setq device (selected-device)))
+    (let* ((default (font-default-object-for-device device))
+	   (family (or (font-family fontobj)
+		       (font-family default)))
+	   (weight (or (font-weight fontobj) :regular))
+	   (size (or (if font-running-xemacs
+			 (font-size fontobj))
+		     (font-size default)))
+	   (underline-p (font-underline-p fontobj))
+	   (strikeout-p (font-strikethru-p fontobj))
+	   (encoding (or (font-encoding fontobj)
+			 (font-encoding default))))
+      (if (stringp family)
+	  (setq family (list family)))
+      (setq weight (font-higher-weight weight
+				       (and (font-bold-p fontobj) :bold)))
+      (if (stringp size)
+	  (setq size (truncate (font-spatial-to-canonical size device))))
+      (setq weight (or (cdr-safe
+			(assq weight mswindows-font-weight-mappings)) ""))
+      (let ((done nil)			; Did we find a good font yet?
+	    (font-name nil)		; font name we are currently checking
+	    (cur-family nil)		; current family we are checking
+	    )
+	(while (and family (not done))
+	  (setq cur-family (car family)
+		family (cdr family))
+	  (if (assoc cur-family font-mswindows-family-mappings)
+	      ;; If the family name is an alias as defined by
+	      ;; font-mswindows-family-mappings, then append those families
+	      ;; to the front of 'family' and continue in the loop.
+	      (setq family (append
+			    (cdr-safe (assoc cur-family
+					     font-mswindows-family-mappings))
+			    family))
+	    ;; We treat oblique and italic as equivalent.  Don't ask.
+            ;; Courier New:Bold Italic:10:underline strikeout:western
+	    (setq font-name (format "%s:%s%s:%s:%s:%s"
+				    cur-family weight
+				    (if (font-italic-p fontobj)
+					" Italic" "")
+				    (if size
+					(int-to-string size) "10")
+				    (if underline-p
+					(if strikeout-p
+					    "underline strikeout"
+					  "underline")
+				      (if strikeout-p "strikeout" ""))
+				    (if encoding
+					encoding ""))
+		  done (try-font-name font-name device))))
+	(if done font-name)))))
+
+
+;;; Cache building code
+;;;###autoload
+(defun x-font-build-cache (&optional device)
+  (let ((hash-table (make-hash-table :test 'equal :size 15))
+	(fonts (mapcar 'x-font-create-object
+		       (list-fonts "-*-*-*-*-*-*-*-*-*-*-*-*-*-*")))
+	(plist nil)
+	(cur nil))
+    (while fonts
+      (setq cur (car fonts)
+	    fonts (cdr fonts)
+	    plist (cl-gethash (car (font-family cur)) hash-table))
+      (if (not (memq (font-weight cur) (plist-get plist 'weights)))
+	  (setq plist (plist-put plist 'weights (cons (font-weight cur)
+						      (plist-get plist 'weights)))))
+      (if (not (member (font-size cur) (plist-get plist 'sizes)))
+	  (setq plist (plist-put plist 'sizes (cons (font-size cur)
+						    (plist-get plist 'sizes)))))
+      (if (and (font-oblique-p cur)
+	       (not (memq 'oblique (plist-get plist 'styles))))
+	  (setq plist (plist-put plist 'styles (cons 'oblique (plist-get plist 'styles)))))
+      (if (and (font-italic-p cur)
+	       (not (memq 'italic (plist-get plist 'styles))))
+	  (setq plist (plist-put plist 'styles (cons 'italic (plist-get plist 'styles)))))
+      (cl-puthash (car (font-family cur)) plist hash-table))
+    hash-table))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Now overwrite the original copy of set-face-font with our own copy that
+;;; can deal with either syntax.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;###autoload
+(defun font-set-face-font (&optional face font &rest args)
+  (cond
+   ((and (vectorp font) (= (length font) 12))
+    (let ((font-name (font-create-name font)))
+      (set-face-property face 'font-specification font)
+      (cond
+       ((null font-name)		; No matching font!
+	nil)
+       ((listp font-name)		; For TTYs
+	(let (cur)
+	  (while font-name
+	    (setq cur (car font-name)
+		  font-name (cdr font-name))
+	    (apply 'set-face-property face (car cur) (cdr cur) args))))
+       (font-running-xemacs
+	(apply 'set-face-font face font-name args)
+	(apply 'set-face-underline-p face (font-underline-p font) args)
+	(if (and (or (font-smallcaps-p font) (font-bigcaps-p font))
+		 (fboundp 'set-face-display-table))
+	    (apply 'set-face-display-table
+		   face font-caps-display-table args))
+	(apply 'set-face-property face 'strikethru (or
+						    (font-linethrough-p font)
+						    (font-strikethru-p font))
+	       args))
+       (t
+	(condition-case nil
+	    (apply 'set-face-font face font-name args)
+	  (error
+	   (let ((args (car-safe args)))
+	     (and (or (font-bold-p font)
+		      (memq (font-weight font) '(:bold :demi-bold)))
+		  (make-face-bold face args t))
+	     (and (font-italic-p font) (make-face-italic face args t)))))
+	(apply 'set-face-underline-p face (font-underline-p font) args)))))
+   (t
+    ;; Let the original set-face-font signal any errors
+    (set-face-property face 'font-specification nil)
+    (apply 'set-face-font face font args))))
+
+(defun font-find-available-family (fontobj &optional device)
+  (let* ((default (font-default-object-for-device device))
+	 (family (or (font-family fontobj)
+		     (font-family default)
+		     (x-font-families-for-device device)))
+	 (cur-family nil)
+	 (font-name nil)
+	 (done nil))
+    (if (stringp family)
+	(setq family (list family)))
+    (while (and family (not done))
+      (setq cur-family (pop family))
+      (if (assoc cur-family font-x-family-mappings)
+	  ;; If the family name is an alias as defined by
+	  ;; font-x-family-mappings, then append those families to the
+	  ;; front fo 'family' and continue in the loop.
+	  (setq family (append (cdr-safe
+				(assoc cur-family font-x-family-mappings))
+			       family))
+	;; Not an alias for a list of fonts, so we just check it.
+	;; First, convert all '-' to spaces so that we don't screw up
+	;; the oh-so wonderful X font model.  Wheee.
+	(let ((x (length cur-family)))
+	  (while (> x 0)
+	    (if (= ?- (aref cur-family (1- x)))
+		(aset cur-family (1- x) ? ))
+	    (setq x (1- x))))
+	(setq font-name (format "-*-%s-*-*-*-*-*-*-*-*-*-*-*-*" cur-family)
+	      done (try-font-name font-name device))))
+    (and done cur-family)))
+
+(defun font-set-face-font-new-redisplay (&optional face font &rest args)
+  (cond
+   ((and (vectorp font) (= (length font) 12))
+    (set-face-property face 'font-specification font)
+    (set-face-attribute face nil
+			:underline (font-underline-p font)
+			:weight (or (cdr-safe (assoc (font-weight font)
+						     font-new-redisplay-weight-mappings))
+				    'normal)
+			:family (font-find-available-family font))
+    (if (font-size font)
+	(set-face-attribute face nil
+			    :height (* 10 (font-spatial-to-canonical (font-size font))))))
+   (t
+    (set-face-property face 'font-specification nil)
+    (apply 'set-face-font face font args))))
+
+(if font-running-emacs-new-redisplay
+    (fset 'font-set-face-font 'font-set-face-font-new-redisplay))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Now for emacsen specific stuff
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun font-update-device-fonts (device)
+  ;; Update all faces that were created with the 'font' package
+  ;; to appear correctly on the new device.  This should be in the
+  ;; create-device-hook.  This is XEmacs 19.12+ specific
+  (let ((faces (face-list 2))
+	(cur nil)
+	(font-spec nil))
+    (while faces
+      (setq cur (car faces)
+	    faces (cdr faces)
+	    font-spec (face-property cur 'font-specification))
+      (if font-spec
+	  (set-face-font cur font-spec device)))))
+
+(defun font-update-one-face (face &optional device-list)
+  ;; Update FACE on all devices in DEVICE-LIST
+  ;; DEVICE_LIST defaults to a list of all active devices
+  (setq device-list (or device-list (device-list)))
+  (if (devicep device-list)
+      (setq device-list (list device-list)))
+  (let* ((cur-device nil)
+	 (font-spec (face-property face 'font-specification)))
+    (if (not font-spec)
+	;; Hey!  Don't mess with fonts we didn't create in the
+	;; first place.
+	nil
+      (while device-list
+	(setq cur-device (car device-list)
+	      device-list (cdr device-list))
+	(if (not (device-live-p cur-device))
+	    ;; Whoah!
+	    nil
+	  (if font-spec
+	      (set-face-font face font-spec cur-device)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Various color related things
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(cond
+ ((fboundp 'display-warning)
+  (fset 'font-warn 'display-warning))
+ ((fboundp 'w3-warn)
+  (fset 'font-warn 'w3-warn))
+ ((fboundp 'url-warn)
+  (fset 'font-warn 'url-warn))
+ ((fboundp 'warn)
+  (defun font-warn (class message &optional level)
+    (warn "(%s/%s) %s" class (or level 'warning) message)))
+ (t
+  (defun font-warn (class message &optional level)
+    (save-excursion
+      (set-buffer (get-buffer-create "*W3-WARNINGS*"))
+      (goto-char (point-max))
+      (save-excursion
+	(insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
+      (display-buffer (current-buffer))))))
+
+(defun font-lookup-rgb-components (color)
+  "Lookup COLOR (a color name) in rgb.txt and return a list of RGB values.
+The list (R G B) is returned, or an error is signaled if the lookup fails."
+  (let ((lib-list (if (boundp 'x-library-search-path)
+		      x-library-search-path
+		    ;; This default is from XEmacs 19.13 - hope it covers
+		    ;; everyone.
+		    (list "/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/")))
+	(file font-rgb-file)
+	r g b)
+    (if (not file)
+	(while lib-list
+	  (setq file (expand-file-name "rgb.txt" (car lib-list)))
+	  (if (file-readable-p file)
+	      (setq lib-list nil
+		    font-rgb-file file)
+	    (setq lib-list (cdr lib-list)
+		  file nil))))
+    (if (null file)
+	(list 0 0 0)
+      (save-excursion
+	(set-buffer (find-file-noselect file))
+	(if (not (= (aref (buffer-name) 0) ? ))
+	    (rename-buffer (generate-new-buffer-name " *rgb-tmp-buffer*")))
+	(save-excursion
+	  (save-restriction
+	    (widen)
+	    (goto-char (point-min))
+	    (if (re-search-forward (format "\t%s$" (regexp-quote color)) nil t)
+		(progn
+		  (beginning-of-line)
+		  (setq r (* (read (current-buffer)) 256)
+			g (* (read (current-buffer)) 256)
+			b (* (read (current-buffer)) 256)))
+	      (font-warn 'color (format "No such color: %s" color))
+	      (setq r 0
+		    g 0
+		    b 0))
+	    (list r g b) ))))))
+
+(defun font-hex-string-to-number (string)
+  "Convert STRING to an integer by parsing it as a hexadecimal number."
+  (let ((conv-list '((?0 . 0) (?a . 10) (?A . 10)
+		     (?1 . 1) (?b . 11) (?B . 11)
+		     (?2 . 2) (?c . 12) (?C . 12)
+		     (?3 . 3) (?d . 13) (?D . 13)
+		     (?4 . 4) (?e . 14) (?E . 14)
+		     (?5 . 5) (?f . 15) (?F . 15)
+		     (?6 . 6) 
+		     (?7 . 7)
+		     (?8 . 8)
+		     (?9 . 9)))
+	(n 0)
+	(i 0)
+	(lim (length string)))
+    (while (< i lim)
+      (setq n (+ (* n 16) (or (cdr (assq (aref string i) conv-list)) 0))
+	    i (1+ i)))
+    n ))
+
+(defun font-parse-rgb-components (color)
+  "Parse RGB color specification and return a list of integers (R G B).
+#FEFEFE and rgb:fe/fe/fe style specifications are parsed."
+  (let ((case-fold-search t)
+	r g b str)
+  (cond ((string-match "^#[0-9a-f]+$" color)
+	 (cond
+	  ((= (length color) 4)
+	   (setq r (font-hex-string-to-number (substring color 1 2))
+		 g (font-hex-string-to-number (substring color 2 3))
+		 b (font-hex-string-to-number (substring color 3 4))
+		 r (* r 4096)
+		 g (* g 4096)
+		 b (* b 4096)))
+	  ((= (length color) 7)
+	   (setq r (font-hex-string-to-number (substring color 1 3))
+		 g (font-hex-string-to-number (substring color 3 5))
+		 b (font-hex-string-to-number (substring color 5 7))
+		 r (* r 256)
+		 g (* g 256)
+		 b (* b 256)))
+	  ((= (length color) 10)
+	   (setq r (font-hex-string-to-number (substring color 1 4))
+		 g (font-hex-string-to-number (substring color 4 7))
+		 b (font-hex-string-to-number (substring color 7 10))
+		 r (* r 16)
+		 g (* g 16)
+		 b (* b 16)))
+	  ((= (length color) 13)
+	   (setq r (font-hex-string-to-number (substring color 1 5))
+		 g (font-hex-string-to-number (substring color 5 9))
+		 b (font-hex-string-to-number (substring color 9 13))))
+	  (t
+	   (font-warn 'color (format "Invalid RGB color specification: %s"
+				     color))
+	   (setq r 0
+		 g 0
+		 b 0))))
+	((string-match "rgb:\\([0-9a-f]+\\)/\\([0-9a-f]+\\)/\\([0-9a-f]+\\)"
+		       color)
+	 (if (or (> (- (match-end 1) (match-beginning 1)) 4)
+		 (> (- (match-end 2) (match-beginning 2)) 4)
+		 (> (- (match-end 3) (match-beginning 3)) 4))
+	     (error "Invalid RGB color specification: %s" color)
+	   (setq str (match-string 1 color)
+		 r (* (font-hex-string-to-number str)
+		      (expt 16 (- 4 (length str))))
+		 str (match-string 2 color)
+		 g (* (font-hex-string-to-number str)
+		      (expt 16 (- 4 (length str))))
+		 str (match-string 3 color)
+		 b (* (font-hex-string-to-number str)
+		      (expt 16 (- 4 (length str)))))))
+	(t
+	 (font-warn 'html (format "Invalid RGB color specification: %s"
+				color))
+	 (setq r 0
+	       g 0
+	       b 0)))
+  (list r g b) ))
+
+(defsubst font-rgb-color-p (obj)
+  (or (and (vectorp obj)
+	   (= (length obj) 4)
+	   (eq (aref obj 0) 'rgb))))
+
+(defsubst font-rgb-color-red (obj) (aref obj 1))
+(defsubst font-rgb-color-green (obj) (aref obj 2))
+(defsubst font-rgb-color-blue (obj) (aref obj 3))
+
+(defun font-color-rgb-components (color)
+  "Return the RGB components of COLOR as a list of integers (R G B).
+16-bit values are always returned.
+#FEFEFE and rgb:fe/fe/fe style color specifications are parsed directly
+into their components.
+RGB values for color names are looked up in the rgb.txt file.
+The variable x-library-search-path is use to locate the rgb.txt file."
+  (let ((case-fold-search t))
+    (cond
+     ((and (font-rgb-color-p color) (floatp (aref color 1)))
+      (list (* 65535 (aref color 0))
+ 	    (* 65535 (aref color 1))
+ 	    (* 65535 (aref color 2))))
+     ((font-rgb-color-p color)
+      (list (font-rgb-color-red color)
+	    (font-rgb-color-green color)
+	    (font-rgb-color-blue color)))
+     ((and (vectorp color) (= 3 (length color)))
+      (list (aref color 0) (aref color 1) (aref color 2)))
+     ((and (listp color) (= 3 (length color)) (floatp (car color)))
+      (mapcar (lambda (x) (* x 65535)) color))
+     ((and (listp color) (= 3 (length color)))
+      color)
+     ((or (string-match "^#" color)
+	  (string-match "^rgb:" color))
+      (font-parse-rgb-components color))
+     ((string-match "\\([0-9.]+\\)[ \t]\\([0-9.]+\\)[ \t]\\([0-9.]+\\)"
+		    color)
+      (let ((r (string-to-number (match-string 1 color)))
+	    (g (string-to-number (match-string 2 color)))
+	    (b (string-to-number (match-string 3 color))))
+	(if (floatp r)
+	    (setq r (round (* 255 r))
+		  g (round (* 255 g))
+		  b (round (* 255 b))))
+	(font-parse-rgb-components (format "#%02x%02x%02x" r g b))))
+     (t
+      (font-lookup-rgb-components color)))))
+
+(defsubst font-tty-compute-color-delta (col1 col2)
+  (+ 
+   (* (- (aref col1 0) (aref col2 0))
+      (- (aref col1 0) (aref col2 0)))
+   (* (- (aref col1 1) (aref col2 1))
+      (- (aref col1 1) (aref col2 1)))
+   (* (- (aref col1 2) (aref col2 2))
+      (- (aref col1 2) (aref col2 2)))))
+
+(defun font-tty-find-closest-color (r g b)
+  ;; This is basically just a lisp copy of allocate_nearest_color
+  ;; from objects-x.c from Emacs 19
+  ;; We really should just check tty-color-list, but unfortunately
+  ;; that does not include any RGB information at all.
+  ;; So for now we just hardwire in the default list and call it
+  ;; good for now.
+  (setq r (/ r 65535.0)
+	g (/ g 65535.0)
+	b (/ b 65535.0))
+  (let* ((color_def (vector r g b))
+	 (colors [([1.0 1.0 1.0] . "white")
+		  ([0.0 1.0 1.0] . "cyan")
+		  ([1.0 0.0 1.0] . "magenta")
+		  ([0.0 0.0 1.0] . "blue")
+		  ([1.0 1.0 0.0] . "yellow")
+		  ([0.0 1.0 0.0] . "green")
+		  ([1.0 0.0 0.0] . "red")
+		  ([0.0 0.0 0.0] . "black")])
+	 (no_cells (length colors))
+	 (x 1)
+	 (nearest 0)
+	 (nearest_delta 0)
+	 (trial_delta 0))
+    (setq nearest_delta (font-tty-compute-color-delta (car (aref colors 0))
+						      color_def))
+    (while (/= no_cells x)
+      (setq trial_delta (font-tty-compute-color-delta (car (aref colors x))
+						      color_def))
+      (if (< trial_delta nearest_delta)
+	  (setq nearest x
+		nearest_delta trial_delta))
+      (setq x (1+ x)))
+    (cdr-safe (aref colors nearest))))
+
+(defun font-normalize-color (color &optional device)
+  "Return an RGB tuple, given any form of input.  If an error occurs, black
+is returned."
+  (case (device-type device)
+   ((x pm)
+    (apply 'format "#%02x%02x%02x" (font-color-rgb-components color)))
+   (win32
+    (let* ((rgb (font-color-rgb-components color))
+	   (color (apply 'format "#%02x%02x%02x" rgb)))
+      (win32-define-rgb-color (nth 0 rgb) (nth 1 rgb) (nth 2 rgb) color)
+      color))
+   (w32
+    (let* ((rgb (font-color-rgb-components color))
+	   (color (apply 'format "#%02x%02x%02x" rgb)))
+      (w32-define-rgb-color (nth 0 rgb) (nth 1 rgb) (nth 2 rgb) color)
+      color))
+   (mswindows
+    (let* ((rgb (font-color-rgb-components color))
+	   (color (apply 'format "#%02x%02x%02x" rgb)))
+      (mswindows-define-rgb-color (nth 0 rgb) (nth 1 rgb) (nth 2 rgb) color)
+      color))
+   (tty
+    (apply 'font-tty-find-closest-color (font-color-rgb-components color)))
+   (ns
+    (let ((vals (mapcar (lambda (x) (>> x 8))
+			(font-color-rgb-components color))))
+      (apply 'format "RGB%02x%02x%02xff" vals)))
+   (otherwise
+    color)))
+
+(defun font-set-face-background (&optional face color &rest args)
+  (interactive)
+  (condition-case nil
+      (cond
+       ((or (font-rgb-color-p color)
+	    (string-match "^#[0-9a-fA-F]+$" color))
+	(apply 'set-face-background face
+	       (font-normalize-color color) args))
+       (t
+	(apply 'set-face-background face color args)))
+    (error nil)))
+
+(defun font-set-face-foreground (&optional face color &rest args)
+  (interactive)
+  (condition-case nil
+      (cond
+       ((or (font-rgb-color-p color)
+	    (string-match "^#[0-9a-fA-F]+$" color))
+	(apply 'set-face-foreground face (font-normalize-color color) args))
+       (t
+	(apply 'set-face-foreground face color args)))
+    (error nil)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for 'blinking' fonts
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun font-map-windows (func &optional arg frame)
+  (let* ((start (selected-window))
+	 (cur start)
+	 (result nil))
+    (push (funcall func start arg) result)
+    (while (not (eq start (setq cur (next-window cur))))
+      (push (funcall func cur arg) result))
+    result))
+
+(defun font-face-visible-in-window-p (window face)
+  (let ((st (window-start window))
+	(nd (window-end window))
+	(found nil)
+	(face-at nil))
+    (setq face-at (get-text-property st 'face (window-buffer window)))
+    (if (or (eq face face-at) (and (listp face-at) (memq face face-at)))
+	(setq found t))
+    (while (and (not found)
+		(/= nd
+		    (setq st (next-single-property-change
+			      st 'face
+			      (window-buffer window) nd))))
+      (setq face-at (get-text-property st 'face (window-buffer window)))
+      (if (or (eq face face-at) (and (listp face-at) (memq face face-at)))
+	  (setq found t)))
+    found))
+  
+(defun font-blink-callback ()
+  ;; Optimized to never invert the face unless one of the visible windows
+  ;; is showing it.
+  (let ((faces (if font-running-xemacs (face-list t) (face-list)))
+	(obj nil))
+    (while faces
+      (if (and (setq obj (face-property (car faces) 'font-specification))
+	       (font-blink-p obj)
+	       (memq t
+		     (font-map-windows 'font-face-visible-in-window-p (car faces))))
+	  (invert-face (car faces)))
+      (pop faces))))
+
+(defcustom font-blink-interval 0.5
+  "How often to blink faces"
+  :type 'number
+  :group 'faces)
+  
+(defun font-blink-initialize ()
+  (cond
+   ((featurep 'itimer)
+    (if (get-itimer "font-blinker")
+	(delete-itimer (get-itimer "font-blinker")))
+    (start-itimer "font-blinker" 'font-blink-callback
+		  font-blink-interval
+		  font-blink-interval))
+   ((fboundp 'run-at-time)
+    (cancel-function-timers 'font-blink-callback)    
+    (run-at-time font-blink-interval
+		 font-blink-interval
+		 'font-blink-callback))
+   (t nil)))
+  
+(provide 'font)
+;;; md5.el -- MD5 Message Digest Algorithm
+;;; Gareth Rees <gdr11@cl.cam.ac.uk>
+
+;; LCD Archive Entry:
+;; md5|Gareth Rees|gdr11@cl.cam.ac.uk|
+;; MD5 cryptographic message digest algorithm|
+;; 13-Nov-95|1.0|~/misc/md5.el.Z|
+
+;;; Details: ------------------------------------------------------------------
+
+;; This is a direct translation into Emacs LISP of the reference C
+;; implementation of the MD5 Message-Digest Algorithm written by RSA
+;; Data Security, Inc.
+;; 
+;; The algorithm takes a message (that is, a string of bytes) and
+;; computes a 16-byte checksum or "digest" for the message.  This digest
+;; is supposed to be cryptographically strong in the sense that if you
+;; are given a 16-byte digest D, then there is no easier way to
+;; construct a message whose digest is D than to exhaustively search the
+;; space of messages.  However, the robustness of the algorithm has not
+;; been proven, and a similar algorithm (MD4) was shown to be unsound,
+;; so treat with caution!
+;; 
+;; The C algorithm uses 32-bit integers; because GNU Emacs
+;; implementations provide 28-bit integers (with 24-bit integers on
+;; versions prior to 19.29), the code represents a 32-bit integer as the
+;; cons of two 16-bit integers.  The most significant word is stored in
+;; the car and the least significant in the cdr.  The algorithm requires
+;; at least 17 bits of integer representation in order to represent the
+;; carry from a 16-bit addition.
+
+;;; Usage: --------------------------------------------------------------------
+
+;; To compute the MD5 Message Digest for a message M (represented as a
+;; string or as a vector of bytes), call
+;; 
+;;   (md5-encode M)
+;; 
+;; which returns the message digest as a vector of 16 bytes.  If you
+;; need to supply the message in pieces M1, M2, ... Mn, then call
+;; 
+;;   (md5-init)
+;;   (md5-update M1)
+;;   (md5-update M2)
+;;   ...
+;;   (md5-update Mn)
+;;   (md5-final)
+
+;;; Copyright and licence: ----------------------------------------------------
+
+;; Copyright (C) 1995, 1996, 1997 by Gareth Rees
+;; Derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm
+;; 
+;; md5.el 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.
+;; 
+;; md5.el 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.
+;; 
+;; The original copyright notice is given below, as required by the
+;; licence for the original code.  This code is distributed under *both*
+;; RSA's original licence and the GNU General Public Licence.  (There
+;; should be no problems, as the former is more liberal than the
+;; latter).
+
+;;; Original copyright notice: ------------------------------------------------
+
+;; Copyright (C) 1990, RSA Data Security, Inc. All rights reserved.
+;;
+;; License to copy and use this software is granted provided that it is
+;; identified as the "RSA Data Security, Inc. MD5 Message- Digest
+;; Algorithm" in all material mentioning or referencing this software or
+;; this function.
+;;
+;; License is also granted to make and use derivative works provided
+;; that such works are identified as "derived from the RSA Data
+;; Security, Inc. MD5 Message-Digest Algorithm" in all material
+;; mentioning or referencing the derived work.
+;;
+;; RSA Data Security, Inc. makes no representations concerning either
+;; the merchantability of this software or the suitability of this
+;; software for any particular purpose.  It is provided "as is" without
+;; express or implied warranty of any kind.
+;;
+;; These notices must be retained in any copies of any part of this
+;; documentation and/or software.
+
+;;; Code: ---------------------------------------------------------------------
+
+(defvar md5-program "md5"
+  "*Program that reads a message on its standard input and writes an
+MD5 digest on its output.")
+
+(defvar md5-maximum-internal-length 4096
+  "*The maximum size of a piece of data that should use the MD5 routines
+written in lisp.  If a message exceeds this, it will be run through an
+external filter for processing.  Also see the `md5-program' variable.
+This variable has no effect if you call the md5-init|update|final
+functions - only used by the `md5' function's simpler interface.")
+
+(defvar md5-bits (make-vector 4 0)
+  "Number of bits handled, modulo 2^64.
+Represented as four 16-bit numbers, least significant first.")
+(defvar md5-buffer (make-vector 4 '(0 . 0))
+  "Scratch buffer (four 32-bit integers).")
+(defvar md5-input (make-vector 64 0)
+  "Input buffer (64 bytes).")
+
+(defun md5-unhex (x)
+  (if (> x ?9)
+      (if (>= x ?a)
+	  (+ 10 (- x ?a))
+	(+ 10 (- x ?A)))
+    (- x ?0)))
+
+(defun md5-encode (message)
+  "Encodes MESSAGE using the MD5 message digest algorithm.
+MESSAGE must be a string or an array of bytes.
+Returns a vector of 16 bytes containing the message digest."
+  (if (<= (length message) md5-maximum-internal-length)
+      (progn
+	(md5-init)
+	(md5-update message)
+	(md5-final))
+    (save-excursion
+      (set-buffer (get-buffer-create " *md5-work*"))
+      (erase-buffer)
+      (insert message)
+      (call-process-region (point-min) (point-max)
+			   md5-program
+			   t (current-buffer))
+      ;; MD5 digest is 32 chars long
+      ;; mddriver adds a newline to make neaten output for tty
+      ;; viewing, make sure we leave it behind.
+      (let ((data (buffer-substring (point-min) (+ (point-min) 32)))
+	    (vec (make-vector 16 0))
+	    (ctr 0))
+	(while (< ctr 16)
+	  (aset vec ctr (+ (* 16 (md5-unhex (aref data (* ctr 2))))
+			   (md5-unhex (aref data (1+ (* ctr 2))))))
+	  (setq ctr (1+ ctr)))))))
+
+(defsubst md5-add (x y)
+  "Return 32-bit sum of 32-bit integers X and Y."
+  (let ((m (+ (car x) (car y)))
+        (l (+ (cdr x) (cdr y))))
+    (cons (logand 65535 (+ m (lsh l -16))) (logand l 65535))))
+
+;; FF, GG, HH and II are basic MD5 functions, providing transformations
+;; for rounds 1, 2, 3 and 4 respectively.  Each function follows this
+;; pattern of computation (where ROTATE(x,y) means rotate 32-bit value x
+;; by y bits to the left):
+;; 
+;;   FF(a,b,c,d,x,s,ac) = ROTATE(a + F(b,c,d) + x + ac,s) + b
+;; 
+;; so we use the macro `md5-make-step' to construct each one.  The
+;; helper functions F, G, H and I operate on 16-bit numbers; the full
+;; operation splits its inputs, operates on the halves separately and
+;; then puts the results together.
+
+(defsubst md5-F (x y z) (logior (logand x y) (logand (lognot x) z)))
+(defsubst md5-G (x y z) (logior (logand x z) (logand y (lognot z))))
+(defsubst md5-H (x y z) (logxor x y z))
+(defsubst md5-I (x y z) (logxor y (logior x (logand 65535 (lognot z)))))
+
+(defmacro md5-make-step (name func)
+  (`
+   (defun (, name) (a b c d x s ac)
+     (let*
+         ((m1 (+ (car a) ((, func) (car b) (car c) (car d)) (car x) (car ac)))
+          (l1 (+ (cdr a) ((, func) (cdr b) (cdr c) (cdr d)) (cdr x) (cdr ac)))
+          (m2 (logand 65535 (+ m1 (lsh l1 -16))))
+          (l2 (logand 65535 l1))
+          (m3 (logand 65535 (if (> s 15)
+                                (+ (lsh m2 (- s 32)) (lsh l2 (- s 16)))
+                              (+ (lsh m2 s) (lsh l2 (- s 16))))))
+          (l3 (logand 65535 (if (> s 15)
+                                (+ (lsh l2 (- s 32)) (lsh m2 (- s 16)))
+                              (+ (lsh l2 s) (lsh m2 (- s 16)))))))
+       (md5-add (cons m3 l3) b)))))
+
+(md5-make-step md5-FF md5-F)
+(md5-make-step md5-GG md5-G)
+(md5-make-step md5-HH md5-H)
+(md5-make-step md5-II md5-I)
+
+(defun md5-init ()
+  "Initialise the state of the message-digest routines."
+  (aset md5-bits 0 0)
+  (aset md5-bits 1 0)
+  (aset md5-bits 2 0)
+  (aset md5-bits 3 0)
+  (aset md5-buffer 0 '(26437 .  8961))
+  (aset md5-buffer 1 '(61389 . 43913))
+  (aset md5-buffer 2 '(39098 . 56574))
+  (aset md5-buffer 3 '( 4146 . 21622)))
+
+(defun md5-update (string)
+  "Update the current MD5 state with STRING (an array of bytes)."
+  (let ((len (length string))
+        (i 0)
+        (j 0))
+    (while (< i len)
+      ;; Compute number of bytes modulo 64
+      (setq j (% (/ (aref md5-bits 0) 8) 64))
+
+      ;; Store this byte (truncating to 8 bits to be sure)
+      (aset md5-input j (logand 255 (aref string i)))
+
+      ;; Update number of bits by 8 (modulo 2^64)
+      (let ((c 8) (k 0))
+        (while (and (> c 0) (< k 4))
+          (let ((b (aref md5-bits k)))
+            (aset md5-bits k (logand 65535 (+ b c)))
+            (setq c (if (> b (- 65535 c)) 1 0)
+                  k (1+ k)))))
+
+      ;; Increment number of bytes processed
+      (setq i (1+ i))
+
+      ;; When 64 bytes accumulated, pack them into sixteen 32-bit
+      ;; integers in the array `in' and then transform them.
+      (if (= j 63)
+          (let ((in (make-vector 16 (cons 0 0)))
+                (k 0)
+                (kk 0))
+            (while (< k 16)
+              (aset in k (md5-pack md5-input kk))
+              (setq k (+ k 1) kk (+ kk 4)))
+            (md5-transform in))))))
+
+(defun md5-pack (array i)
+  "Pack the four bytes at ARRAY reference I to I+3 into a 32-bit integer."
+  (cons (+ (lsh (aref array (+ i 3)) 8) (aref array (+ i 2)))
+        (+ (lsh (aref array (+ i 1)) 8) (aref array (+ i 0)))))
+
+(defun md5-byte (array n b)
+  "Unpack byte B (0 to 3) from Nth member of ARRAY of 32-bit integers."
+  (let ((e (aref array n)))
+    (cond ((eq b 0) (logand 255 (cdr e)))
+          ((eq b 1) (lsh (cdr e) -8))
+          ((eq b 2) (logand 255 (car e)))
+          ((eq b 3) (lsh (car e) -8)))))
+
+(defun md5-final ()
+  (let ((in (make-vector 16 (cons 0 0)))
+        (j 0)
+        (digest (make-vector 16 0))
+        (padding))
+
+    ;; Save the number of bits in the message
+    (aset in 14 (cons (aref md5-bits 1) (aref md5-bits 0)))
+    (aset in 15 (cons (aref md5-bits 3) (aref md5-bits 2)))
+
+    ;; Compute number of bytes modulo 64
+    (setq j (% (/ (aref md5-bits 0) 8) 64))
+
+    ;; Pad out computation to 56 bytes modulo 64
+    (setq padding (make-vector (if (< j 56) (- 56 j) (- 120 j)) 0))
+    (aset padding 0 128)
+    (md5-update padding)
+
+    ;; Append length in bits and transform
+    (let ((k 0) (kk 0))
+      (while (< k 14)
+        (aset in k (md5-pack md5-input kk))
+        (setq k (+ k 1) kk (+ kk 4))))
+    (md5-transform in)
+
+    ;; Store the results in the digest
+    (let ((k 0) (kk 0))
+      (while (< k 4)
+        (aset digest (+ kk 0) (md5-byte md5-buffer k 0))
+        (aset digest (+ kk 1) (md5-byte md5-buffer k 1))
+        (aset digest (+ kk 2) (md5-byte md5-buffer k 2))
+        (aset digest (+ kk 3) (md5-byte md5-buffer k 3))
+        (setq k (+ k 1) kk (+ kk 4))))
+
+    ;; Return digest
+    digest))
+
+;; It says in the RSA source, "Note that if the Mysterious Constants are
+;; arranged backwards in little-endian order and decrypted with the DES
+;; they produce OCCULT MESSAGES!"  Security through obscurity?
+
+(defun md5-transform (in)
+  "Basic MD5 step. Transform md5-buffer based on array IN."
+  (let ((a (aref md5-buffer 0))
+        (b (aref md5-buffer 1))
+        (c (aref md5-buffer 2))
+        (d (aref md5-buffer 3)))
+    (setq
+     a (md5-FF a b c d (aref in  0)  7 '(55146 . 42104))
+     d (md5-FF d a b c (aref in  1) 12 '(59591 . 46934))
+     c (md5-FF c d a b (aref in  2) 17 '( 9248 . 28891))
+     b (md5-FF b c d a (aref in  3) 22 '(49597 . 52974))
+     a (md5-FF a b c d (aref in  4)  7 '(62844 .  4015))
+     d (md5-FF d a b c (aref in  5) 12 '(18311 . 50730))
+     c (md5-FF c d a b (aref in  6) 17 '(43056 . 17939))
+     b (md5-FF b c d a (aref in  7) 22 '(64838 . 38145))
+     a (md5-FF a b c d (aref in  8)  7 '(27008 . 39128))
+     d (md5-FF d a b c (aref in  9) 12 '(35652 . 63407))
+     c (md5-FF c d a b (aref in 10) 17 '(65535 . 23473))
+     b (md5-FF b c d a (aref in 11) 22 '(35164 . 55230))
+     a (md5-FF a b c d (aref in 12)  7 '(27536 .  4386))
+     d (md5-FF d a b c (aref in 13) 12 '(64920 . 29075))
+     c (md5-FF c d a b (aref in 14) 17 '(42617 . 17294))
+     b (md5-FF b c d a (aref in 15) 22 '(18868 .  2081))
+     a (md5-GG a b c d (aref in  1)  5 '(63006 .  9570))
+     d (md5-GG d a b c (aref in  6)  9 '(49216 . 45888))
+     c (md5-GG c d a b (aref in 11) 14 '( 9822 . 23121))
+     b (md5-GG b c d a (aref in  0) 20 '(59830 . 51114))
+     a (md5-GG a b c d (aref in  5)  5 '(54831 .  4189))
+     d (md5-GG d a b c (aref in 10)  9 '(  580 .  5203))
+     c (md5-GG c d a b (aref in 15) 14 '(55457 . 59009))
+     b (md5-GG b c d a (aref in  4) 20 '(59347 . 64456))
+     a (md5-GG a b c d (aref in  9)  5 '( 8673 . 52710))
+     d (md5-GG d a b c (aref in 14)  9 '(49975 .  2006))
+     c (md5-GG c d a b (aref in  3) 14 '(62677 .  3463))
+     b (md5-GG b c d a (aref in  8) 20 '(17754 .  5357))
+     a (md5-GG a b c d (aref in 13)  5 '(43491 . 59653))
+     d (md5-GG d a b c (aref in  2)  9 '(64751 . 41976))
+     c (md5-GG c d a b (aref in  7) 14 '(26479 .   729))
+     b (md5-GG b c d a (aref in 12) 20 '(36138 . 19594))
+     a (md5-HH a b c d (aref in  5)  4 '(65530 . 14658))
+     d (md5-HH d a b c (aref in  8) 11 '(34673 . 63105))
+     c (md5-HH c d a b (aref in 11) 16 '(28061 . 24866))
+     b (md5-HH b c d a (aref in 14) 23 '(64997 . 14348))
+     a (md5-HH a b c d (aref in  1)  4 '(42174 . 59972))
+     d (md5-HH d a b c (aref in  4) 11 '(19422 . 53161))
+     c (md5-HH c d a b (aref in  7) 16 '(63163 . 19296))
+     b (md5-HH b c d a (aref in 10) 23 '(48831 . 48240))
+     a (md5-HH a b c d (aref in 13)  4 '(10395 . 32454))
+     d (md5-HH d a b c (aref in  0) 11 '(60065 . 10234))
+     c (md5-HH c d a b (aref in  3) 16 '(54511 . 12421))
+     b (md5-HH b c d a (aref in  6) 23 '( 1160 .  7429))
+     a (md5-HH a b c d (aref in  9)  4 '(55764 . 53305))
+     d (md5-HH d a b c (aref in 12) 11 '(59099 . 39397))
+     c (md5-HH c d a b (aref in 15) 16 '( 8098 . 31992))
+     b (md5-HH b c d a (aref in  2) 23 '(50348 . 22117))
+     a (md5-II a b c d (aref in  0)  6 '(62505 .  8772))
+     d (md5-II d a b c (aref in  7) 10 '(17194 . 65431))
+     c (md5-II c d a b (aref in 14) 15 '(43924 .  9127))
+     b (md5-II b c d a (aref in  5) 21 '(64659 . 41017))
+     a (md5-II a b c d (aref in 12)  6 '(25947 . 22979))
+     d (md5-II d a b c (aref in  3) 10 '(36620 . 52370))
+     c (md5-II c d a b (aref in 10) 15 '(65519 . 62589))
+     b (md5-II b c d a (aref in  1) 21 '(34180 . 24017))
+     a (md5-II a b c d (aref in  8)  6 '(28584 . 32335))
+     d (md5-II d a b c (aref in 15) 10 '(65068 . 59104))
+     c (md5-II c d a b (aref in  6) 15 '(41729 . 17172))
+     b (md5-II b c d a (aref in 13) 21 '(19976 .  4513))
+     a (md5-II a b c d (aref in  4)  6 '(63315 . 32386))
+     d (md5-II d a b c (aref in 11) 10 '(48442 . 62005))
+     c (md5-II c d a b (aref in  2) 15 '(10967 . 53947))
+     b (md5-II b c d a (aref in  9) 21 '(60294 . 54161)))
+
+     (aset md5-buffer 0 (md5-add (aref md5-buffer 0) a))
+     (aset md5-buffer 1 (md5-add (aref md5-buffer 1) b))
+     (aset md5-buffer 2 (md5-add (aref md5-buffer 2) c))
+     (aset md5-buffer 3 (md5-add (aref md5-buffer 3) d))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Here begins the merger with the XEmacs API and the md5.el from the URL
+;;; package.  Courtesy wmperry@cs.indiana.edu
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun md5 (object &optional start end)
+  "Return the MD5 (a secure message digest algorithm) of an object.
+OBJECT is either a string or a buffer.
+Optional arguments START and END denote buffer positions for computing the
+hash of a portion of OBJECT."
+ (let ((buffer nil))
+    (unwind-protect
+	(save-excursion
+	  (setq buffer (generate-new-buffer " *md5-work*"))
+	  (set-buffer buffer)
+	  (cond
+	   ((bufferp object)
+	    (insert-buffer-substring object start end))
+	   ((stringp object)
+	    (insert (if (or start end)
+			(substring object start end)
+		      object)))
+	   (t nil))
+	  (prog1
+	      (if (<= (point-max) md5-maximum-internal-length)
+		  (mapconcat
+		   (function (lambda (node) (format "%02x" node)))
+		   (md5-encode (buffer-string))
+		   "")
+		(call-process-region (point-min) (point-max)
+				     shell-file-name
+				     t buffer nil
+				     shell-command-switch md5-program)
+		;; MD5 digest is 32 chars long
+		;; mddriver adds a newline to make neaten output for tty
+		;; viewing, make sure we leave it behind.
+		(buffer-substring (point-min) (+ (point-min) 32)))
+	    (kill-buffer buffer)))
+      (and buffer (buffer-name buffer) (kill-buffer buffer) nil))))
+
+(provide 'md5)
+# Makefile for XEmacs package w3 manual
+
+# This file is part of XEmacs.
+
+# 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.
+
+HTML_FILES = w3-faq*.html w3*.html
+HTML_DEP = w3-faq.html w3.html
+
+include ../../../XEmacs.rules
+
+.PHONY: mostlyclean clean distclean realclean extraclean
+mostlyclean:
+	rm -f *.toc *.aux *.oaux *.log *.cp *.cps *.fn *.fns *.tp *.tps \
+              *.vr *.vrs *.pg *.pgs *.ky *.kys
+clean:: mostlyclean
+	rm -f $(HTML_FILES)
+distclean::  clean
+realclean:  clean
+extraclean: clean
+	-rm -f *~ \#*
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.