-;;; 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.
;;; 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 'faces)
(require 'select)
(require 'menu-bar)
-
-;; Disable until scrollbars are fully functional
-(scroll-bar-mode nil)
+(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 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))))
+
+;; The following definition is used for debugging.
+;(defun w32-handle-scroll-bar-event (event) (interactive "e") (princ 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)
(defvar x-invocation-args)
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))
(setq defined-colors (cons this-color defined-colors))))
defined-colors))
\f
+\f
;;;; 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)
(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 [backspace] [127])
-(define-key function-key-map [delete] [127])
-(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-backspace] [?\M-\d])
-(define-key function-key-map [M-delete] [?\M-\d])
-(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 tell read-char how to convert
-;; these special chars to ASCII.
-(put 'backspace 'ascii-character 127)
-(put 'delete 'ascii-character 127)
-(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)
-
\f
;;;; Selections and cut buffers
(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.
;;; Consult the selection, then the cut buffer. Treat empty strings
(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))
- text)))
+ (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.
(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)
(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)))
(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)))
+ (interactive
+ (if w32-use-w32-font-dialog
+ (list (w32-select-font))
+ (x-popup-menu
+ last-nonmenu-event
+ ;; Append list of fontsets currently defined.
+ (append w32-fixed-font-alist (list (generate-fontset-menu))))))
+ (if fonts
+ (let (font)
+ (while fonts
+ (condition-case nil
+ (progn
+ (set-default-font (car fonts))
+ (setq font (car fonts))
+ (setq fonts nil))
+ (error
+ (setq fonts (cdr fonts)))))
+ (if (null font)
+ (error "Font not found")))))
+
+;;; w32-win.el ends here
+;;; The code in w32-init-fontsets requires a w32 frame to have been created,
+;;; which is not the case when this file is loaded during startup.
+(add-hook 'before-init-hook 'w32-init-fontsets)
+
+(defun w32-init-fontsets ()
+ "Initialize standard fontsets for w32."
+ (if (fboundp 'new-fontset)
+ (progn
+ ;; Create the standard fontset.
+ (create-fontset-from-fontset-spec standard-fontset-spec t)
+
+ ;; Create fontset specified in X resources "Fontset-N" (N is 0, 1, ...).
+ (create-fontset-from-x-resource)
+
+ ;; Try to create a fontset from a font specification which comes
+ ;; from initial-frame-alist, default-frame-alist, or X resource.
+ ;; A font specification in command line argument (i.e. -fn XXXX)
+ ;; should be already in default-frame-alist as a `font'
+ ;; parameter. However, any font specifications in site-start
+ ;; library, user's init file (.emacs), and default.el are not
+ ;; yet handled here.
+
+ (let ((font (or (cdr (assq 'font initial-frame-alist))
+ (cdr (assq 'font default-frame-alist))
+ (x-get-resource "font" "Font")))
+ xlfd-fields resolved-name)
+ (if (and font
+ (not (query-fontset font))
+ (setq resolved-name (x-resolve-font-name font))
+ (setq xlfd-fields (x-decompose-font-name font)))
+ (if (string= "fontset"
+ (aref xlfd-fields xlfd-regexp-registry-subnum))
+ (new-fontset font (x-complement-fontset-spec xlfd-fields nil))
+ ;; Create a fontset from FONT. The fontset name is
+ ;; generated from FONT. Create style variants of the
+ ;; fontset too. Font names in the variants are
+ ;; generated automatially unless X resources
+ ;; XXX.attribyteFont explicitly specify them.
+ (let ((styles (mapcar 'car x-style-funcs-alist))
+ (faces '(bold italic bold-italic))
+ face face-font fontset fontset-spec)
+ (while faces
+ (setq face (car faces))
+ (setq face-font (x-get-resource (concat (symbol-name face)
+ ".attributeFont")
+ "Face.AttributeFont"))
+ (if face-font
+ (setq styles (cons (cons face face-font)
+ (delq face styles))))
+ (setq faces (cdr faces)))
+ (aset xlfd-fields xlfd-regexp-foundry-subnum nil)
+ (aset xlfd-fields xlfd-regexp-family-subnum nil)
+ (aset xlfd-fields xlfd-regexp-registry-subnum "fontset")
+ (aset xlfd-fields xlfd-regexp-encoding-subnum "startup")
+ ;; The fontset name should have concrete values in
+ ;; weight and slant field.
+ (let ((weight (aref xlfd-fields xlfd-regexp-weight-subnum))
+ (slant (aref xlfd-fields xlfd-regexp-slant-subnum))
+ xlfd-temp)
+ (if (or (not weight) (string-match "[*?]*" weight))
+ (progn
+ (setq xlfd-temp (x-decompose-font-name resolved-name))
+ (aset xlfd-fields xlfd-regexp-weight-subnum
+ (aref xlfd-temp xlfd-regexp-weight-subnum))))
+ (if (or (not slant) (string-match "[*?]*" slant))
+ (progn
+ (or xlfd-temp
+ (setq xlfd-temp
+ (x-decompose-font-name resolved-name)))
+ (aset xlfd-fields xlfd-regexp-slant-subnum
+ (aref xlfd-temp xlfd-regexp-slant-subnum)))))
+ (setq fontset (x-compose-font-name xlfd-fields))
+ (create-fontset-from-fontset-spec
+ (concat fontset ", ascii:" font) styles)
+ )))))))
-;;; win32-win.el ends here