X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/87485d6fc91710d31c0ed046744f5f7a95f11115..c006623074918b4068bda65e3c5bcc076f2d8deb:/lisp/dos-fns.el diff --git a/lisp/dos-fns.el b/lisp/dos-fns.el index 39cbbf2f12..cf626185e9 100644 --- a/lisp/dos-fns.el +++ b/lisp/dos-fns.el @@ -1,8 +1,9 @@ -;;; dos-fns.el --- MS-Dos specific functions. +;;; dos-fns.el --- MS-Dos specific functions -;; Copyright (C) 1991, 1993 Free Software Foundation, Inc. +;; Copyright (C) 1991, 1993, 1995, 1996, 2001, 2002, 2003, 2004, +;; 2005, 2006, 2007 Free Software Foundation, Inc. -;; Maintainer: Morten Welinder (terra@diku.dk) +;; Maintainer: Morten Welinder ;; Keywords: internal ;; This file is part of GNU Emacs. @@ -18,8 +19,9 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -27,82 +29,175 @@ ;;; Code: -(setq-default mode-line-format - (list (purecopy "") - 'mode-line-modified - 'mode-line-buffer-identification - (purecopy " ") - 'global-mode-string - (purecopy " %[(") - (purecopy "%t:") - 'mode-name 'mode-line-process 'minor-mode-alist - (purecopy "%n") - (purecopy ")%]--") - (purecopy '(line-number-mode "L%l--")) - (purecopy '(-3 . "%p")) - (purecopy "-%-"))) - -(defvar file-name-buffer-file-type-alist - '( - ("[:/].*config.sys$" . nil) ; config.sys text - ("\\.elc$" . t) ; emacs stuff - ("\\.\\(obj\\|exe\\|com\\|lib\\|sys\\|chk\\|out\\|bin\\|ico\\|pif\\)$" . t) - ; MS-Dos stuff - ("\\.\\(arc\\|zip\\|pak\\|lzh\\|zoo\\)$" . t) - ; Packers - ("\\.\\(a\\|o\\|tar\\|z\\|gz\\|taz\\)$" . t) - ; Unix stuff - ("\\.tp[ulpw]$" . t) - ; Borland Pascal stuff - ("[:/]tags$" . t) - ; Emacs TAGS file - ) - "*Alist for distinguishing text files from binary files. -Each element has the form (REGEXP . TYPE), where REGEXP is matched -against the file name, and TYPE is nil for text, t for binary.") - -(defun find-buffer-file-type (filename) - (let ((alist file-name-buffer-file-type-alist) - (found nil) - (code nil)) - (let ((case-fold-search t)) - (setq filename (file-name-sans-versions filename)) - (while (and (not found) alist) - (if (string-match (car (car alist)) filename) - (setq code (cdr (car alist)) - found t)) - (setq alist (cdr alist)))) - (if found - (cond((memq code '(nil t)) code) - ((and (symbolp code) (fboundp code)) - (funcall code filename))) - default-buffer-file-type))) - -(defun find-file-binary (filename) - "Visit file FILENAME and treat it as binary." - (interactive "FFind file binary: ") - (let ((file-name-buffer-file-type-alist '(("" . t)))) - (find-file filename))) - -(defun find-file-text (filename) - "Visit file FILENAME and treat it as a text file." - (interactive "FFind file text: ") - (let ((file-name-buffer-file-type-alist '(("" . nil)))) - (find-file filename))) - -(defun find-file-not-found-set-buffer-file-type () - (save-excursion - (set-buffer (current-buffer)) - (setq buffer-file-type (find-buffer-file-type (buffer-file-name)))) - nil) - -;;; To set the default file type on new files. -(add-hook 'find-file-not-found-hooks 'find-file-not-found-set-buffer-file-type) - -(defvar msdos-shells '("command.com" "4dos.com" "ndos.com") - "*List of shells that use `/c' instead of `-c' and a backslashed command.") - -(defconst register-name-alist +;; This overrides a trivial definition in files.el. +(defun convert-standard-filename (filename) + "Convert a standard file's name to something suitable for the current OS. +This means to guarantee valid names and perhaps to canonicalize +certain patterns. + +On Windows and DOS, replace invalid characters. On DOS, make +sure to obey the 8.3 limitations. On Windows, turn Cygwin names +into native names, and also turn slashes into backslashes if the +shell requires it (see `w32-shell-dos-semantics')." + (if (or (not (stringp filename)) + ;; This catches the case where FILENAME is "x:" or "x:/" or + ;; "/", thus preventing infinite recursion. + (string-match "\\`\\([a-zA-Z]:\\)?[/\\]?\\'" filename)) + filename + (let ((flen (length filename))) + ;; If FILENAME has a trailing slash, remove it and recurse. + (if (memq (aref filename (1- flen)) '(?/ ?\\)) + (concat (convert-standard-filename + (substring filename 0 (1- flen))) + "/") + (let* (;; ange-ftp gets in the way for names like "/foo:bar". + ;; We need to inhibit all magic file names, because + ;; remote file names should never be passed through + ;; this function, as they are not meant for the local + ;; filesystem! + (file-name-handler-alist nil) + (dir + ;; If FILENAME is "x:foo", file-name-directory returns + ;; "x:/bar/baz", substituting the current working + ;; directory on drive x:. We want to be left with "x:" + ;; instead. + (if (and (< 1 flen) + (eq (aref filename 1) ?:) + (null (string-match "[/\\]" filename))) + (substring filename 0 2) + (file-name-directory filename))) + (dlen-m-1 (1- (length dir))) + (string (copy-sequence (file-name-nondirectory filename))) + (lastchar (aref string (1- (length string)))) + i firstdot) + (cond + ((msdos-long-file-names) + ;; Replace characters that are invalid even on Windows. + (while (setq i (string-match "[?*:<>|\"\000-\037]" string)) + (aset string i ?!))) + ((not (member string '("" "." ".."))) + ;; Change a leading period to a leading underscore. + (if (= (aref string 0) ?.) + (aset string 0 ?_)) + ;; If the name is longer than 8 chars, and doesn't have a + ;; period, and we have a dash or underscore that isn't too + ;; close to the beginning, change that to a period. This + ;; is so we could salvage more characters of the original + ;; name by pushing them into the extension. + (if (and (not (string-match "\\." string)) + (> (length string) 8) + ;; We don't gain anything if we put the period closer + ;; than 5 chars from the beginning (5 + 3 = 8). + (setq i (string-match "[-_]" string 5))) + (aset string i ?\.)) + ;; Get rid of invalid characters. + (while (setq i (string-match + "[^-a-zA-Z0-9_.%~^$!#&{}@`'()\200-\376]" + string)) + (aset string i ?_)) + ;; If we don't have a period in the first 8 chars, insert one. + ;; This enables to have 3 more characters from the original + ;; name in the extension. + (if (> (or (string-match "\\." string) (length string)) + 8) + (setq string + (concat (substring string 0 8) + "." + (substring string 8)))) + (setq firstdot (or (string-match "\\." string) + (1- (length string)))) + ;; Truncate to 3 chars after the first period. + (if (> (length string) (+ firstdot 4)) + (setq string (substring string 0 (+ firstdot 4)))) + ;; Change all periods except the first one into underscores. + ;; (DOS doesn't allow more than one period.) + (while (string-match "\\." string (1+ firstdot)) + (setq i (string-match "\\." string (1+ firstdot))) + (aset string i ?_)) + ;; If the last character of the original filename was `~' or `#', + ;; make sure the munged name ends with it also. This is so that + ;; backup and auto-save files retain their telltale form. + (if (memq lastchar '(?~ ?#)) + (aset string (1- (length string)) lastchar)))) + (concat (if (and (stringp dir) + (memq (aref dir dlen-m-1) '(?/ ?\\))) + (concat (convert-standard-filename + (substring dir 0 dlen-m-1)) + "/") + (convert-standard-filename dir)) + string)))))) + +(defun dos-8+3-filename (filename) + "Truncate FILENAME to DOS 8+3 limits." + (if (or (not (stringp filename)) + (< (length filename) 5)) ; too short to give any trouble + filename + (let ((flen (length filename))) + ;; If FILENAME has a trailing slash, remove it and recurse. + (if (memq (aref filename (1- flen)) '(?/ ?\\)) + (concat (dos-8+3-filename (substring filename 0 (1- flen))) + "/") + (let* (;; ange-ftp gets in the way for names like "/foo:bar". + ;; We need to inhibit all magic file names, because + ;; remote file names should never be passed through + ;; this function, as they are not meant for the local + ;; filesystem! + (file-name-handler-alist nil) + (dir + ;; If FILENAME is "x:foo", file-name-directory returns + ;; "x:/bar/baz", substituting the current working + ;; directory on drive x:. We want to be left with "x:" + ;; instead. + (if (and (< 1 flen) + (eq (aref filename 1) ?:) + (null (string-match "[/\\]" filename))) + (substring filename 0 2) + (file-name-directory filename))) + (dlen-m-1 (1- (length dir))) + (string (copy-sequence (file-name-nondirectory filename))) + (strlen (length string)) + (lastchar (aref string (1- strlen))) + i firstdot) + (setq firstdot (string-match "\\." string)) + (cond + (firstdot + ;; Truncate the extension to 3 characters. + (if (> strlen (+ firstdot 4)) + (setq string (substring string 0 (+ firstdot 4)))) + ;; Truncate the basename to 8 characters. + (if (> firstdot 8) + (setq string (concat (substring string 0 8) + "." + (substring string (1+ firstdot)))))) + ((> strlen 8) + ;; No dot; truncate file name to 8 characters. + (setq string (substring string 0 8)))) + ;; If the last character of the original filename was `~', + ;; make sure the munged name ends with it also. This is so + ;; a backup file retains its final `~'. + (if (equal lastchar ?~) + (aset string (1- (length string)) lastchar)) + (concat (if (and (stringp dir) + (memq (aref dir dlen-m-1) '(?/ ?\\))) + (concat (dos-8+3-filename (substring dir 0 dlen-m-1)) + "/") + ;; Recurse to truncate the leading directories. + (dos-8+3-filename dir)) + string)))))) + +;; See dos-vars.el for defcustom. +(defvar msdos-shells) + +;;; Override setting chosen at startup. +(defun set-default-process-coding-system () + (setq default-process-coding-system + (if default-enable-multibyte-characters + '(undecided-dos . undecided-dos) + '(raw-text-dos . raw-text-dos)))) + +(add-hook 'before-init-hook 'set-default-process-coding-system) + +(defvar register-name-alist '((ax . 0) (bx . 1) (cx . 2) (dx . 3) (si . 4) (di . 5) (cflag . 6) (flags . 7) (al . (0 . 0)) (bl . (1 . 0)) (cl . (2 . 0)) (dl . (3 . 0)) @@ -141,14 +236,26 @@ against the file name, and TYPE is nil for text, t for binary.") (defsubst intdos (regs) (int86 33 regs)) -;; Extra stub to functions in src/frame.c -;; Emacs aborts during dump if the following don't have a doc string. -(defun window-frame (window) - "Return the frame that WINDOW resides on." - (selected-frame)) -(defun raise-frame (frame) - "Raise FRAME to the top of the desktop." - nil) -(defun select-frame (frame &optional no-enter) - "Select FRAME for input events." - (selected-frame)) +;; Backward compatibility for obsolescent functions which +;; set screen size. + +(defun mode25 () + "Changes the number of screen rows to 25." + (interactive) + (set-frame-size (selected-frame) 80 25)) + +(defun mode4350 () + "Changes the number of rows to 43 or 50. +Emacs always tries to set the screen height to 50 rows first. +If this fails, it will try to set it to 43 rows, on the assumption +that your video hardware might not support 50-line mode." + (interactive) + (set-frame-size (selected-frame) 80 50) + (if (eq (frame-height (selected-frame)) 50) + nil ; the original built-in function returned nil + (set-frame-size (selected-frame) 80 43))) + +(provide 'dos-fns) + +;;; arch-tag: 00b03579-8ebb-4a02-8762-5c5a929774ad +;;; dos-fns.el ends here