code.delx.au - gnu-emacs/blob - lisp/term/w32-win.el

   1 ;;; w32-win.el --- parse switches controlling interface with W32 window system.
   2
   3 ;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
   4
   5 ;; Author: Kevin Gallo
   6 ;; Keywords: terminals
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; w32-win.el:  this file is loaded from ../lisp/startup.el when it recognizes
  28 ;; that W32 windows are to be used.  Command line switches are parsed and those
  29 ;; pertaining to W32 are processed and removed from the command line.  The
  30 ;; W32 display is opened and hooks are set for popping up the initial window.
  31
  32 ;; startup.el will then examine startup files, and eventually call the hooks
  33 ;; which create the first window (s).
  34
  35 ;;; Code:
  36 \f
  37
  38 ;; These are the standard X switches from the Xt Initialize.c file of
  39 ;; Release 4.
  40
  41 ;; Command line         Resource Manager string
  42
  43 ;; +rv                  *reverseVideo
  44 ;; +synchronous         *synchronous
  45 ;; -background          *background
  46 ;; -bd                  *borderColor
  47 ;; -bg                  *background
  48 ;; -bordercolor         *borderColor
  49 ;; -borderwidth         .borderWidth
  50 ;; -bw                  .borderWidth
  51 ;; -display             .display
  52 ;; -fg                  *foreground
  53 ;; -fn                  *font
  54 ;; -font                *font
  55 ;; -foreground          *foreground
  56 ;; -geometry            .geometry
  57 ;; -i                   .iconType
  58 ;; -itype               .iconType
  59 ;; -iconic              .iconic
  60 ;; -name                .name
  61 ;; -reverse             *reverseVideo
  62 ;; -rv                  *reverseVideo
  63 ;; -selectionTimeout    .selectionTimeout
  64 ;; -synchronous         *synchronous
  65 ;; -xrm
  66
  67 ;; An alist of X options and the function which handles them.  See
  68 ;; ../startup.el.
  69
  70 (if (not (eq window-system 'w32))
  71     (error "%s: Loading w32-win.el but not compiled for w32" (invocation-name)))
  72
  73 (require 'frame)
  74 (require 'mouse)
  75 (require 'scroll-bar)
  76 (require 'faces)
  77 (require 'select)
  78 (require 'menu-bar)
  79
  80 ;; Because Windows scrollbars look and act quite differently compared
  81 ;; with the standard X scroll-bars, we don't try to use the normal
  82 ;; scroll bar routines.
  83
  84 (defun w32-handle-scroll-bar-event (event)
  85   "Handle W32 scroll bar events to do normal Window style scrolling."
  86   (interactive "e")
  87   (let ((old-window (selected-window)))
  88     (unwind-protect
  89         (let* ((position (event-start event))
  90                (window (nth 0 position))
  91                (portion-whole (nth 2 position))
  92                (bar-part (nth 4 position)))
  93           (save-excursion
  94             (select-window window)
  95             (cond
  96              ((eq bar-part 'up)
  97               (goto-char (window-start window))
  98               (scroll-down 1))
  99              ((eq bar-part 'above-handle)
 100               (scroll-down))
 101              ((eq bar-part 'handle)
 102               (scroll-bar-maybe-set-window-start event))
 103              ((eq bar-part 'below-handle)
 104               (scroll-up))
 105              ((eq bar-part 'down)
 106               (goto-char (window-start window))
 107               (scroll-up 1))
 108              )))
 109       (select-window old-window))))
 110
 111 ;; The following definition is used for debugging.
 112 ;(defun w32-handle-scroll-bar-event (event) (interactive "e") (princ event))
 113
 114 (global-set-key [vertical-scroll-bar mouse-1] 'w32-handle-scroll-bar-event)
 115
 116 ;; (scroll-bar-mode nil)
 117
 118 (defvar mouse-wheel-scroll-amount 4
 119   "*Number of lines to scroll per click of the mouse wheel.")
 120
 121 (defun mouse-wheel-scroll-line (event)
 122   "Scroll the current buffer by `mouse-wheel-scroll-amount'."
 123   (interactive "e")
 124   (condition-case nil
 125       (if (< (car (cdr (cdr event))) 0)
 126           (scroll-up mouse-wheel-scroll-amount)
 127         (scroll-down mouse-wheel-scroll-amount))
 128     (error nil)))
 129
 130 ;; for scroll-in-place.el, this way the -scroll-line and -scroll-screen
 131 ;; commands won't interact
 132 (setq scroll-command-groups (list '(mouse-wheel-scroll-line)))
 133
 134 (defun mouse-wheel-scroll-screen (event)
 135   "Scroll the current buffer by `mouse-wheel-scroll-amount'."
 136   (interactive "e")
 137   (condition-case nil
 138       (if (< (car (cdr (cdr event))) 0)
 139           (scroll-up)
 140         (scroll-down))
 141     (error nil)))
 142
 143 ;; Bind the mouse-wheel event:
 144 (global-set-key [mouse-wheel] 'mouse-wheel-scroll-line)
 145 (global-set-key [C-mouse-wheel] 'mouse-wheel-scroll-screen)
 146
 147 (defvar x-invocation-args)
 148
 149 (defvar x-command-line-resources nil)
 150
 151 (defconst x-option-alist
 152   '(("-bw" .    x-handle-numeric-switch)
 153     ("-d" .             x-handle-display)
 154     ("-display" .       x-handle-display)
 155     ("-name" .  x-handle-name-rn-switch)
 156     ("-rn" .    x-handle-name-rn-switch)
 157     ("-T" .             x-handle-switch)
 158     ("-r" .             x-handle-switch)
 159     ("-rv" .    x-handle-switch)
 160     ("-reverse" .       x-handle-switch)
 161     ("-fn" .    x-handle-switch)
 162     ("-font" .  x-handle-switch)
 163     ("-ib" .    x-handle-numeric-switch)
 164     ("-g" .             x-handle-geometry)
 165     ("-geometry" .      x-handle-geometry)
 166     ("-fg" .    x-handle-switch)
 167     ("-foreground".     x-handle-switch)
 168     ("-bg" .    x-handle-switch)
 169     ("-background".     x-handle-switch)
 170     ("-ms" .    x-handle-switch)
 171     ("-itype" . x-handle-switch)
 172     ("-i"       .       x-handle-switch)
 173     ("-iconic" .        x-handle-iconic)
 174     ("-xrm" .       x-handle-xrm-switch)
 175     ("-cr" .    x-handle-switch)
 176     ("-vb" .    x-handle-switch)
 177     ("-hb" .    x-handle-switch)
 178     ("-bd" .    x-handle-switch)))
 179
 180 (defconst x-long-option-alist
 181   '(("--border-width" . "-bw")
 182     ("--display" .      "-d")
 183     ("--name" .         "-name")
 184     ("--title" .        "-T")
 185     ("--reverse-video" . "-reverse")
 186     ("--font" .         "-font")
 187     ("--internal-border" . "-ib")
 188     ("--geometry" .     "-geometry")
 189     ("--foreground-color" . "-fg")
 190     ("--background-color" . "-bg")
 191     ("--mouse-color" .  "-ms")
 192     ("--icon-type" .    "-itype")
 193     ("--iconic" .       "-iconic")
 194     ("--xrm" .          "-xrm")
 195     ("--cursor-color" . "-cr")
 196     ("--vertical-scroll-bars" . "-vb")
 197     ("--border-color" . "-bd")))
 198
 199 (defconst x-switch-definitions
 200   '(("-name" name)
 201     ("-T" name)
 202     ("-r" reverse t)
 203     ("-rv" reverse t)
 204     ("-reverse" reverse t)
 205     ("-fn" font)
 206     ("-font" font)
 207     ("-ib" internal-border-width)
 208     ("-fg" foreground-color)
 209     ("-foreground" foreground-color)
 210     ("-bg" background-color)
 211     ("-background" background-color)
 212     ("-ms" mouse-color)
 213     ("-cr" cursor-color)
 214     ("-itype" icon-type t)
 215     ("-i" icon-type t)
 216     ("-vb" vertical-scroll-bars t)
 217     ("-hb" horizontal-scroll-bars t)
 218     ("-bd" border-color)
 219     ("-bw" border-width)))
 220
 221 ;; Handler for switches of the form "-switch value" or "-switch".
 222 (defun x-handle-switch (switch)
 223   (let ((aelt (assoc switch x-switch-definitions)))
 224     (if aelt
 225         (if (nth 2 aelt)
 226             (setq default-frame-alist
 227                   (cons (cons (nth 1 aelt) (nth 2 aelt))
 228                         default-frame-alist))
 229           (setq default-frame-alist
 230                 (cons (cons (nth 1 aelt)
 231                             (car x-invocation-args))
 232                       default-frame-alist)
 233                 x-invocation-args (cdr x-invocation-args))))))
 234
 235 ;; Make -iconic apply only to the initial frame!
 236 (defun x-handle-iconic (switch)
 237   (setq initial-frame-alist
 238         (cons '(visibility . icon) initial-frame-alist)))
 239
 240 ;; Handler for switches of the form "-switch n"
 241 (defun x-handle-numeric-switch (switch)
 242   (let ((aelt (assoc switch x-switch-definitions)))
 243     (if aelt
 244         (setq default-frame-alist
 245               (cons (cons (nth 1 aelt)
 246                           (string-to-int (car x-invocation-args)))
 247                     default-frame-alist)
 248               x-invocation-args
 249               (cdr x-invocation-args)))))
 250
 251 ;; Handle the -xrm option.
 252 (defun x-handle-xrm-switch (switch)
 253   (or (consp x-invocation-args)
 254       (error "%s: missing argument to `%s' option" (invocation-name) switch))
 255   (setq x-command-line-resources (car x-invocation-args))
 256   (setq x-invocation-args (cdr x-invocation-args)))
 257
 258 ;; Handle the geometry option
 259 (defun x-handle-geometry (switch)
 260   (let ((geo (x-parse-geometry (car x-invocation-args))))
 261     (setq initial-frame-alist
 262           (append initial-frame-alist
 263                   (if (or (assq 'left geo) (assq 'top geo))
 264                       '((user-position . t)))
 265                   (if (or (assq 'height geo) (assq 'width geo))
 266                       '((user-size . t)))
 267                   geo)
 268           x-invocation-args (cdr x-invocation-args))))
 269
 270 ;; Handle the -name and -rn options.  Set the variable x-resource-name
 271 ;; to the option's operand; if the switch was `-name', set the name of
 272 ;; the initial frame, too.
 273 (defun x-handle-name-rn-switch (switch)
 274   (or (consp x-invocation-args)
 275       (error "%s: missing argument to `%s' option" (invocation-name) switch))
 276   (setq x-resource-name (car x-invocation-args)
 277         x-invocation-args (cdr x-invocation-args))
 278   (if (string= switch "-name")
 279       (setq initial-frame-alist (cons (cons 'name x-resource-name)
 280                                       initial-frame-alist))))
 281
 282 (defvar x-display-name nil
 283   "The display name specifying server and frame.")
 284
 285 (defun x-handle-display (switch)
 286   (setq x-display-name (car x-invocation-args)
 287         x-invocation-args (cdr x-invocation-args)))
 288
 289 (defvar x-invocation-args nil)
 290
 291 (defun x-handle-args (args)
 292   "Process the X-related command line options in ARGS.
 293 This is done before the user's startup file is loaded.  They are copied to
 294 x-invocation args from which the X-related things are extracted, first
 295 the switch (e.g., \"-fg\") in the following code, and possible values
 296 \(e.g., \"black\") in the option handler code (e.g., x-handle-switch).
 297 This returns ARGS with the arguments that have been processed removed."
 298   (message "%s" args)
 299   (setq x-invocation-args args
 300         args nil)
 301   (while x-invocation-args
 302     (let* ((this-switch (car x-invocation-args))
 303            (orig-this-switch this-switch)
 304            completion argval aelt)
 305       (setq x-invocation-args (cdr x-invocation-args))
 306       ;; Check for long options with attached arguments
 307       ;; and separate out the attached option argument into argval.
 308       (if (string-match "^--[^=]*=" this-switch)
 309           (setq argval (substring this-switch (match-end 0))
 310                 this-switch (substring this-switch 0 (1- (match-end 0)))))
 311       (setq completion (try-completion this-switch x-long-option-alist))
 312       (if (eq completion t)
 313           ;; Exact match for long option.
 314           (setq this-switch (cdr (assoc this-switch x-long-option-alist)))
 315         (if (stringp completion)
 316             (let ((elt (assoc completion x-long-option-alist)))
 317               ;; Check for abbreviated long option.
 318               (or elt
 319                   (error "Option `%s' is ambiguous" this-switch))
 320               (setq this-switch (cdr elt)))
 321           ;; Check for a short option.
 322           (setq argval nil this-switch orig-this-switch)))
 323       (setq aelt (assoc this-switch x-option-alist))
 324       (if aelt
 325           (if argval
 326               (let ((x-invocation-args
 327                      (cons argval x-invocation-args)))
 328                 (funcall (cdr aelt) this-switch))
 329             (funcall (cdr aelt) this-switch))
 330         (setq args (cons this-switch args)))))
 331   (setq args (nreverse args)))
 332
 333
 334 \f
 335 ;;
 336 ;; Available colors
 337 ;;
 338
 339 (defvar x-colors '("aquamarine"
 340                    "Aquamarine"
 341                    "medium aquamarine"
 342                    "MediumAquamarine"
 343                    "black"
 344                    "Black"
 345                    "blue"
 346                    "Blue"
 347                    "cadet blue"
 348                    "CadetBlue"
 349                    "cornflower blue"
 350                    "CornflowerBlue"
 351                    "dark slate blue"
 352                    "DarkSlateBlue"
 353                    "light blue"
 354                    "LightBlue"
 355                    "light steel blue"
 356                    "LightSteelBlue"
 357                    "medium blue"
 358                    "MediumBlue"
 359                    "medium slate blue"
 360                    "MediumSlateBlue"
 361                    "midnight blue"
 362                    "MidnightBlue"
 363                    "navy blue"
 364                    "NavyBlue"
 365                    "navy"
 366                    "Navy"
 367                    "sky blue"
 368                    "SkyBlue"
 369                    "slate blue"
 370                    "SlateBlue"
 371                    "steel blue"
 372                    "SteelBlue"
 373                    "coral"
 374                    "Coral"
 375                    "cyan"
 376                    "Cyan"
 377                    "firebrick"
 378                    "Firebrick"
 379                    "brown"
 380                    "Brown"
 381                    "gold"
 382                    "Gold"
 383                    "goldenrod"
 384                    "Goldenrod"
 385                    "green"
 386                    "Green"
 387                    "dark green"
 388                    "DarkGreen"
 389                    "dark olive green"
 390                    "DarkOliveGreen"
 391                    "forest green"
 392                    "ForestGreen"
 393                    "lime green"
 394                    "LimeGreen"
 395                    "medium sea green"
 396                    "MediumSeaGreen"
 397                    "medium spring green"
 398                    "MediumSpringGreen"
 399                    "pale green"
 400                    "PaleGreen"
 401                    "sea green"
 402                    "SeaGreen"
 403                    "spring green"
 404                    "SpringGreen"
 405                    "yellow green"
 406                    "YellowGreen"
 407                    "dark slate grey"
 408                    "DarkSlateGrey"
 409                    "dark slate gray"
 410                    "DarkSlateGray"
 411                    "dim grey"
 412                    "DimGrey"
 413                    "dim gray"
 414                    "DimGray"
 415                    "light grey"
 416                    "LightGrey"
 417                    "light gray"
 418                    "LightGray"
 419                    "gray"
 420                    "grey"
 421                    "Gray"
 422                    "Grey"
 423                    "khaki"
 424                    "Khaki"
 425                    "magenta"
 426                    "Magenta"
 427                    "maroon"
 428                    "Maroon"
 429                    "orange"
 430                    "Orange"
 431                    "orchid"
 432                    "Orchid"
 433                    "dark orchid"
 434                    "DarkOrchid"
 435                    "medium orchid"
 436                    "MediumOrchid"
 437                    "pink"
 438                    "Pink"
 439                    "plum"
 440                    "Plum"
 441                    "red"
 442                    "Red"
 443                    "indian red"
 444                    "IndianRed"
 445                    "medium violet red"
 446                    "MediumVioletRed"
 447                    "orange red"
 448                    "OrangeRed"
 449                    "violet red"
 450                    "VioletRed"
 451                    "salmon"
 452                    "Salmon"
 453                    "sienna"
 454                    "Sienna"
 455                    "tan"
 456                    "Tan"
 457                    "thistle"
 458                    "Thistle"
 459                    "turquoise"
 460                    "Turquoise"
 461                    "dark turquoise"
 462                    "DarkTurquoise"
 463                    "medium turquoise"
 464                    "MediumTurquoise"
 465                    "violet"
 466                    "Violet"
 467                    "blue violet"
 468                    "BlueViolet"
 469                    "wheat"
 470                    "Wheat"
 471                    "white"
 472                    "White"
 473                    "yellow"
 474                    "Yellow"
 475                    "green yellow"
 476                    "GreenYellow")
 477   "The full list of X colors from the `rgb.text' file.")
 478
 479 (defun x-defined-colors (&optional frame)
 480   "Return a list of colors supported for a particular frame.
 481 The argument FRAME specifies which frame to try.
 482 The value may be different for frames on different X displays."
 483   (or frame (setq frame (selected-frame)))
 484   (let* ((color-map-colors (mapcar (lambda (clr) (car clr)) w32-color-map))
 485          (all-colors (or color-map-colors x-colors))
 486          (this-color nil)
 487          (defined-colors nil))
 488     (message "Defining colors...")
 489     (while all-colors
 490       (setq this-color (car all-colors)
 491             all-colors (cdr all-colors))
 492       (and (face-color-supported-p frame this-color t)
 493            (setq defined-colors (cons this-color defined-colors))))
 494     defined-colors))
 495 \f
 496 \f
 497 ;;;; Function keys
 498
 499 ;;; make f10 activate the real menubar rather than the mini-buffer menu
 500 ;;; navigation feature.
 501 (global-set-key [f10] (lambda ()
 502                         (interactive) (w32-send-sys-command ?\xf100)))
 503
 504 (defun iconify-or-deiconify-frame ()
 505   "Iconify the selected frame, or deiconify if it's currently an icon."
 506   (interactive)
 507   (if (eq (cdr (assq 'visibility (frame-parameters))) t)
 508       (iconify-frame)
 509     (make-frame-visible)))
 510
 511 (substitute-key-definition 'suspend-emacs 'iconify-or-deiconify-frame
 512                            global-map)
 513
 514 \f
 515 ;;;; Selections and cut buffers
 516
 517 ;;; We keep track of the last text selected here, so we can check the
 518 ;;; current selection against it, and avoid passing back our own text
 519 ;;; from x-cut-buffer-or-selection-value.
 520 (defvar x-last-selected-text nil)
 521
 522 ;;; It is said that overlarge strings are slow to put into the cut buffer.
 523 ;;; Note this value is overridden below.
 524 (defvar x-cut-buffer-max 20000
 525   "Max number of characters to put in the cut buffer.")
 526
 527 (defvar x-select-enable-clipboard t
 528   "Non-nil means cutting and pasting uses the clipboard.
 529 This is in addition to the primary selection.")
 530
 531 (defun x-select-text (text &optional push)
 532   (if x-select-enable-clipboard
 533       (w32-set-clipboard-data text))
 534   (setq x-last-selected-text text))
 535
 536 ;;; Return the value of the current selection.
 537 ;;; Consult the selection, then the cut buffer.  Treat empty strings
 538 ;;; as if they were unset.
 539 (defun x-get-selection-value ()
 540   (if x-select-enable-clipboard
 541       (let (text)
 542         ;; Don't die if x-get-selection signals an error.
 543         (condition-case c
 544             (setq text (w32-get-clipboard-data))
 545           (error (message "w32-get-clipboard-data:%s" c)))
 546         (if (string= text "") (setq text nil))
 547         (cond
 548          ((not text) nil)
 549          ((eq text x-last-selected-text) nil)
 550          ((string= text x-last-selected-text)
 551           ;; Record the newer string, so subsequent calls can use the 'eq' test.
 552           (setq x-last-selected-text text)
 553           nil)
 554          (t
 555           (setq x-last-selected-text text))))))
 556 \f
 557 ;;; Do the actual Windows setup here; the above code just defines
 558 ;;; functions and variables that we use now.
 559
 560 (setq command-line-args (x-handle-args command-line-args))
 561
 562 ;;; Make sure we have a valid resource name.
 563 (or (stringp x-resource-name)
 564     (let (i)
 565       (setq x-resource-name (invocation-name))
 566
 567       ;; Change any . or * characters in x-resource-name to hyphens,
 568       ;; so as not to choke when we use it in X resource queries.
 569       (while (setq i (string-match "[.*]" x-resource-name))
 570         (aset x-resource-name i ?-))))
 571
 572 ;; For the benefit of older Emacses (19.27 and earlier) that are sharing
 573 ;; the same lisp directory, don't pass the third argument unless we seem
 574 ;; to have the multi-display support.
 575 (if (fboundp 'x-close-connection)
 576     (x-open-connection ""
 577                        x-command-line-resources
 578                        ;; Exit Emacs with fatal error if this fails.
 579                        t)
 580   (x-open-connection ""
 581                      x-command-line-resources))
 582
 583 (setq frame-creation-function 'x-create-frame-with-faces)
 584
 585 (setq x-cut-buffer-max (min (- (/ (x-server-max-request-size) 2) 100)
 586                             x-cut-buffer-max))
 587
 588 ;; W32 expects the menu bar cut and paste commands to use the clipboard.
 589 ;; This has ,? to match both on Sunos and on Solaris.
 590 (menu-bar-enable-clipboard)
 591
 592 ;; Apply a geometry resource to the initial frame.  Put it at the end
 593 ;; of the alist, so that anything specified on the command line takes
 594 ;; precedence.
 595 (let* ((res-geometry (x-get-resource "geometry" "Geometry"))
 596        parsed)
 597   (if res-geometry
 598       (progn
 599         (setq parsed (x-parse-geometry res-geometry))
 600         ;; If the resource specifies a position,
 601         ;; call the position and size "user-specified".
 602         (if (or (assq 'top parsed) (assq 'left parsed))
 603             (setq parsed (cons '(user-position . t)
 604                                (cons '(user-size . t) parsed))))
 605         ;; All geometry parms apply to the initial frame.
 606         (setq initial-frame-alist (append initial-frame-alist parsed))
 607         ;; The size parms apply to all frames.
 608         (if (assq 'height parsed)
 609             (setq default-frame-alist
 610                   (cons (cons 'height (cdr (assq 'height parsed)))
 611                         default-frame-alist)))
 612         (if (assq 'width parsed)
 613             (setq default-frame-alist
 614                   (cons (cons 'width (cdr (assq 'width parsed)))
 615                         default-frame-alist))))))
 616
 617 ;; Check the reverseVideo resource.
 618 (let ((case-fold-search t))
 619   (let ((rv (x-get-resource "reverseVideo" "ReverseVideo")))
 620     (if (and rv
 621              (string-match "^\\(true\\|yes\\|on\\)$" rv))
 622         (setq default-frame-alist
 623               (cons '(reverse . t) default-frame-alist)))))
 624
 625 ;; Set x-selection-timeout, measured in milliseconds.
 626 (let ((res-selection-timeout
 627        (x-get-resource "selectionTimeout" "SelectionTimeout")))
 628   (setq x-selection-timeout 20000)
 629   (if res-selection-timeout
 630       (setq x-selection-timeout (string-to-number res-selection-timeout))))
 631
 632 (defun x-win-suspend-error ()
 633   (error "Suspending an emacs running under W32 makes no sense"))
 634 (add-hook 'suspend-hook 'x-win-suspend-error)
 635
 636 ;;; Arrange for the kill and yank functions to set and check the clipboard.
 637 (setq interprogram-cut-function 'x-select-text)
 638 (setq interprogram-paste-function 'x-get-selection-value)
 639
 640 ;;; Turn off window-splitting optimization; w32 is usually fast enough
 641 ;;; that this is only annoying.
 642 (setq split-window-keep-point t)
 643
 644 ;; Don't show the frame name; that's redundant.
 645 (setq-default mode-line-frame-identification "  ")
 646
 647 ;;; Set to a system sound if you want a fancy bell.
 648 (set-message-beep 'ok)
 649
 650 ;; Remap some functions to call w32 common dialogs
 651
 652 (defun internal-face-interactive (what &optional bool)
 653   (let* ((fn (intern (concat "face-" what)))
 654          (prompt (concat "Set " what " of face"))
 655          (face (read-face-name (concat prompt ": ")))
 656          (default (if (fboundp fn)
 657                       (or (funcall fn face (selected-frame))
 658                           (funcall fn 'default (selected-frame)))))
 659          (fn-win (intern (concat (symbol-name window-system) "-select-" what)))
 660          (value
 661           (if (fboundp fn-win)
 662               (funcall fn-win)
 663             (if bool
 664                 (y-or-n-p (concat "Should face " (symbol-name face)
 665                                   " be " bool "? "))
 666               (read-string (concat prompt " " (symbol-name face) " to: ")
 667                            default)))))
 668          (list face (if (equal value "") nil value))))
 669
 670 ;; Redefine the font selection to use the standard W32 dialog
 671
 672 (defun mouse-set-font (&rest fonts)
 673   (interactive)
 674   (set-default-font (w32-select-font)))
 675
 676 ;;; w32-win.el ends here