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 ;; Set the null device (for compile.el).
  36 (setq grep-null-device "NUL")
  37
  38 ;; Set the grep regexp to match entries with drive letters.
  39 (setq grep-regexp-alist
  40   '(("^\\(\\([a-zA-Z]:\\)?[^:( \t\n]+\\)[:( \t]+\\([0-9]+\\)[:) \t]" 1 3)))
  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     ("\\.elc$" . t)                     ; emacs stuff
  47     ("\\.\\(obj\\|exe\\|com\\|lib\\|sym\\|sys\\|chk\\|out\\|bin\\|ico\\|pif\\|class\\)$" . t)
  48                                         ; MS-Dos stuff
  49     ("\\.\\(dll\\|drv\\|cpl\\|scr\\vbx\\|386\\|vxd\\|fon\\|fnt\\|fot\\|ttf\\|grp\\)$" . t)
  50                                         ; Windows stuff
  51     ("\\.\\(hlp\\|bmp\\|wav\\|avi\\|mpg\\|jpg\\|tif\\mov\\au\\)" . t)
  52                                         ; known binary data files
  53     ("\\.\\(arc\\|zip\\|pak\\|lzh\\|zoo\\)$" . t)
  54                                         ; Packers
  55     ("\\.\\(a\\|o\\|tar\\|z\\|gz\\|taz\\|jar\\)$" . t)
  56                                         ; Unix stuff
  57     ("\\.tp[ulpw]$" . t)
  58                                         ; Borland Pascal stuff
  59     ("[:/]tags$" . t)
  60                                         ; Emacs TAGS file
  61     )
  62   "*Alist for distinguishing text files from binary files.
  63 Each element has the form (REGEXP . TYPE), where REGEXP is matched
  64 against the file name, and TYPE is nil for text, t for binary.")
  65
  66 ;; Return the pair matching filename on file-name-buffer-file-type-alist,
  67 ;; or nil otherwise.
  68 (defun find-buffer-file-type-match (filename)
  69   (let ((alist file-name-buffer-file-type-alist)
  70         (found nil))
  71     (let ((case-fold-search t))
  72       (setq filename (file-name-sans-versions filename))
  73       (while (and (not found) alist)
  74         (if (string-match (car (car alist)) filename)
  75             (setq found (car alist)))
  76         (setq alist (cdr alist)))
  77       found)))
  78
  79 ;; Don't check for untranslated file systems here.
  80 (defun find-buffer-file-type (filename)
  81   (let ((match (find-buffer-file-type-match filename))
  82         (code))
  83     (if (not match)
  84         default-buffer-file-type
  85       (setq code (cdr match))
  86       (cond ((memq code '(nil t)) code)
  87             ((and (symbolp code) (fboundp code))
  88              (funcall code filename))))))
  89
  90 (setq-default buffer-file-coding-system 'undecided-dos)
  91
  92 (defun find-buffer-file-type-coding-system (command)
  93   "Choose a coding system for a file operation.
  94 If COMMAND is `insert-file-contents', the coding system is chosen based
  95 upon the filename, the contents of `untranslated-filesystem-list' and
  96 `file-name-buffer-file-type-alist', and whether the file exists:
  97
  98   If it matches in `untranslated-filesystem-list':
  99     If the file exists:                                 `no-conversion'
 100     If the file does not exist:                         `undecided'
 101   If it matches in `file-name-buffer-file-type-alist':
 102     If the match is t (for binary):                     `no-conversion'
 103     If the match is nil (for dos-text):                 `undecided-dos'
 104   Otherwise:
 105     If the file exists:                                 `undecided'
 106     If the file does not exist:                         `undecided-dos'
 107
 108 If COMMAND is `write-region', the coding system is chosen based upon
 109 the value of `buffer-file-coding-system' and `buffer-file-type'. If
 110 `buffer-file-coding-system' is non-nil, its value is used.  If it is
 111 nil and `buffer-file-type' is t, the coding system is `no-conversion'.
 112 Otherwise, it is `undecided-dos'.
 113
 114 The two most common situations are when DOS and Unix files are read
 115 and written, and their names do not match in
 116 `untranslated-filesystem-list' and `file-name-buffer-file-type-alist'.
 117 In these cases, the coding system initially will be `undecided'.  As
 118 the file is read in the DOS case, the coding system will be changed to
 119 `undecided-dos' as CR/LFs are detected.  As the file is read in the
 120 Unix case, the coding system will be changed to `undecided-unix' as
 121 LFs are detected.  In both cases, `buffer-file-coding-system' will be
 122 set to the appropriate coding system, and the value of
 123 `buffer-file-coding-system' will be used when writing the file."
 124
 125   (let ((op (nth 0 command))
 126         (target)
 127         (binary nil) (text nil)
 128         (undecided nil) (undecided-unix nil))
 129     (cond ((eq op 'insert-file-contents)
 130            (setq target (nth 1 command))
 131            ;; First check for a file name that indicates
 132            ;; it is truly binary.
 133            (setq binary (find-buffer-file-type target))
 134            (cond (binary)
 135                  ;; Next check for files that MUST use DOS eol conversion.
 136                  ((find-buffer-file-type-match target)
 137                   (setq text t))
 138                  ;; For any other existing file, decide based on contents.
 139                  ((file-exists-p target)
 140                   (setq undecided t))
 141                  ;; Next check for a non-DOS file system.
 142                  ((untranslated-file-p target)
 143                   (setq undecided-unix t)))
 144            (cond (binary '(no-conversion . no-conversion))
 145                  (text '(undecided-dos . undecided-dos))
 146                  (undecided-unix '(undecided-unix . undecided-unix))
 147                  (undecided '(undecided . undecided))
 148                  (t '(undecided-dos . undecided-dos))))
 149           ((eq op 'write-region)
 150            (if buffer-file-coding-system
 151                (cons buffer-file-coding-system
 152                      buffer-file-coding-system)
 153              ;; Normally this is used only in a non-file-visiting
 154              ;; buffer, because normally buffer-file-coding-system is non-nil
 155              ;; in a file-visiting buffer.
 156              (if buffer-file-type
 157                  '(no-conversion . no-conversion)
 158                '(undecided-dos . undecided-dos)))))))
 159
 160 (modify-coding-system-alist 'file "" 'find-buffer-file-type-coding-system)
 161
 162 (defun find-file-binary (filename)
 163   "Visit file FILENAME and treat it as binary."
 164   (interactive "FFind file binary: ")
 165   (let ((file-name-buffer-file-type-alist '(("" . t))))
 166     (find-file filename)))
 167
 168 (defun find-file-text (filename)
 169   "Visit file FILENAME and treat it as a text file."
 170   (interactive "FFind file text: ")
 171   (let ((file-name-buffer-file-type-alist '(("" . nil))))
 172     (find-file filename)))
 173
 174 (defun find-file-not-found-set-buffer-file-coding-system ()
 175   (save-excursion
 176     (set-buffer (current-buffer))
 177     (let* ((dummy-insert-op (list 'insert-file-contents (buffer-file-name)))
 178            (coding-system-pair
 179             (find-buffer-file-type-coding-system dummy-insert-op)))
 180       (setq buffer-file-coding-system (car coding-system-pair))
 181       (setq buffer-file-type (eq buffer-file-coding-system 'no-conversion)))))
 182
 183 ;;; To set the default coding system on new files.
 184 (add-hook 'find-file-not-found-hooks
 185           'find-file-not-found-set-buffer-file-coding-system)
 186
 187 ;;; To accomodate filesystems that do not require CR/LF translation.
 188 (defvar untranslated-filesystem-list nil
 189   "List of filesystems that require no CR/LF translation when reading
 190 and writing files.  Each filesystem in the list is a string naming
 191 the directory prefix corresponding to the filesystem.")
 192
 193 (defun untranslated-canonical-name (filename)
 194   "Return FILENAME in a canonicalized form for use with the functions
 195 dealing with untranslated filesystems."
 196   (if (memq system-type '(ms-dos windows-nt))
 197       ;; The canonical form for DOS/W32 is with A-Z downcased and all
 198       ;; directory separators changed to directory-sep-char.
 199       (let ((name nil))
 200         (setq name (mapconcat
 201                     '(lambda (char)
 202                        (if (and (<= ?A char) (<= char ?Z))
 203                            (char-to-string (+ (- char ?A) ?a))
 204                          (char-to-string char)))
 205                     filename nil))
 206         ;; Use expand-file-name to canonicalize directory separators, except
 207         ;; with bare drive letters (which would have the cwd appended).
 208         (if (string-match "^.:$" name)
 209             name
 210           (expand-file-name name)))
 211     filename))
 212
 213 (defun untranslated-file-p (filename)
 214   "Return t if FILENAME is on a filesystem that does not require
 215 CR/LF translation, and nil otherwise."
 216   (let ((fs (untranslated-canonical-name filename))
 217         (ufs-list untranslated-filesystem-list)
 218         (found nil))
 219     (while (and (not found) ufs-list)
 220       (if (string-match (concat "^" (car ufs-list)) fs)
 221           (setq found t)
 222         (setq ufs-list (cdr ufs-list))))
 223     found))
 224
 225 (defun add-untranslated-filesystem (filesystem)
 226   "Add FILESYSTEM to the list of filesystems that do not require
 227 CR/LF translation.  FILESYSTEM is a string containing the directory
 228 prefix corresponding to the filesystem.  For example, for a Unix
 229 filesystem mounted on drive Z:, FILESYSTEM could be \"Z:\"."
 230   (interactive "fUntranslated file system: ")
 231   (let ((fs (untranslated-canonical-name filesystem)))
 232     (if (member fs untranslated-filesystem-list)
 233         untranslated-filesystem-list
 234       (setq untranslated-filesystem-list
 235             (cons fs untranslated-filesystem-list)))))
 236
 237 (defun remove-untranslated-filesystem (filesystem)
 238   "Remove FILESYSTEM from the list of filesystems that do not require
 239 CR/LF translation.  FILESYSTEM is a string containing the directory
 240 prefix corresponding to the filesystem.  For example, for a Unix
 241 filesystem mounted on drive Z:, FILESYSTEM could be \"Z:\"."
 242   (interactive "fUntranslated file system: ")
 243   (setq untranslated-filesystem-list
 244         (delete (untranslated-canonical-name filesystem)
 245                 untranslated-filesystem-list)))
 246
 247 ;; Process I/O decoding and encoding.
 248
 249 (defun find-binary-process-coding-system (command)
 250   "Choose a coding system for process I/O.
 251 The coding system for decode is 'no-conversion' if 'binary-process-output'
 252 is non-nil, and 'undecided-dos' otherwise.  Similarly, the coding system
 253 for encode is 'no-conversion' if 'binary-process-input' is non-nil,
 254 and 'undecided-dos' otherwise."
 255   (let ((decode 'undecided-dos)
 256         (encode 'undecided-dos))
 257     (if binary-process-output
 258         (setq decode 'no-conversion))
 259     (if binary-process-input
 260         (setq encode 'no-conversion))
 261     (cons decode encode)))
 262
 263 (modify-coding-system-alist 'process "" 'find-binary-process-coding-system)
 264
 265
 266 (provide 'dos-w32)
 267
 268 ;;; dos-w32.el ends here