code.delx.au - gnu-emacs/blob - lisp/dos-w32.el

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