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 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         ;; Avoid expanding names that could trigger ange-ftp to prompt
 212         ;; for passwords, though.
 213         (if (or (string-match "^.:$" name)
 214                 (string-match "^/[^/:]+:" name))
 215             name
 216           (expand-file-name name)))
 217     filename))
 218
 219 (defun untranslated-file-p (filename)
 220   "Return t if FILENAME is on a filesystem that does not require
 221 CR/LF translation, and nil otherwise."
 222   (let ((fs (untranslated-canonical-name filename))
 223         (ufs-list untranslated-filesystem-list)
 224         (found nil))
 225     (while (and (not found) ufs-list)
 226       (if (string-match (concat "^" (car ufs-list)) fs)
 227           (setq found t)
 228         (setq ufs-list (cdr ufs-list))))
 229     found))
 230
 231 (defun add-untranslated-filesystem (filesystem)
 232   "Add FILESYSTEM to the list of filesystems that do not require
 233 CR/LF translation.  FILESYSTEM is a string containing the directory
 234 prefix corresponding to the filesystem.  For example, for a Unix
 235 filesystem mounted on drive Z:, FILESYSTEM could be \"Z:\"."
 236   (interactive "fUntranslated file system: ")
 237   (let ((fs (untranslated-canonical-name filesystem)))
 238     (if (member fs untranslated-filesystem-list)
 239         untranslated-filesystem-list
 240       (setq untranslated-filesystem-list
 241             (cons fs untranslated-filesystem-list)))))
 242
 243 (defun remove-untranslated-filesystem (filesystem)
 244   "Remove FILESYSTEM from 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   (interactive "fUntranslated file system: ")
 249   (setq untranslated-filesystem-list
 250         (delete (untranslated-canonical-name filesystem)
 251                 untranslated-filesystem-list)))
 252
 253 ;;; Support for printing under DOS/Windows, see lpr.el and ps-print.el.
 254
 255 (defvar direct-print-region-use-command-dot-com t
 256   "*Control whether command.com is used to print on Windows 9x.")
 257
 258 ;; Function to actually send data to the printer port.
 259 ;; Supports writing directly, and using various programs.
 260 (defun direct-print-region-helper (printer
 261                                    start end
 262                                    lpr-prog
 263                                    delete-text buf display
 264                                    rest)
 265   (let* (;; Ignore case when matching known external program names.
 266          (case-fold-search t)
 267          ;; Convert / to \ in printer name, for sake of external programs.
 268          (printer
 269           (if (stringp printer)
 270               (subst-char-in-string ?/ ?\\ printer)
 271             printer))
 272          ;; Find a directory that is local, to work-around Windows bug.
 273          (safe-dir
 274           (let ((safe-dirs (list "c:/" (getenv "windir") (getenv "TMPDIR"))))
 275             (while (not (file-attributes (car safe-dirs)))
 276               (setq safe-dirs (cdr safe-dirs)))
 277             (car safe-dirs)))
 278          (tempfile
 279           (subst-char-in-string
 280            ?/ ?\\
 281            (make-temp-name
 282             (expand-file-name "EP" (getenv "TMPDIR")))))
 283          ;; capture output for diagnosis
 284          (errbuf (list (get-buffer-create " *print-region-helper*") t)))
 285     ;; It seems that we must be careful about the directory name that
 286     ;; gets added to the printer port name by write-region when using
 287     ;; the standard "PRN" or "LPTx" ports, because the write can fail if
 288     ;; the directory is on a network drive.  The same is true when
 289     ;; asking command.com to copy the file.
 290     ;; No action is needed for UNC printer names, which is just as well
 291     ;; because `expand-file-name' doesn't support UNC names on MS-DOS.
 292     (if (and (stringp printer) (not (string-match "^\\\\" printer)))
 293         (setq printer
 294               (subst-char-in-string ?/ ?\\ (expand-file-name printer safe-dir))))
 295     ;; Handle known programs specially where necessary.
 296     (unwind-protect
 297         (cond
 298          ;; nprint.exe is the standard print command on Netware
 299          ((string-match "^nprint\\(\\.exe\\)?$" (file-name-nondirectory lpr-prog))
 300           (write-region start end tempfile nil 0)
 301           (call-process lpr-prog nil errbuf nil
 302                         tempfile (concat "P=" printer)))
 303          ;; print.exe is a standard command on NT
 304          ((string-match "^print\\(\\.exe\\)?$" (file-name-nondirectory lpr-prog))
 305           ;; Be careful not to invoke print.exe on MS-DOS or Windows 9x
 306           ;; though, because it is a TSR program there (hangs Emacs).
 307           (or (and (eq system-type 'windows-nt)
 308                    (null (getenv "winbootdir")))
 309               (error "Printing via print.exe is not supported on MS-DOS or Windows 9x"))
 310           ;; It seems that print.exe always appends a form-feed so we
 311           ;; should make sure to omit the last FF in the data.
 312           (if (and (> end start)
 313                    (char-equal (char-before end) ?\C-l))
 314               (setq end (1- end)))
 315           ;; cancel out annotate function for non-PS case
 316           (let ((write-region-annotate-functions nil))
 317             (write-region start end tempfile nil 0))
 318           (call-process lpr-prog nil errbuf nil
 319                         (concat "/D:" printer) tempfile))
 320          ;; support lpr and similar programs for convenience, but
 321          ;; supply an explicit filename because the NT version of lpr
 322          ;; can't read from stdin.
 323          ((> (length lpr-prog) 0)
 324           (write-region start end tempfile nil 0)
 325           (setq rest (append rest (list tempfile)))
 326           (apply 'call-process lpr-prog nil errbuf nil rest))
 327          ;; Run command.com to access printer port on Windows 9x, unless
 328          ;; we are supposed to append to an existing (non-empty) file,
 329          ;; to work around a bug in Windows 9x that prevents Win32
 330          ;; programs from accessing LPT ports reliably.
 331          ((and (eq system-type 'windows-nt)
 332                (getenv "winbootdir")
 333                ;; Allow cop-out so command.com isn't invoked
 334                direct-print-region-use-command-dot-com
 335                ;; file-attributes fails on LPT ports on Windows 9x but
 336                ;; not on NT, so handle both cases for safety.
 337                (eq (or (nth 7 (file-attributes printer)) 0) 0))
 338           (write-region start end tempfile nil 0)
 339           (let ((w32-quote-process-args nil))
 340             (call-process "command.com" nil errbuf nil "/c"
 341                           (format "copy /b %s %s" tempfile printer))))
 342          ;; write directly to the printer port
 343          (t
 344           (write-region start end printer t 0)))
 345       ;; ensure we remove the tempfile if created
 346       (if (file-exists-p tempfile)
 347           (delete-file tempfile)))))
 348
 349 (defvar printer-name)
 350
 351 (defun direct-print-region-function (start end
 352                                            &optional lpr-prog
 353                                            delete-text buf display
 354                                            &rest rest)
 355   "DOS/Windows-specific function to print the region on a printer.
 356 Writes the region to the device or file which is a value of
 357 `printer-name' \(which see\), unless the value of `lpr-command'
 358 indicates a specific program should be invoked."
 359
 360   ;; DOS printers need the lines to end with CR-LF pairs, so make
 361   ;; sure it always happens that way, unless the buffer is binary.
 362   (let* ((coding coding-system-for-write)
 363          (coding-base
 364           (if (null coding) 'undecided (coding-system-base coding)))
 365          (eol-type (coding-system-eol-type coding-base))
 366          ;; Make each print-out eject the final page, but don't waste
 367          ;; paper if the file ends with a form-feed already.
 368          (write-region-annotate-functions
 369           (cons
 370            (lambda (start end)
 371              (if (not (char-equal (char-before end) ?\C-l))
 372                  `((,end . "\f"))))
 373            write-region-annotate-functions))
 374          (printer (or (and (boundp 'dos-printer)
 375                            (stringp (symbol-value 'dos-printer))
 376                            (symbol-value 'dos-printer))
 377                       printer-name)))
 378     (or (eq coding-system-for-write 'no-conversion)
 379         (setq coding-system-for-write
 380               (aref eol-type 1)))       ; force conversion to DOS EOLs
 381     (direct-print-region-helper printer start end lpr-prog
 382                                 delete-text buf display rest)))
 383
 384 (setq print-region-function 'direct-print-region-function)
 385
 386 ;; Set this to nil if you have a port of the `pr' program
 387 ;; (e.g., from GNU Textutils), or if you have an `lpr'
 388 ;; program (see above) that can print page headers.
 389 ;; If `lpr-headers-switches' is non-nil (the default) and
 390 ;; `print-region-function' is set to `dos-print-region-function',
 391 ;; then requests to print page headers will be silently
 392 ;; ignored, and `print-buffer' and `print-region' produce
 393 ;; the same output as `lpr-buffer' and `lpr-region', accordingly.
 394 (setq lpr-headers-switches "(page headers are not supported)")
 395
 396 (defvar ps-printer-name)
 397
 398 (defun direct-ps-print-region-function (start end
 399                                               &optional lpr-prog
 400                                               delete-text buf display
 401                                               &rest rest)
 402   "DOS/Windows-specific function to print the region on a PostScript printer.
 403 Writes the region to the device or file which is a value of
 404 `ps-printer-name' \(which see\), unless the value of `ps-lpr-command'
 405 indicates a specific program should be invoked."
 406
 407   (let ((printer (or (and (boundp 'dos-ps-printer)
 408                           (stringp (symbol-value 'dos-ps-printer))
 409                           (symbol-value 'dos-ps-printer))
 410                      ps-printer-name)))
 411     (direct-print-region-helper printer start end lpr-prog
 412                                 delete-text buf display rest)))
 413
 414 (setq ps-print-region-function 'direct-ps-print-region-function)
 415
 416 ;(setq ps-lpr-command "gs")
 417
 418 ;(setq ps-lpr-switches '("-q" "-dNOPAUSE" "-sDEVICE=epson" "-r240x60"
 419 ;                         "-sOutputFile=LPT1"))
 420
 421 (provide 'dos-w32)
 422
 423 ;;; dos-w32.el ends here