lisp/dos-w32.el

   1 ;;; dos-w32.el --- Functions shared among MS-DOS and W32 (NT/95) platforms
   2
   3 ;; Copyright (C) 1996 Free Software Foundation, Inc.
   4
   5 ;; Maintainer: Geoff Voelker <voelker@cs.washington.edu>
   6 ;; Keywords: internal
   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 ;; Parts of this code are duplicated functions taken from dos-fns.el
  28 ;; and winnt.el.
  29
  30 ;;; Code:
  31
  32 ;; Use ";" instead of ":" as a path separator (from files.el).
  33 (setq path-separator ";")
  34
  35 (setq minibuffer-history-case-insensitive-variables
  36       (cons 'file-name-history minibuffer-history-case-insensitive-variables))
  37
  38 ;; Set the null device (for compile.el).
  39 (setq null-device "NUL")
  40
  41 ;; Set the grep regexp to match entries with drive letters.
  42 (setq grep-regexp-alist
  43   '(("^\\(\\([a-zA-Z]:\\)?[^:( \t\n]+\\)[:( \t]+\\([0-9]+\\)[:) \t]" 1 3)))
  44
  45 ;; For distinguishing file types based upon suffixes.
  46 (defvar file-name-buffer-file-type-alist
  47   '(
  48     ("[:/].*config.sys$" . nil)         ; config.sys text
  49     ("\\.\\(obj\\|exe\\|com\\|lib\\|sys\\|bin\\|ico\\|pif\\|class\\)$" . t)
  50                                         ; MS-Dos stuff
  51     ("\\.\\(dll\\|drv\\|386\\|vxd\\|fon\\|fnt\\|fot\\|ttf\\|grp\\)$" . t)
  52                                         ; Windows stuff
  53     ("\\.\\(bmp\\|wav\\|avi\\|mpg\\|jpg\\|tif\\|mov\\|au\\)" . t)
  54                                         ; known binary data files
  55     ("\\.\\(arc\\|zip\\|pak\\|lzh\\|zoo\\)$" . t)
  56                                         ; Packers
  57     ("\\.\\(a\\|o\\|tar\\|z\\|gz\\|taz\\|jar\\)$" . t)
  58                                         ; Unix stuff
  59     ("\\.tp[ulpw]$" . t)
  60                                         ; Borland Pascal stuff
  61     ("[:/]tags$" . nil)
  62                                         ; Emacs TAGS file
  63     )
  64   "*Alist for distinguishing text files from binary files.
  65 Each element has the form (REGEXP . TYPE), where REGEXP is matched
  66 against the file name, and TYPE is nil for text, t for binary.")
  67
  68 ;; Return the pair matching filename on file-name-buffer-file-type-alist,
  69 ;; or nil otherwise.
  70 (defun find-buffer-file-type-match (filename)
  71   (let ((alist file-name-buffer-file-type-alist)
  72         (found nil))
  73     (let ((case-fold-search t))
  74       (setq filename (file-name-sans-versions filename))
  75       (while (and (not found) alist)
  76         (if (string-match (car (car alist)) filename)
  77             (setq found (car alist)))
  78         (setq alist (cdr alist)))
  79       found)))
  80
  81 ;; Don't check for untranslated file systems here.
  82 (defun find-buffer-file-type (filename)
  83   (let ((match (find-buffer-file-type-match filename))
  84         (code))
  85     (if (not match)
  86         default-buffer-file-type
  87       (setq code (cdr match))
  88       (cond ((memq code '(nil t)) code)
  89             ((and (symbolp code) (fboundp code))
  90              (funcall code filename))))))
  91
  92 (setq-default buffer-file-coding-system 'undecided-dos)
  93
  94 (defun find-buffer-file-type-coding-system (command)
  95   "Choose a coding system for a file operation.
  96 If COMMAND is `insert-file-contents', the coding system is chosen based
  97 upon the filename, the contents of `untranslated-filesystem-list' and
  98 `file-name-buffer-file-type-alist', and whether the file exists:
  99
 100   If it matches in `untranslated-filesystem-list':
 101     If the file exists:                                 `no-conversion'
 102     If the file does not exist:                         `undecided'
 103   If it matches in `file-name-buffer-file-type-alist':
 104     If the match is t (for binary):                     `no-conversion'
 105     If the match is nil (for dos-text):                 `undecided-dos'
 106   Otherwise:
 107     If the file exists:                                 `undecided'
 108     If the file does not exist:        default-buffer-file-coding-system
 109
 110 If COMMAND is `write-region', the coding system is chosen based upon
 111 the value of `buffer-file-coding-system' and `buffer-file-type'. If
 112 `buffer-file-coding-system' is non-nil, its value is used.  If it is
 113 nil and `buffer-file-type' is t, the coding system is `no-conversion'.
 114 Otherwise, it is `undecided-dos'.
 115
 116 The two most common situations are when DOS and Unix files are read
 117 and written, and their names do not match in
 118 `untranslated-filesystem-list' and `file-name-buffer-file-type-alist'.
 119 In these cases, the coding system initially will be `undecided'.  As
 120 the file is read in the DOS case, the coding system will be changed to
 121 `undecided-dos' as CR/LFs are detected.  As the file is read in the
 122 Unix case, the coding system will be changed to `undecided-unix' as
 123 LFs are detected.  In both cases, `buffer-file-coding-system' will be
 124 set to the appropriate coding system, and the value of
 125 `buffer-file-coding-system' will be used when writing the file."
 126
 127   (let ((op (nth 0 command))
 128         (target)
 129         (binary nil) (text nil)
 130         (undecided nil) (undecided-unix nil))
 131     (cond ((eq op 'insert-file-contents)
 132            (setq target (nth 1 command))
 133            ;; First check for a file name that indicates
 134            ;; it is truly binary.
 135            (setq binary (find-buffer-file-type target))
 136            (cond (binary)
 137                  ;; Next check for files that MUST use DOS eol conversion.
 138                  ((find-buffer-file-type-match target)
 139                   (setq text t))
 140                  ;; For any other existing file, decide based on contents.
 141                  ((file-exists-p target)
 142                   (setq undecided t))
 143                  ;; Next check for a non-DOS file system.
 144                  ((untranslated-file-p target)
 145                   (setq undecided-unix t)))
 146            (cond (binary '(no-conversion . no-conversion))
 147                  (text '(undecided-dos . undecided-dos))
 148                  (undecided-unix '(undecided-unix . undecided-unix))
 149                  (undecided '(undecided . undecided))
 150                  (t (cons default-buffer-file-coding-system
 151                           default-buffer-file-coding-system))))
 152           ((eq op 'write-region)
 153            (if buffer-file-coding-system
 154                (cons buffer-file-coding-system
 155                      buffer-file-coding-system)
 156              ;; Normally this is used only in a non-file-visiting
 157              ;; buffer, because normally buffer-file-coding-system is non-nil
 158              ;; in a file-visiting buffer.
 159              (if buffer-file-type
 160                  '(no-conversion . no-conversion)
 161                '(undecided-dos . undecided-dos)))))))
 162
 163 (modify-coding-system-alist 'file "" 'find-buffer-file-type-coding-system)
 164
 165 (defun find-file-binary (filename)
 166   "Visit file FILENAME and treat it as binary."
 167   (interactive "FFind file binary: ")
 168   (let ((file-name-buffer-file-type-alist '(("" . t))))
 169     (find-file filename)))
 170
 171 (defun find-file-text (filename)
 172   "Visit file FILENAME and treat it as a text file."
 173   (interactive "FFind file text: ")
 174   (let ((file-name-buffer-file-type-alist '(("" . nil))))
 175     (find-file filename)))
 176
 177 (defun find-file-not-found-set-buffer-file-coding-system ()
 178   (save-excursion
 179     (set-buffer (current-buffer))
 180     (let* ((dummy-insert-op (list 'insert-file-contents (buffer-file-name)))
 181            (coding-system-pair
 182             (find-buffer-file-type-coding-system dummy-insert-op)))
 183       (setq buffer-file-coding-system (car coding-system-pair))
 184       (setq buffer-file-type (eq buffer-file-coding-system 'no-conversion)))))
 185
 186 ;;; To set the default coding system on new files.
 187 (add-hook 'find-file-not-found-hooks
 188           'find-file-not-found-set-buffer-file-coding-system)
 189
 190 ;;; To accomodate filesystems that do not require CR/LF translation.
 191 (defvar untranslated-filesystem-list nil
 192   "List of filesystems that require no CR/LF translation when reading
 193 and writing files.  Each filesystem in the list is a string naming
 194 the directory prefix corresponding to the filesystem.")
 195
 196 (defun untranslated-canonical-name (filename)
 197   "Return FILENAME in a canonicalized form for use with the functions
 198 dealing with untranslated filesystems."
 199   (if (memq system-type '(ms-dos windows-nt))
 200       ;; The canonical form for DOS/W32 is with A-Z downcased and all
 201       ;; directory separators changed to directory-sep-char.
 202       (let ((name nil))
 203         (setq name (mapconcat
 204                     '(lambda (char)
 205                        (if (and (<= ?A char) (<= char ?Z))
 206                            (char-to-string (+ (- char ?A) ?a))
 207                          (char-to-string char)))
 208                     filename nil))
 209         ;; Use expand-file-name to canonicalize directory separators, except
 210         ;; with bare drive letters (which would have the cwd appended).
 211         (if (string-match "^.:$" name)
 212             name
 213           (expand-file-name name)))
 214     filename))
 215
 216 (defun untranslated-file-p (filename)
 217   "Return t if FILENAME is on a filesystem that does not require
 218 CR/LF translation, and nil otherwise."
 219   (let ((fs (untranslated-canonical-name filename))
 220         (ufs-list untranslated-filesystem-list)
 221         (found nil))
 222     (while (and (not found) ufs-list)
 223       (if (string-match (concat "^" (car ufs-list)) fs)
 224           (setq found t)
 225         (setq ufs-list (cdr ufs-list))))
 226     found))
 227
 228 (defun add-untranslated-filesystem (filesystem)
 229   "Add FILESYSTEM to the list of filesystems that do not require
 230 CR/LF translation.  FILESYSTEM is a string containing the directory
 231 prefix corresponding to the filesystem.  For example, for a Unix
 232 filesystem mounted on drive Z:, FILESYSTEM could be \"Z:\"."
 233   (interactive "fUntranslated file system: ")
 234   (let ((fs (untranslated-canonical-name filesystem)))
 235     (if (member fs untranslated-filesystem-list)
 236         untranslated-filesystem-list
 237       (setq untranslated-filesystem-list
 238             (cons fs untranslated-filesystem-list)))))
 239
 240 (defun remove-untranslated-filesystem (filesystem)
 241   "Remove FILESYSTEM from the list of filesystems that do not require
 242 CR/LF translation.  FILESYSTEM is a string containing the directory
 243 prefix corresponding to the filesystem.  For example, for a Unix
 244 filesystem mounted on drive Z:, FILESYSTEM could be \"Z:\"."
 245   (interactive "fUntranslated file system: ")
 246   (setq untranslated-filesystem-list
 247         (delete (untranslated-canonical-name filesystem)
 248                 untranslated-filesystem-list)))
 249
 250 ;;; Support for printing under DOS/Windows, see lpr.el and ps-print.el.
 251
 252 (defvar direct-print-region-use-command-dot-com t
 253   "*Control whether command.com is used to print on Windows 9x.")
 254
 255 ;; Function to actually send data to the printer port.
 256 ;; Supports writing directly, and using various programs.
 257 (defun direct-print-region-helper (printer
 258                                    start end
 259                                    lpr-prog
 260                                    delete-text buf display
 261                                    rest)
 262   (let* (;; Ignore case when matching known external program names.
 263          (case-fold-search t)
 264          ;; Convert / to \ in printer name, for sake of external programs.
 265          (printer
 266           (if (stringp printer)
 267               (subst-char-in-string ?/ ?\\ printer)
 268             printer))
 269          ;; Find a directory that is local, to work-around Windows bug.
 270          (safe-dir
 271           (let ((safe-dirs (list "c:/" (getenv "windir") (getenv "TMPDIR"))))
 272             (while (not (file-attributes (car safe-dirs)))
 273               (setq safe-dirs (cdr safe-dirs)))
 274             (car safe-dirs)))
 275          (tempfile
 276           (subst-char-in-string
 277            ?/ ?\\
 278            (make-temp-name
 279             (expand-file-name "EP" (getenv "TMPDIR")))))
 280          ;; capture output for diagnosis
 281          (errbuf (list (get-buffer-create " *print-region-helper*") t)))
 282     ;; It seems that we must be careful about the directory name that
 283     ;; gets added to the printer port name by write-region when using
 284     ;; the standard "PRN" or "LPTx" ports, because the write can fail if
 285     ;; the directory is on a network drive.  The same is true when
 286     ;; asking command.com to copy the file.
 287     ;; No action is needed for UNC printer names, which is just as well
 288     ;; because `expand-file-name' doesn't support UNC names on MS-DOS.
 289     (if (and (stringp printer) (not (string-match "^\\\\" printer)))
 290         (setq printer
 291               (subst-char-in-string ?/ ?\\ (expand-file-name printer safe-dir))))
 292     ;; Handle known programs specially where necessary.
 293     (unwind-protect
 294         (cond
 295          ;; nprint.exe is the standard print command on Netware
 296          ((string-match "^nprint\\(\\.exe\\)?$" (file-name-nondirectory lpr-prog))
 297           (write-region start end tempfile nil 0)
 298           (call-process lpr-prog nil errbuf nil
 299                         tempfile (concat "P=" printer)))
 300          ;; print.exe is a standard command on NT
 301          ((string-match "^print\\(\\.exe\\)?$" (file-name-nondirectory lpr-prog))
 302           ;; Be careful not to invoke print.exe on MS-DOS or Windows 9x
 303           ;; though, because it is a TSR program there (hangs Emacs).
 304           (or (and (eq system-type 'windows-nt)
 305                    (null (getenv "winbootdir")))
 306               (error "Printing via print.exe is not supported on MS-DOS or Windows 9x"))
 307           ;; It seems that print.exe always appends a form-feed so we
 308           ;; should make sure to omit the last FF in the data.
 309           (if (and (> end start)
 310                    (char-equal (char-before end) ?\C-l))
 311               (setq end (1- end)))
 312           ;; cancel out annotate function for non-PS case
 313           (let ((write-region-annotate-functions nil))
 314             (write-region start end tempfile nil 0))
 315           (call-process lpr-prog nil errbuf nil
 316                         (concat "/D:" printer) tempfile))
 317          ;; support lpr and similar programs for convenience, but
 318          ;; supply an explicit filename because the NT version of lpr
 319          ;; can't read from stdin.
 320          ((> (length lpr-prog) 0)
 321           (write-region start end tempfile nil 0)
 322           (setq rest (append rest (list tempfile)))
 323           (apply 'call-process lpr-prog nil errbuf nil rest))
 324          ;; Run command.com to access printer port on Windows 9x, unless
 325          ;; we are supposed to append to an existing (non-empty) file,
 326          ;; to work around a bug in Windows 9x that prevents Win32
 327          ;; programs from accessing LPT ports reliably.
 328          ((and (eq system-type 'windows-nt)
 329                (getenv "winbootdir")
 330                ;; Allow cop-out so command.com isn't invoked
 331                direct-print-region-use-command-dot-com
 332                ;; file-attributes fails on LPT ports on Windows 9x but
 333                ;; not on NT, so handle both cases for safety.
 334                (eq (or (nth 7 (file-attributes printer)) 0) 0))
 335           (write-region start end tempfile nil 0)
 336           (let ((w32-quote-process-args nil))
 337             (call-process "command.com" nil errbuf nil "/c"
 338                           (format "copy /b %s %s" tempfile printer))))
 339          ;; write directly to the printer port
 340          (t
 341           (write-region start end printer t 0)))
 342       ;; ensure we remove the tempfile if created
 343       (if (file-exists-p tempfile)
 344           (delete-file tempfile)))))
 345
 346 (defvar printer-name)
 347
 348 (defun direct-print-region-function (start end
 349                                            &optional lpr-prog
 350                                            delete-text buf display
 351                                            &rest rest)
 352   "DOS/Windows-specific function to print the region on a printer.
 353 Writes the region to the device or file which is a value of
 354 `printer-name' \(which see\), unless the value of `lpr-command'
 355 indicates a specific program should be invoked."
 356
 357   ;; DOS printers need the lines to end with CR-LF pairs, so make
 358   ;; sure it always happens that way, unless the buffer is binary.
 359   (let* ((coding coding-system-for-write)
 360          (coding-base
 361           (if (null coding) 'undecided (coding-system-base coding)))
 362          (eol-type (coding-system-eol-type coding-base))
 363          ;; Make each print-out eject the final page, but don't waste
 364          ;; paper if the file ends with a form-feed already.
 365          (write-region-annotate-functions
 366           (cons
 367            (lambda (start end)
 368              (if (not (char-equal (char-before end) ?\C-l))
 369                  `((,end . "\f"))))
 370            write-region-annotate-functions))
 371          (printer (or (and (boundp 'dos-printer)
 372                            (stringp (symbol-value 'dos-printer))
 373                            (symbol-value 'dos-printer))
 374                       printer-name)))
 375     (or (eq coding-system-for-write 'no-conversion)
 376         (setq coding-system-for-write
 377               (aref eol-type 1)))       ; force conversion to DOS EOLs
 378     (direct-print-region-helper printer start end lpr-prog
 379                                 delete-text buf display rest)))
 380
 381 (setq print-region-function 'direct-print-region-function)
 382
 383 ;; Set this to nil if you have a port of the `pr' program
 384 ;; (e.g., from GNU Textutils), or if you have an `lpr'
 385 ;; program (see above) that can print page headers.
 386 ;; If `lpr-headers-switches' is non-nil (the default) and
 387 ;; `print-region-function' is set to `dos-print-region-function',
 388 ;; then requests to print page headers will be silently
 389 ;; ignored, and `print-buffer' and `print-region' produce
 390 ;; the same output as `lpr-buffer' and `lpr-region', accordingly.
 391 (setq lpr-headers-switches "(page headers are not supported)")
 392
 393 (defvar ps-printer-name)
 394
 395 (defun direct-ps-print-region-function (start end
 396                                               &optional lpr-prog
 397                                               delete-text buf display
 398                                               &rest rest)
 399   "DOS/Windows-specific function to print the region on a PostScript printer.
 400 Writes the region to the device or file which is a value of
 401 `ps-printer-name' \(which see\), unless the value of `ps-lpr-command'
 402 indicates a specific program should be invoked."
 403
 404   (let ((printer (or (and (boundp 'dos-ps-printer)
 405                           (stringp (symbol-value 'dos-ps-printer))
 406                           (symbol-value 'dos-ps-printer))
 407                      ps-printer-name)))
 408     (direct-print-region-helper printer start end lpr-prog
 409                                 delete-text buf display rest)))
 410
 411 (setq ps-print-region-function 'direct-ps-print-region-function)
 412
 413 ;(setq ps-lpr-command "gs")
 414
 415 ;(setq ps-lpr-switches '("-q" "-dNOPAUSE" "-sDEVICE=epson" "-r240x60"
 416 ;                         "-sOutputFile=LPT1"))
 417
 418 (provide 'dos-w32)
 419
 420 ;;; dos-w32.el ends here