lisp/dos-w32.el

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