(if (not (eq window-system 'w32))
(error "%s: Loading w32-win.el but not compiled for w32" (invocation-name)))
(require 'frame)
(require 'mouse)
(require 'scroll-bar)
(require 'faces)
(require 'select)
(require 'menu-bar)
(if (fboundp 'new-fontset)
(require 'fontset))
(defun w32-handle-scroll-bar-event (event)
"Handle W32 scroll bar events to do normal Window style scrolling."
(interactive "e")
(let ((old-window (selected-window)))
(unwind-protect
(let* ((position (event-start event))
(window (nth 0 position))
(portion-whole (nth 2 position))
(bar-part (nth 4 position)))
(save-excursion
(select-window window)
(cond
((eq bar-part 'up)
(goto-char (window-start window))
(scroll-down 1))
((eq bar-part 'above-handle)
(scroll-down))
((eq bar-part 'handle)
(scroll-bar-maybe-set-window-start event))
((eq bar-part 'below-handle)
(scroll-up))
((eq bar-part 'down)
(goto-char (window-start window))
(scroll-up 1))
)))
(select-window old-window))))
(global-set-key [vertical-scroll-bar mouse-1] 'w32-handle-scroll-bar-event)
(defvar mouse-wheel-scroll-amount 4
"*Number of lines to scroll per click of the mouse wheel.")
(defun mouse-wheel-scroll-line (event)
"Scroll the current buffer by `mouse-wheel-scroll-amount'."
(interactive "e")
(condition-case nil
(if (< (car (cdr (cdr event))) 0)
(scroll-up mouse-wheel-scroll-amount)
(scroll-down mouse-wheel-scroll-amount))
(error nil)))
(setq scroll-command-groups (list '(mouse-wheel-scroll-line)))
(defun mouse-wheel-scroll-screen (event)
"Scroll the current buffer by `mouse-wheel-scroll-amount'."
(interactive "e")
(condition-case nil
(if (< (car (cdr (cdr event))) 0)
(scroll-up)
(scroll-down))
(error nil)))
(global-set-key [mouse-wheel] 'mouse-wheel-scroll-line)
(global-set-key [C-mouse-wheel] 'mouse-wheel-scroll-screen)
(defun w32-drag-n-drop-debug (event)
"Print the drag-n-drop event in a readable form."
(interactive "e")
(princ event))
(defun w32-drag-n-drop (event)
"Edit the files listed in the drag-n-drop event.
Switch to a buffer editing the last file dropped."
(interactive "e")
(save-excursion
(let* ((window (posn-window (event-start event)))
(coords (posn-x-y (event-start event)))
(x (car coords))
(y (cdr coords)))
(if (and (> x 0) (> y 0))
(set-frame-selected-window nil window))
(mapcar 'find-file (car (cdr (cdr event)))))
(raise-frame)))
(defun w32-drag-n-drop-other-frame (event)
"Edit the files listed in the drag-n-drop event, in other frames.
May create new frames, or reuse existing ones. The frame editing
the last file dropped is selected."
(interactive "e")
(mapcar 'find-file-other-frame (car (cdr (cdr event)))))
(global-set-key [drag-n-drop] 'w32-drag-n-drop)
(global-set-key [C-drag-n-drop] 'w32-drag-n-drop-other-frame)
(global-set-key [language-change] 'ignore)
(defvar x-invocation-args)
(defvar x-command-line-resources nil)
(defconst x-option-alist
'(("-bw" . x-handle-numeric-switch)
("-d" . x-handle-display)
("-display" . x-handle-display)
("-name" . x-handle-name-rn-switch)
("-rn" . x-handle-name-rn-switch)
("-T" . x-handle-switch)
("-r" . x-handle-switch)
("-rv" . x-handle-switch)
("-reverse" . x-handle-switch)
("-fn" . x-handle-switch)
("-font" . x-handle-switch)
("-ib" . x-handle-numeric-switch)
("-g" . x-handle-geometry)
("-geometry" . x-handle-geometry)
("-fg" . x-handle-switch)
("-foreground". x-handle-switch)
("-bg" . x-handle-switch)
("-background". x-handle-switch)
("-ms" . x-handle-switch)
("-itype" . x-handle-switch)
("-i" . x-handle-switch)
("-iconic" . x-handle-iconic)
("-xrm" . x-handle-xrm-switch)
("-cr" . x-handle-switch)
("-vb" . x-handle-switch)
("-hb" . x-handle-switch)
("-bd" . x-handle-switch)))
(defconst x-long-option-alist
'(("--border-width" . "-bw")
("--display" . "-d")
("--name" . "-name")
("--title" . "-T")
("--reverse-video" . "-reverse")
("--font" . "-font")
("--internal-border" . "-ib")
("--geometry" . "-geometry")
("--foreground-color" . "-fg")
("--background-color" . "-bg")
("--mouse-color" . "-ms")
("--icon-type" . "-itype")
("--iconic" . "-iconic")
("--xrm" . "-xrm")
("--cursor-color" . "-cr")
("--vertical-scroll-bars" . "-vb")
("--border-color" . "-bd")))
(defconst x-switch-definitions
'(("-name" name)
("-T" name)
("-r" reverse t)
("-rv" reverse t)
("-reverse" reverse t)
("-fn" font)
("-font" font)
("-ib" internal-border-width)
("-fg" foreground-color)
("-foreground" foreground-color)
("-bg" background-color)
("-background" background-color)
("-ms" mouse-color)
("-cr" cursor-color)
("-itype" icon-type t)
("-i" icon-type t)
("-vb" vertical-scroll-bars t)
("-hb" horizontal-scroll-bars t)
("-bd" border-color)
("-bw" border-width)))
(defun x-handle-switch (switch)
(let ((aelt (assoc switch x-switch-definitions)))
(if aelt
(if (nth 2 aelt)
(setq default-frame-alist
(cons (cons (nth 1 aelt) (nth 2 aelt))
default-frame-alist))
(setq default-frame-alist
(cons (cons (nth 1 aelt)
(car x-invocation-args))
default-frame-alist)
x-invocation-args (cdr x-invocation-args))))))
(defun x-handle-iconic (switch)
(setq initial-frame-alist
(cons '(visibility . icon) initial-frame-alist)))
(defun x-handle-numeric-switch (switch)
(let ((aelt (assoc switch x-switch-definitions)))
(if aelt
(setq default-frame-alist
(cons (cons (nth 1 aelt)
(string-to-int (car x-invocation-args)))
default-frame-alist)
x-invocation-args
(cdr x-invocation-args)))))
(defun x-handle-xrm-switch (switch)
(or (consp x-invocation-args)
(error "%s: missing argument to `%s' option" (invocation-name) switch))
(setq x-command-line-resources (car x-invocation-args))
(setq x-invocation-args (cdr x-invocation-args)))
(defun x-handle-geometry (switch)
(let ((geo (x-parse-geometry (car x-invocation-args))))
(setq initial-frame-alist
(append initial-frame-alist
(if (or (assq 'left geo) (assq 'top geo))
'((user-position . t)))
(if (or (assq 'height geo) (assq 'width geo))
'((user-size . t)))
geo)
x-invocation-args (cdr x-invocation-args))))
(defun x-handle-name-rn-switch (switch)
(or (consp x-invocation-args)
(error "%s: missing argument to `%s' option" (invocation-name) switch))
(setq x-resource-name (car x-invocation-args)
x-invocation-args (cdr x-invocation-args))
(if (string= switch "-name")
(setq initial-frame-alist (cons (cons 'name x-resource-name)
initial-frame-alist))))
(defvar x-display-name nil
"The display name specifying server and frame.")
(defun x-handle-display (switch)
(setq x-display-name (car x-invocation-args)
x-invocation-args (cdr x-invocation-args)))
(defvar x-invocation-args nil)
(defun x-handle-args (args)
"Process the X-related command line options in ARGS.
This is done before the user's startup file is loaded. They are copied to
x-invocation args from which the X-related things are extracted, first
the switch (e.g., \"-fg\") in the following code, and possible values
\(e.g., \"black\") in the option handler code (e.g., x-handle-switch).
This returns ARGS with the arguments that have been processed removed."
(message "%s" args)
(setq x-invocation-args args
args nil)
(while x-invocation-args
(let* ((this-switch (car x-invocation-args))
(orig-this-switch this-switch)
completion argval aelt)
(setq x-invocation-args (cdr x-invocation-args))
(if (string-match "^--[^=]*=" this-switch)
(setq argval (substring this-switch (match-end 0))
this-switch (substring this-switch 0 (1- (match-end 0)))))
(setq completion (try-completion this-switch x-long-option-alist))
(if (eq completion t)
(setq this-switch (cdr (assoc this-switch x-long-option-alist)))
(if (stringp completion)
(let ((elt (assoc completion x-long-option-alist)))
(or elt
(error "Option `%s' is ambiguous" this-switch))
(setq this-switch (cdr elt)))
(setq argval nil this-switch orig-this-switch)))
(setq aelt (assoc this-switch x-option-alist))
(if aelt
(if argval
(let ((x-invocation-args
(cons argval x-invocation-args)))
(funcall (cdr aelt) this-switch))
(funcall (cdr aelt) this-switch))
(setq args (cons this-switch args)))))
(setq args (nreverse args)))
(defvar x-colors '("aquamarine"
"Aquamarine"
"medium aquamarine"
"MediumAquamarine"
"black"
"Black"
"blue"
"Blue"
"cadet blue"
"CadetBlue"
"cornflower blue"
"CornflowerBlue"
"dark slate blue"
"DarkSlateBlue"
"light blue"
"LightBlue"
"light steel blue"
"LightSteelBlue"
"medium blue"
"MediumBlue"
"medium slate blue"
"MediumSlateBlue"
"midnight blue"
"MidnightBlue"
"navy blue"
"NavyBlue"
"navy"
"Navy"
"sky blue"
"SkyBlue"
"slate blue"
"SlateBlue"
"steel blue"
"SteelBlue"
"coral"
"Coral"
"cyan"
"Cyan"
"firebrick"
"Firebrick"
"brown"
"Brown"
"gold"
"Gold"
"goldenrod"
"Goldenrod"
"green"
"Green"
"dark green"
"DarkGreen"
"dark olive green"
"DarkOliveGreen"
"forest green"
"ForestGreen"
"lime green"
"LimeGreen"
"medium sea green"
"MediumSeaGreen"
"medium spring green"
"MediumSpringGreen"
"pale green"
"PaleGreen"
"sea green"
"SeaGreen"
"spring green"
"SpringGreen"
"yellow green"
"YellowGreen"
"dark slate grey"
"DarkSlateGrey"
"dark slate gray"
"DarkSlateGray"
"dim grey"
"DimGrey"
"dim gray"
"DimGray"
"light grey"
"LightGrey"
"light gray"
"LightGray"
"gray"
"grey"
"Gray"
"Grey"
"khaki"
"Khaki"
"magenta"
"Magenta"
"maroon"
"Maroon"
"orange"
"Orange"
"orchid"
"Orchid"
"dark orchid"
"DarkOrchid"
"medium orchid"
"MediumOrchid"
"pink"
"Pink"
"plum"
"Plum"
"red"
"Red"
"indian red"
"IndianRed"
"medium violet red"
"MediumVioletRed"
"orange red"
"OrangeRed"
"violet red"
"VioletRed"
"salmon"
"Salmon"
"sienna"
"Sienna"
"tan"
"Tan"
"thistle"
"Thistle"
"turquoise"
"Turquoise"
"dark turquoise"
"DarkTurquoise"
"medium turquoise"
"MediumTurquoise"
"violet"
"Violet"
"blue violet"
"BlueViolet"
"wheat"
"Wheat"
"white"
"White"
"yellow"
"Yellow"
"green yellow"
"GreenYellow")
"The full list of X colors from the `rgb.text' file.")
(defun x-defined-colors (&optional frame)
"Return a list of colors supported for a particular frame.
The argument FRAME specifies which frame to try.
The value may be different for frames on different X displays."
(or frame (setq frame (selected-frame)))
(let* ((color-map-colors (mapcar (lambda (clr) (car clr)) w32-color-map))
(all-colors (or color-map-colors x-colors))
(this-color nil)
(defined-colors nil))
(message "Defining colors...")
(while all-colors
(setq this-color (car all-colors)
all-colors (cdr all-colors))
(and (face-color-supported-p frame this-color t)
(setq defined-colors (cons this-color defined-colors))))
defined-colors))
(global-set-key [f10] (lambda ()
(interactive) (w32-send-sys-command ?\xf100)))
(defun iconify-or-deiconify-frame ()
"Iconify the selected frame, or deiconify if it's currently an icon."
(interactive)
(if (eq (cdr (assq 'visibility (frame-parameters))) t)
(iconify-frame)
(make-frame-visible)))
(substitute-key-definition 'suspend-emacs 'iconify-or-deiconify-frame
global-map)
(defvar x-last-selected-text nil)
(defvar x-cut-buffer-max 20000
"Max number of characters to put in the cut buffer.")
(defvar x-select-enable-clipboard t
"Non-nil means cutting and pasting uses the clipboard.
This is in addition to the primary selection.")
(defun x-select-text (text &optional push)
(if x-select-enable-clipboard
(w32-set-clipboard-data text))
(setq x-last-selected-text text))
(defun x-get-selection-value ()
(if x-select-enable-clipboard
(let (text)
(condition-case c
(setq text (w32-get-clipboard-data))
(error (message "w32-get-clipboard-data:%s" c)))
(if (string= text "") (setq text nil))
(cond
((not text) nil)
((eq text x-last-selected-text) nil)
((string= text x-last-selected-text)
(setq x-last-selected-text text)
nil)
(t
(setq x-last-selected-text text))))))
(defalias 'x-cut-buffer-or-selection-value 'x-get-selection-value)
(setq command-line-args (x-handle-args command-line-args))
(or (stringp x-resource-name)
(let (i)
(setq x-resource-name (invocation-name))
(while (setq i (string-match "[.*]" x-resource-name))
(aset x-resource-name i ?-))))
(if (fboundp 'x-close-connection)
(x-open-connection ""
x-command-line-resources
t)
(x-open-connection ""
x-command-line-resources))
(setq frame-creation-function 'x-create-frame-with-faces)
(setq x-cut-buffer-max (min (- (/ (x-server-max-request-size) 2) 100)
x-cut-buffer-max))
(menu-bar-enable-clipboard)
(defvar w32-standard-fontset-spec
"-*-Courier New-normal-r-*-*-13-*-*-*-c-*-fontset-standard"
"String of fontset spec of the standard fontset. This defines a
fontset consisting of the Courier New variations for European
languages which are distributed with Windows as \"Multilanguage Support\".
See the documentation of `create-fontset-from-fontset-spec for the format.")
(if (fboundp 'new-fontset)
(progn
(defun w32-create-initial-fontsets ()
"Create fontset-startup, fontset-standard and any fontsets
specified in X resources."
(create-fontset-from-fontset-spec w32-standard-fontset-spec t)
(create-fontset-from-x-resource)
(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))
(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")
(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)
)))))
(add-hook 'before-init-hook 'w32-create-initial-fontsets)
))
(let* ((res-geometry (x-get-resource "geometry" "Geometry"))
parsed)
(if res-geometry
(progn
(setq parsed (x-parse-geometry res-geometry))
(if (or (assq 'top parsed) (assq 'left parsed))
(setq parsed (cons '(user-position . t)
(cons '(user-size . t) parsed))))
(setq initial-frame-alist (append initial-frame-alist parsed))
(if (assq 'height parsed)
(setq default-frame-alist
(cons (cons 'height (cdr (assq 'height parsed)))
default-frame-alist)))
(if (assq 'width parsed)
(setq default-frame-alist
(cons (cons 'width (cdr (assq 'width parsed)))
default-frame-alist))))))
(let ((case-fold-search t))
(let ((rv (x-get-resource "reverseVideo" "ReverseVideo")))
(if (and rv
(string-match "^\\(true\\|yes\\|on\\)$" rv))
(setq default-frame-alist
(cons '(reverse . t) default-frame-alist)))))
(let ((res-selection-timeout
(x-get-resource "selectionTimeout" "SelectionTimeout")))
(setq x-selection-timeout 20000)
(if res-selection-timeout
(setq x-selection-timeout (string-to-number res-selection-timeout))))
(defun x-win-suspend-error ()
(error "Suspending an emacs running under W32 makes no sense"))
(add-hook 'suspend-hook 'x-win-suspend-error)
(setq interprogram-cut-function 'x-select-text)
(setq interprogram-paste-function 'x-get-selection-value)
(setq split-window-keep-point t)
(setq-default mode-line-frame-identification " ")
(set-message-beep 'ok)
(defun internal-face-interactive (what &optional bool)
(let* ((fn (intern (concat "face-" what)))
(prompt (concat "Set " what " of face"))
(face (read-face-name (concat prompt ": ")))
(default (if (fboundp fn)
(or (funcall fn face (selected-frame))
(funcall fn 'default (selected-frame)))))
(fn-win (intern (concat (symbol-name window-system) "-select-" what)))
value)
(setq value
(cond ((fboundp fn-win)
(funcall fn-win))
((eq bool 'color)
(completing-read (concat prompt " " (symbol-name face) " to: ")
(mapcar (function (lambda (color)
(cons color color)))
x-colors)
nil nil nil nil default))
(bool
(y-or-n-p (concat "Should face " (symbol-name face)
" be " bool "? ")))
(t
(read-string (concat prompt " " (symbol-name face) " to: ")
nil nil default))))
(list face (if (equal value "") nil value))))
(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"
("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")
("")
("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.")
(put-charset-property 'katakana-jisx0201 'x-charset-registry "JISX0208-SJIS")
(put-charset-property 'latin-jisx0201 'x-charset-registry "JISX0208-SJIS")
(put-charset-property 'japanese-jisx0208 'x-charset-registry "JISX0208-SJIS")
(put-charset-property 'japanese-jisx0208-1978 'x-charset-registry
"JISX0208-SJIS")
(defun mouse-set-font (&rest fonts)
"Select a font. If `w32-use-w32-font-dialog' is non-nil (the default),
use the Windows font dialog. Otherwise use a pop-up menu (like Emacs
on other platforms) initialized with the fonts in
`w32-fixed-font-alist'. Emacs will attempt to create a fontset from
the font chosen, covering all the charsets that can be fully represented
with the font."
(interactive
(if w32-use-w32-font-dialog
(list (w32-select-font))
(x-popup-menu
last-nonmenu-event
(if (fboundp 'new-fontset)
(append w32-fixed-font-alist (list (generate-fontset-menu)))))))
(if fonts
(let (font fontset xlfd resolved-font)
(while fonts
(condition-case nil
(progn
(setq font (car fonts))
(if (fontset-name-p font)
(setq fontset font)
(condition-case nil
(setq resolved-font (x-resolve-font-name font)
xlfd (x-decompose-font-name resolved-font)
fontset
(create-fontset-from-ascii-font
font resolved-font
(format "%s_%s_%s_%s"
(aref xlfd xlfd-regexp-family-subnum)
(aref xlfd xlfd-regexp-registry-subnum)
(aref xlfd xlfd-regexp-encoding-subnum)
(aref xlfd
xlfd-regexp-pixelsize-subnum))))
(error nil)))
(if fontset
(set-default-font fontset)
(set-default-font font))
(setq fonts nil))
(error (setq fonts (cdr fonts)))))
(if (null font)
(error "Font not found")))))