X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/ebb0719c46bf2a7856696ec283f6d1159093c79e..0064ab85ad90a26302b4841d8ee5601be2cb08a5:/lisp/term/w32-win.el diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 3d42104e88..9593e79f53 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -1,4 +1,4 @@ -;;; 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. @@ -24,10 +24,10 @@ ;;; 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). @@ -67,8 +67,8 @@ ;; 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) @@ -76,40 +76,105 @@ (require 'faces) (require 'select) (require 'menu-bar) +(if (fboundp 'new-fontset) + (require 'fontset)) ;; 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. -(defun win32-handle-scroll-bar-event (event) - "Handle Win32 scroll bar events to do normal Window style scrolling." +(defun w32-handle-scroll-bar-event (event) + "Handle W32 scroll bar events to do normal Window style scrolling." (interactive "e") - (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-drag-1 event)) - ((eq bar-part 'below-handle) - (scroll-up)) - ((eq bar-part 'down) - (scroll-up 1)) - )))) + (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)))) ;; The following definition is used for debugging. -;(defun win32-handle-scroll-bar-event (event) (interactive "e") (princ event)) +;(defun w32-handle-scroll-bar-event (event) (interactive "e") (princ event)) -(global-set-key [vertical-scroll-bar mouse-1] 'win32-handle-scroll-bar-event) +(global-set-key [vertical-scroll-bar mouse-1] 'w32-handle-scroll-bar-event) ;; (scroll-bar-mode nil) +(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))) + +;; for scroll-in-place.el, this way the -scroll-line and -scroll-screen +;; commands won't interact +(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))) + +;; Bind the mouse-wheel event: +(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") + (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))))) + +;; 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) + +;; 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) @@ -447,9 +512,11 @@ This returns ARGS with the arguments that have been processed removed." 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 ((all-colors x-colors) - (this-color nil) - (defined-colors nil)) + (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)) @@ -457,8 +524,14 @@ The value may be different for frames on different X displays." (setq defined-colors (cons this-color defined-colors)))) defined-colors)) + ;;;; Function keys +;;; 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))) + (defun iconify-or-deiconify-frame () "Iconify the selected frame, or deiconify if it's currently an icon." (interactive) @@ -469,36 +542,6 @@ The value may be different for frames on different X displays." (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) - ;;;; Selections and cut buffers @@ -518,7 +561,7 @@ This is in addition to the primary selection.") (defun x-select-text (text &optional push) (if x-select-enable-clipboard - (win32-set-clipboard-data text)) + (w32-set-clipboard-data text)) (setq x-last-selected-text text)) ;;; Return the value of the current selection. @@ -529,8 +572,8 @@ This is in addition to the primary selection.") (let (text) ;; Don't die if x-get-selection signals an error. (condition-case c - (setq text (win32-get-clipboard-data)) - (error (message "win32-get-clipboard-data:%s" 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) @@ -541,6 +584,9 @@ This is in addition to the primary selection.") nil) (t (setq x-last-selected-text text)))))) + +(defalias 'x-cut-buffer-or-selection-value 'x-get-selection-value) + ;;; Do the actual Windows setup here; the above code just defines ;;; functions and variables that we use now. @@ -573,10 +619,105 @@ This is in addition to the primary selection.") (setq x-cut-buffer-max (min (- (/ (x-server-max-request-size) 2) 100) x-cut-buffer-max)) -;; Win32 expects the menu bar cut and paste commands to use the clipboard. +;; 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. +(defvar w32-standard-fontset-spec + "-*-Courier New-normal-r-*-*-13-*-*-*-c-*-fontset-standard, + latin-iso8859-2:-*-Courier New CE-normal-r-*-*-13-*-*-*-c-*-iso8859-2, + latin-iso8859-3:-*-Courier New Tur-normal-r-*-*-13-*-*-*-c-*-iso8859-3, + latin-iso8859-4:-*-Courier New Baltic-normal-r-*-*-13-*-*-*-c-*-iso8859-4, + cyrillic-iso8859-5:-*-Courier New Cyr-normal-r-*-*-13-*-*-*-c-*-iso8859-5, + greek-iso8859-7:-*-Courier New Greek-normal-r-*-*-13-*-*-*-c-*-iso8859-7" + "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 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 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) + ))))) + ;; This cannot be run yet, as creating fontsets requires a + ;; Window to be initialised so the fonts can be listed. + ;; Add it to a hook so it gets run later. + (add-hook 'before-init-hook 'w32-create-initial-fontsets) + )) + ;; 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. @@ -618,24 +759,24 @@ This is in addition to the primary selection.") (setq x-selection-timeout (string-to-number res-selection-timeout)))) (defun x-win-suspend-error () - (error "Suspending an emacs running under Win32 makes no sense")) + (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; win32 is usually fast enough +;;; 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) -;; Remap some functions to call win32 common dialogs +;; Remap some functions to call w32 common dialogs (defun internal-face-interactive (what &optional bool) (let* ((fn (intern (concat "face-" what))) @@ -645,20 +786,127 @@ This is in addition to the primary selection.") (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 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)))) + +;; 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 (win32-select-font))) - -;;; win32-win.el ends here + (interactive + (if w32-use-w32-font-dialog + (list (w32-select-font)) + (x-popup-menu + last-nonmenu-event + ;; Append list of fontsets currently defined. + (if (fboundp 'new-fontset) + (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