-;;; win32-win.el --- parse switches controlling interface with win32
+;;; w32-win.el --- parse switches controlling interface with W32 window system
-;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1994, 2002, 2003, 2004,
+;; 2005 Free Software Foundation, Inc.
;; Author: Kevin Gallo
;; Keywords: terminals
;; 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.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
-;; win32-win.el: this file is loaded from ../lisp/startup.el when it recognizes
-;; that win32 windows are to be used. Command line switches are parsed and those
-;; pertaining to win32 are processed and removed from the command line. The
-;; win32 display is opened and hooks are set for popping up the initial window.
+;; w32-win.el: this file is loaded from ../lisp/startup.el when it recognizes
+;; that W32 windows are to be used. Command line switches are parsed and those
+;; pertaining to W32 are processed and removed from the command line. The
+;; W32 display is opened and hooks are set for popping up the initial window.
;; startup.el will then examine startup files, and eventually call the hooks
;; which create the first window (s).
;; An alist of X options and the function which handles them. See
;; ../startup.el.
-(if (not (eq window-system 'win32))
- (error "%s: Loading win32-win.el but not compiled for win32" (invocation-name)))
-
+(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)
+(require 'dnd)
+(require 'code-pages)
-;; Because Windows scrollbars look and act quite differently compared
-;; with the standard X scroll-bars, we don't try to use the normal
-;; scroll bar routines.
+(defvar xlfd-regexp-registry-subnum)
-(defun w32-handle-scroll-bar-event (event)
- "Handle Win32 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)
- (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)
- (scroll-up 1))
- )))
- (select-window old-window))))
-
-;; The following definition is used for debugging.
+;; Conditional on new-fontset so bootstrapping works on non-GUI compiles
+(if (fboundp 'new-fontset)
+ (require 'fontset))
+
+;; The following definition is used for debugging scroll bar events.
;(defun w32-handle-scroll-bar-event (event) (interactive "e") (princ event))
-(global-set-key [vertical-scroll-bar mouse-1] 'w32-handle-scroll-bar-event)
+;; Handle mouse-wheel events with mwheel.
+(mouse-wheel-mode 1)
+
+(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
+ ;; Make sure the drop target has positive co-ords
+ ;; before setting the selected frame - otherwise it
+ ;; won't work. <skx@tardis.ed.ac.uk>
+ (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 (lambda (file-name)
+ (dnd-handle-one-url window 'private
+ (concat "file:" file-name)))
+ (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)))))
+
+;; Bind the drag-n-drop event.
+(global-set-key [drag-n-drop] 'w32-drag-n-drop)
+(global-set-key [C-drag-n-drop] 'w32-drag-n-drop-other-frame)
-;; (scroll-bar-mode nil)
+;; Keyboard layout/language change events
+;; For now ignore language-change events; in the future
+;; we should switch the Emacs Input Method to match the
+;; new layout/language selected by the user.
+(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)))
-
-;; Handler for switches of the form "-switch value" or "-switch".
(defun x-handle-switch (switch)
- (let ((aelt (assoc switch x-switch-definitions)))
+ "Handle SWITCH of the form \"-switch value\" or \"-switch\"."
+ (let ((aelt (assoc switch command-line-x-option-alist)))
(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))))))
-
-;; Make -iconic apply only to the initial frame!
-(defun x-handle-iconic (switch)
- (setq initial-frame-alist
- (cons '(visibility . icon) initial-frame-alist)))
+ (push (cons (nth 3 aelt) (or (nth 4 aelt) (pop x-invocation-args)))
+ default-frame-alist))))
-;; Handler for switches of the form "-switch n"
(defun x-handle-numeric-switch (switch)
- (let ((aelt (assoc switch x-switch-definitions)))
+ "Handle SWITCH of the form \"-switch n\"."
+ (let ((aelt (assoc switch command-line-x-option-alist)))
(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)))))
+ (push (cons (nth 3 aelt) (string-to-number (pop x-invocation-args)))
+ default-frame-alist))))
+
+;; Handle options that apply to initial frame only
+(defun x-handle-initial-switch (switch)
+ (let ((aelt (assoc switch command-line-x-option-alist)))
+ (if aelt
+ (push (cons (nth 3 aelt) (or (nth 4 aelt) (pop x-invocation-args)))
+ initial-frame-alist))))
+
+(defun x-handle-iconic (switch)
+ "Make \"-iconic\" SWITCH apply only to the initial frame."
+ (push '(visibility . icon) initial-frame-alist))
-;; Handle the -xrm option.
(defun x-handle-xrm-switch (switch)
+ "Handle the \"-xrm\" 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-command-line-resources
+ (if (null x-command-line-resources)
+ (car x-invocation-args)
+ (concat x-command-line-resources "\n" (car x-invocation-args))))
(setq x-invocation-args (cdr x-invocation-args)))
-;; Handle the geometry option
(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))))
-
-;; Handle the -name and -rn options. Set the variable x-resource-name
-;; to the option's operand; if the switch was `-name', set the name of
-;; the initial frame, too.
-(defun x-handle-name-rn-switch (switch)
+ "Handle the \"-geometry\" SWITCH."
+ (let* ((geo (x-parse-geometry (car x-invocation-args)))
+ (left (assq 'left geo))
+ (top (assq 'top geo))
+ (height (assq 'height geo))
+ (width (assq 'width geo)))
+ (if (or height width)
+ (setq default-frame-alist
+ (append default-frame-alist
+ '((user-size . t))
+ (if height (list height))
+ (if width (list width)))
+ initial-frame-alist
+ (append initial-frame-alist
+ '((user-size . t))
+ (if height (list height))
+ (if width (list width)))))
+ (if (or left top)
+ (setq initial-frame-alist
+ (append initial-frame-alist
+ '((user-position . t))
+ (if left (list left))
+ (if top (list top)))))
+ (setq x-invocation-args (cdr x-invocation-args))))
+
+(defun x-handle-name-switch (switch)
+ "Handle a \"-name\" SWITCH."
+;; Handle the -name option. Set the variable x-resource-name
+;; to the option's operand; set the name of the initial frame, too.
(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))))
+ (setq x-resource-name (pop x-invocation-args))
+ (push (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)
+ "Handle the \"-display\" SWITCH."
+ (setq x-display-name (pop x-invocation-args)))
(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
+`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)
+ ;; We use ARGS to accumulate the args that we don't handle here, to return.
(setq x-invocation-args args
args nil)
- (while x-invocation-args
+ (while (and x-invocation-args
+ (not (equal (car x-invocation-args) "--")))
(let* ((this-switch (car x-invocation-args))
(orig-this-switch this-switch)
- completion argval aelt)
+ completion argval aelt handler)
(setq x-invocation-args (cdr x-invocation-args))
;; Check for long options with attached arguments
;; and separate out the attached option argument into argval.
(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)
- ;; Exact match for long option.
- (setq this-switch (cdr (assoc this-switch x-long-option-alist)))
- (if (stringp completion)
- (let ((elt (assoc completion x-long-option-alist)))
- ;; Check for abbreviated long option.
- (or elt
- (error "Option `%s' is ambiguous" this-switch))
- (setq this-switch (cdr elt)))
- ;; Check for a short option.
- (setq argval nil this-switch orig-this-switch)))
- (setq aelt (assoc this-switch x-option-alist))
- (if aelt
+ ;; Complete names of long options.
+ (if (string-match "^--" this-switch)
+ (progn
+ (setq completion (try-completion this-switch command-line-x-option-alist))
+ (if (eq completion t)
+ ;; Exact match for long option.
+ nil
+ (if (stringp completion)
+ (let ((elt (assoc completion command-line-x-option-alist)))
+ ;; Check for abbreviated long option.
+ (or elt
+ (error "Option `%s' is ambiguous" this-switch))
+ (setq this-switch completion))))))
+ (setq aelt (assoc this-switch command-line-x-option-alist))
+ (if aelt (setq handler (nth 2 aelt)))
+ (if handler
(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)))
-
-
+ (funcall handler this-switch))
+ (funcall handler this-switch))
+ (push orig-this-switch args))))
+ (nconc (nreverse args) x-invocation-args))
\f
;;
;; Available colors
;;
-(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"
+(defvar x-colors '("LightGreen"
+ "light green"
+ "DarkRed"
+ "dark red"
+ "DarkMagenta"
+ "dark magenta"
+ "DarkCyan"
+ "dark cyan"
+ "DarkBlue"
+ "dark blue"
+ "DarkGray"
+ "dark gray"
+ "DarkGrey"
+ "dark grey"
+ "grey100"
+ "gray100"
+ "grey99"
+ "gray99"
+ "grey98"
+ "gray98"
+ "grey97"
+ "gray97"
+ "grey96"
+ "gray96"
+ "grey95"
+ "gray95"
+ "grey94"
+ "gray94"
+ "grey93"
+ "gray93"
+ "grey92"
+ "gray92"
+ "grey91"
+ "gray91"
+ "grey90"
+ "gray90"
+ "grey89"
+ "gray89"
+ "grey88"
+ "gray88"
+ "grey87"
+ "gray87"
+ "grey86"
+ "gray86"
+ "grey85"
+ "gray85"
+ "grey84"
+ "gray84"
+ "grey83"
+ "gray83"
+ "grey82"
+ "gray82"
+ "grey81"
+ "gray81"
+ "grey80"
+ "gray80"
+ "grey79"
+ "gray79"
+ "grey78"
+ "gray78"
+ "grey77"
+ "gray77"
+ "grey76"
+ "gray76"
+ "grey75"
+ "gray75"
+ "grey74"
+ "gray74"
+ "grey73"
+ "gray73"
+ "grey72"
+ "gray72"
+ "grey71"
+ "gray71"
+ "grey70"
+ "gray70"
+ "grey69"
+ "gray69"
+ "grey68"
+ "gray68"
+ "grey67"
+ "gray67"
+ "grey66"
+ "gray66"
+ "grey65"
+ "gray65"
+ "grey64"
+ "gray64"
+ "grey63"
+ "gray63"
+ "grey62"
+ "gray62"
+ "grey61"
+ "gray61"
+ "grey60"
+ "gray60"
+ "grey59"
+ "gray59"
+ "grey58"
+ "gray58"
+ "grey57"
+ "gray57"
+ "grey56"
+ "gray56"
+ "grey55"
+ "gray55"
+ "grey54"
+ "gray54"
+ "grey53"
+ "gray53"
+ "grey52"
+ "gray52"
+ "grey51"
+ "gray51"
+ "grey50"
+ "gray50"
+ "grey49"
+ "gray49"
+ "grey48"
+ "gray48"
+ "grey47"
+ "gray47"
+ "grey46"
+ "gray46"
+ "grey45"
+ "gray45"
+ "grey44"
+ "gray44"
+ "grey43"
+ "gray43"
+ "grey42"
+ "gray42"
+ "grey41"
+ "gray41"
+ "grey40"
+ "gray40"
+ "grey39"
+ "gray39"
+ "grey38"
+ "gray38"
+ "grey37"
+ "gray37"
+ "grey36"
+ "gray36"
+ "grey35"
+ "gray35"
+ "grey34"
+ "gray34"
+ "grey33"
+ "gray33"
+ "grey32"
+ "gray32"
+ "grey31"
+ "gray31"
+ "grey30"
+ "gray30"
+ "grey29"
+ "gray29"
+ "grey28"
+ "gray28"
+ "grey27"
+ "gray27"
+ "grey26"
+ "gray26"
+ "grey25"
+ "gray25"
+ "grey24"
+ "gray24"
+ "grey23"
+ "gray23"
+ "grey22"
+ "gray22"
+ "grey21"
+ "gray21"
+ "grey20"
+ "gray20"
+ "grey19"
+ "gray19"
+ "grey18"
+ "gray18"
+ "grey17"
+ "gray17"
+ "grey16"
+ "gray16"
+ "grey15"
+ "gray15"
+ "grey14"
+ "gray14"
+ "grey13"
+ "gray13"
+ "grey12"
+ "gray12"
+ "grey11"
+ "gray11"
+ "grey10"
+ "gray10"
+ "grey9"
+ "gray9"
+ "grey8"
+ "gray8"
+ "grey7"
+ "gray7"
+ "grey6"
+ "gray6"
+ "grey5"
+ "gray5"
+ "grey4"
+ "gray4"
+ "grey3"
+ "gray3"
+ "grey2"
+ "gray2"
+ "grey1"
+ "gray1"
+ "grey0"
+ "gray0"
+ "thistle4"
+ "thistle3"
+ "thistle2"
+ "thistle1"
+ "MediumPurple4"
+ "MediumPurple3"
+ "MediumPurple2"
+ "MediumPurple1"
+ "purple4"
+ "purple3"
+ "purple2"
+ "purple1"
+ "DarkOrchid4"
+ "DarkOrchid3"
+ "DarkOrchid2"
+ "DarkOrchid1"
+ "MediumOrchid4"
+ "MediumOrchid3"
+ "MediumOrchid2"
+ "MediumOrchid1"
+ "plum4"
+ "plum3"
+ "plum2"
+ "plum1"
+ "orchid4"
+ "orchid3"
+ "orchid2"
+ "orchid1"
+ "magenta4"
+ "magenta3"
+ "magenta2"
+ "magenta1"
+ "VioletRed4"
+ "VioletRed3"
+ "VioletRed2"
+ "VioletRed1"
+ "maroon4"
+ "maroon3"
+ "maroon2"
+ "maroon1"
+ "PaleVioletRed4"
+ "PaleVioletRed3"
+ "PaleVioletRed2"
+ "PaleVioletRed1"
+ "LightPink4"
+ "LightPink3"
+ "LightPink2"
+ "LightPink1"
+ "pink4"
+ "pink3"
+ "pink2"
+ "pink1"
+ "HotPink4"
+ "HotPink3"
+ "HotPink2"
+ "HotPink1"
+ "DeepPink4"
+ "DeepPink3"
+ "DeepPink2"
+ "DeepPink1"
+ "red4"
+ "red3"
+ "red2"
+ "red1"
+ "OrangeRed4"
+ "OrangeRed3"
+ "OrangeRed2"
+ "OrangeRed1"
+ "tomato4"
+ "tomato3"
+ "tomato2"
+ "tomato1"
+ "coral4"
+ "coral3"
+ "coral2"
+ "coral1"
+ "DarkOrange4"
+ "DarkOrange3"
+ "DarkOrange2"
+ "DarkOrange1"
+ "orange4"
+ "orange3"
+ "orange2"
+ "orange1"
+ "LightSalmon4"
+ "LightSalmon3"
+ "LightSalmon2"
+ "LightSalmon1"
+ "salmon4"
+ "salmon3"
+ "salmon2"
+ "salmon1"
+ "brown4"
+ "brown3"
+ "brown2"
+ "brown1"
+ "firebrick4"
+ "firebrick3"
+ "firebrick2"
+ "firebrick1"
+ "chocolate4"
+ "chocolate3"
+ "chocolate2"
+ "chocolate1"
+ "tan4"
+ "tan3"
+ "tan2"
+ "tan1"
+ "wheat4"
+ "wheat3"
+ "wheat2"
+ "wheat1"
+ "burlywood4"
+ "burlywood3"
+ "burlywood2"
+ "burlywood1"
+ "sienna4"
+ "sienna3"
+ "sienna2"
+ "sienna1"
+ "IndianRed4"
+ "IndianRed3"
+ "IndianRed2"
+ "IndianRed1"
+ "RosyBrown4"
+ "RosyBrown3"
+ "RosyBrown2"
+ "RosyBrown1"
+ "DarkGoldenrod4"
+ "DarkGoldenrod3"
+ "DarkGoldenrod2"
+ "DarkGoldenrod1"
+ "goldenrod4"
+ "goldenrod3"
+ "goldenrod2"
+ "goldenrod1"
+ "gold4"
+ "gold3"
+ "gold2"
+ "gold1"
+ "yellow4"
+ "yellow3"
+ "yellow2"
+ "yellow1"
+ "LightYellow4"
+ "LightYellow3"
+ "LightYellow2"
+ "LightYellow1"
+ "LightGoldenrod4"
+ "LightGoldenrod3"
+ "LightGoldenrod2"
+ "LightGoldenrod1"
+ "khaki4"
+ "khaki3"
+ "khaki2"
+ "khaki1"
+ "DarkOliveGreen4"
+ "DarkOliveGreen3"
+ "DarkOliveGreen2"
+ "DarkOliveGreen1"
+ "OliveDrab4"
+ "OliveDrab3"
+ "OliveDrab2"
+ "OliveDrab1"
+ "chartreuse4"
+ "chartreuse3"
+ "chartreuse2"
+ "chartreuse1"
+ "green4"
+ "green3"
+ "green2"
+ "green1"
+ "SpringGreen4"
+ "SpringGreen3"
+ "SpringGreen2"
+ "SpringGreen1"
+ "PaleGreen4"
+ "PaleGreen3"
+ "PaleGreen2"
+ "PaleGreen1"
+ "SeaGreen4"
+ "SeaGreen3"
+ "SeaGreen2"
+ "SeaGreen1"
+ "DarkSeaGreen4"
+ "DarkSeaGreen3"
+ "DarkSeaGreen2"
+ "DarkSeaGreen1"
+ "aquamarine4"
+ "aquamarine3"
+ "aquamarine2"
+ "aquamarine1"
+ "DarkSlateGray4"
+ "DarkSlateGray3"
+ "DarkSlateGray2"
+ "DarkSlateGray1"
+ "cyan4"
+ "cyan3"
+ "cyan2"
+ "cyan1"
+ "turquoise4"
+ "turquoise3"
+ "turquoise2"
+ "turquoise1"
+ "CadetBlue4"
+ "CadetBlue3"
+ "CadetBlue2"
+ "CadetBlue1"
+ "PaleTurquoise4"
+ "PaleTurquoise3"
+ "PaleTurquoise2"
+ "PaleTurquoise1"
+ "LightCyan4"
+ "LightCyan3"
+ "LightCyan2"
+ "LightCyan1"
+ "LightBlue4"
+ "LightBlue3"
+ "LightBlue2"
+ "LightBlue1"
+ "LightSteelBlue4"
+ "LightSteelBlue3"
+ "LightSteelBlue2"
+ "LightSteelBlue1"
+ "SlateGray4"
+ "SlateGray3"
+ "SlateGray2"
+ "SlateGray1"
+ "LightSkyBlue4"
+ "LightSkyBlue3"
+ "LightSkyBlue2"
+ "LightSkyBlue1"
+ "SkyBlue4"
+ "SkyBlue3"
+ "SkyBlue2"
+ "SkyBlue1"
+ "DeepSkyBlue4"
+ "DeepSkyBlue3"
+ "DeepSkyBlue2"
+ "DeepSkyBlue1"
+ "SteelBlue4"
+ "SteelBlue3"
+ "SteelBlue2"
+ "SteelBlue1"
+ "DodgerBlue4"
+ "DodgerBlue3"
+ "DodgerBlue2"
+ "DodgerBlue1"
+ "blue4"
+ "blue3"
+ "blue2"
+ "blue1"
+ "RoyalBlue4"
+ "RoyalBlue3"
+ "RoyalBlue2"
+ "RoyalBlue1"
+ "SlateBlue4"
+ "SlateBlue3"
+ "SlateBlue2"
+ "SlateBlue1"
+ "azure4"
+ "azure3"
+ "azure2"
+ "azure1"
+ "MistyRose4"
+ "MistyRose3"
+ "MistyRose2"
+ "MistyRose1"
+ "LavenderBlush4"
+ "LavenderBlush3"
+ "LavenderBlush2"
+ "LavenderBlush1"
+ "honeydew4"
+ "honeydew3"
+ "honeydew2"
+ "honeydew1"
+ "ivory4"
+ "ivory3"
+ "ivory2"
+ "ivory1"
+ "cornsilk4"
+ "cornsilk3"
+ "cornsilk2"
+ "cornsilk1"
+ "LemonChiffon4"
+ "LemonChiffon3"
+ "LemonChiffon2"
+ "LemonChiffon1"
+ "NavajoWhite4"
+ "NavajoWhite3"
+ "NavajoWhite2"
+ "NavajoWhite1"
+ "PeachPuff4"
+ "PeachPuff3"
+ "PeachPuff2"
+ "PeachPuff1"
+ "bisque4"
+ "bisque3"
+ "bisque2"
+ "bisque1"
+ "AntiqueWhite4"
+ "AntiqueWhite3"
+ "AntiqueWhite2"
+ "AntiqueWhite1"
+ "seashell4"
+ "seashell3"
+ "seashell2"
+ "seashell1"
+ "snow4"
+ "snow3"
+ "snow2"
+ "snow1"
+ "thistle"
+ "MediumPurple"
+ "medium purple"
+ "purple"
+ "BlueViolet"
+ "blue violet"
+ "DarkViolet"
+ "dark violet"
+ "DarkOrchid"
+ "dark orchid"
+ "MediumOrchid"
+ "medium orchid"
+ "orchid"
+ "plum"
+ "violet"
+ "magenta"
+ "VioletRed"
+ "violet red"
+ "MediumVioletRed"
+ "medium violet red"
+ "maroon"
+ "PaleVioletRed"
+ "pale violet red"
+ "LightPink"
+ "light pink"
+ "pink"
+ "DeepPink"
+ "deep pink"
+ "HotPink"
+ "hot pink"
+ "red"
+ "OrangeRed"
+ "orange red"
+ "tomato"
+ "LightCoral"
+ "light coral"
"coral"
- "Coral"
- "cyan"
- "Cyan"
- "firebrick"
- "Firebrick"
+ "DarkOrange"
+ "dark orange"
+ "orange"
+ "LightSalmon"
+ "light salmon"
+ "salmon"
+ "DarkSalmon"
+ "dark salmon"
"brown"
- "Brown"
- "gold"
- "Gold"
+ "firebrick"
+ "chocolate"
+ "tan"
+ "SandyBrown"
+ "sandy brown"
+ "wheat"
+ "beige"
+ "burlywood"
+ "peru"
+ "sienna"
+ "SaddleBrown"
+ "saddle brown"
+ "IndianRed"
+ "indian red"
+ "RosyBrown"
+ "rosy brown"
+ "DarkGoldenrod"
+ "dark goldenrod"
"goldenrod"
- "Goldenrod"
- "green"
- "Green"
- "dark green"
- "DarkGreen"
- "dark olive green"
- "DarkOliveGreen"
- "forest green"
+ "LightGoldenrod"
+ "light goldenrod"
+ "gold"
+ "yellow"
+ "LightYellow"
+ "light yellow"
+ "LightGoldenrodYellow"
+ "light goldenrod yellow"
+ "PaleGoldenrod"
+ "pale goldenrod"
+ "khaki"
+ "DarkKhaki"
+ "dark khaki"
+ "OliveDrab"
+ "olive drab"
"ForestGreen"
- "lime green"
+ "forest green"
+ "YellowGreen"
+ "yellow green"
"LimeGreen"
- "medium sea green"
- "MediumSeaGreen"
- "medium spring green"
+ "lime green"
+ "GreenYellow"
+ "green yellow"
"MediumSpringGreen"
- "pale green"
+ "medium spring green"
+ "chartreuse"
+ "green"
+ "LawnGreen"
+ "lawn green"
+ "SpringGreen"
+ "spring green"
"PaleGreen"
- "sea green"
+ "pale green"
+ "LightSeaGreen"
+ "light sea green"
+ "MediumSeaGreen"
+ "medium 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"
+ "sea green"
+ "DarkSeaGreen"
+ "dark sea green"
+ "DarkOliveGreen"
+ "dark olive green"
+ "DarkGreen"
+ "dark green"
+ "aquamarine"
+ "MediumAquamarine"
+ "medium aquamarine"
+ "CadetBlue"
+ "cadet blue"
+ "LightCyan"
+ "light cyan"
+ "cyan"
"turquoise"
- "Turquoise"
- "dark turquoise"
- "DarkTurquoise"
- "medium turquoise"
"MediumTurquoise"
- "violet"
- "Violet"
- "blue violet"
- "BlueViolet"
- "wheat"
- "Wheat"
+ "medium turquoise"
+ "DarkTurquoise"
+ "dark turquoise"
+ "PaleTurquoise"
+ "pale turquoise"
+ "PowderBlue"
+ "powder blue"
+ "LightBlue"
+ "light blue"
+ "LightSteelBlue"
+ "light steel blue"
+ "SteelBlue"
+ "steel blue"
+ "LightSkyBlue"
+ "light sky blue"
+ "SkyBlue"
+ "sky blue"
+ "DeepSkyBlue"
+ "deep sky blue"
+ "DodgerBlue"
+ "dodger blue"
+ "blue"
+ "RoyalBlue"
+ "royal blue"
+ "MediumBlue"
+ "medium blue"
+ "LightSlateBlue"
+ "light slate blue"
+ "MediumSlateBlue"
+ "medium slate blue"
+ "SlateBlue"
+ "slate blue"
+ "DarkSlateBlue"
+ "dark slate blue"
+ "CornflowerBlue"
+ "cornflower blue"
+ "NavyBlue"
+ "navy blue"
+ "navy"
+ "MidnightBlue"
+ "midnight blue"
+ "LightGray"
+ "light gray"
+ "LightGrey"
+ "light grey"
+ "grey"
+ "gray"
+ "LightSlateGrey"
+ "light slate grey"
+ "LightSlateGray"
+ "light slate gray"
+ "SlateGrey"
+ "slate grey"
+ "SlateGray"
+ "slate gray"
+ "DimGrey"
+ "dim grey"
+ "DimGray"
+ "dim gray"
+ "DarkSlateGrey"
+ "dark slate grey"
+ "DarkSlateGray"
+ "dark slate gray"
+ "black"
"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."
+ "MistyRose"
+ "misty rose"
+ "LavenderBlush"
+ "lavender blush"
+ "lavender"
+ "AliceBlue"
+ "alice blue"
+ "azure"
+ "MintCream"
+ "mint cream"
+ "honeydew"
+ "seashell"
+ "LemonChiffon"
+ "lemon chiffon"
+ "ivory"
+ "cornsilk"
+ "moccasin"
+ "NavajoWhite"
+ "navajo white"
+ "PeachPuff"
+ "peach puff"
+ "bisque"
+ "BlanchedAlmond"
+ "blanched almond"
+ "PapayaWhip"
+ "papaya whip"
+ "AntiqueWhite"
+ "antique white"
+ "linen"
+ "OldLace"
+ "old lace"
+ "FloralWhite"
+ "floral white"
+ "gainsboro"
+ "WhiteSmoke"
+ "white smoke"
+ "GhostWhite"
+ "ghost white"
+ "snow")
+ "The list of X colors from the `rgb.txt' file.
+XConsortium: rgb.txt,v 10.41 94/02/20 18:39:36 rws Exp")
+
+(defun xw-defined-colors (&optional frame)
+ "Internal function called by `defined-colors', which see."
(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))))
+ (let ((defined-colors nil))
+ (dolist (this-color (or (mapcar 'car w32-color-map) x-colors))
+ (and (color-supported-p this-color frame t)
+ (push this-color defined-colors)))
defined-colors))
\f
+\f
;;;; Function keys
-(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)))
+;;; make f10 activate the real menubar rather than the mini-buffer menu
+;;; navigation feature.
+(global-set-key [f10] (lambda ()
+ (interactive) (w32-send-sys-command ?\xf100)))
(substitute-key-definition 'suspend-emacs 'iconify-or-deiconify-frame
global-map)
-;; Map certain keypad keys into ASCII characters
-;; that people usually expect.
-(define-key function-key-map [tab] [?\t])
-(define-key function-key-map [linefeed] [?\n])
-(define-key function-key-map [clear] [11])
-(define-key function-key-map [return] [13])
-(define-key function-key-map [escape] [?\e])
-(define-key function-key-map [M-tab] [?\M-\t])
-(define-key function-key-map [M-linefeed] [?\M-\n])
-(define-key function-key-map [M-clear] [?\M-\013])
-(define-key function-key-map [M-return] [?\M-\015])
-(define-key function-key-map [M-escape] [?\M-\e])
-
-;; These don't do the right thing (voelker)
-;(define-key function-key-map [backspace] [127])
-;(define-key function-key-map [delete] [127])
-;(define-key function-key-map [M-backspace] [?\M-\d])
-;(define-key function-key-map [M-delete] [?\M-\d])
-
-;; These tell read-char how to convert
-;; these special chars to ASCII.
-(put 'tab 'ascii-character ?\t)
-(put 'linefeed 'ascii-character ?\n)
-(put 'clear 'ascii-character 12)
-(put 'return 'ascii-character 13)
-(put 'escape 'ascii-character ?\e)
-;; These don't seem to be necessary (voelker)
-;(put 'backspace 'ascii-character 127)
-;(put 'delete 'ascii-character 127)
-
-\f
-;;;; Selections and cut buffers
-
-;;; We keep track of the last text selected here, so we can check the
-;;; current selection against it, and avoid passing back our own text
-;;; from x-cut-buffer-or-selection-value.
-(defvar x-last-selected-text nil)
-
-;;; It is said that overlarge strings are slow to put into the cut buffer.
-;;; Note this value is overridden below.
-(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))
-
-;;; Return the value of the current selection.
-;;; Consult the selection, then the cut buffer. Treat empty strings
-;;; as if they were unset.
-(defun x-get-selection-value ()
- (if x-select-enable-clipboard
- (let (text)
- ;; Don't die if x-get-selection signals an error.
- (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)
- ;; Record the newer string, so subsequent calls can use the 'eq' test.
- (setq x-last-selected-text text)
- nil)
- (t
- (setq x-last-selected-text text))))))
\f
;;; Do the actual Windows setup here; the above code just defines
;;; functions and variables that we use now.
;;; Make sure we have a valid resource name.
(or (stringp x-resource-name)
- (let (i)
- (setq x-resource-name (invocation-name))
-
- ;; Change any . or * characters in x-resource-name to hyphens,
- ;; so as not to choke when we use it in X resource queries.
- (while (setq i (string-match "[.*]" x-resource-name))
- (aset x-resource-name i ?-))))
+ (setq x-resource-name
+ ;; Change any . or * characters in x-resource-name to hyphens,
+ ;; so as not to choke when we use it in X resource queries.
+ (replace-regexp-in-string "[.*]" "-" (invocation-name))))
;; For the benefit of older Emacses (19.27 and earlier) that are sharing
;; the same lisp directory, don't pass the third argument unless we seem
;; This has ,? to match both on Sunos and on Solaris.
(menu-bar-enable-clipboard)
+;; W32 systems have different fonts than commonly found on X, so
+;; we define our own standard fontset here.
+(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.")
+
+;; Conditional on new-fontset so bootstrapping works on non-GUI compiles
+(if (fboundp 'new-fontset)
+ (progn
+ ;; Setup the default fontset.
+ (setup-default-fontset)
+ ;; Create the standard fontset.
+ (create-fontset-from-fontset-spec w32-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-fontset-from-ascii-font font
+ resolved-name "startup"))))))
+
;; Apply a geometry resource to the initial frame. Put it at the end
;; of the alist, so that anything specified on the command line takes
;; precedence.
(setq initial-frame-alist (append initial-frame-alist parsed))
;; The size parms apply to all frames.
(if (assq 'height parsed)
- (setq default-frame-alist
- (cons (cons 'height (cdr (assq 'height parsed)))
- default-frame-alist)))
+ (push (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))))))
+ (push (cons 'width (cdr (assq 'width parsed)))
+ default-frame-alist)))))
;; Check the reverseVideo resource.
(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)))))
-
-;; Set x-selection-timeout, measured in milliseconds.
-(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))))
+ (if (and rv (string-match "^\\(true\\|yes\\|on\\)$" rv))
+ (push '(reverse . t) default-frame-alist))))
(defun x-win-suspend-error ()
- (error "Suspending an emacs running under Win32 makes no sense"))
+ "Report an error when a suspend is attempted."
+ (error "Suspending an Emacs running under W32 makes no sense"))
(add-hook 'suspend-hook 'x-win-suspend-error)
-;;; Arrange for the kill and yank functions to set and check the clipboard.
-(setq interprogram-cut-function 'x-select-text)
-(setq interprogram-paste-function 'x-get-selection-value)
-
;;; Turn off window-splitting optimization; w32 is usually fast enough
;;; that this is only annoying.
(setq split-window-keep-point t)
;; Don't show the frame name; that's redundant.
-(setq-default mode-line-buffer-identification '("Emacs: %12b"))
+(setq-default mode-line-frame-identification " ")
;;; Set to a system sound if you want a fancy bell.
(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 ": ")))
+ (prompt (concat "Set " what " of face "))
+ (face (read-face-name 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
- (if (fboundp fn-win)
- (funcall fn-win)
- (if bool
- (y-or-n-p (concat "Should face " (symbol-name face)
- " be " bool "? "))
- (read-string (concat prompt " " (symbol-name face) " to: ")
- default)))))
- (list face (if (equal value "") nil value))))
-
-;; Redefine the font selection to use the standard Win32 dialog
+ 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))))
+
+;;; Enable Japanese fonts on Windows to be used by default.
+(set-fontset-font nil (make-char 'katakana-jisx0201) '("*" . "JISX0208-SJIS"))
+(set-fontset-font nil (make-char 'latin-jisx0201) '("*" . "JISX0208-SJIS"))
+(set-fontset-font nil (make-char 'japanese-jisx0208) '("*" . "JISX0208-SJIS"))
+(set-fontset-font nil (make-char 'japanese-jisx0208-1978) '("*" . "JISX0208-SJIS"))
(defun mouse-set-font (&rest fonts)
- (interactive)
- (set-default-font (w32-select-font)))
-
-;;; win32-win.el ends here
+ "Select a font.
+If `w32-use-w32-font-dialog' is non-nil (the default), use the Windows
+font dialog to get the matching FONTS. Otherwise use a pop-up menu
+\(like Emacs on other platforms) initialized with the fonts in
+`w32-fixed-font-alist'."
+ (interactive
+ (if w32-use-w32-font-dialog
+ (let ((chosen-font (w32-select-font (selected-frame)
+ w32-list-proportional-fonts)))
+ (and chosen-font (list chosen-font)))
+ (x-popup-menu
+ last-nonmenu-event
+ ;; Append list of fontsets currently defined.
+ ;; Conditional on new-fontset so bootstrapping works on non-GUI compiles
+ (if (fboundp 'new-fontset)
+ (append w32-fixed-font-alist (list (generate-fontset-menu)))))))
+ (if fonts
+ (let (font)
+ (while fonts
+ (condition-case nil
+ (progn
+ (setq font (car fonts))
+ (set-default-font font)
+ (setq fonts nil))
+ (error (setq fonts (cdr fonts)))))
+ (if (null font)
+ (error "Font not found")))))
+
+;;; Set default known names for image libraries
+(setq image-library-alist
+ '((xpm "xpm4.dll" "libXpm-nox4.dll" "libxpm.dll")
+ (png "libpng13d.dll" "libpng13.dll" "libpng12d.dll" "libpng12.dll" "libpng.dll")
+ (jpeg "jpeg62.dll" "libjpeg.dll" "jpeg-62.dll" "jpeg.dll")
+ (tiff "libtiff3.dll" "libtiff.dll")
+ (gif "libungif.dll")))
+
+;; arch-tag: 69fb1701-28c2-4890-b351-3d1fe4b4f166
+;;; w32-win.el ends here