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     ("\\.elc$" . t)                     ; emacs stuff
  50     ("\\.\\(obj\\|exe\\|com\\|lib\\|sym\\|sys\\|chk\\|out\\|bin\\|ico\\|pif\\|class\\)$" . t)
  51                                         ; MS-Dos stuff
  52     ("\\.\\(dll\\|drv\\|cpl\\|scr\\vbx\\|386\\|vxd\\|fon\\|fnt\\|fot\\|ttf\\|grp\\)$" . t)
  53                                         ; Windows stuff
  54     ("\\.\\(hlp\\|bmp\\|wav\\|avi\\|mpg\\|jpg\\|tif\\|mov\\|au\\)" . t)
  55                                         ; known binary data files
  56     ("\\.\\(arc\\|zip\\|pak\\|lzh\\|zoo\\)$" . t)
  57                                         ; Packers
  58     ("\\.\\(a\\|o\\|tar\\|z\\|gz\\|taz\\|jar\\)$" . t)
  59                                         ; Unix stuff
  60     ("\\.tp[ulpw]$" . t)
  61                                         ; Borland Pascal stuff
  62     ("[:/]tags$" . nil)
  63                                         ; Emacs TAGS file
  64     )
  65   "*Alist for distinguishing text files from binary files.
  66 Each element has the form (REGEXP . TYPE), where REGEXP is matched
  67 against the file name, and TYPE is nil for text, t for binary.")
  68
  69 ;; Return the pair matching filename on file-name-buffer-file-type-alist,
  70 ;; or nil otherwise.
  71 (defun find-buffer-file-type-match (filename)
  72   (let ((alist file-name-buffer-file-type-alist)
  73         (found nil))
  74     (let ((case-fold-search t))
  75       (setq filename (file-name-sans-versions filename))
  76       (while (and (not found) alist)
  77         (if (string-match (car (car alist)) filename)
  78             (setq found (car alist)))
  79         (setq alist (cdr alist)))
  80       found)))
  81
  82 ;; Don't check for untranslated file systems here.
  83 (defun find-buffer-file-type (filename)
  84   (let ((match (find-buffer-file-type-match filename))
  85         (code))
  86     (if (not match)
  87         default-buffer-file-type
  88       (setq code (cdr match))
  89       (cond ((memq code '(nil t)) code)
  90             ((and (symbolp code) (fboundp code))
  91              (funcall code filename))))))
  92
  93 (setq-default buffer-file-coding-system 'undecided-dos)
  94
  95 (defun find-buffer-file-type-coding-system (command)
  96   "Choose a coding system for a file operation.
  97 If COMMAND is `insert-file-contents', the coding system is chosen based
  98 upon the filename, the contents of `untranslated-filesystem-list' and
  99 `file-name-buffer-file-type-alist', and whether the file exists:
 100
 101   If it matches in `untranslated-filesystem-list':
 102     If the file exists:                                 `no-conversion'
 103     If the file does not exist:                         `undecided'
 104   If it matches in `file-name-buffer-file-type-alist':
 105     If the match is t (for binary):                     `no-conversion'
 106     If the match is nil (for dos-text):                 `undecided-dos'
 107   Otherwise:
 108     If the file exists:                                 `undecided'
 109     If the file does not exist:        default-buffer-file-coding-system
 110
 111 If COMMAND is `write-region', the coding system is chosen based upon
 112 the value of `buffer-file-coding-system' and `buffer-file-type'. If
 113 `buffer-file-coding-system' is non-nil, its value is used.  If it is
 114 nil and `buffer-file-type' is t, the coding system is `no-conversion'.
 115 Otherwise, it is `undecided-dos'.
 116
 117 The two most common situations are when DOS and Unix files are read
 118 and written, and their names do not match in
 119 `untranslated-filesystem-list' and `file-name-buffer-file-type-alist'.
 120 In these cases, the coding system initially will be `undecided'.  As
 121 the file is read in the DOS case, the coding system will be changed to
 122 `undecided-dos' as CR/LFs are detected.  As the file is read in the
 123 Unix case, the coding system will be changed to `undecided-unix' as
 124 LFs are detected.  In both cases, `buffer-file-coding-system' will be
 125 set to the appropriate coding system, and the value of
 126 `buffer-file-coding-system' will be used when writing the file."
 127
 128   (let ((op (nth 0 command))
 129         (target)
 130         (binary nil) (text nil)
 131         (undecided nil) (undecided-unix nil))
 132     (cond ((eq op 'insert-file-contents)
 133            (setq target (nth 1 command))
 134            ;; First check for a file name that indicates
 135            ;; it is truly binary.
 136            (setq binary (find-buffer-file-type target))
 137            (cond (binary)
 138                  ;; Next check for files that MUST use DOS eol conversion.
 139                  ((find-buffer-file-type-match target)
 140                   (setq text t))
 141                  ;; For any other existing file, decide based on contents.
 142                  ((file-exists-p target)
 143                   (setq undecided t))
 144                  ;; Next check for a non-DOS file system.
 145                  ((untranslated-file-p target)
 146                   (setq undecided-unix t)))
 147            (cond (binary '(no-conversion . no-conversion))
 148                  (text '(undecided-dos . undecided-dos))
 149                  (undecided-unix '(undecided-unix . undecided-unix))
 150                  (undecided '(undecided . undecided))
 151                  (t (cons default-buffer-file-coding-system
 152                           default-buffer-file-coding-system))))
 153           ((eq op 'write-region)
 154            (if buffer-file-coding-system
 155                (cons buffer-file-coding-system
 156                      buffer-file-coding-system)
 157              ;; Normally this is used only in a non-file-visiting
 158              ;; buffer, because normally buffer-file-coding-system is non-nil
 159              ;; in a file-visiting buffer.
 160              (if buffer-file-type
 161                  '(no-conversion . no-conversion)
 162                '(undecided-dos . undecided-dos)))))))
 163
 164 (modify-coding-system-alist 'file "" 'find-buffer-file-type-coding-system)
 165
 166 (defun find-file-binary (filename)
 167   "Visit file FILENAME and treat it as binary."
 168   (interactive "FFind file binary: ")
 169   (let ((file-name-buffer-file-type-alist '(("" . t))))
 170     (find-file filename)))
 171
 172 (defun find-file-text (filename)
 173   "Visit file FILENAME and treat it as a text file."
 174   (interactive "FFind file text: ")
 175   (let ((file-name-buffer-file-type-alist '(("" . nil))))
 176     (find-file filename)))
 177
 178 (defun find-file-not-found-set-buffer-file-coding-system ()
 179   (save-excursion
 180     (set-buffer (current-buffer))
 181     (let* ((dummy-insert-op (list 'insert-file-contents (buffer-file-name)))
 182            (coding-system-pair
 183             (find-buffer-file-type-coding-system dummy-insert-op)))
 184       (setq buffer-file-coding-system (car coding-system-pair))
 185       (setq buffer-file-type (eq buffer-file-coding-system 'no-conversion)))))
 186
 187 ;;; To set the default coding system on new files.
 188 (add-hook 'find-file-not-found-hooks
 189           'find-file-not-found-set-buffer-file-coding-system)
 190
 191 ;;; To accomodate filesystems that do not require CR/LF translation.
 192 (defvar untranslated-filesystem-list nil
 193   "List of filesystems that require no CR/LF translation when reading
 194 and writing files.  Each filesystem in the list is a string naming
 195 the directory prefix corresponding to the filesystem.")
 196
 197 (defun untranslated-canonical-name (filename)
 198   "Return FILENAME in a canonicalized form for use with the functions
 199 dealing with untranslated filesystems."
 200   (if (memq system-type '(ms-dos windows-nt))
 201       ;; The canonical form for DOS/W32 is with A-Z downcased and all
 202       ;; directory separators changed to directory-sep-char.
 203       (let ((name nil))
 204         (setq name (mapconcat
 205                     '(lambda (char)
 206                        (if (and (<= ?A char) (<= char ?Z))
 207                            (char-to-string (+ (- char ?A) ?a))
 208                          (char-to-string char)))
 209                     filename nil))
 210         ;; Use expand-file-name to canonicalize directory separators, except
 211         ;; with bare drive letters (which would have the cwd appended).
 212         (if (string-match "^.:$" name)
 213             name
 214           (expand-file-name name)))
 215     filename))
 216
 217 (defun untranslated-file-p (filename)
 218   "Return t if FILENAME is on a filesystem that does not require
 219 CR/LF translation, and nil otherwise."
 220   (let ((fs (untranslated-canonical-name filename))
 221         (ufs-list untranslated-filesystem-list)
 222         (found nil))
 223     (while (and (not found) ufs-list)
 224       (if (string-match (concat "^" (car ufs-list)) fs)
 225           (setq found t)
 226         (setq ufs-list (cdr ufs-list))))
 227     found))
 228
 229 (defun add-untranslated-filesystem (filesystem)
 230   "Add FILESYSTEM to the list of filesystems that do not require
 231 CR/LF translation.  FILESYSTEM is a string containing the directory
 232 prefix corresponding to the filesystem.  For example, for a Unix
 233 filesystem mounted on drive Z:, FILESYSTEM could be \"Z:\"."
 234   (interactive "fUntranslated file system: ")
 235   (let ((fs (untranslated-canonical-name filesystem)))
 236     (if (member fs untranslated-filesystem-list)
 237         untranslated-filesystem-list
 238       (setq untranslated-filesystem-list
 239             (cons fs untranslated-filesystem-list)))))
 240
 241 (defun remove-untranslated-filesystem (filesystem)
 242   "Remove FILESYSTEM from the list of filesystems that do not require
 243 CR/LF translation.  FILESYSTEM is a string containing the directory
 244 prefix corresponding to the filesystem.  For example, for a Unix
 245 filesystem mounted on drive Z:, FILESYSTEM could be \"Z:\"."
 246   (interactive "fUntranslated file system: ")
 247   (setq untranslated-filesystem-list
 248         (delete (untranslated-canonical-name filesystem)
 249                 untranslated-filesystem-list)))
 250
 251 ;;; Override setting chosen at startup.
 252 (defun set-default-process-coding-system ()
 253   (setq default-process-coding-system
 254         (if default-enable-multibyte-characters
 255             '(undecided-dos . undecided-dos)
 256           '(raw-text-dos . raw-text-dos))))
 257
 258 (add-hook 'before-init-hook 'set-default-process-coding-system)
 259
 260 ;;; Support for printing under DOS/Windows, see lpr.el and ps-print.el.
 261
 262 ;; Function to actually send data to the printer port.
 263 ;; Supports writing directly, and using various programs.
 264 (defun direct-print-region-helper (printer
 265                                    start end
 266                                    lpr-prog
 267                                    delete-text buf display
 268                                    rest)
 269   (let* ((directory-sep-char ?\\)       ; expand file names in DOS format
 270          ;; 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           (make-temp-name
 285            (expand-file-name "EP" (getenv "TMPDIR"))))
 286          ;; capture output for diagnosis
 287          (errbuf (list (get-buffer-create " *print-region-helper*") t)))
 288     ;; It seems that we must be careful about the directory name that
 289     ;; gets added to the printer port name by write-region when using
 290     ;; the standard "PRN" or "LPTx" ports, because the write can fail if
 291     ;; the directory is on a network drive.  The same is true when
 292     ;; asking command.com to copy the file.
 293     ;; No action is needed for UNC printer names, which is just as well
 294     ;; because `expand-file-name' doesn't support UNC names on MS-DOS.
 295     (if (not (string-match "^\\\\" printer))
 296         (setq printer (expand-file-name printer safe-dir)))
 297     ;; Handle known programs specially where necessary.
 298     (unwind-protect
 299         (cond
 300          ;; nprint.exe is the standard print command on Netware
 301          ((string-match "^nprint\\(\\.exe\\)?$" (file-name-nondirectory lpr-prog))
 302           (write-region start end tempfile nil 0)
 303           (call-process lpr-prog nil errbuf nil
 304                         tempfile (concat "P=" printer)))
 305          ;; print.exe is a standard command on NT
 306          ((string-match "^print\\(\\.exe\\)?$" (file-name-nondirectory lpr-prog))
 307           ;; Be careful not to invoke print.exe on MS-DOS or Windows 9x
 308           ;; though, because it is a TSR program there (hangs Emacs).
 309           (or (and (eq system-type 'windows-nt)
 310                    (null (getenv "winbootdir")))
 311               (error "Printing via print.exe is not supported on MS-DOS or Windows 9x"))
 312           ;; It seems that print.exe always appends a form-feed so we
 313           ;; should make sure to omit the last FF in the data.
 314           (if (and (> end start)
 315                    (char-equal (char-before end) ?\C-l))
 316               (setq end (1- end)))
 317           ;; cancel out annotate function for non-PS case
 318           (let ((write-region-annotate-functions nil))
 319             (write-region start end tempfile nil 0))
 320           (call-process lpr-prog nil errbuf nil
 321                         (concat "/D:" printer) tempfile))
 322          ;; support lpr and similar programs for convenience, but
 323          ;; supply an explicit filename because the NT version of lpr
 324          ;; can't read from stdin.
 325          ((> (length lpr-prog) 0)
 326           (write-region start end tempfile nil 0)
 327           (setq rest (append rest (list tempfile)))
 328           (apply 'call-process lpr-prog nil errbuf nil rest))
 329          ;; Run command.com to access printer port on Windows 9x, unless
 330          ;; we are supposed to append to an existing (non-empty) file,
 331          ;; to work around a bug in Windows 9x that prevents Win32
 332          ;; programs from accessing LPT ports reliably.
 333          ((and (eq system-type 'windows-nt)
 334                (getenv "winbootdir")
 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