Mercurial > emacs

changeset 23560:6414b7085648

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
(w32-use-w32-font-dialog, w32-fixed-font-alist): New variables. (mouse-set-font): Use font menus instead of dialog according to w32-use-w32-font-dialog.
author Geoff Voelker <voelker@cs.washington.edu>
date Tue, 27 Oct 1998 23:46:26 +0000
parents 989c9cb875e3
children 70fafedc3c4c
files lisp/term/w32-win.el
diffstat 1 files changed, 176 insertions(+), 2 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/term/w32-win.el	Tue Oct 27 23:42:26 1998 +0000
+++ b/lisp/term/w32-win.el	Tue Oct 27 23:46:26 1998 +0000
@@ -699,9 +699,183 @@
     (list face (if (equal value "") nil value))))
 
 ;; Redefine the font selection to use the standard W32 dialog
+(defvar w32-use-w32-font-dialog t
+  "Use the standard font dialog if 't' - otherwise pop up a menu of
+some standard fonts like X does - including fontsets")
+
+(defvar w32-fixed-font-alist
+  '("Font menu"
+    ("Misc"
+     ;; For these, we specify the pixel height and width.
+     ("fixed" "Fixedsys")
+     ("")
+     ("Terminal 5x4"
+      "-*-Terminal-normal-r-*-*-*-45-*-*-c-40-*-oem")
+     ("Terminal 6x8"
+      "-*-Terminal-normal-r-*-*-*-60-*-*-c-80-*-oem")
+     ("Terminal 9x5"
+      "-*-Terminal-normal-r-*-*-*-90-*-*-c-50-*-oem")
+     ("Terminal 9x7"
+      "-*-Terminal-normal-r-*-*-*-90-*-*-c-70-*-oem")
+     ("Terminal 9x8"
+      "-*-Terminal-normal-r-*-*-*-90-*-*-c-80-*-oem")
+     ("Terminal 12x12"
+      "-*-Terminal-normal-r-*-*-*-120-*-*-c-120-*-oem")
+     ("Terminal 14x10"
+      "-*-Terminal-normal-r-*-*-*-135-*-*-c-100-*-oem")
+     ("Terminal 6x6 Bold"
+      "-*-Terminal-bold-r-*-*-*-60-*-*-c-60-*-oem")
+     ("")
+     ("Lucida Sans Typewriter.8"
+      "-*-Lucida Sans Typewriter-normal-r-*-*-11-*-*-*-c-*-iso8859-1")
+     ("Lucida Sans Typewriter.9"
+      "-*-Lucida Sans Typewriter-normal-r-*-*-12-*-*-*-c-*-iso8859-1")
+     ("Lucida Sans Typewriter.10"
+      "-*-Lucida Sans Typewriter-normal-r-*-*-13-*-*-*-c-*-iso8859-1")
+     ("Lucida Sans Typewriter.11"
+      "-*-Lucida Sans Typewriter-normal-r-*-*-15-*-*-*-c-*-iso8859-1")
+     ("Lucida Sans Typewriter.12"
+      "-*-Lucida Sans Typewriter-normal-r-*-*-16-*-*-*-c-*-iso8859-1")
+     ("Lucida Sans Typewriter.8 Bold"
+      "-*-Lucida Sans Typewriter-semibold-r-*-*-11-*-*-*-c-*-iso8859-1")
+     ("Lucida Sans Typewriter.9 Bold"
+      "-*-Lucida Sans Typewriter-semibold-r-*-*-12-*-*-*-c-*-iso8859-1")
+     ("Lucida Sans Typewriter.10 Bold"
+      "-*-Lucida Sans Typewriter-semibold-r-*-*-13-*-*-*-c-*-iso8859-1")
+     ("Lucida Sans Typewriter.11 Bold"
+      "-*-Lucida Sans Typewriter-semibold-r-*-*-15-*-*-*-c-*-iso8859-1")
+     ("Lucida Sans Typewriter.12 Bold"
+      "-*-Lucida Sans Typewriter-semibold-r-*-*-16-*-*-*-c-*-iso8859-1"))
+    ("Courier"
+     ("Courier 10x8"
+      "-*-Courier-*normal-r-*-*-*-97-*-*-c-80-iso8859-1")
+     ("Courier 12x9"
+      "-*-Courier-*normal-r-*-*-*-120-*-*-c-90-iso8859-1")
+     ("Courier 15x12"
+      "-*-Courier-*normal-r-*-*-*-150-*-*-c-120-iso8859-1")
+     ;; For these, we specify the point height.
+     ("")
+     ("8" "-*-Courier New-normal-r-*-*-11-*-*-*-c-*-iso8859-1")
+     ("9" "-*-Courier New-normal-r-*-*-12-*-*-*-c-*-iso8859-1")
+     ("10" "-*-Courier New-normal-r-*-*-13-*-*-*-c-*-iso8859-1")
+     ("11" "-*-Courier New-normal-r-*-*-15-*-*-*-c-*-iso8859-1")
+     ("12" "-*-Courier New-normal-r-*-*-16-*-*-*-c-*-iso8859-1")
+     ("8 bold" "-*-Courier New-bold-r-*-*-11-*-*-*-c-*-iso8859-1")
+     ("9 bold" "-*-Courier New-bold-r-*-*-12-*-*-*-c-*-iso8859-1")
+     ("10 bold" "-*-Courier New-bold-r-*-*-13-*-*-*-c-*-iso8859-1")
+     ("11 bold" "-*-Courier New-bold-r-*-*-15-*-*-*-c-*-iso8859-1")
+     ("12 bold" "-*-Courier New-bold-r-*-*-16-*-*-*-c-*-iso8859-1")
+     ("8 italic" "-*-Courier New-normal-i-*-*-11-*-*-*-c-*-iso8859-1")
+     ("9 italic" "-*-Courier New-normal-i-*-*-12-*-*-*-c-*-iso8859-1")
+     ("10 italic" "-*-Courier New-normal-i-*-*-13-*-*-*-c-*-iso8859-1")
+     ("11 italic" "-*-Courier New-normal-i-*-*-15-*-*-*-c-*-iso8859-1")
+     ("12 italic" "-*-Courier New-normal-i-*-*-16-*-*-*-c-*-iso8859-1")
+     ("8 bold italic" "-*-Courier New-bold-i-*-*-11-*-*-*-c-*-iso8859-1")
+     ("9 bold italic" "-*-Courier New-bold-i-*-*-12-*-*-*-c-*-iso8859-1")
+     ("10 bold italic" "-*-Courier New-bold-i-*-*-13-*-*-*-c-*-iso8859-1")
+     ("11 bold italic" "-*-Courier New-bold-i-*-*-15-*-*-*-c-*-iso8859-1")
+     ("12 bold italic" "-*-Courier New-bold-i-*-*-16-*-*-*-c-*-iso8859-1")
+     ))
+    "Fonts suitable for use in Emacs. Initially this is a list of some
+fixed width fonts that most people will have like Terminal and
+Courier. These fonts are used in the font menu if the variable
+`w32-use-w32-font-dialog' is nil.")
 
 (defun mouse-set-font (&rest fonts)
-  (interactive)
-  (set-default-font (w32-select-font)))
+  (interactive
+   (if w32-use-w32-font-dialog
+       (list (w32-select-font))
+     (x-popup-menu
+      last-nonmenu-event
+    ;; Append list of fontsets currently defined.
+    (append w32-fixed-font-alist (list (generate-fontset-menu))))))
+  (if fonts
+      (let (font)
+	(while fonts
+	  (condition-case nil
+	      (progn
+		(set-default-font (car fonts))
+		(setq font (car fonts))
+		(setq fonts nil))
+	    (error
+	     (setq fonts (cdr fonts)))))
+	(if (null font)
+	    (error "Font not found")))))
 
 ;;; w32-win.el ends here
+;;; The code in w32-init-fontsets requires a w32 frame to have been created,
+;;; which is not the case when this file is loaded during startup.
+(add-hook 'before-init-hook 'w32-init-fontsets)
+
+(defun w32-init-fontsets ()
+  "Initialize standard fontsets for w32."
+  (if (fboundp 'new-fontset)
+      (progn
+	;; Create the standard fontset.
+	(create-fontset-from-fontset-spec standard-fontset-spec t)
+
+	;; Create fontset specified in X resources "Fontset-N" (N is 0, 1, ...).
+	(create-fontset-from-x-resource)
+
+	;; Try to create a fontset from a font specification which comes
+	;; from initial-frame-alist, default-frame-alist, or X resource.
+	;; A font specification in command line argument (i.e. -fn XXXX)
+	;; should be already in default-frame-alist as a `font'
+	;; parameter.  However, any font specifications in site-start
+	;; library, user's init file (.emacs), and default.el are not
+	;; yet handled here.
+
+	(let ((font (or (cdr (assq 'font initial-frame-alist))
+			(cdr (assq 'font default-frame-alist))
+			(x-get-resource "font" "Font")))
+	      xlfd-fields resolved-name)
+	  (if (and font
+		   (not (query-fontset font))
+		   (setq resolved-name (x-resolve-font-name font))
+		   (setq xlfd-fields (x-decompose-font-name font)))
+	      (if (string= "fontset"
+			   (aref xlfd-fields xlfd-regexp-registry-subnum))
+		  (new-fontset font (x-complement-fontset-spec xlfd-fields nil))
+		;; Create a fontset from FONT.  The fontset name is
+		;; generated from FONT.  Create style variants of the
+		;; fontset too.  Font names in the variants are
+		;; generated automatially unless X resources
+		;; XXX.attribyteFont explicitly specify them.
+		(let ((styles (mapcar 'car x-style-funcs-alist))
+		      (faces '(bold italic bold-italic))
+		      face face-font fontset fontset-spec)
+		  (while faces
+		    (setq face (car faces))
+		    (setq face-font (x-get-resource (concat (symbol-name face)
+							    ".attributeFont")
+						    "Face.AttributeFont"))
+		    (if face-font
+			(setq styles (cons (cons face face-font)
+					   (delq face styles))))
+		    (setq faces (cdr faces)))
+		  (aset xlfd-fields xlfd-regexp-foundry-subnum nil)
+		  (aset xlfd-fields xlfd-regexp-family-subnum nil)
+		  (aset xlfd-fields xlfd-regexp-registry-subnum "fontset")
+		  (aset xlfd-fields xlfd-regexp-encoding-subnum "startup")
+		  ;; The fontset name should have concrete values in
+		  ;; weight and slant field.
+		  (let ((weight (aref xlfd-fields xlfd-regexp-weight-subnum))
+			(slant (aref xlfd-fields xlfd-regexp-slant-subnum))
+			xlfd-temp)
+		    (if (or (not weight) (string-match "[*?]*" weight))
+			(progn
+			  (setq xlfd-temp (x-decompose-font-name resolved-name))
+			  (aset xlfd-fields xlfd-regexp-weight-subnum
+				(aref xlfd-temp xlfd-regexp-weight-subnum))))
+		    (if (or (not slant) (string-match "[*?]*" slant))
+			(progn
+			  (or xlfd-temp
+			      (setq xlfd-temp
+				    (x-decompose-font-name resolved-name)))
+			  (aset xlfd-fields xlfd-regexp-slant-subnum
+				(aref xlfd-temp xlfd-regexp-slant-subnum)))))
+		  (setq fontset (x-compose-font-name xlfd-fields))
+		  (create-fontset-from-fontset-spec
+		   (concat fontset ", ascii:" font) styles)
+		  )))))))
+