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