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