lisp/dos-fns.el

   1 ;;; dos-fns.el --- MS-Dos specific functions
   2
   3 ;; Copyright (C) 1991, 1993, 1995, 1996, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
   5
   6 ;; Maintainer: Morten Welinder <terra@diku.dk>
   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 3 of the License, or
  14 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; Part of this code is taken from (or derived from) demacs.
  27
  28 ;;; Code:
  29
  30 (declare-function int86 "dosfns.c")
  31 (declare-function msdos-long-file-names "msdos.c")
  32
  33 ;; This overrides a trivial definition in files.el.
  34 (defun convert-standard-filename (filename)
  35   "Convert a standard file's name to something suitable for the current OS.
  36 This means to guarantee valid names and perhaps to canonicalize
  37 certain patterns.
  38
  39 On Windows and DOS, replace invalid characters.  On DOS, make
  40 sure to obey the 8.3 limitations.  On Windows, turn Cygwin names
  41 into native names, and also turn slashes into backslashes if the
  42 shell requires it (see `w32-shell-dos-semantics')."
  43   (if (or (not (stringp filename))
  44           ;; This catches the case where FILENAME is "x:" or "x:/" or
  45           ;; "/", thus preventing infinite recursion.
  46           (string-match "\\`\\([a-zA-Z]:\\)?[/\\]?\\'" filename))
  47       filename
  48     (let ((flen (length filename)))
  49       ;; If FILENAME has a trailing slash, remove it and recurse.
  50       (if (memq (aref filename (1- flen)) '(?/ ?\\))
  51           (concat (convert-standard-filename
  52                    (substring filename 0 (1- flen)))
  53                   "/")
  54         (let* (;; ange-ftp gets in the way for names like "/foo:bar".
  55                ;; We need to inhibit all magic file names, because
  56                ;; remote file names should never be passed through
  57                ;; this function, as they are not meant for the local
  58                ;; filesystem!
  59                (file-name-handler-alist nil)
  60                (dir
  61                 ;; If FILENAME is "x:foo", file-name-directory returns
  62                 ;; "x:/bar/baz", substituting the current working
  63                 ;; directory on drive x:.  We want to be left with "x:"
  64                 ;; instead.
  65                 (if (and (< 1 flen)
  66                          (eq (aref filename 1) ?:)
  67                          (null (string-match "[/\\]" filename)))
  68                     (substring filename 0 2)
  69                   (file-name-directory filename)))
  70                (dlen-m-1 (1- (length dir)))
  71                (string (copy-sequence (file-name-nondirectory filename)))
  72                (lastchar (aref string (1- (length string))))
  73                i firstdot)
  74           (cond
  75            ((msdos-long-file-names)
  76             ;; Replace characters that are invalid even on Windows.
  77             (while (setq i (string-match "[?*:<>|\"\000-\037]" string))
  78               (aset string i ?!)))
  79            ((not (member string '("" "." "..")))
  80             ;; Change a leading period to a leading underscore.
  81             (if (= (aref string 0) ?.)
  82                 (aset string 0 ?_))
  83             ;; If the name is longer than 8 chars, and doesn't have a
  84             ;; period, and we have a dash or underscore that isn't too
  85             ;; close to the beginning, change that to a period.  This
  86             ;; is so we could salvage more characters of the original
  87             ;; name by pushing them into the extension.
  88             (if (and (not (string-match "\\." string))
  89                      (> (length string) 8)
  90                      ;; We don't gain anything if we put the period closer
  91                      ;; than 5 chars from the beginning (5 + 3 = 8).
  92                      (setq i (string-match "[-_]" string 5)))
  93                 (aset string i ?\.))
  94             ;; Get rid of invalid characters.
  95             (while (setq i (string-match
  96                             "[^-a-zA-Z0-9_.%~^$!#&{}@`'()\200-\376]"
  97                             string))
  98               (aset string i ?_))
  99             ;; If we don't have a period in the first 8 chars, insert one.
 100             ;; This enables to have 3 more characters from the original
 101             ;; name in the extension.
 102             (if (> (or (string-match "\\." string) (length string))
 103                    8)
 104                 (setq string
 105                       (concat (substring string 0 8)
 106                               "."
 107                               (substring string 8))))
 108             (setq firstdot (or (string-match "\\." string)
 109                                (1- (length string))))
 110             ;; Truncate to 3 chars after the first period.
 111             (if (> (length string) (+ firstdot 4))
 112                 (setq string (substring string 0 (+ firstdot 4))))
 113             ;; Change all periods except the first one into underscores.
 114             ;; (DOS doesn't allow more than one period.)
 115             (while (string-match "\\." string (1+ firstdot))
 116               (setq i (string-match "\\." string (1+ firstdot)))
 117               (aset string i ?_))
 118             ;; If the last character of the original filename was `~' or `#',
 119             ;; make sure the munged name ends with it also.  This is so that
 120             ;; backup and auto-save files retain their telltale form.
 121             (if (memq lastchar '(?~ ?#))
 122                 (aset string (1- (length string)) lastchar))))
 123           (concat (if (and (stringp dir)
 124                            (memq (aref dir dlen-m-1) '(?/ ?\\)))
 125                       (concat (convert-standard-filename
 126                                (substring dir 0 dlen-m-1))
 127                               "/")
 128                     (convert-standard-filename dir))
 129                   string))))))
 130
 131 (defun dos-8+3-filename (filename)
 132   "Truncate FILENAME to DOS 8+3 limits."
 133   (if (or (not (stringp filename))
 134           (< (length filename) 5))      ; too short to give any trouble
 135       filename
 136     (let ((flen (length filename)))
 137       ;; If FILENAME has a trailing slash, remove it and recurse.
 138       (if (memq (aref filename (1- flen)) '(?/ ?\\))
 139           (concat (dos-8+3-filename (substring filename 0 (1- flen)))
 140                   "/")
 141         (let* (;; ange-ftp gets in the way for names like "/foo:bar".
 142                ;; We need to inhibit all magic file names, because
 143                ;; remote file names should never be passed through
 144                ;; this function, as they are not meant for the local
 145                ;; filesystem!
 146                (file-name-handler-alist nil)
 147                (dir
 148                 ;; If FILENAME is "x:foo", file-name-directory returns
 149                 ;; "x:/bar/baz", substituting the current working
 150                 ;; directory on drive x:.  We want to be left with "x:"
 151                 ;; instead.
 152                 (if (and (< 1 flen)
 153                          (eq (aref filename 1) ?:)
 154                          (null (string-match "[/\\]" filename)))
 155                     (substring filename 0 2)
 156                   (file-name-directory filename)))
 157                (dlen-m-1 (1- (length dir)))
 158                (string (copy-sequence (file-name-nondirectory filename)))
 159                (strlen (length string))
 160                (lastchar (aref string (1- strlen)))
 161                i firstdot)
 162           (setq firstdot (string-match "\\." string))
 163           (cond
 164            (firstdot
 165             ;; Truncate the extension to 3 characters.
 166             (if (> strlen (+ firstdot 4))
 167                 (setq string (substring string 0 (+ firstdot 4))))
 168             ;; Truncate the basename to 8 characters.
 169             (if (> firstdot 8)
 170                 (setq string (concat (substring string 0 8)
 171                                      "."
 172                                      (substring string (1+ firstdot))))))
 173            ((> strlen 8)
 174             ;; No dot; truncate file name to 8 characters.
 175             (setq string (substring string 0 8))))
 176           ;; If the last character of the original filename was `~',
 177           ;; make sure the munged name ends with it also.  This is so
 178           ;; a backup file retains its final `~'.
 179           (if (equal lastchar ?~)
 180               (aset string (1- (length string)) lastchar))
 181           (concat (if (and (stringp dir)
 182                            (memq (aref dir dlen-m-1) '(?/ ?\\)))
 183                       (concat (dos-8+3-filename (substring dir 0 dlen-m-1))
 184                               "/")
 185                     ;; Recurse to truncate the leading directories.
 186                     (dos-8+3-filename dir))
 187                   string))))))
 188
 189 ;; See dos-vars.el for defcustom.
 190 (defvar msdos-shells)
 191
 192 ;;; Override setting chosen at startup.
 193 (defun set-default-process-coding-system ()
 194   (setq default-process-coding-system
 195         (if default-enable-multibyte-characters
 196             '(undecided-dos . undecided-dos)
 197           '(raw-text-dos . raw-text-dos))))
 198
 199 (add-hook 'before-init-hook 'set-default-process-coding-system)
 200
 201 (defvar register-name-alist
 202   '((ax . 0) (bx . 1) (cx . 2) (dx . 3) (si . 4) (di . 5)
 203     (cflag . 6) (flags . 7)
 204     (al . (0 . 0)) (bl . (1 . 0)) (cl . (2 . 0)) (dl . (3 . 0))
 205     (ah . (0 . 1)) (bh . (1 . 1)) (ch . (2 . 1)) (dh . (3 . 1))))
 206
 207 (defun make-register ()
 208   (make-vector 8 0))
 209
 210 (defun register-value (regs name)
 211   (let ((where (cdr (assoc name register-name-alist))))
 212     (cond ((consp where)
 213            (let ((tem (aref regs (car where))))
 214              (if (zerop (cdr where))
 215                  (% tem 256)
 216                (/ tem 256))))
 217           ((numberp where)
 218            (aref regs where))
 219           (t nil))))
 220
 221 (defun set-register-value (regs name value)
 222   (and (numberp value)
 223        (>= value 0)
 224        (let ((where (cdr (assoc name register-name-alist))))
 225          (cond ((consp where)
 226                 (let ((tem (aref regs (car where)))
 227                       (value (logand value 255)))
 228                   (aset regs
 229                         (car where)
 230                         (if (zerop (cdr where))
 231                             (logior (logand tem 65280) value)
 232                           (logior (logand tem 255) (lsh value 8))))))
 233                ((numberp where)
 234                 (aset regs where (logand value 65535))))))
 235   regs)
 236
 237 (defsubst intdos (regs)
 238   (int86 33 regs))
 239
 240 ;; Backward compatibility for obsolescent functions which
 241 ;; set screen size.
 242
 243 (defun mode25 ()
 244   "Changes the number of screen rows to 25."
 245   (interactive)
 246   (set-frame-size (selected-frame) 80 25))
 247
 248 (defun mode4350 ()
 249   "Changes the number of rows to 43 or 50.
 250 Emacs always tries to set the screen height to 50 rows first.
 251 If this fails, it will try to set it to 43 rows, on the assumption
 252 that your video hardware might not support 50-line mode."
 253   (interactive)
 254   (set-frame-size (selected-frame) 80 50)
 255   (if (eq (frame-height (selected-frame)) 50)
 256       nil  ; the original built-in function returned nil
 257     (set-frame-size (selected-frame) 80 43)))
 258
 259 (provide 'dos-fns)
 260
 261 ;; arch-tag: 00b03579-8ebb-4a02-8762-5c5a929774ad
 262 ;;; dos-fns.el ends here