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 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     ("sky blue"         . "lightblue")
  85     ("skyblue"          . "lightblue")
  86     ("dodger blue"      . "blue")
  87     ("dodgerblue"       . "blue")
  88     ("powder blue"      . "lightblue")
  89     ("powderblue"       . "lightblue")
  90     ("slate blue"       . "cyan")
  91     ("slateblue"        . "cyan")
  92     ("steel blue"       . "blue")
  93     ("steelblue"        . "blue")
  94     ("coral"            . "lightred")
  95     ("firebrick"        . "red")
  96     ("gold"             . "yellow")
  97     ("goldenrod"        . "yellow")
  98     ("pale goldenrod"   . "yellow")
  99     ("palegoldenrod"    . "yellow")
 100     ("olive green"      . "lightgreen")
 101     ("olivegreen"       . "lightgreen")
 102     ("olive drab"       . "green")
 103     ("olivedrab"        . "green")
 104     ("forest green"     . "green")
 105     ("forestgreen"      . "green")
 106     ("lime green"       . "lightgreen")
 107     ("limegreen"        . "lightgreen")
 108     ("sea green"        . "lightcyan")
 109     ("seagreen"         . "lightcyan")
 110     ("spring green"     . "green")
 111     ("springgreen"      . "green")
 112     ("pale green"       . "lightgreen")
 113     ("palegreen"        . "lightgreen")
 114     ("lawn green"       . "lightgreen")
 115     ("lawngreen"        . "lightgreen")
 116     ("chartreuse"       . "yellow")
 117     ("yellow green"     . "lightgreen")
 118     ("yellowgreen"      . "lightgreen")
 119     ("green yellow"     . "lightgreen")
 120     ("greenyellow"      . "lightgreen")
 121     ("slate grey"       . "lightgray")
 122     ("slategrey"        . "lightgray")
 123     ("slate gray"       . "lightgray")
 124     ("slategray"        . "lightgray")
 125     ("dim grey"         . "darkgray")
 126     ("dimgrey"          . "darkgray")
 127     ("dim gray"         . "darkgray")
 128     ("dimgray"          . "darkgray")
 129     ("light grey"       . "lightgray")
 130     ("lightgrey"        . "lightgray")
 131     ("light gray"       . "lightgray")
 132     ("gray"             . "darkgray")
 133     ("grey"             . "darkgray")
 134     ("gray80"           . "darkgray")
 135     ("gray50"           . "black")
 136     ("gray90"           . "darkgray")
 137     ("khaki"            . "green")
 138     ("maroon"           . "red")
 139     ("orange"           . "brown")
 140     ("orchid"           . "brown")
 141     ("saddle brown"     . "red")
 142     ("saddlebrown"      . "red")
 143     ("sienna"           . "red")
 144     ("peru"             . "red")
 145     ("pink"             . "lightred")
 146     ("plum"             . "magenta")
 147     ("indian red"       . "red")
 148     ("indianred"        . "red")
 149     ("violet red"       . "magenta")
 150     ("violetred"        . "magenta")
 151     ("orange red"       . "red")
 152     ("orangered"        . "red")
 153     ("salmon"           .  "lightred")
 154     ("sienna"           . "lightred")
 155     ("tan"              . "lightred")
 156     ("thistle"          . "magenta")
 157     ("turquoise"        . "lightgreen")
 158     ("pale turquoise"   . "cyan")
 159     ("paleturquoise"    . "cyan")
 160     ("violet"           . "magenta")
 161     ("blue violet"      . "lightmagenta")
 162     ("blueviolet"       . "lightmagenta")
 163     ("wheat"            . "white")
 164     ("green yellow"     . "yellow")
 165     ("greenyellow"      . "yellow")
 166     ("purple"           . "magenta")
 167     ("royalblue"        . "blue")
 168     ("grey40"           . "darkgray")
 169     ("rosybrown"        . "brown")
 170     ("rosy brown"       . "brown")
 171     ("beige"            . "brown"))
 172   "List of alternate names for colors.")
 173
 174 (defun msdos-color-translate (name)
 175   (setq name (downcase name))
 176   (let* ((len (length name))
 177          (val (- (length x-colors)
 178                  (length (member name x-colors))))
 179          (try))
 180     (if (or (< val 0) (>= val (length x-colors))) (setq val nil))
 181     (or val
 182         (and (setq try (cdr (assoc name msdos-color-aliases)))
 183              (msdos-color-translate try))
 184         (and (> len 5)
 185              (string= "light" (substring name 0 5))
 186              (setq try (msdos-color-translate (substring name 5)))
 187              (logior try 8))
 188         (and (> len 6)
 189              (string= "light " (substring name 0 6))
 190              (setq try (msdos-color-translate (substring name 6)))
 191              (logior try 8))
 192         (and (> len 6)
 193              (string= "medium" (substring name 0 6))
 194              (msdos-color-translate (substring name 6)))
 195         (and (> len 7)
 196              (string= "medium " (substring name 0 7))
 197              (msdos-color-translate (substring name 7)))
 198         (and (> len 4)
 199              (string= "dark" (substring name 0 4))
 200              (msdos-color-translate (substring name 4)))
 201         (and (> len 5)
 202              (string= "dark " (substring name 0 5))
 203              (msdos-color-translate (substring name 5))))))
 204 ;; ---------------------------------------------------------------------------
 205 ;; We want to delay setting frame parameters until the faces are setup
 206 (defvar default-frame-alist nil)
 207 (modify-frame-parameters terminal-frame default-frame-alist)
 208
 209 (defun msdos-face-setup ()
 210   (modify-frame-parameters terminal-frame default-frame-alist)
 211
 212   (set-face-foreground 'bold "yellow" terminal-frame)
 213   (set-face-foreground 'italic "red" terminal-frame)
 214   (set-face-foreground 'bold-italic "lightred" terminal-frame)
 215   (set-face-foreground 'underline "white" terminal-frame)
 216   (set-face-background 'region "green" terminal-frame)
 217
 218   (make-face 'msdos-menu-active-face)
 219   (make-face 'msdos-menu-passive-face)
 220   (make-face 'msdos-menu-select-face)
 221   (set-face-foreground 'msdos-menu-active-face "white" terminal-frame)
 222   (set-face-foreground 'msdos-menu-passive-face "lightgray" terminal-frame)
 223   (set-face-background 'msdos-menu-active-face "blue" terminal-frame)
 224   (set-face-background 'msdos-menu-passive-face "blue" terminal-frame)
 225   (set-face-background 'msdos-menu-select-face "red" terminal-frame))
 226
 227 ;; We have only one font, so...
 228 (add-hook 'before-init-hook 'msdos-face-setup)
 229
 230 ;; We create frames as if we were a terminal, but with a twist.
 231 (defun make-msdos-frame (&optional parameters)
 232   (let ((parms
 233          (append initial-frame-alist default-frame-alist parameters nil)))
 234     (make-terminal-frame parms)))
 235
 236 (setq frame-creation-function 'make-msdos-frame)
 237
 238 ;; ---------------------------------------------------------------------------
 239 ;; More or less useful imitations of certain X-functions.  A lot of the
 240 ;; values returned are questionable, but usually only the form of the
 241 ;; returned value matters.  Also, by the way, recall that `ignore' is
 242 ;; a useful function for returning 'nil regardless of argument.
 243
 244 ;; From src/xfns.c
 245 (defun x-display-color-p (&optional display) 't)
 246 (defun x-list-fonts (pattern &optional face frame) (list "default"))
 247 (defun x-color-defined-p (color) (numberp (msdos-color-translate color)))
 248 (defun x-display-pixel-width (&optional frame) (frame-width frame))
 249 (defun x-display-pixel-height (&optional frame) (frame-height frame))
 250 (defun x-display-planes (&optional frame) 4) ; 3 for background, actually
 251 (defun x-display-color-cells (&optional frame) 16) ; ???
 252 (defun x-server-max-request-size (&optional frame) 1000000) ; ???
 253 (defun x-server-vendor (&optional frame) t "GNU")
 254 (defun x-server-version (&optional frame) '(1 0 0))
 255 (defun x-display-screens (&optional frame) 1)
 256 (defun x-display-mm-height (&optional frame) 200) ; Guess the size of my
 257 (defun x-display-mm-width (&optional frame) 253)  ; monitor, MW...
 258 (defun x-display-backing-store (&optional frame) 'not-useful)
 259 (defun x-display-visual-class (&optional frame) 'static-color)
 260 (fset 'x-display-save-under 'ignore)
 261 (fset 'x-get-resource 'ignore)
 262
 263 ;; From lisp/term/x-win.el
 264 (setq x-display-name "pc")
 265 (setq split-window-keep-point t)
 266 (defvar x-colors '("black"
 267                    "blue"
 268                    "green"
 269                    "cyan"
 270                    "red"
 271                    "magenta"
 272                    "brown"
 273                    "lightgray"
 274                    "darkgray"
 275                    "lightblue"
 276                    "lightgreen"
 277                    "lightcyan"
 278                    "lightred"
 279                    "lightmagenta"
 280                    "yellow"
 281                    "white")
 282   "The list of colors available on a PC display under MS-DOS.")
 283 (defun x-defined-colors (&optional frame)
 284   "Return a list of colors supported for a particular frame.
 285 The argument FRAME specifies which frame to try.
 286 The value may be different for frames on different X displays."
 287   x-colors)
 288
 289 ;; From lisp/term/win32-win.el
 290 ;
 291 ;;;; Selections and cut buffers
 292 ;
 293 ;;; We keep track of the last text selected here, so we can check the
 294 ;;; current selection against it, and avoid passing back our own text
 295 ;;; from x-cut-buffer-or-selection-value.
 296 (defvar x-last-selected-text nil)
 297
 298 (defvar x-select-enable-clipboard t
 299   "Non-nil means cutting and pasting uses the clipboard.
 300 This is in addition to the primary selection.")
 301
 302 (defun x-select-text (text &optional push)
 303   (if x-select-enable-clipboard
 304       (win16-set-clipboard-data text))
 305   (setq x-last-selected-text text))
 306
 307 ;;; Return the value of the current selection.
 308 ;;; Consult the selection, then the cut buffer.  Treat empty strings
 309 ;;; as if they were unset.
 310 (defun x-get-selection-value ()
 311   (if x-select-enable-clipboard
 312       (let (text)
 313         ;; Don't die if x-get-selection signals an error.
 314         (condition-case c
 315             (setq text (win16-get-clipboard-data))
 316           (error (message "win16-get-clipboard-data:%s" c)))
 317         (if (string= text "") (setq text nil))
 318         (cond
 319          ((not text) nil)
 320          ((eq text x-last-selected-text) nil)
 321          ((string= text x-last-selected-text)
 322           ;; Record the newer string, so subsequent calls can use the 'eq' test.
 323           (setq x-last-selected-text text)
 324           nil)
 325          (t
 326           (setq x-last-selected-text text))))))
 327
 328 ;;; Arrange for the kill and yank functions to set and check the clipboard.
 329 (setq interprogram-cut-function 'x-select-text)
 330 (setq interprogram-paste-function 'x-get-selection-value)
 331
 332 ;; From lisp/faces.el: we only have one font, so always return
 333 ;; it, no matter which variety they've asked for.
 334 (defun x-frob-font-slant (font which)
 335   font)
 336
 337 ;; From lisp/term/x-win.el: make iconify-or-deiconify-frame a no-op.
 338 (fset 'iconify-or-deiconify-frame 'ignore)
 339
 340 ;; From lisp/frame.el
 341 (fset 'set-default-font 'ignore)
 342 (fset 'set-mouse-color 'ignore)         ; We cannot, I think.
 343 (fset 'set-cursor-color 'ignore)        ; Hardware determined by char under.
 344 (fset 'set-border-color 'ignore)        ; Not useful.
 345 ;; ---------------------------------------------------------------------------
 346 ;; Handle the X-like command line parameters "-fg" and "-bg"
 347 (defun msdos-handle-args (args)
 348   (let ((rest nil))
 349     (while args
 350       (let ((this (car args)))
 351         (setq args (cdr args))
 352         (cond ((or (string= this "-fg") (string= this "-foreground"))
 353                (if args
 354                    (setq default-frame-alist
 355                          (cons (cons 'foreground-color (car args))
 356                                default-frame-alist)
 357                          args (cdr args))))
 358               ((or (string= this "-bg") (string= this "-background"))
 359                (if args
 360                    (setq default-frame-alist
 361                          (cons (cons 'background-color (car args))
 362                                default-frame-alist)
 363                          args (cdr args))))
 364               (t (setq rest (cons this rest))))))
 365     (nreverse rest)))
 366
 367 (setq command-line-args (msdos-handle-args command-line-args))
 368 ;; ---------------------------------------------------------------------------