diff options
Diffstat (limited to 'lisp/term/w32-win.el')
| -rw-r--r-- | lisp/term/w32-win.el | 299 |
1 files changed, 128 insertions, 171 deletions
diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 0ba22896daf..62fd6edd919 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -68,8 +68,8 @@ ;; An alist of X options and the function which handles them. See ;; ../startup.el. -(if (not (eq window-system 'w32)) - (error "%s: Loading w32-win.el but not compiled for w32" (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) @@ -78,9 +78,18 @@ (require 'select) (require 'menu-bar) (require 'dnd) -(require 'code-pages) +(require 'w32-vars) + +;; Keep an obsolete alias for w32-focus-frame in case it is used by code +;; outside Emacs. +(define-obsolete-function-alias 'w32-focus-frame 'x-focus-frame "23.1") (defvar xlfd-regexp-registry-subnum) +(defvar w32-color-map) ;; defined in w32fns.c + +(declare-function w32-send-sys-command "w32fns.c") +(declare-function w32-select-font "w32fns.c") +(declare-function set-message-beep "w32console.c") ;; Conditional on new-fontset so bootstrapping works on non-GUI compiles (if (fboundp 'new-fontset) @@ -89,9 +98,6 @@ ;; The following definition is used for debugging scroll bar events. ;(defun w32-handle-scroll-bar-event (event) (interactive "e") (princ 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") @@ -111,7 +117,7 @@ Switch to a buffer editing the last file dropped." (y (cdr coords))) (if (and (> x 0) (> y 0)) (set-frame-selected-window nil window)) - (mapcar (lambda (file-name) + (mapc (lambda (file-name) (let ((f (subst-char-in-string ?\\ ?/ file-name)) (coding (or file-name-coding-system default-file-name-coding-system))) @@ -1039,58 +1045,19 @@ XConsortium: rgb.txt,v 10.41 94/02/20 18:39:36 rws Exp") ;;;; Function keys -;;; make f10 activate the real menubar rather than the mini-buffer menu -;;; navigation feature. -(defun menu-bar-open (&optional frame) - "Start key navigation of the menu bar in FRAME. - -This initially activates the first menu-bar item, and you can then navigate -with the arrow keys, select a menu entry with the Return key or cancel with -the Escape key. If FRAME has no menu bar, this function does nothing. - -If FRAME is nil or not given, use the selected frame." - (interactive "i") - (w32-send-sys-command ?\xf100 frame)) -; -(global-set-key [f10] 'menu-bar-open) - -(substitute-key-definition 'suspend-emacs 'iconify-or-deiconify-frame - global-map) - -(define-key function-key-map [S-tab] [backtab]) - + ;;; make f10 activate the real menubar rather than the mini-buffer menu + ;;; navigation feature. + (defun menu-bar-open (&optional frame) + "Start key navigation of the menu bar in FRAME. + + This initially activates the first menu-bar item, and you can then navigate + with the arrow keys, select a menu entry with the Return key or cancel with + the Escape key. If FRAME has no menu bar, this function does nothing. + + If FRAME is nil or not given, use the selected frame." + (interactive "i") + (w32-send-sys-command ?\xf100 frame)) -;;; Do the actual Windows setup here; the above code just defines -;;; functions and variables that we use now. - -(setq command-line-args (x-handle-args command-line-args)) - -;;; Make sure we have a valid resource name. -(or (stringp x-resource-name) - (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 -;; to have the multi-display support. -(if (fboundp 'x-close-connection) - (x-open-connection "" - x-command-line-resources - ;; Exit Emacs with fatal error if this fails. - 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)) - -;; W32 expects the menu bar cut and paste commands to use the clipboard. -;; 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. @@ -1103,120 +1070,10 @@ European languages which are distributed with Windows as 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) - ;; 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")) - ;; 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. -(let* ((res-geometry (x-get-resource "geometry" "Geometry")) - parsed) - (if res-geometry - (progn - (setq parsed (x-parse-geometry res-geometry)) - ;; If the resource specifies a position, - ;; call the position and size "user-specified". - (if (or (assq 'top parsed) (assq 'left parsed)) - (setq parsed (cons '(user-position . t) - (cons '(user-size . t) parsed)))) - ;; All geometry parms apply to the initial frame. - (setq initial-frame-alist (append initial-frame-alist parsed)) - ;; The size parms apply to all frames. - (if (assq 'height parsed) - (push (cons 'height (cdr (assq 'height parsed))) - default-frame-alist)) - (if (assq 'width parsed) - (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)) - (push '(reverse . t) default-frame-alist)))) - (defun x-win-suspend-error () "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) - -;;; 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-frame-identification " ") - -;;; Set to a system sound if you want a fancy bell. -(set-message-beep 'ok) - -;; Remap some functions to call w32 common dialogs - -(defun internal-face-interactive (what &optional bool) - (let* ((fn (intern (concat "face-" what))) - (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) - (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)))) + (defun mouse-set-font (&rest fonts) "Select an Emacs font from a list of known good fonts and fontsets. @@ -1238,7 +1095,7 @@ pop-up menu are unaffected by `w32-list-proportional-fonts')." ;; 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))))))) + (append w32-fixed-font-alist (list (generate-fontset-menu))))))) (if fonts (let (font) (while fonts @@ -1259,7 +1116,107 @@ pop-up menu are unaffected by `w32-list-proportional-fonts')." "libpng13d.dll" "libpng13.dll") (jpeg "jpeg62.dll" "libjpeg.dll" "jpeg-62.dll" "jpeg.dll") (tiff "libtiff3.dll" "libtiff.dll") - (gif "giflib4.dll" "libungif4.dll" "libungif.dll"))) + (gif "giflib4.dll" "libungif4.dll" "libungif.dll") + (svg "librsvg-2-2.dll") + (gdk-pixbuf "libgdk_pixbuf-2.0-0.dll") + (glib "libglib-2.0-0.dll"))) + +;;; multi-tty support +(defvar w32-initialized nil + "Non-nil if the w32 window system has been initialized.") + +(defun w32-initialize-window-system () + "Initialize Emacs for W32 GUI frames." + + ;; Do the actual Windows setup here; the above code just defines + ;; functions and variables that we use now. + + (setq command-line-args (x-handle-args command-line-args)) + + ;; Make sure we have a valid resource name. + (or (stringp x-resource-name) + (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)))) + + (x-open-connection "" x-command-line-resources + ;; Exit with a fatal error if this fails and we + ;; are the initial display + (eq initial-window-system 'w32)) + + ;; Setup the default fontset. + (setup-default-fontset) + + ;; Enable Japanese fonts on Windows to be used by default. + (set-fontset-font t (make-char 'katakana-jisx0201) + '("*" . "JISX0208-SJIS")) + (set-fontset-font t (make-char 'latin-jisx0201) + '("*" . "JISX0208-SJIS")) + (set-fontset-font t (make-char 'japanese-jisx0208) + '("*" . "JISX0208-SJIS")) + (set-fontset-font t (make-char 'japanese-jisx0208-1978) + '("*" . "JISX0208-SJIS")) + + ;; 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) + + ;; 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. + (let* ((res-geometry (x-get-resource "geometry" "Geometry")) + parsed) + (if res-geometry + (progn + (setq parsed (x-parse-geometry res-geometry)) + ;; If the resource specifies a position, + ;; call the position and size "user-specified". + (if (or (assq 'top parsed) (assq 'left parsed)) + (setq parsed (cons '(user-position . t) + (cons '(user-size . t) parsed)))) + ;; All geometry parms apply to the initial frame. + (setq initial-frame-alist (append initial-frame-alist parsed)) + ;; The size parms apply to all frames. + (if (assq 'height parsed) + (push (cons 'height (cdr (assq 'height parsed))) + default-frame-alist)) + (if (assq 'width parsed) + (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)) + (push '(reverse . t) default-frame-alist)))) + + ;; Don't let Emacs suspend under w32 gui + (add-hook 'suspend-hook 'x-win-suspend-error) + + ;; Turn off window-splitting optimization; w32 is usually fast enough + ;; that this is only annoying. + (setq split-window-keep-point t) + + ;; Turn on support for mouse wheels + (mouse-wheel-mode 1) + + ;; W32 expects the menu bar cut and paste commands to use the clipboard. + (menu-bar-enable-clipboard) + + ;; Don't show the frame name; that's redundant. + (setq-default mode-line-frame-identification " ") + + ;; Set to a system sound if you want a fancy bell. + (set-message-beep 'ok) + (setq w32-initialized t)) + +(add-to-list 'handle-args-function-alist '(w32 . x-handle-args)) +(add-to-list 'frame-creation-function-alist '(w32 . x-create-frame-with-faces)) +(add-to-list 'window-system-initialization-alist '(w32 . w32-initialize-window-system)) + +(provide 'w32-win) ;; arch-tag: 69fb1701-28c2-4890-b351-3d1fe4b4f166 ;;; w32-win.el ends here |