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

   1 ;;; pc-win.el --- setup support for `PC windows' (whatever that is).
   2
   3 ;; Copyright (C) 1994, 1996, 1997 Free Software Foundation, Inc.
   4
   5 ;; Author: Morten Welinder <terra@diku.dk>
   6 ;; Maintainer: FSF
   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 ;;; Code:
  26
  27 (load "term/internal" nil t)
  28
  29 ;; Color translation -- doesn't really need to be fast.
  30 ;; Colors listed here do not include the "light-",
  31 ;; "medium-" and "dark-" prefixes that are accounted for
  32 ;; by `msdos-color-translate', which see below).
  33
  34 (defvar msdos-color-aliases
  35   '(("snow"             . "white")
  36     ("ghost white"      . "white")
  37     ("ghostwhite"       . "white")
  38     ("white smoke"      . "white")
  39     ("whitesmoke"       . "white")
  40     ("gainsboro"        . "white")
  41     ("floral white"     . "white")
  42     ("floralwhite"      . "white")
  43     ("old lace"         . "white")
  44     ("oldlace"          . "white")
  45     ("linen"            . "white")
  46     ("antique white"    . "white")
  47     ("antiquewhite"     . "white")
  48     ("papaya whip"      . "white")
  49     ("papayawhip"       . "white")
  50     ("blanched almond"  . "white")
  51     ("blanchedalmond"   . "white")
  52     ("bisque"           . "white")
  53     ("peach puff"       . "lightred")
  54     ("peachpuff"        . "lightred")
  55     ("navajo white"     . "lightred")
  56     ("navajowhite"      . "lightred")
  57     ("moccasin"         . "lightred")
  58     ("cornsilk"         . "white")
  59     ("ivory"            . "white")
  60     ("lemon chiffon"    . "yellow")
  61     ("lemonchiffon"     . "yellow")
  62     ("seashell"         . "white")
  63     ("honeydew"         . "white")
  64     ("mint cream"       . "white")
  65     ("mintcream"        . "white")
  66     ("azure"            . "lightcyan")
  67     ("alice blue"       . "lightcyan")
  68     ("aliceblue"        . "lightcyan")
  69     ("lavender"         . "lightcyan")
  70     ("lavender blush"   . "lightcyan")
  71     ("lavenderblush"    . "lightcyan")
  72     ("misty rose"       . "lightred")
  73     ("mistyrose"        . "lightred")
  74     ("aquamarine"       . "blue")
  75     ("cadet blue"       . "blue")
  76     ("cadetblue"        . "blue")
  77     ("cornflower blue"  . "lightblue")
  78     ("cornflowerblue"   . "lightblue")
  79     ("midnight blue"    . "blue")
  80     ("midnightblue"     . "blue")
  81     ("navy blue"        . "cyan")
  82     ("navyblue"         . "cyan")
  83     ("navy"             . "cyan")
  84     ("royalblue"        . "blue")
  85     ("royal blue"       . "blue")
  86     ("sky blue"         . "lightblue")
  87     ("skyblue"          . "lightblue")
  88     ("dodger blue"      . "blue")
  89     ("dodgerblue"       . "blue")
  90     ("powder blue"      . "lightblue")
  91     ("powderblue"       . "lightblue")
  92     ("slate blue"       . "cyan")
  93     ("slateblue"        . "cyan")
  94     ("steel blue"       . "blue")
  95     ("steelblue"        . "blue")
  96     ("coral"            . "lightred")
  97     ("tomato"           . "lightred")
  98     ("firebrick"        . "red")
  99     ("gold"             . "yellow")
 100     ("goldenrod"        . "yellow")
 101     ("goldenrod yellow" . "yellow")
 102     ("goldenrodyellow"  . "yellow")
 103     ("pale goldenrod"   . "yellow")
 104     ("palegoldenrod"    . "yellow")
 105     ("olive green"      . "lightgreen")
 106     ("olivegreen"       . "lightgreen")
 107     ("olive drab"       . "green")
 108     ("olivedrab"        . "green")
 109     ("forest green"     . "green")
 110     ("forestgreen"      . "green")
 111     ("lime green"       . "lightgreen")
 112     ("limegreen"        . "lightgreen")
 113     ("sea green"        . "lightcyan")
 114     ("seagreen"         . "lightcyan")
 115     ("spring green"     . "green")
 116     ("springgreen"      . "green")
 117     ("lawn green"       . "lightgreen")
 118     ("lawngreen"        . "lightgreen")
 119     ("chartreuse"       . "yellow")
 120     ("yellow green"     . "lightgreen")
 121     ("yellowgreen"      . "lightgreen")
 122     ("green yellow"     . "lightgreen")
 123     ("greenyellow"      . "lightgreen")
 124     ("slate grey"       . "lightgray")
 125     ("slategrey"        . "lightgray")
 126     ("slate gray"       . "lightgray")
 127     ("slategray"        . "lightgray")
 128     ("dim grey"         . "darkgray")
 129     ("dimgrey"          . "darkgray")
 130     ("dim gray"         . "darkgray")
 131     ("dimgray"          . "darkgray")
 132     ("light grey"       . "lightgray")
 133     ("lightgrey"        . "lightgray")
 134     ("light gray"       . "lightgray")
 135     ("gray"             . "darkgray")
 136     ("grey"             . "darkgray")
 137     ("khaki"            . "green")
 138     ("maroon"           . "red")
 139     ("orange"           . "brown")
 140     ("orchid"           . "brown")
 141     ("saddle brown"     . "red")
 142     ("saddlebrown"      . "red")
 143     ("peru"             . "red")
 144     ("burlywood"        . "brown")
 145     ("sandy brown"      . "brown")
 146     ("sandybrown"       . "brown")
 147     ("pink"             . "lightred")
 148     ("hotpink"          . "lightred")
 149     ("hot pink"         ."lightred")
 150     ("plum"             . "magenta")
 151     ("indian red"       . "red")
 152     ("indianred"        . "red")
 153     ("violet red"       . "magenta")
 154     ("violetred"        . "magenta")
 155     ("orange red"       . "red")
 156     ("orangered"        . "red")
 157     ("salmon"           .  "lightred")
 158     ("sienna"           . "lightred")
 159     ("tan"              . "lightred")
 160     ("chocolate"        . "brown")
 161     ("thistle"          . "magenta")
 162     ("turquoise"        . "lightgreen")
 163     ("pale turquoise"   . "cyan")
 164     ("paleturquoise"    . "cyan")
 165     ("violet"           . "magenta")
 166     ("blue violet"      . "lightmagenta")
 167     ("blueviolet"       . "lightmagenta")
 168     ("wheat"            . "white")
 169     ("green yellow"     . "yellow")
 170     ("greenyellow"      . "yellow")
 171     ("purple"           . "magenta")
 172     ("rosybrown"        . "brown")
 173     ("rosy brown"       . "brown")
 174     ("beige"            . "brown"))
 175   "List of alternate names for colors.")
 176
 177 (defun msdos-color-translate (name)
 178   (setq name (downcase name))
 179   (let* ((len (length name))
 180          (val (- (length x-colors)
 181                  (length (member name x-colors))))
 182          (try))
 183     (if (or (< val 0) (>= val (length x-colors))) (setq val nil))
 184     (or val
 185         (and (setq try (cdr (assoc name msdos-color-aliases)))
 186              (msdos-color-translate try))
 187         (and (> len 5)
 188              (string= "light" (substring name 0 5))
 189              (setq try (msdos-color-translate (substring name 5)))
 190              (logior try 8))
 191         (and (> len 6)
 192              (string= "light " (substring name 0 6))
 193              (setq try (msdos-color-translate (substring name 6)))
 194              (logior try 8))
 195         (and (> len 4)
 196              (string= "pale" (substring name 0 4))
 197              (setq try (msdos-color-translate (substring name 4)))
 198              (logior try 8))
 199         (and (> len 5)
 200              (string= "pale " (substring name 0 5))
 201              (setq try (msdos-color-translate (substring name 5)))
 202              (logior try 8))
 203         (and (> len 6)
 204              (string= "medium" (substring name 0 6))
 205              (msdos-color-translate (substring name 6)))
 206         (and (> len 7)
 207              (string= "medium " (substring name 0 7))
 208              (msdos-color-translate (substring name 7)))
 209         (and (> len 4)
 210              (or (string= "dark" (substring name 0 4))
 211                  (string= "deep" (substring name 0 4)))
 212              (msdos-color-translate (substring name 4)))
 213         (and (> len 5)
 214              (or (string= "dark " (substring name 0 5))
 215                  (string= "deep " (substring name 0 5)))
 216              (msdos-color-translate (substring name 5)))
 217         (and (> len 4) ;; gray shades: gray0 to gray100
 218              (save-match-data
 219                (and
 220                 (string-match "gr[ae]y[0-9]" name)
 221                 (string-match "[0-9]+\\'" name)
 222                 (let ((num (string-to-int
 223                             (substring name (match-beginning 0)))))
 224                   (msdos-color-translate
 225                    (cond
 226                     ((> num 90) "white")
 227                     ((> num 50) "lightgray")
 228                     ((> num 10) "darkgray")
 229                     (t "black")))))))
 230         (and (> len 1) ;; purple1 to purple4 and the like
 231              (save-match-data
 232                (and
 233                 (string-match "[1-4]\\'" name)
 234                 (msdos-color-translate
 235                  (substring name 0 (match-beginning 0)))))))))
 236 ;; ---------------------------------------------------------------------------
 237 ;; We want to delay setting frame parameters until the faces are setup
 238 (defvar default-frame-alist nil)
 239 (modify-frame-parameters terminal-frame default-frame-alist)
 240
 241 (defun msdos-bg-mode (&optional frame)
 242   (let* ((frame (or frame (selected-frame)))
 243          (params (frame-parameters frame))
 244          (bg (cdr (assq 'background-color params))))
 245     ;; The list of ``dark'' colors should be consistent with
 246     ;; `x-color-values' (below) and the dark/light color
 247     ;; decisions `frame-set-background-mode' in lisp/faces.el.
 248     (if (member bg
 249                 '("black" "blue" "green" "red" "magenta" "brown" "darkgray"))
 250         'dark
 251       'light)))
 252
 253 (defun msdos-face-setup ()
 254   (modify-frame-parameters terminal-frame default-frame-alist)
 255
 256   (modify-frame-parameters terminal-frame
 257                            (list (cons 'background-mode
 258                                        (msdos-bg-mode terminal-frame))
 259                                  (cons 'display-type 'color)))
 260   (face-set-after-frame-default terminal-frame)
 261
 262   (set-face-foreground 'bold "yellow" terminal-frame)
 263   (set-face-foreground 'italic "red" terminal-frame)
 264   (set-face-foreground 'bold-italic "lightred" terminal-frame)
 265   (set-face-foreground 'underline "white" terminal-frame)
 266
 267   (make-face 'msdos-menu-active-face)
 268   (make-face 'msdos-menu-passive-face)
 269   (make-face 'msdos-menu-select-face)
 270   (set-face-foreground 'msdos-menu-active-face "white" terminal-frame)
 271   (set-face-foreground 'msdos-menu-passive-face "lightgray" terminal-frame)
 272   (set-face-background 'msdos-menu-active-face "blue" terminal-frame)
 273   (set-face-background 'msdos-menu-passive-face "blue" terminal-frame)
 274   (set-face-background 'msdos-menu-select-face "red" terminal-frame))
 275
 276 ;; We have only one font, so...
 277 (add-hook 'before-init-hook 'msdos-face-setup)
 278
 279 ;; We create frames as if we were a terminal, but with a twist.
 280 (defun make-msdos-frame (&optional parameters)
 281   (let* ((parms
 282           (append initial-frame-alist default-frame-alist parameters nil))
 283          (frame (make-terminal-frame parms)))
 284     (modify-frame-parameters frame
 285                              (list (cons 'background-mode
 286                                          (msdos-bg-mode frame))
 287                                    (cons 'display-type 'color)))
 288     frame))
 289
 290 (setq frame-creation-function 'make-msdos-frame)
 291
 292 ;; ---------------------------------------------------------------------------
 293 ;; More or less useful imitations of certain X-functions.  A lot of the
 294 ;; values returned are questionable, but usually only the form of the
 295 ;; returned value matters.  Also, by the way, recall that `ignore' is
 296 ;; a useful function for returning 'nil regardless of argument.
 297
 298 ;; From src/xfns.c
 299 (defun x-display-color-p (&optional display) 't)
 300 (defun x-list-fonts (pattern &optional face frame maximum width)
 301   (if (and (numberp width) (= width 1))
 302       (list "default")
 303     (list "no-such-font")))
 304 (defun x-color-defined-p (color) (numberp (msdos-color-translate color)))
 305 (defun x-display-pixel-width (&optional frame) (frame-width frame))
 306 (defun x-display-pixel-height (&optional frame) (frame-height frame))
 307 (defun x-display-planes (&optional frame) 4) ; 3 for background, actually
 308 (defun x-display-color-cells (&optional frame) 16) ; ???
 309 (defun x-server-max-request-size (&optional frame) 1000000) ; ???
 310 (defun x-server-vendor (&optional frame) t "GNU")
 311 (defun x-server-version (&optional frame) '(1 0 0))
 312 (defun x-display-screens (&optional frame) 1)
 313 (defun x-display-mm-height (&optional frame) 200) ; Guess the size of my
 314 (defun x-display-mm-width (&optional frame) 253)  ; monitor, MW...
 315 (defun x-display-backing-store (&optional frame) 'not-useful)
 316 (defun x-display-visual-class (&optional frame) 'static-color)
 317 (fset 'x-display-save-under 'ignore)
 318 (fset 'x-get-resource 'ignore)
 319 ;;;
 320 ;;; This is copied from etc/rgb.txt, except that some values were changed
 321 ;;; a bit to make them consistent with DOS console colors.  The order of
 322 ;;; the colors is according to the PC text mode color codes.
 323 ;;;
 324 ;;; If you want to change the RGB values, keep in mind that various pieces
 325 ;;; of Emacs think that a color whose RGB values add up to less than 0.6 of
 326 ;;; the values for WHITE (i.e. less than 459) are ``dark'', otherwise the
 327 ;;; color is ``light''; see `frame-set-background-mode' in lisp/faces.el for
 328 ;;; an example.
 329 (defvar msdos-color-values
 330   '(("black"          0   0   0)
 331     ("blue"           0   0 255)
 332     ("green"          0 255   0)
 333     ("cyan"           0 255 255)
 334     ("red"          255   0   0)
 335     ("magenta"      139   0 139)        ; dark magenta
 336     ("brown"        165  42  42)
 337     ("lightgray"    211 211 211)
 338     ("darkgray"     102 102 102)        ; gray40
 339     ("lightblue"    173 216 230)
 340     ("lightgreen"   144 238 144)
 341     ("lightcyan"    224 255 255)
 342     ("lightred"     255  52 179)        ; maroon1
 343     ("lightmagenta" 238   0 238)        ; magenta2
 344     ("yellow"       255 255   0)
 345     ("white"        255 255 255))
 346   "A list of MS-DOS console colors and their RGB values.")
 347
 348 (defun x-color-values (color &optional frame)
 349   "Return a description of the color named COLOR on frame FRAME.\n\
 350 The value is a list of integer RGB values--(RED GREEN BLUE).\n\
 351 These values range from 0 to 255; white is (255 255 255).\n\
 352 If FRAME is omitted or nil, use the selected frame."
 353   (if (x-color-defined-p color)
 354       (let ((frame (or frame (selected-frame)))
 355             (color-code (msdos-color-translate color)))
 356         (cdr (nth color-code msdos-color-values)))))
 357
 358 ;; From lisp/term/x-win.el
 359 (setq x-display-name "pc")
 360 (setq split-window-keep-point t)
 361 (defvar x-colors '("black"
 362                    "blue"
 363                    "green"
 364                    "cyan"
 365                    "red"
 366                    "magenta"
 367                    "brown"
 368                    "lightgray"
 369                    "darkgray"
 370                    "lightblue"
 371                    "lightgreen"
 372                    "lightcyan"
 373                    "lightred"
 374                    "lightmagenta"
 375                    "yellow"
 376                    "white")
 377   "The list of colors available on a PC display under MS-DOS.")
 378 (defun x-defined-colors (&optional frame)
 379   "Return a list of colors supported for a particular frame.
 380 The argument FRAME specifies which frame to try.
 381 The value may be different for frames on different X displays."
 382   x-colors)
 383
 384 ;; From lisp/term/w32-win.el
 385 ;
 386 ;;;; Selections and cut buffers
 387 ;
 388 ;;; We keep track of the last text selected here, so we can check the
 389 ;;; current selection against it, and avoid passing back our own text
 390 ;;; from x-cut-buffer-or-selection-value.
 391 (defvar x-last-selected-text nil)
 392
 393 (defvar x-select-enable-clipboard t
 394   "Non-nil means cutting and pasting uses the clipboard.
 395 This is in addition to the primary selection.")
 396
 397 (defun x-select-text (text &optional push)
 398   (if x-select-enable-clipboard
 399       (w16-set-clipboard-data text))
 400   (setq x-last-selected-text text))
 401
 402 ;;; Return the value of the current selection.
 403 ;;; Consult the selection, then the cut buffer.  Treat empty strings
 404 ;;; as if they were unset.
 405 (defun x-get-selection-value ()
 406   (if x-select-enable-clipboard
 407       (let (text)
 408         ;; Don't die if x-get-selection signals an error.
 409         (condition-case c
 410             (setq text (w16-get-clipboard-data))
 411           (error (message "w16-get-clipboard-data:%s" c)))
 412         (if (string= text "") (setq text nil))
 413         (cond
 414          ((not text) nil)
 415          ((eq text x-last-selected-text) nil)
 416          ((string= text x-last-selected-text)
 417           ;; Record the newer string, so subsequent calls can use the 'eq' test.
 418           (setq x-last-selected-text text)
 419           nil)
 420          (t
 421           (setq x-last-selected-text text))))))
 422
 423 ;;; Arrange for the kill and yank functions to set and check the clipboard.
 424 (setq interprogram-cut-function 'x-select-text)
 425 (setq interprogram-paste-function 'x-get-selection-value)
 426
 427 ;; From lisp/faces.el: we only have one font, so always return
 428 ;; it, no matter which variety they've asked for.
 429 (defun x-frob-font-slant (font which)
 430   font)
 431
 432 ;; From src/fontset.c:
 433 (fset 'query-fontset 'ignore)
 434
 435 ;; From lisp/term/x-win.el: make iconify-or-deiconify-frame a no-op.
 436 (fset 'iconify-or-deiconify-frame 'ignore)
 437
 438 ;; From lisp/frame.el
 439 (fset 'set-default-font 'ignore)
 440 (fset 'set-mouse-color 'ignore)         ; We cannot, I think.
 441 (fset 'set-cursor-color 'ignore)        ; Hardware determined by char under.
 442 (fset 'set-border-color 'ignore)        ; Not useful.
 443
 444 ;; From lisp/term/x-win.el:
 445 (defconst x-long-option-alist
 446   '(("--name" .         "-name")
 447     ("--title" .        "-T")
 448     ("--reverse-video" . "-reverse")
 449     ("--foreground-color" . "-fg")
 450     ("--background-color" . "-bg")))
 451 ;; ---------------------------------------------------------------------------
 452 ;; Handle the X-like command line parameters "-fg", "-bg", "-name", etc.
 453 (defun msdos-handle-args (args)
 454   (let ((rest nil))
 455     (message "%s" args)
 456     (while args
 457       (let* ((this (car args))
 458              (orig-this this)
 459              completion argval)
 460         (setq args (cdr args))
 461         ;; Check for long options with attached arguments
 462         ;; and separate out the attached option argument into argval.
 463         (if (string-match "^--[^=]*=" this)
 464             (setq argval (substring this (match-end 0))
 465                   this (substring this 0 (1- (match-end 0)))))
 466         (setq completion (try-completion this x-long-option-alist))
 467         (if (eq completion t)
 468             ;; Exact match for long option.
 469             (setq this (cdr (assoc this x-long-option-alist)))
 470           (if (stringp completion)
 471               (let ((elt (assoc completion x-long-option-alist)))
 472                 ;; Check for abbreviated long option.
 473                 (or elt
 474                     (error "Option `%s' is ambiguous" this))
 475                 (setq this (cdr elt)))
 476             ;; Check for a short option.
 477             (setq argval nil this orig-this)))
 478         (cond ((or (string= this "-fg") (string= this "-foreground"))
 479                (or argval (setq argval (car args) args (cdr args)))
 480                (setq default-frame-alist
 481                      (cons (cons 'foreground-color argval)
 482                            default-frame-alist)))
 483               ((or (string= this "-bg") (string= this "-background"))
 484                (or argval (setq argval (car args) args (cdr args)))
 485                (setq default-frame-alist
 486                      (cons (cons 'background-color argval)
 487                            default-frame-alist)))
 488               ((or (string= this "-T") (string= this "-name"))
 489                (or argval (setq argval (car args) args (cdr args)))
 490                (setq default-frame-alist
 491                      (cons
 492                       (cons 'title
 493                             (if (stringp argval)
 494                                 argval
 495                               (let ((case-fold-search t)
 496                                     i)
 497                                 (setq argval (invocation-name))
 498
 499                                 ;; Change any . or * characters in name to
 500                                 ;; hyphens, so as to emulate behavior on X.
 501                                 (while
 502                                     (setq i (string-match "[.*]" argval))
 503                                   (aset argval i ?-))
 504                                 argval)))
 505                       default-frame-alist)))
 506               ((or (string= this "-r")
 507                    (string= this "-rv")
 508                    (string= this "-reverse"))
 509                (setq default-frame-alist
 510                      (cons '(reverse . t)
 511                            default-frame-alist)))
 512               (t (setq rest (cons this rest))))))
 513         (nreverse rest)))
 514
 515 (setq command-line-args (msdos-handle-args command-line-args))
 516 ;; ---------------------------------------------------------------------------
 517
 518 ;;; pc-win.el ends here